Add a database logging backend.

lib/Trog/Log.pm

@@ -5,9 +5,13 @@ use warnings;
 
 use POSIX qw{strftime};
 use Log::Dispatch;
+use Log::Dispatch::DBI;
 use Log::Dispatch::Screen;
 use Log::Dispatch::FileRotate;
 
+use Trog::SQLite;
+use Trog::Log::DBI;
+
 use Exporter 'import';
 our @EXPORT_OK   = qw{is_debug INFO DEBUG WARN FATAL};
 our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
@@ -33,9 +37,18 @@ my $screen = Log::Dispatch::Screen->new(
     name      => 'screen',
     min_level => 'error',
 );
+
+# Send things like requests in to the stats log
+my $dblog = Trog::Log::DBI->new(
+    name => 'dbi',
+    min_level => $LEVEL,
+    dbh  => _dbh(),
+);
+
 our $log = Log::Dispatch->new();
 $log->add($rotate);
 $log->add($screen);
+$log->add($dblog);
 
 uuid("INIT");
 DEBUG("If you see this message, you are running in DEBUG mode.  Turn off WWW_VERBOSE env var if you are running in production.");
@@ -44,6 +57,10 @@ uuid("BEGIN");
 #memoize
 my $rq;
 
+sub _dbh {
+	return Trog::SQLite::dbh( 'schema/log.schema', "data/log.db" );
+}
+
 sub is_debug {
     return $LEVEL eq 'debug';
 }

lib/Trog/Log/DBI.pm

@@ -0,0 +1,45 @@
+package Trog::Log::DBI;
+
+use strict;
+use warnings;
+
+use parent qw{Log::Dispatch::DBI};
+
+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, code) VALUES (?,?,?,?,?,?,?)";
+
+    my $sql2 = "INSERT INTO messages (uuid, message) VALUES (?,?)";
+    $self->{sth2} = $self->{dbh}->prepare($sql2);
+
+    return $self->{dbh}->prepare($sql);
+}
+
+sub log_message {
+    my ($self, %params) = @_;
+
+    # Rip apart the message.  If it's got any extended info, lets grab that too.
+    my $msg = $params{message};
+    my $message;
+    my ($date, $uuid, $ip, $user, $method, $code, $route) = $msg =~ m!^([\w|\-|:]+) \[INFO\]: RequestId ([\w|\-]+) From ([\w|\.|:]+) \|(\w+)\| (\w+) (\d+) (.+)!;
+
+    # Otherwise, let's mark it down in the "messages" table.
+    if (!$date) {
+        ($date, $uuid, $ip, $user, $message) = $msg =~ m!^([\w|\-|:]+) \[\w+\]: RequestId ([\w|\-]+) From ([\w|\.|:]+) \|(\w+)\| (.+)!;
+        # Dummy up the method, code and route, as otherwise we summon complexity demon due to lack of FULL OUTER JOIN.
+        $method = "UNKNOWN";
+        $code   = 100;
+        $route  = "bogus";
+    }
+
+    # If this is a mangled log, forget it.
+    return unless $date;
+
+    my $res = $self->{sth}->execute($uuid, $date, $ip, $user, $method, $route, $code);
+    $self->{sth2}->execute($uuid, $message) if $message;
+    return $res;
+}
+
+1;

lib/Trog/SQLite.pm

@@ -43,6 +43,7 @@ sub dbh {
     my ( $schema, $dbname ) = @_;
     return $dbh->{$schema} if $dbh->{$schema};
     File::Touch::touch($dbname) unless -f $dbname;
+    die "No such schema file '$schema' !" unless -f $schema;
     my $qq = File::Slurper::read_text($schema);
     my $db = DBI->connect( "dbi:SQLite:dbname=$dbname", "", "" );
     $db->{sqlite_allow_multiple_statements} = 1;

schema/log.schema

@@ -0,0 +1,75 @@
+CREATE TABLE IF NOT EXISTS seen_hosts (
+    id INTEGER PRIMARY KEY AUTOINCREMENT,
+    ip_address TEXT NOT NULL
+);
+
+CREATE TABLE IF NOT EXISTS seen_users (
+    id INTEGER PRIMARY KEY AUTOINCREMENT,
+    user TEXT NOT NULL
+);
+
+CREATE TABLE IF NOT EXISTS seen_routes (
+    id INTEGER PRIMARY KEY AUTOINCREMENT,
+    route TEXT NOT NULL,
+    method TEXT NOT NULL
+);
+
+CREATE TABLE IF NOT EXISTS response_code (
+    id INTEGER PRIMARY KEY AUTOINCREMENT,
+    code INTEGER NOT NULL
+);
+
+CREATE TABLE IF NOT EXISTS requests (
+    uuid TEXT PRIMARY KEY,
+    date TEXT NOT NULL,
+    host_id INTEGER NOT NULL REFERENCES seen_hosts(id) ON DELETE CASCADE,
+    user_id INTEGER NOT NULL REFERENCES seen_users(id) ON DELETE CASCADE,
+    route_id INTEGER NOT NULL REFERENCES seen_routes(id) ON DELETE CASCADE,
+    response_code_id INTEGER NOT NULL REFERENCES response_code(id) ON DELETE RESTRICT
+);
+
+CREATE VIEW IF NOT EXISTS all_requests AS
+    SELECT
+        q.uuid,
+        q.date,
+        h.ip_address,
+        u.user,
+        r.method,
+        r.route,
+        c.code
+    FROM
+        requests AS q
+    JOIN
+        seen_hosts AS h ON q.host_id = h.id
+    JOIN
+        seen_users AS u ON q.user_id = u.id
+    JOIN
+        seen_routes AS r ON q.route_id = r.id
+    JOIN
+        response_code AS c on q.response_code_id = c.id;
+
+/* Make all_requests a writable view via triggers.  We will always stomp the main row, as the last update will be what we want. */
+CREATE TRIGGER IF NOT EXISTS insert_all_requests INSTEAD OF INSERT ON all_requests BEGIN
+    INSERT OR IGNORE  INTO response_code (code)         VALUES (NEW.code);
+    INSERT OR IGNORE  INTO seen_routes   (route,method) VALUES (NEW.route, NEW.method);
+    INSERT OR IGNORE  INTO seen_users    (user)         VALUES (NEW.user);
+    INSERT OR IGNORE  INTO seen_hosts    (ip_address)   VALUES (NEW.ip_address);
+    INSERT OR REPLACE INTO requests SELECT
+        NEW.uuid,
+        NEW.date,
+        h.id AS host_id,
+        u.id AS user_id,
+        r.id AS route_id,
+        c.id AS response_code_id
+    FROM seen_hosts AS h
+    JOIN seen_users AS u ON u.user = NEW.user
+    JOIN seen_routes AS r ON r.route = NEW.route AND r.method = NEW.method
+    JOIN response_code AS c ON c.code = NEW.code
+    WHERE h.ip_address = NEW.ip_address;
+END;
+
+/* This is just to store various messages associated with requests, which are usually errors. */
+CREATE TABLE IF NOT EXISTS messages (
+    uuid TEXT NOT NULL REFERENCES requests ON DELETE NO ACTION,
+    message TEXT NOT NULL
+);

www/server.psgi

@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 #Grab our custom routes
-use lib 'lib';
+use FindBin::libs;
 use TCMS;
 
 $ENV{PSGI_ENGINE} //= 'starman';