tCMS/lib/Trog/Log/DBI.pm

package Trog::Log::DBI;

use 5.040;
use re '/aasx';
use warnings FATAL => 'all';

use parent qw{Log::Dispatch::DBI};

use Ref::Util qw{is_arrayref};

use POSIX           qw{mktime};
use POSIX::strptime qw{strptime};

our ( $referer, $ua, $urchin );

=head1 Trog::Log::DBI

A Log::Dispatch::DBI subclass which files tCMS's request log into SQLite, so
that Trog::Log::Metrics has something to compute time series out of.

Rather than storing log lines verbatim, log_message() picks apart the format
Trog::Log emits and stores the pieces in columns.  Lines which don't match the
request format are treated as free text belonging to whichever request was in
flight, and are buffered until that request's own line shows up to hang them
off of.

Anything too mangled to identify a request is dropped -- a metrics database is
not the place to go looking for them, the log file has them either way.

=head1 VARIABLES

=over 4

=item $referer, $ua, $urchin

Per-request context which isn't in the log line itself.  The routes set these
before responding; they only exist for metrics, which is why they aren't in the
text logs.  $urchin is a hashref of utm_* parameters, and is only recorded when
it has a utm_source.

=back

=head1 METHODS

=head2 create_statement() = DBI::st

Called by Log::Dispatch::DBI at construction.  Prepares, and returns, the
statement for the requests view, and prepares the two extra statements
log_message() needs for messages and urchin data.

=cut

sub create_statement {
    my $self = shift;

    # This is a writable view.  Consult schema for its behavior.
    my $sql = "INSERT INTO all_requests (uuid, date, ip_address, user, method, route, referer, ua, code) VALUES (?,?,?,?,?,?,?,?,?)";

    my $sql2 = "INSERT INTO messages (uuid, message) VALUES (?,?)";
    $self->{sth2} = $self->{dbh}->prepare($sql2);

    my $sql3 = "INSERT INTO urchin_requests (request_uuid, utm_source, utm_medium, utm_campaign, utm_term, utm_content) VALUES (?,?,?,?,?,?)";
    $self->{sth3} = $self->{dbh}->prepare($sql3);

    return $self->{dbh}->prepare($sql);
}

my %buffer;

# A line as Trog::Log formats it: the time, the level, who asked, and what
# happened.
my $STAMP   = qr/[\w:-]+/;
my $REQUEST = qr/[\w-]+/;
my $ADDRESS = qr/[\w.:]+/;
my $WHO     = qr/RequestId[ ]($REQUEST)[ ]From[ ]($ADDRESS)[ ]\|(\w+)\|/;
my $LINE    = qr/\A($STAMP)[ ]\[(\w+)\]:[ ]$WHO[ ](\N+)/;

# What happened, when that is a request that was served: the method, the
# code, the bytes, and the route.
my $SERVED = qr/\A(\w+)[ ](\d+)[ ](\d+)[ ](\N+)/;

=head2 log_message(HASH params) = MIXED

Record one log line.

Returns the request insert's result for a request line, 1 for a message that
got buffered, and undef for a line we couldn't make sense of or could not write.
A write that fails is a warning on stderr, and never dies.

=cut

sub log_message {
    my ( $self, %params ) = @_;

    my ( $date, $level, $uuid, $ip, $user, $message ) = $params{message} =~ $LINE;
    return unless $uuid;

    my ( $method, $code, undef, $route ) = $level eq 'INFO' ? $message =~ $SERVED : ();

    # Anything else goes in the "messages" table, once its request is written.
    if ( !defined $method ) {
        push( @{ $buffer{$uuid} }, $message );
        return 1;
    }

    # 2024-01-20T22:37:41Z
    # Transform the date into an epoch so we can do math on it
    my $fmt     = "%Y-%m-%dT%H:%M:%SZ";
    my @cracked = strptime( $date, $fmt );

    #XXX get a dumb warning otherwise
    pop @cracked;
    my $epoch = mktime(@cracked);

    # Allow callers to set quasi-tracking parameters.
    # We only care about this in DB context, as it's only for metrics, which are irrelevant in text logs/debugging.
    $referer //= 'none';
    $ua      //= 'none';
    $urchin  //= {};

    # The handle raises, and this runs inside every log call, so a failed write warns rather than dies.
    my $messages = delete $buffer{$uuid};
    my $res;
    eval {
        # TODO track bytes in the DB
        $res = $self->{sth}->execute( $uuid, $epoch, $ip, $user, $method, $route, $referer, $ua, $code );

        # Dump in the accumulated messages
        if ( is_arrayref($messages) && @$messages ) {
            $self->{sth2}->bind_param_array( 1, $uuid );
            $self->{sth2}->bind_param_array( 2, $messages );
            $self->{sth2}->execute_array( {} );
        }

        # Record urchin data if there is any.
        if ( %$urchin && $urchin->{utm_source} ) {
            $self->{sth3}->execute( $uuid, $urchin->{utm_source}, $urchin->{utm_medium}, $urchin->{utm_campaign}, $urchin->{utm_term}, $urchin->{utm_content} );
        }
        1;
    } or do {
        warn "Could not record request $uuid in the metrics database: $@";
        return;
    };

    return $res;
}

1;