File Coverage

blib/lib/Mojolicious/Plugin/AccessLog.pm

Criterion	Covered	Total	%
statement	138	160	86.2
branch	44	70	62.8
condition	30	49	61.2
subroutine	37	39	94.8
pod	1	1	100.0
total	250	319	78.3

package Mojolicious::Plugin::AccessLog;

use Mojo::Base 'Mojolicious::Plugin';
use Mojo::IOLoop;

use File::Spec;
use IO::File;
use POSIX qw(setlocale strftime LC_ALL);
use Scalar::Util qw(blessed reftype weaken);
use Socket qw(inet_aton AF_INET);
use Time::HiRes qw(gettimeofday tv_interval);

our $VERSION = '0.010001';

my $DEFAULT_FORMAT = 'common';
my %FORMATS = (
    $DEFAULT_FORMAT => '%h %l %u %t "%r" %>s %b',
    combined => '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-Agent}i"',
    combinedio => '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-Agent}i" %I %O',
);

# some systems (Windows) don't support %z correctly
my $TZOFFSET = strftime('%z', localtime) !~ /^[+-]\d{4}$/ && do {
    require Time::Local;
    my $t = time;
    my $d = (Time::Local::timegm(localtime($t)) - $t) / 60;
    sprintf '%+03d%02u', int($d / 60), $d % 60;
};
# some systems (Windows) don't support %s
my $NOEPOCHSECS = strftime('%s', localtime) !~ /^\d+$/;

sub register {
    my ($self, $app, $conf) = @_;
    my $log = $conf->{log} // $app->log->handle;
    my ($pkg, $f, $l) = caller 2;   # :-/

    unless ($log) { # somebody cleared $app->log->handle?
        # Log a warning nevertheless - there might be an event handler.
        $app->log->warn(__PACKAGE__ . ': Log handle is not defined');
        return;
    }

    my $reftype = reftype $log // '';
    my $logger;

    if ($reftype eq 'GLOB') {
        eval { $log->autoflush(1) };
        $logger = sub { $log->print($_[0]) };
    }
    elsif (blessed($log) and my $l = $log->can('print') || $log->can('info')) {
        $logger = sub { $l->($log, $_[0]) };
    }
    elsif ($reftype eq 'CODE') {
        $logger = $log;
    }
    elsif (defined $log and not ref $log) {
        File::Spec->file_name_is_absolute($log)
            or $log = $app->home->rel_file($log);

        my $fh = IO::File->new($log, '>>')
            or die <<"";
Can't open log file "$log": $! at $f line $l.

        $fh->autoflush(1);
        $logger = sub { $fh->print($_[0]) };
    }
    else {
        $app->log->error(__PACKAGE__ . ': not a valid "log" value');
        return;
    }

    if ($conf->{uname_helper}) {
        warn <<"";
uname_helper is DEPRECATED in favor of \$c->req->env->{REMOTE_USER} at $f line $l.


        my $helper_name = $conf->{uname_helper};

        $helper_name = 'set_username' if $helper_name !~ /^[\_A-za-z]\w*$/;

        $app->helper(
            $helper_name => sub { $_[0]->req->env->{REMOTE_USER} = $_[1] }
        );
    }

    my @handler;
    my $strftime = sub {
        my ($fmt, @time) = @_;
        $fmt =~ s/%z/$TZOFFSET/g if $TZOFFSET;
        $fmt =~ s/%s/time()/ge if $NOEPOCHSECS;
        my $old_locale = setlocale(LC_ALL);
        setlocale(LC_ALL, 'C');
        my $out = strftime($fmt, @time);
        setlocale(LC_ALL, $old_locale);
        return $out;
    };
    my $format = $FORMATS{$conf->{format} // $DEFAULT_FORMAT};
    my $safe_re;

    if ($format) {
        # Apache default log formats don't quote username, which might
        # have spaces.
        $safe_re = qr/([^[:print:]]|\s)/;
    }
    else {
        # For custom log format appropriate quoting is the user's responsibility.
        $format = $conf->{format};
    }

    # each handler is called with following parameters:
    # 0: $tx, 1: $tx->req, 2: $tx->res, 3: $tx->req->url,
    # 4: $request_start_time, 5: $process_time, 6: $bytes_in, 7: $bytes_out
    # 8: HTTP request start line

    my $block_handler = sub {
        my ($block, $type) = @_;

        return sub { _safe($_[1]->headers->header($block) // '-') }
            if $type eq 'i';

        return sub { $_[2]->headers->header($block) // '-' }
            if $type eq 'o';

        return sub {
            return $_[4][0]
                if $block eq 'sec';
            return sprintf "%u%03u", $_[4][0], int($_[4][1] / 1000)
                if $block eq 'msec';
            return sprintf "%u%06u", @{$_[4]}
                if $block eq 'usec';
            return sprintf('%03u', $_[4][1] / 1000)
                if $block eq 'msec_frac';
            return sprintf('%06u', $_[4][1])
                if $block eq 'usec_frac';
            return $strftime->($block, localtime($_[4][0]));
        }
            if $type eq 't';

        return sub { _safe($_[1]->cookie($block // '')) }
            if $type eq 'C';

        return sub { _safe($_[1]->env->{$block // ''}) }
            if $type eq 'e';

        $app->log->error("{$block}$type not supported");

        return '-';
    };

    my $servername_cb = sub { $_[3]->base->host || '-' };
    my $remoteaddr_cb = sub { $_[0]->remote_address || '-' };
    my %char_handler = (
        '%' => '%',
        a => $remoteaddr_cb,
        A => sub { $_[0]->local_address // '-' },
        b => sub {
            $_[7] && ($_[7] - $_[2]->header_size - $_[2]->start_line_size) || '-'
        },
        B => sub {
            $_[7] ? $_[7] - $_[2]->header_size - $_[2]->start_line_size : '0'
        },
        D => sub { int($_[5] * 1000000) },
        h => $remoteaddr_cb,
        H => sub { 'HTTP/' . $_[1]->version },
        I => sub { $_[6] },
        l => '-',
        m => sub { $_[1]->method },
        O => sub { $_[7] },
        p => sub { $_[0]->local_port },
        P => sub { $$ },
        q => sub {
            my $s = $_[3]->query->to_string or return '';
            return '?' . $s;
        },
        r => sub { $_[8] },
        s => sub { $_[2]->code // '-' },
        t => sub {
            $strftime->('[%d/%b/%Y:%H:%M:%S %z]', localtime($_[4][0]))
        },
        T => sub { int $_[5] },
        u => sub {
            my $env = $_[1]->env;
            my $user =
                exists($env->{REMOTE_USER}) ?
                    length($env->{REMOTE_USER} // '') ?
                        $env->{REMOTE_USER} : '-' :
                        (split ':', $_[3]->base->userinfo || '-:')[0];

            return _safe($user, $safe_re)
        },
        U => sub { $_[3]->path },
        v => $servername_cb,
        V => $servername_cb,
    );

    if ($conf->{hostname_lookups}) {
        $char_handler{h} = sub {
            my $ip = $_[0]->remote_address or return '-';
            return gethostbyaddr(inet_aton($ip), AF_INET);
        };
    }

    my $char_handler = sub {
        my $char = shift;
        my $cb = $char_handler{$char};

        return $char_handler{$char} if $char_handler{$char};

        $app->log->error("\%$char not supported.");

        return '-';
    };

    $format =~ s~
        (?:
        \%\{(.+?)\}([a-z]) |
        \%(?:[<>])?([a-zA-Z\%])
        )
    ~
        push @handler, $1 ? $block_handler->($1, $2) : $char_handler->($3);
        '%s';
    ~egx;

    chomp $format;
    $format .= $conf->{lf} // $/ // "\n";

    $app->hook(after_build_tx => sub {
        my $tx = $_[0];

        $tx->on(connection => sub {
            my ($tx, $connection) = @_;
            my $bcr = my $bcw = 0;
            my $sl;
            my $t = [gettimeofday];
            my $s = Mojo::IOLoop->stream($connection);
            my $r = $s->on(read  => sub {
                # get the unmodified HTTP request start line
                $sl //= substr($_[1], 0, index($_[1], "\r\n"));
                $bcr += length $_[1];
            });
            my $w = $s->on(write => sub { $bcw += length $_[1] });

            weaken $s;
            weaken $r;
            weaken $w;

            $tx->on(finish => sub {
                my $tx = shift;
                my $dt = tv_interval($t);

                $s->unsubscribe(read  => $r);
                $s->unsubscribe(write => $w);
                $logger->(_log($tx, $format, \@handler, $t, $dt, $bcr, $bcw, $sl));
            });
        });
    });
}

sub _log {
    my ($tx, $format, $handler) = (shift, shift, shift);
    my $req = $tx->req;
    my @args = ($tx, $req, $tx->res, $req->url, @_);

    sprintf $format, map(ref() ? ($_->(@args))[0] // '' : $_, @$handler);
}

sub _safe {
    my $string = shift;
    my $re = shift // qr/([^[:print:]])/;

    $string =~ s/$re/'\x' . unpack('H*', $1)/eg
        if defined $string;

    return $string;
}

1;

__END__