Fix #305: use Trog::TOTP, remove UUID::Tiny altogether

Makefile

@@ -37,7 +37,7 @@ prereq-debs:
 		uwsgi uwsgi-plugin-psgi fail2ban nginx certbot postfix dovecot-imapd dovecot-pop3d postgrey spamassassin amavis clamav\
 	    libtext-xslate-perl libplack-perl libconfig-tiny-perl libdatetime-format-http-perl libjson-maybexs-perl          \
 	    libuuid-tiny-perl libcapture-tiny-perl libconfig-simple-perl libdbi-perl libfile-slurper-perl libfile-touch-perl \
-	    libfile-copy-recursive-perl libxml-rss-perl libmodule-install-perl libio-string-perl                             \
+	    libfile-copy-recursive-perl libxml-rss-perl libmodule-install-perl libio-string-perl uuid-dev                    \
 	    libmoose-perl libmoosex-types-datetime-perl libxml-libxml-perl liblist-moreutils-perl libclone-perl libpath-tiny-perl
 
 .PHONY: prereq-perl

Makefile.PL

@@ -16,7 +16,7 @@ WriteMakefile(
     },
   },
   PREREQ_PM => {
-    'Authen::TOTP'           => '0',
+    'Trog::TOTP'           => '0',
     'CGI::Cookie'            => '0',
     'Capture::Tiny'          => '0',
     'Carp'                   => '0',
@@ -43,7 +43,7 @@ WriteMakefile(
     'Starman'                => '0',
     'Text::Xslate'           => '0',
     'URL::Encode'            => '0',
-    'UUID::Tiny'             => '0',
+    'UUID'                   => '0',
     'WWW::Sitemap::XML'      => '0',
     'WWW::SitemapIndex::XML' => '0',
     'CSS::Minifier::XS'      => '0',

bin/totp

@@ -13,10 +13,7 @@ my $domain = shift @ARGV;
 die "Must provide a user"   unless $user;
 die "Must provide a domain" unless $domain;
 
-my $dbh = Trog::Auth::_dbh();
-
-my $rows = $dbh->selectall_arrayref( "SELECT name, totp_secret FROM user WHERE name = ?", { Slice => {} }, $user );
-die "no such user" unless @$rows;
-my $secret = $rows->[0]->{totp_secret};
-
-print Trog::Auth::expected_totp_code( undef, $secret ) . "\n";
+my ( $uri, $qr, $failure, $message, $totp ) = Trog::Auth::totp($user,$domain);
+print "TOTP URI: $uri\n";
+print "Secret: ".$totp->base32secret()."\n";
+print "Current Auth code: ".$totp->expected_totp_code( time ) . "\n";

lib/TCMS.pm

@@ -372,6 +372,8 @@ sub _toolong ($query) {
 }
 
 sub _error ($query) {
+    $query->{method} //= "UNKNOWN";
+    $query->{fullpath} //= $query->{route} // '/?';
     INFO("$query->{method} 500 $query->{fullpath}");
     return _generic( 'error', $query );
 }

lib/Trog/Auth.pm

@@ -9,11 +9,11 @@ use feature qw{signatures state};
 use FindBin::libs;
 
 use Ref::Util qw{is_arrayref};
-use UUID::Tiny ':std';
 use Digest::SHA 'sha256';
-use Authen::TOTP;
+use Trog::TOTP;
 use Imager::QRCode;
 
+use Trog::Utils;
 use Trog::Log qw{:all};
 use Trog::Config;
 use Trog::SQLite;
@@ -153,7 +153,7 @@ sub totp ( $user, $domain ) {
     my $secret_is_generated = 0;
     if ( !$secret ) {
         $secret_is_generated = 1;
-        $totp->valid_secret();
+        $totp->_valid_secret();
         $secret = $totp->secret();
     }
 
@@ -190,48 +190,20 @@ sub totp ( $user, $domain ) {
         my $img = $qrcode->plot($uri);
         $img->write( file => "totp/$qr", type => "bmp" ) or return ( undef, undef, 1, "Could not write totp/$qr: " . $img->errstr );
     }
-    return ( $uri, $qr, $failure, $message );
+    return ( $uri, $qr, $failure, $message, $totp );
 }
 
+
 sub _totp {
     state $totp;
     if ( !$totp ) {
-        $totp = Authen::TOTP->new();
+        $totp = Trog::TOTP->new();
         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 provided user
@@ -272,7 +244,7 @@ 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) {
         return '' unless $token;
-        DEBUG( "TOTP Auth: Sent code $token, expect " . expected_totp_code( $totp, $secret ) );
+        DEBUG( "TOTP Auth: Sent code $token, expect " . $totp->expected_totp_code(time) );
 
         #XXX we have to force the secret into compliance, otherwise it generates one on the fly, oof
         $totp->{secret} = $secret;
@@ -282,7 +254,7 @@ sub mksession ( $user, $pass, $token ) {
     }
 
     # Issue cookie
-    my $uuid = create_uuid_as_string( UUID_V1, UUID_NS_DNS );
+    my $uuid = Trog::Utils::uuid();
     $dbh->do( "INSERT OR REPLACE INTO session (id,username) VALUES (?,?)", undef, $uuid, $uid ) or return '';
     return $uuid;
 }
@@ -325,7 +297,7 @@ sub useradd ( $user, $displayname, $pass, $acls, $contactemail ) {
 
     my $dbh  = _dbh();
     if ($pass) {
-        $salt = create_uuid();
+        $salt = Trog::Utils::uuid();
         $hash = sha256( $pass . $salt );
     }
     my $res  = $dbh->do( "INSERT OR REPLACE INTO user (name, display_name, salt,hash,contact_email) VALUES (?,?,?,?,?)", undef, $user, $displayname, $salt, $hash, $contactemail );

lib/Trog/DataModule.pm

@@ -3,7 +3,6 @@ package Trog::DataModule;
 use strict;
 use warnings;
 
-use UUID::Tiny;
 use List::Util;
 use File::Copy;
 use Mojo::File;
@@ -311,7 +310,7 @@ sub add ( $self, @posts ) {
 			delete $post->{$key} unless List::Util::any { ($_ eq $key) && ($schema{$key}->($post->{$key})) } keys(%schema);
 		}
 
-        $post->{id}      //= UUID::Tiny::create_uuid_as_string( UUID::Tiny::UUID_V1, UUID::Tiny::UUID_NS_DNS );
+        $post->{id}      //= Trog::Utils::uuid();
         $post->{aliases} //= [];
         $post->{aliases} = [ $post->{aliases} ] unless ref $post->{aliases} eq 'ARRAY';
 

lib/Trog/Utils.pm

@@ -6,7 +6,7 @@ use warnings;
 no warnings 'experimental';
 use feature qw{signatures};
 
-use UUID::Tiny();
+use UUID;
 use HTTP::Tiny::UNIX();
 use Trog::Log qw{WARN};
 use Trog::Config();
@@ -41,7 +41,7 @@ sub restart_parent {
 }
 
 sub uuid {
-    return UUID::Tiny::create_uuid_as_string( UUID::Tiny::UUID_V1, UUID::Tiny::UUID_NS_DNS );
+    return UUID::uuid();
 }
 
 1;