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

tCMS wrote its log to tpsgi.log and nowhere else.  rsyslog does not read
that file, so a guest that forwards its logs to a collector did not forward
these, and they hold the failed logins that fail2ban bans for.

Trog::Log::Syslog is a Log::Dispatch output that sends each line to
/dev/log with Log::Syslog::Fast, as daemon, tagged tcms, at the severity of
its level.  A line it cannot send is dropped, because the file has it and a
request must not fail over its log line.  log_init() now takes the loggers
of tpsgi.ini, so one setting sends the lines of tPSGI and of tCMS to the
same places.

tPSGI must load the logger by name before this works, which its branch
require-loggers does.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>

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();