Merge pull request #348 from Troglodyne-Internet-Widgets/syslog-logger

Send the log to syslog as well, when tpsgi.ini names Trog::Log::Syslog

Makefile.PL

@@ -79,6 +79,8 @@ WriteMakefile(
         'Email::Sender::Simple'               => '0',
         'POSIX::strptime'                     => '0',
         'Log::Dispatch::DBI'                  => '0',
+        'Log::Syslog::Fast'                   => '0',
+        'Module::Runtime'                     => '0',
         'Email::MIME'                         => '0',
         'Email::Sender::Simple'               => '0',
         'Net::IP'                             => '0',

lib/TCMS.pm

@@ -75,7 +75,7 @@ sub build_routes {
             confess "Cannot determine directory for logs!" unless $tpsgi->{log_dir};
 
             # Make sure the tCMS logs live in the same dir as the tpsgi logs.
-            log_init( "$tpsgi->{log_dir}/tpsgi.log", $tpsgi->{verbose} ? 'debug' : 'info' );
+            log_init( "$tpsgi->{log_dir}/tpsgi.log", $tpsgi->{verbose} ? 'debug' : 'info', $tpsgi->{loggers} );
 
             # Let's open up our default route if needed before we bother thinking any harder
             return $default_route->($query) unless -f "config/setup";    ## no critic (ProhibitFiletest_f) -- a flag file, only ever touched

lib/Trog/Log.pm

@@ -4,6 +4,7 @@ use v5.36;
 use re '/aa';
 
 use POSIX qw{strftime};
+use Module::Runtime();
 use Log::Dispatch;
 use Log::Dispatch::DBI;
 use Log::Dispatch::Screen;
@@ -61,7 +62,7 @@ Where the current request came from, same deal.  Defaults to '0.0.0.0'.
 
 =head1 FUNCTIONS
 
-=head2 log_init(STRING logname, STRING level) = BOOL
+=head2 log_init(STRING logname, STRING level, [ARRAYREF loggers]) = BOOL
 
 Build the logger.  Must be called before anything tries to log.
 
@@ -69,12 +70,17 @@ $logname is the path to the log file; its directory is also where the metrics
 database gets put.  $level is a Log::Dispatch level, generally 'info' or
 'debug'.
 
+$loggers names more Log::Dispatch outputs to add, by class, and each gets
+C<min_level> and C<log_dir> as tPSGI gives them.  The server passes the
+C<loggers> of tpsgi.ini, so that one setting sends the lines of tPSGI and of
+tCMS to the same places.  See Trog::Log::Syslog.
+
 Returns 1.
 
 =cut
 
 sub log_init {
-    my ( $LOGNAME, $LEVEL ) = @_;
+    my ( $LOGNAME, $LEVEL, $loggers ) = @_;
 
     die "Cannot initialize logs without log name and log level" unless $LOGNAME && $LEVEL;
 
@@ -112,6 +118,10 @@ sub log_init {
     $log->add($screen);
     $log->add($dblog);
 
+    foreach my $logger ( @{ $loggers // [] } ) {
+        $log->add( Module::Runtime::use_module($logger)->new( min_level => $LEVEL, log_dir => $LOGDIR ) );
+    }
+
     uuid("INIT");
     return 1;
 }

lib/Trog/Log/Syslog.pm

@@ -0,0 +1,87 @@
+package Trog::Log::Syslog;
+
+use v5.36;
+use re '/aa';
+
+use parent qw{Log::Dispatch::Output};
+
+use Log::Syslog::Fast qw{:protos :formats};
+
+=head1 Trog::Log::Syslog
+
+A Log::Dispatch output which hands each line to the syslog of the machine, over
+its unix socket.  From there journald and rsyslog have it, and whatever they
+forward it to.
+
+Name it in the C<loggers> of tpsgi.ini:
+
+    loggers = Trog::Log::Syslog
+
+tPSGI then adds it to its own logger, and TCMS passes the same list to
+log_init(), so both write here as well as to the rotated file.
+
+Lines go out as C<daemon>, tagged C<tcms>, at the severity of their level.
+Each keeps the timestamp that Trog::Log puts at its front, so a line on a log
+collector reads the same as the line in the file.
+
+=head1 Termination Conditions
+
+new() dies when it cannot connect to the socket.  A line that cannot be sent
+later is dropped without a word: the file output has it, and a request that
+fails because its log line did not arrive is worse than a line that did not
+arrive.
+
+=head1 METHODS
+
+=head2 new(%options) = Trog::Log::Syslog
+
+Takes what tPSGI hands every logger, C<min_level> and C<log_dir>, and ignores
+C<log_dir>.  C<socket> is where to send, F</dev/log> unless a test says
+otherwise.  C<ident> is the tag, C<tcms> unless given.
+
+=cut
+
+# LOG_DAEMON, from sys/syslog.h.
+my $DAEMON = 3;
+
+sub new ( $class, %p ) {
+    my $self = bless( {}, $class );
+    $self->_basic_init( map { exists $p{$_} ? ( $_ => $p{$_} ) : () } qw{name min_level max_level} );
+
+    my $socket = $p{socket} // '/dev/log';
+    my $ident  = $p{ident}  // 'tcms';
+
+    # The sender is left out of the format, as syslog(3) leaves it out when it
+    # writes to this socket, because the receiver is this machine.
+    $self->{syslog} = Log::Syslog::Fast->new( LOG_UNIX, $socket, 0, $DAEMON, 6, '', $ident );
+    $self->{syslog}->set_format(LOG_RFC3164_LOCAL);
+
+    return $self;
+}
+
+=head2 log_message(%p)
+
+Called by Log::Dispatch for each line at or above C<min_level>.
+
+=cut
+
+sub log_message ( $self, %p ) {
+
+    # Log::Dispatch numbers its levels from debug at 0 to emergency at 7, and
+    # syslog numbers its severities the other way round.
+    my $severity = 7 - $self->_level_as_number( $p{level} );
+
+    # Trog::Log ends every line with a newline, which a syslog message does
+    # not carry.
+    my $message = $p{message} =~ s/\n+\z//r;
+
+    local $@;
+    eval {
+        $self->{syslog}->set_severity($severity);
+        $self->{syslog}->send( $message, time );
+        1;
+    };
+    return;
+}
+
+1;

t/Trog-Log-Syslog.t

@@ -0,0 +1,102 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::NoWarnings;
+use Test::Fatal qw{exception};
+use File::Temp  qw{tempdir};
+use IO::Socket::UNIX;
+use Socket qw{SOCK_DGRAM};
+use Log::Dispatch;
+use FindBin;
+
+use lib "$FindBin::Bin/../lib";
+
+require_ok('Trog::Log::Syslog') or BAIL_OUT("Can't find SUT");
+
+# A datagram socket in a temporary directory stands in for /dev/log, which is
+# a datagram socket too.
+my $dir  = tempdir( CLEANUP => 1 );
+my $path = "$dir/log";
+my $sink = IO::Socket::UNIX->new( Type => SOCK_DGRAM, Local => $path ) or die "Cannot listen on $path: $!";
+
+sub received {
+    my $got = '';
+    $sink->recv( $got, 65536 );
+    return $got;
+}
+
+# What tPSGI passes to every logger that its configuration names.
+my $output = Trog::Log::Syslog->new( min_level => 'info', log_dir => $dir, socket => $path );
+my $log    = Log::Dispatch->new();
+$log->add($output);
+
+subtest 'a line arrives as the syslog of this machine reads it' => sub {
+    $log->info("2026-09-29T12:00:00Z [INFO]: RequestId x From 192.0.2.1 |nobody| Failed login for user\n");
+    my $got = received();
+
+    # daemon is facility 3 and info is severity 6, so the priority is 3*8+6.
+    like( $got, qr/^<30>/,                                                                                            'as daemon.info' );
+    like( $got, qr/\btcms\[$$\]: /,                                                                                   'tagged with the program name and the pid' );
+    like( $got, qr/: 2026-09-29T12:00:00Z \[INFO\]: RequestId x From 192\.0\.2\.1 \|nobody\| Failed login for user$/, 'with the line that the file gets, and no newline' );
+};
+
+subtest 'each level keeps its severity' => sub {
+    my %severity = ( info => 6, notice => 5, warning => 4, error => 3, critical => 2, alert => 1, emergency => 0 );
+    foreach my $level ( sort keys %severity ) {
+        $log->log( level => $level, message => "at $level" );
+        my $priority = 3 * 8 + $severity{$level};
+        like( received(), qr/^<$priority>.*: at $level$/, "$level is severity $severity{$level}" );
+    }
+};
+
+subtest 'nothing below the level goes out' => sub {
+    $log->debug('too quiet');
+    $log->info('loud enough');
+    like( received(), qr/loud enough$/, 'the debug line was not sent' );
+};
+
+subtest 'a syslog that went away does not take the application with it' => sub {
+    close($sink);
+    unlink($path);
+
+    # The file output still has the line, and a request that fails because
+    # its log line did not arrive is worse than a line that did not arrive.
+    is( exception { $log->warning('into the void') }, undef, 'logging to a missing socket does not die' );
+};
+
+subtest 'log_init adds the loggers that tpsgi.ini names' => sub {
+    require Trog::Log;
+
+    # A stand-in, so that this test does not write to the syslog of the
+    # machine that runs it.
+    {
+
+        package Test::Capture;
+        use parent -norequire, qw{Log::Dispatch::Output};
+        our ( @lines, %given );
+
+        sub new {
+            my ( $class, %p ) = @_;
+            %given = %p;
+            my $self = bless( {}, $class );
+            $self->_basic_init( min_level => $p{min_level} );
+            return $self;
+        }
+        sub log_message { my ( $self, %p ) = @_; push( @lines, $p{message} ); return }
+    }
+    local $INC{'Test/Capture.pm'} = __FILE__;
+
+    Trog::Log::log_init( "$dir/tcms.log", 'info', ['Test::Capture'] );
+    Trog::Log::INFO('through every output');
+
+    no warnings 'once';
+    is( $Test::Capture::given{log_dir}, $dir, 'handed the log directory, as tPSGI hands it' );
+    like( $Test::Capture::lines[-1], qr/through every output/, 'and given the lines' );
+
+    like( exception { Trog::Log::log_init( "$dir/tcms.log", 'info', ['../../etc/passwd'] ) }, qr/not a module name/, 'a logger that is not a module name is refused' );
+};
+
+Test::NoWarnings::had_no_warnings();
+
+done_testing();