Fix #127 - Add generic logging framework Trog::Log

Makefile

@@ -12,6 +12,8 @@ install:
 	test -d www/assets || mkdir -p www/assets
 	test -d www/statics || mkdir -p www/statics
 	test -d totp/ || mkdir -p totp
+	test -d ~/.tcms || mkdir ~/.tcms
+	test -d /var/log && mkdir /var/log/www; /bin/true
 	$(RM) pod2htmd.tmp;
 
 .PHONY: install-service

Makefile.PL

@@ -54,6 +54,10 @@ WriteMakefile(
     'IO::Compress::Gzip'     => '0',
     'IO::Compress::Deflate'  => '0',
     'HTTP::Parser::XS'       => '0',
+    'Log::Dispatch'          => '0',
+    'Log::Dispatch::FileRotate' => '0',
+    'Digest::SHA'               => '0',
+    'MIME::Base32::XS'          => '0',
   },
   test => {TESTS => 't/*.t'}
 );

lib/TCMS.pm

@@ -20,12 +20,14 @@ use IO::Compress::Gzip();
 use Time::HiRes      qw{gettimeofday tv_interval};
 use HTTP::Parser::XS qw{HEADERS_AS_HASHREF};
 use List::Util;
+use UUID::Tiny();
 
 #Grab our custom routes
 use lib 'lib';
 use Trog::Routes::HTML;
 use Trog::Routes::JSON;
 
+use Trog::Log qw{:all};
 use Trog::Auth;
 use Trog::Utils;
 use Trog::Config;
@@ -138,12 +140,18 @@ sub app {
     }
 
     my $active_user = '';
+    $Trog::Log::user = 'nobody';
     if ( exists $cookies->{tcmslogin} ) {
         $active_user = Trog::Auth::session2user( $cookies->{tcmslogin}->value );
+        $Trog::Log::user = $active_user if $active_user;
     }
     $query->{user_acls} = [];
     $query->{user_acls} = Trog::Auth::acls4user($active_user) // [] if $active_user;
 
+    # Log the request.
+    Trog::Log::uuid(UUID::Tiny::create_uuid_as_string( UUID::Tiny::UUID_V1, UUID::Tiny::UUID_NS_DNS ));
+    INFO("$env->{REQUEST_METHOD} $path");
+
     # Filter out passed ACLs which are naughty
     my $is_admin = grep { $_ eq 'admin' } @{ $query->{user_acls} };
     @{ $query->{acls} } = grep { $_ ne 'admin' } @{ $query->{acls} } unless $is_admin;

lib/Trog/Auth.pm

@@ -6,6 +6,7 @@ use warnings;
 no warnings 'experimental';
 use feature qw{signatures state};
 
+use Trog::Log qw{:all};
 use UUID::Tiny ':std';
 use Digest::SHA 'sha256';
 use Authen::TOTP;
@@ -54,7 +55,7 @@ sub acls4user ($username) {
     return \@acls;
 }
 
-=head2 totp(user)
+=head2 totp(user, domain)
 
 Enable TOTP 2fa for the specified user, or if already enabled return the existing info.
 Returns a QR code and URI for pasting into authenticator apps.
@@ -82,6 +83,7 @@ sub totp ( $user, $domain ) {
 
         #XXX verifier apps will only do 30s :(
         period => 30,
+        digits => 6,
         $secret ? ( secret => $secret ) : (),
     );
 
@@ -116,10 +118,46 @@ sub _totp {
         die "Global secret must be set in tCMS configuration totp section!" unless $global_secret;
         $totp = Authen::TOTP->new( secret => $global_secret );
         die "Cannot instantiate TOTP client!" unless $totp;
+        $totp->{DEBUG} = 1 if is_debug();
     }
     return $totp;
 }
 
+=head2 expected_totp_code(totp, secret, when, digits)
+
+Return the expected totp code at a given time with a given secret.
+
+=cut
+
+#XXX authen::totp does not expose this, sigh
+sub expected_totp_code {
+    my ( $self, $secret, $when, $digits ) = @_;
+    $self //= _totp();
+    $when   //= time;
+    my $period  = 30;
+    $digits //= 6;
+    $self->{secret} = $secret;
+
+    my $T  = sprintf( "%016x", int( $when / $period ) );
+    my $Td = pack( 'H*', $T );
+
+    my $hmac = $self->hmac($Td);
+
+    # take the 4 least significant bits (1 hex char) from the encrypted string as an offset
+    my $offset = hex( substr( $hmac, -1 ) );
+
+    # take the 4 bytes (8 hex chars) at the offset (* 2 for hex), and drop the high bit
+    my $encrypted = hex( substr( $hmac, $offset * 2, 8 ) ) & 0x7fffffff;
+
+    return sprintf( "%0" . $digits . "d", ( $encrypted % ( 10**$digits ) ) );
+}
+
+=head2 clear_totp
+
+Clear the totp codes for all users
+
+=cut
+
 sub clear_totp {
     my $dbh = _dbh();
     $dbh->do("UPDATE user SET totp_secret=null") or die "Could not clear user TOTP secrets";
@@ -151,7 +189,9 @@ sub mksession ( $user, $pass, $token ) {
 
     # Validate the 2FA Token.  If we have no secret, allow login so they can see their QR code, and subsequently re-auth.
     if ($secret) {
-        my $rc = $totp->validate_otp( otp => $token, secret => $secret, tolerance => 1, period => 30 );
+        return '' unless $token;
+        DEBUG("TOTP Auth: Sent code $token, expect ".expected_totp_code());
+        my $rc = $totp->validate_otp( otp => $token, secret => $secret, tolerance => 5, period => 30, digits => 6 );
         return '' unless $rc;
     }
 

lib/Trog/Log.pm

@@ -0,0 +1,88 @@
+package Trog::Log;
+
+use strict;
+use warnings;
+
+use POSIX qw{strftime};
+use Log::Dispatch;
+use Log::Dispatch::Screen;
+use Log::Dispatch::FileRotate;
+
+use Exporter 'import';
+our @EXPORT_OK   = qw{is_debug INFO DEBUG WARN FATAL};
+our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
+
+my $LOGNAME = -d '/var/log' ? '/var/log/www/tcms.log' : '~/.tcms/tcms.log';
+$LOGNAME = $ENV{CUSTOM_LOG} if $ENV{CUSTOM_LOG};
+
+my $LEVEL = $ENV{WWW_VERBOSE} ? 'debug' : 'info';
+
+# By default only log requests & warnings.
+# Otherwise emit debug messages.
+my $rotate = Log::Dispatch::FileRotate->new(
+    name      => 'tcms',
+    filename  => $LOGNAME,
+    min_level => $LEVEL,
+    'mode'    => 'append',
+    size      => 10 * 1024 * 1024,
+    max       => 6,
+);
+
+# Only send fatal events/errors to prod-web.log
+my $screen = Log::Dispatch::Screen->new(
+    name      => 'screen',
+    min_level => 'error',
+);
+our $log = Log::Dispatch->new();
+$log->add($rotate);
+$log->add($screen);
+
+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.");
+uuid("BEGIN");
+
+#memoize
+my $rq;
+
+sub is_debug {
+    return $LEVEL eq 'debug';
+}
+
+sub uuid {
+    my $requestid = shift;
+    $rq = $requestid if $requestid;
+    $requestid //= return $rq;
+}
+
+#XXX make perl -c quit whining
+BEGIN {
+    our $user;
+    $Trog::Log::user = 'nobody';
+}
+
+sub _log {
+    my ( $msg, $level ) = @_;
+
+    my $tstamp = strftime "%a %b %d %T %Y", localtime;
+    my $uuid   = uuid();
+
+    return "[$level]: <$tstamp> {Request $uuid} |$Trog::Log::user| $msg\n";
+}
+
+sub DEBUG {
+    $log->debug( _log( shift, 'DEBUG' ) );
+}
+
+sub INFO {
+    $log->info( _log( shift, 'INFO' ) );
+}
+
+sub WARN {
+    $log->warning( _log( shift, 'WARN' ) );
+}
+
+sub FATAL {
+    $log->log_and_die( level => 'error', message => _log( shift, 'FATAL' ) );
+}
+
+1;

lib/Trog/Routes/HTML.pm

@@ -19,6 +19,7 @@ use CSS::Minifier::XS;
 use Path::Tiny();
 use File::Basename qw{dirname};
 
+use Trog::Log qw{:all};
 use Trog::Utils;
 use Trog::Config;
 use Trog::Auth;