A vault, and a code that is worth one thing

Reprovisioning asks for the KeePass passphrase every run, which means the person
doing it has to be holding it -- so it gets written down, and the thing too
dangerous for a config file ends up in a text file.  Trog::Vault keeps it
instead, sealed with a key the database does not contain, so a stolen auth.db is
ciphertext.

AES-256-GCM per row, under HKDF(master, fresh 32 byte salt), with the username
and the secret's name as associated data -- so a row cannot be lifted into
another account or renamed into being the answer to a different question.  The
key comes out of the environment at load and is deleted in the same breath,
because one of the things this process forks is a provisioner we hand a
decrypted password to.

TOTP is what authorizes opening it, which is only honest if a code is worth one
use: six digits inside a ninety second tolerance was fine for a door and is not
fine for releasing a password.  spend_totp walks a per-user counter forwards,
tolerance is down to one step, and logging in spends a code like everything
else.

Passwords were one unstretched sha256 -- a hash built to be fast over a thing
built to be guessed.  They are Argon2id at OWASP's minimum configuration now,
and the old ones rewrite themselves the next time their owner logs in, so
nobody is locked out and nobody has to be told.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01ADwKSaBSvUTdA3RtGQeNau

Makefile.PL

@@ -25,6 +25,8 @@ WriteMakefile(
         'Capture::Tiny'                       => '0',
         'Carp'                                => '0',
         'Config::Simple'                      => '0',
+        'Crypt::Argon2'                       => '0',
+        'CryptX'                              => '0',
         'DBD::SQLite'                         => '0',
         'DBI'                                 => '0',
         'Date::Format'                        => '0',

lib/Trog/Auth.pm

@@ -7,6 +7,7 @@ use FindBin::libs;
 
 use Ref::Util qw{is_arrayref};
 use Digest::SHA 'sha256';
+use Crypt::Argon2 qw{argon2id_pass argon2id_verify argon2_needs_rehash};
 use Trog::TOTP;
 use Imager::QRCode;
 
@@ -271,6 +272,146 @@ sub has_totp ($user) {
     return $rows->[0]{totp_secret} ? 1 : 0;
 }
 
+=head2 spend_totp(user, code) = ($ok, $why)
+
+Check a TOTP code and spend it.  A code that has been spent, or that is older
+than one this user has already spent, is refused however valid the arithmetic
+says it is.
+
+This is the difference between a second factor at the door and a second factor
+that authorizes a particular thing.  A code read over somebody's shoulder, or
+left in a proxy log, is good for the rest of its window otherwise -- and what it
+would be good for is releasing a stored password, which is not a window anybody
+should be relaxed about.
+
+The cost is that a code is worth one action.  Logging in and then immediately
+asking for a secret means waiting for the next one, which is thirty seconds and
+is the point.
+
+Tolerance is one step either way, for clocks that disagree a little.  It used to
+be three, which was ninety seconds of a code staying good, and there is no
+reason for that once a code cannot be used twice anyway.
+
+=cut
+
+our $totp_tolerance = 1;
+our $totp_period    = 30;
+our $totp_digits    = 6;
+
+sub spend_totp ( $user, $code ) {
+    return ( 0, 'no code given' ) unless defined $code && $code =~ m/^[0-9]{$totp_digits}$/;
+
+    my $dbh    = _dbh();
+    my $rows   = $dbh->selectall_arrayref( "SELECT totp_secret FROM user WHERE name=?", { Slice => {} }, $user );
+    my $secret = ref $rows eq 'ARRAY' && @$rows ? $rows->[0]{totp_secret} : undef;
+    return ( 0, 'this user has no second factor enrolled' ) unless $secret;
+
+    # Forced in rather than passed: expected_totp_code reads the object, and
+    # the object generates a secret of its own if it has not got one.
+    my $totp = _totp();
+    $totp->{secret} = $secret;
+    $totp->{period} = $totp_period;
+    $totp->{digits} = $totp_digits;
+
+    my $now = time();
+    my $matched;
+    foreach my $offset ( -$totp_tolerance .. $totp_tolerance ) {
+        my $when = $now + ( $offset * $totp_period );
+        next unless $totp->expected_totp_code($when) eq $code;
+        $matched = int( $when / $totp_period );
+        last;
+    }
+
+    if ( !defined $matched ) {
+        log_event( 'totp_failure', $user );
+        return ( 0, 'that code is not right' );
+    }
+
+    my $spent = $dbh->selectall_arrayref( "SELECT step FROM totp_spent WHERE username=?", { Slice => {} }, $user );
+    my $last  = ref $spent eq 'ARRAY' && @$spent ? $spent->[0]{step} : 0;
+    if ( $matched <= $last ) {
+        log_event( 'totp_replay', $user );
+        return ( 0, 'that code has already been used; wait for the next one' );
+    }
+
+    $dbh->do( "INSERT OR REPLACE INTO totp_spent (username, step) VALUES (?,?)", undef, $user, $matched )
+      or return ( 0, 'could not record the code as used, so it is refused' );
+
+    return ( 1, '' );
+}
+
+=head2 check_password(user, pass) = BOOL
+
+Whether this is the user's password, upgrading how it is stored if it is.
+
+Passwords were kept as a single unstretched sha256 of the password and a salt,
+which is a hash built to be fast over a thing built to be guessed: a commodity
+GPU walks a list of them at billions a second.  They are Argon2id now, which is
+built to be slow and to want memory, so the same list costs real hardware and
+real time.
+
+Both live in the same column.  An Argon2 hash says what it is in its first few
+characters, so a row that does not is the old kind: it is checked the old way,
+and then, having just been handed a correct password in plaintext for the only
+moment anyone ever will be, rewritten as the new kind.  Nobody is logged out and
+nobody has to be told, and the old hashes leave as their owners come back.
+
+The same rewrite happens when the parameters here are raised, which is what
+makes raising them later a one-line change rather than a migration.
+
+=cut
+
+# OWASP's minimum acceptable Argon2id configuration.  Deliberately not their
+# generous one: /auth takes a password from anybody who asks, so what is on the
+# other side of it is a memory allocation an unauthenticated request can ask
+# for, times however many workers are listening.
+our $argon2_time    = 2;
+our $argon2_memory  = '19456k';
+our $argon2_lanes   = 1;
+our $argon2_tag     = 32;
+our $argon2_saltlen = 16;
+
+sub check_password ( $user, $pass ) {
+    return 0 unless defined $pass && length($pass);
+
+    my $dbh  = _dbh();
+    my $rows = $dbh->selectall_arrayref( "SELECT hash, salt FROM user WHERE name = ?", { Slice => {} }, $user );
+    return 0 unless ref $rows eq 'ARRAY' && @$rows;
+
+    my ( $hash, $salt ) = ( $rows->[0]{hash}, $rows->[0]{salt} );
+    return 0 unless defined $hash && length($hash);
+
+    if ( index( $hash, '$argon2' ) == 0 ) {
+        return 0 unless eval { argon2id_verify( $hash, $pass ) };
+
+        # Cheap, and it is the only time we hold the password, so it is the only
+        # time the cost of a stronger hash can be paid.
+        _store_password( $user, $pass )
+          if argon2_needs_rehash( $hash, 'argon2id', $argon2_time, $argon2_memory, $argon2_lanes, $argon2_tag, $argon2_saltlen );
+        return 1;
+    }
+
+    return 0 unless sha256( $pass . ( $salt // '' ) ) eq $hash;
+    INFO("Upgrading the stored password for $user from sha256 to argon2id");
+    _store_password( $user, $pass );
+    return 1;
+}
+
+# The hash and the salt that goes with it.  Argon2 carries the salt in its own
+# encoding as well; the column keeps it because the rows which have not been
+# upgraded yet are still using it for what it was for.
+sub _hash_password ($pass) {
+    my $salt = Trog::Utils::uuid();
+    $salt = substr( $salt, 0, $argon2_saltlen );
+    return ( argon2id_pass( $pass, $salt, $argon2_time, $argon2_memory, $argon2_lanes, $argon2_tag ), $salt );
+}
+
+sub _store_password ( $user, $pass ) {
+    my ( $hash, $salt ) = _hash_password($pass);
+    my $dbh = _dbh();
+    return $dbh->do( "UPDATE user SET hash=?, salt=? WHERE name=?", undef, $hash, $salt, $user ) ? 1 : 0;
+}
+
 =head2 mksession(user, pass, token) = STRING
 
 Create a session for the user and waste all other sessions.
@@ -280,37 +421,26 @@ Returns a session ID, or blank string in the event the user does not exist or in
 =cut
 
 sub mksession ( $user, $pass, $token, $ip_addr = '' ) {
-    my $dbh  = _dbh();
-    my $totp = _totp();
+    my $dbh = _dbh();
 
-    # Check the password
-    my $records = $dbh->selectall_arrayref( "SELECT salt FROM user WHERE name = ?", { Slice => {} }, $user );
-    return '' unless ref $records eq 'ARRAY' && @$records;
-    my $salt   = $records->[0]->{salt};
-    my $hash   = sha256( $pass . $salt );
-    my $worked = $dbh->selectall_arrayref( "SELECT name, totp_secret FROM user WHERE hash=? AND name = ?", { Slice => {} }, $hash, $user );
-    if ( !( ref $worked eq 'ARRAY' && @$worked ) ) {
+    my $records = $dbh->selectall_arrayref( "SELECT name, hash, salt, totp_secret FROM user WHERE name = ?", { Slice => {} }, $user );
+    if ( !( ref $records eq 'ARRAY' && @$records ) || !check_password( $user, $pass ) ) {
         INFO("Failed login for user $user");
-        _log_event( 'login_failure', $user, $ip_addr );
+        log_event( 'login_failure', $user, $ip_addr );
         return '';
     }
-    my $uid    = $worked->[0]{name};
-    my $secret = $worked->[0]{totp_secret};
+    my $uid    = $records->[0]{name};
+    my $secret = $records->[0]{totp_secret};
 
-    # Validate the 2FA Token.  If we have no secret, allow login so they can see their QR code, and subsequently re-auth.
+    # No secret means they have not enrolled yet, and letting them in is how
+    # they get to -- the enrolment page is behind a login, since the QR on it is
+    # the secret.  TCMS::needs_enrolment is what stops that being a way to have
+    # an account with no second factor: it is the only page they can reach.
     if ($secret) {
-        if ( !$token ) {
-            _log_event( 'totp_failure', $user, $ip_addr );
-            return '';
-        }
-        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;
-        my $rc = $totp->validate_otp( otp => $token, secret => $secret, tolerance => 3, period => 30, digits => 6 );
-        if ( !$rc ) {
-            INFO("TOTP Auth failed for user $user");
-            _log_event( 'totp_failure', $user, $ip_addr );
+        my ( $ok, $why ) = spend_totp( $user, $token );
+        if ( !$ok ) {
+            INFO("TOTP auth failed for user $user: $why");
+            log_event( 'totp_failure', $user, $ip_addr );
             return '';
         }
     }
@@ -318,7 +448,7 @@ sub mksession ( $user, $pass, $token, $ip_addr = '' ) {
     # Issue cookie
     my $uuid = Trog::Utils::uuid();
     $dbh->do( "INSERT OR REPLACE INTO session (id,username) VALUES (?,?)", undef, $uuid, $uid ) or return '';
-    _log_event( 'login_success', $user, $ip_addr, $uuid );
+    log_event( 'login_success', $user, $ip_addr, $uuid );
     return $uuid;
 }
 
@@ -331,7 +461,7 @@ Delete the provided user's session from the auth db.
 sub killsession ( $user, $ip_addr = '' ) {
     my $dbh = _dbh();
     $dbh->do( "DELETE FROM session WHERE username=?", undef, $user );
-    _log_event( 'logout', $user, $ip_addr );
+    log_event( 'logout', $user, $ip_addr );
     return 1;
 }
 
@@ -359,10 +489,7 @@ sub useradd ( $user, $displayname, $pass, $acls, $contactemail ) {
     die "No contact email set for user!" unless $contactemail;
 
     my $dbh = _dbh();
-    if ($pass) {
-        $salt = Trog::Utils::uuid();
-        $hash = sha256( $pass . $salt );
-    }
+    ( $hash, $salt ) = _hash_password($pass) if $pass;
     my $res = $dbh->do( "INSERT OR REPLACE INTO user (name, display_name, salt, hash, contact_email, totp_secret) VALUES (?,?,?,?,?,?)", undef, $user, $displayname, $salt, $hash, $contactemail, $t_secret );
     return unless $res && ref $acls eq 'ARRAY';
 
@@ -443,8 +570,19 @@ sub audit_log (%opts) {
     return $rows;
 }
 
-# Write one event row; silently swallows errors so logging never breaks auth flow.
-sub _log_event ( $event_type, $username, $ip_addr = '', $session_id = undef ) {
+=head2 log_event($event_type, $username, $ip_addr, $session_id)
+
+Write one row to the audit log.
+
+Public because the vault writes to it too: reading somebody's stored password is
+the same kind of event as logging in as them, and it belongs in the same list.
+
+Swallows its own errors.  A login that fails because the audit table is unhappy
+would be a worse outcome than a login nobody wrote down.
+
+=cut
+
+sub log_event ( $event_type, $username, $ip_addr = '', $session_id = undef ) {
     eval {
         my $dbh = _dbh();
         $dbh->do(

lib/Trog/Vault.pm

@@ -0,0 +1,301 @@
+package Trog::Vault;
+
+use v5.36;
+use re '/aa';
+
+use Crypt::AuthEnc::GCM  ();
+use Crypt::KeyDerivation ();
+use Crypt::Misc          ();
+use Crypt::PRNG          ();
+use Digest::SHA          ();
+use File::Slurper        ();
+
+use Trog::Auth;
+use Trog::Log qw{WARN INFO};
+use Trog::SQLite;
+
+=head1 Trog::Vault
+
+Things a user asked us to remember, kept where the database alone will not give
+them up.
+
+=head1 WHAT THIS IS FOR
+
+Some of what tCMS does on a user's behalf needs a password that is not tCMS's:
+the KeePass passphrase every provisioning recipe's secret: values are behind,
+for one.  Asking for it every time works, and is what reprovisioning used to do,
+but it means the person has to be holding it -- so it gets written down, and the
+thing that was too dangerous to keep in a config file ends up in a text file
+instead.
+
+So we keep it, and ask for a TOTP code instead of the password when it is time
+to use it.
+
+=head1 WHAT A TOTP CODE IS AND IS NOT
+
+It is not a key.  Six digits is twenty bits, it changes every thirty seconds,
+and we have to know the secret to check it, so nothing can be encrypted with it
+and stay encrypted.  What it is, is evidence that the person is at the keyboard
+right now, which is exactly what you want to demand before handing a stored
+password to a process.  See Trog::Auth::spend_totp: a code is worth one thing
+rather than everything you can do inside its window.
+
+The key is elsewhere.
+
+=head1 WHERE THE KEY IS
+
+An installation has one master key, and it is not in the database, so the
+database on its own is ciphertext.  It is looked for in this order:
+
+    TCMS_VAULT_KEY              base64, in the environment
+    $CREDENTIALS_DIRECTORY/tcms-vault
+    config/secrets.key          base64, in a file
+
+The first is how a real deployment does it, and the reason it is first is the
+chroot: tPSGI runs the workers chrooted into the installation, and systemd's
+credential store is a ramdisk at /run/credentials which is outside it.  So the
+unit takes the credential, service/tpsgi.sh reads it before the chroot happens
+and puts it in the environment, and the key never touches a disk anywhere.
+
+It is taken out of the environment at load, so nothing we fork afterwards
+inherits it -- which matters, because one of the things we fork is a provisioner
+that we are handing a decrypted password to on its stdin.  Read once, in the
+parent, before there are any workers; the workers inherit the key as a variable
+and an environment without it.
+
+The second is for a service that is not chrooted.  The third is for a machine
+that is not running systemd at all, and it is the weakest of the three: a file
+next to the database it protects is a file that goes into the same backup.
+
+No key means no vault.  Nothing is stored and nothing is offered, and the parts
+of tCMS which would have used one ask for the password directly, as they did
+before.  That is a feature being off, not a failure.
+
+=head1 WHAT IS ACTUALLY DONE TO A SECRET
+
+AES-256-GCM, under a key derived for that one row:
+
+    salt        32 random bytes, fresh for every write
+    key, iv     HKDF-SHA256(master, salt) -- 44 bytes, split 32 and 12
+    aad         the username and the secret's name
+
+The salt being fresh per write is what makes the derived key and iv fresh per
+write, which is the thing GCM cares about.  The username and name go in as
+associated data rather than being merely stored alongside, so a row cannot be
+lifted into another user's account or renamed into being the answer to a
+different question -- the tag stops checking out.
+
+key_id is a fingerprint of the master key.  It is not needed to decrypt
+anything; it is there so that a row written under a key you no longer have says
+so, rather than presenting as corruption.
+
+=head1 FUNCTIONS
+
+=cut
+
+# 32 raw bytes.  Read at load: see WHERE THE KEY IS -- this is the moment the
+# environment is scrubbed, and it has to be before anything forks.
+our $key_file       = 'config/secrets.key';
+our $credential     = 'tcms-vault';
+our $key_bytes      = 32;
+our $master         = _from_env();
+our $looked_further = 0;
+
+sub _from_env {
+    my $raw = delete $ENV{TCMS_VAULT_KEY};
+    return undef unless defined $raw && length($raw);
+    return _decode( $raw, 'TCMS_VAULT_KEY' );
+}
+
+sub _decode ( $raw, $whence ) {
+    $raw =~ s/\s+//g;
+    my $key = eval { Crypt::Misc::decode_b64($raw) };
+    if ( !defined $key || length($key) != $key_bytes ) {
+        WARN("The vault key in $whence is not $key_bytes base64 encoded bytes; ignoring it");
+        return undef;
+    }
+    return $key;
+}
+
+# The two places worth looking that are not the environment.  Deferred rather
+# than done at load, since both are files and this module is loaded by things
+# which have no interest in a vault.
+sub _look_further {
+    $looked_further = 1;
+
+    my $dir = $ENV{CREDENTIALS_DIRECTORY};
+    if ($dir) {
+        my $path = "$dir/$credential";
+        my $raw  = eval { File::Slurper::read_binary($path) };
+        return _decode( $raw, $path ) if defined $raw;
+    }
+
+    my $raw = eval { File::Slurper::read_binary($key_file) };
+    return undef unless defined $raw;
+
+    # A key file the group or the world can read is a key file that has already
+    # been read.  Said rather than refused: the alternative is a site that
+    # silently stops being able to open its own secrets.
+    my @stat = stat($key_file);
+    WARN("$key_file is readable by more than its owner; chmod 600 it") if @stat && ( $stat[2] & oct('077') );
+
+    return _decode( $raw, $key_file );
+}
+
+=head2 key() = STRING or undef
+
+The master key, or undef when this installation has none.
+
+=head2 has_key() = BOOL
+
+Whether there is a vault at all.  Ask this before offering a user anywhere to
+put a secret, so that a site with no key says so rather than accepting one and
+losing it.
+
+=cut
+
+sub key {
+    $master //= _look_further() unless $looked_further;
+    return $master;
+}
+
+sub has_key { return key() ? 1 : 0 }
+
+=head2 key_id() = STRING
+
+A fingerprint of the master key, stored on each row so that a row written under
+a key which is no longer here can say which.
+
+=cut
+
+sub key_id {
+    my $key = key() or return '';
+    return substr( Digest::SHA::sha256_hex($key), 0, 16 );
+}
+
+# Bound into the ciphertext, so that moving a row between users or renaming it
+# breaks the tag rather than working.
+sub _aad ( $user, $name ) { return join( "\0", $user, $name ) }
+
+sub _derive ($salt) {
+    my $material = Crypt::KeyDerivation::hkdf( key(), $salt, 'SHA256', 44, 'tcms/user-secret' );
+    return ( substr( $material, 0, 32 ), substr( $material, 32, 12 ) );
+}
+
+=head2 set($user, $name, $secret) = ($ok, $message)
+
+Remember one thing for one user, replacing whatever was there under that name.
+
+=cut
+
+sub set ( $user, $name, $secret ) {
+    return ( 0, 'this installation has no vault key, so there is nowhere to keep it' ) unless has_key();
+    return ( 0, 'a secret needs a name' )                                              unless _safe_name($name);
+    return ( 0, 'nothing to store' )                                                   unless defined $secret && length($secret);
+
+    my $salt = Crypt::PRNG::random_bytes(32);
+    my ( $key, $iv ) = _derive($salt);
+
+    my $gcm = Crypt::AuthEnc::GCM->new( 'AES', $key, $iv );
+    $gcm->adata_add( _aad( $user, $name ) );
+    my $ciphertext = $gcm->encrypt_add($secret);
+    my $tag        = $gcm->encrypt_done();
+
+    my $dbh = _dbh();
+    $dbh->do(
+        "INSERT OR REPLACE INTO user_secret (username, name, key_id, salt, ciphertext, tag, created) VALUES (?,?,?,?,?,?,?)",
+        undef, $user, $name, key_id(), $salt, $ciphertext, $tag, time()
+    ) or return ( 0, 'could not store it' );
+
+    Trog::Auth::log_event( 'secret_write', $user );
+    return ( 1, "'$name' stored" );
+}
+
+=head2 get($user, $name) = STRING or undef
+
+What was stored, or undef if there is nothing under that name, no key to open it
+with, or a key which is not the one it was sealed under.
+
+Every call is an audit_log row.  Reading a stored password is the interesting
+event here, not writing one.
+
+=cut
+
+sub get ( $user, $name ) {
+    return undef unless has_key();
+
+    my $dbh  = _dbh();
+    my $rows = $dbh->selectall_arrayref(
+        "SELECT key_id, salt, ciphertext, tag FROM user_secret WHERE username=? AND name=?",
+        { Slice => {} }, $user, $name
+    );
+    return undef unless ref $rows eq 'ARRAY' && @$rows;
+    my $row = $rows->[0];
+
+    if ( $row->{key_id} ne key_id() ) {
+        WARN( "'$name' for $user was sealed under vault key $row->{key_id}, and this installation has " . key_id() );
+        return undef;
+    }
+
+    my ( $key, $iv ) = _derive( $row->{salt} );
+    my $gcm = Crypt::AuthEnc::GCM->new( 'AES', $key, $iv );
+    $gcm->adata_add( _aad( $user, $name ) );
+    my $secret = $gcm->decrypt_add( $row->{ciphertext} );
+
+    # The tag is the whole point: it says this ciphertext, under this key, for
+    # this user and this name, is the one that was written.
+    if ( !$gcm->decrypt_done( $row->{tag} ) ) {
+        WARN("'$name' for $user did not survive its own tag check; it has been tampered with or the database is damaged");
+        return undef;
+    }
+
+    $dbh->do( "UPDATE user_secret SET last_used=? WHERE username=? AND name=?", undef, time(), $user, $name );
+    Trog::Auth::log_event( 'secret_read', $user );
+    return $secret;
+}
+
+=head2 list($user) = ARRAYREF
+
+What this user has stored, as names and dates.  Never values -- there is no
+route, page or log line anywhere that shows one back to them, because a secret
+you can read off a screen is one you did not need us to keep.
+
+=cut
+
+sub list ($user) {
+    my $dbh  = _dbh();
+    my $rows = $dbh->selectall_arrayref(
+        "SELECT name, created, last_used, key_id FROM user_secret WHERE username=? ORDER BY name",
+        { Slice => {} }, $user
+    );
+    return [] unless ref $rows eq 'ARRAY';
+
+    # A row we cannot open is worth saying so about rather than listing as
+    # though it were usable.
+    my $id = key_id();
+    $_->{readable} = ( $id && $_->{key_id} eq $id ) ? 1 : 0 foreach @$rows;
+    return $rows;
+}
+
+=head2 forget($user, $name) = BOOL
+
+=cut
+
+sub forget ( $user, $name ) {
+    my $dbh = _dbh();
+    my $res = $dbh->do( "DELETE FROM user_secret WHERE username=? AND name=?", undef, $user, $name );
+    Trog::Auth::log_event( 'secret_delete', $user ) if $res && $res != 0;
+    return $res && $res != 0 ? 1 : 0;
+}
+
+# A name is a label in a form and a key in a table, and it is half of what binds
+# a row to its owner, so it is a short plain thing or it is nothing.
+sub _safe_name ($name) {
+    return 0 unless defined $name && length($name) && length($name) <= 64;
+    return $name =~ m/^[A-Za-z0-9][A-Za-z0-9._-]*$/ ? 1 : 0;
+}
+
+# The same database the users are in, since a secret belongs to one.
+sub _dbh { return Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' ) }
+
+1;

schema/auth.schema

@@ -42,3 +42,26 @@ CREATE TABLE IF NOT EXISTS audit_log (
 
 CREATE INDEX IF NOT EXISTS audit_log_time_idx ON audit_log(event_time);
 CREATE INDEX IF NOT EXISTS audit_log_user_idx ON audit_log(username);
+
+-- What a user asked us to remember for them, sealed with the installation's
+-- master key.  See Trog::Vault: the key is not in this file and not in this
+-- database, so these rows are ciphertext to anybody who only has the db.
+CREATE TABLE IF NOT EXISTS user_secret (
+    username   TEXT    NOT NULL REFERENCES user(name) ON DELETE CASCADE,
+    name       TEXT    NOT NULL,
+    key_id     TEXT    NOT NULL,
+    salt       BLOB    NOT NULL,
+    ciphertext BLOB    NOT NULL,
+    tag        BLOB    NOT NULL,
+    created    INTEGER NOT NULL,
+    last_used  INTEGER DEFAULT NULL,
+    PRIMARY KEY (username, name)
+);
+
+-- The last TOTP timestep this user spent.  A code authorizes things now, so it
+-- is worth exactly one thing rather than everything you can do inside its
+-- window.
+CREATE TABLE IF NOT EXISTS totp_spent (
+    username TEXT    NOT NULL UNIQUE REFERENCES user(name) ON DELETE CASCADE,
+    step     INTEGER NOT NULL
+);

t/Trog-Vault.t

@@ -0,0 +1,258 @@
+#!/usr/bin/env perl
+
+# The vault, the code that authorizes opening it, and the hashing underneath
+# both.  Nothing here needs a webserver: what is being tested is that a database
+# on its own is not enough, and that a code is worth one thing.
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+use Test::More;
+use Test::MockModule qw{strict};
+
+our ( $REPO, $ROOT, $OLDCWD );
+
+BEGIN {
+    require Cwd;
+    require File::Copy;
+    require File::Path;
+    require File::Temp;
+
+    $REPO   = Cwd::abs_path("$FindBin::Bin/..");
+    $OLDCWD = Cwd::getcwd();
+    $ROOT   = File::Temp::tempdir( 'tcms-vault-XXXXXX', TMPDIR => 1, CLEANUP => 1 );
+
+    $ENV{HOME} = $ROOT;
+    File::Path::make_path( map { "$ROOT/$_" } qw{config schema logs totp} );
+    File::Copy::copy( "$REPO/schema/auth.schema", "$ROOT/schema/auth.schema" ) or die $!;
+
+    open( my $fh, '>', "$ROOT/config/default.cfg" ) or die $!;
+    print {$fh} "[general]\n    data_model=FlatFile\n    hostname=vault.example.com\n";
+    close $fh;
+
+    # The key the way a deployment hands one over: base64, in the environment,
+    # put there by tpsgi.sh out of a systemd credential.  Trog::Vault takes it
+    # out of %ENV as it loads, which is the behaviour tested below.
+    require Crypt::PRNG;
+    require Crypt::Misc;
+    $ENV{TCMS_VAULT_KEY} = Crypt::Misc::encode_b64( Crypt::PRNG::random_bytes(32) );
+
+    chdir($ROOT) or die "could not chdir to the sandbox: $!";
+}
+
+END {
+    chdir($OLDCWD) if $OLDCWD;
+}
+
+require_ok('Trog::Auth')  or BAIL_OUT("Can't find Trog::Auth");
+require_ok('Trog::Vault') or BAIL_OUT("Can't find SUT");
+
+Trog::Auth::useradd( 'bob', 'Bob Bobson', 'hunter2', ['admin'], 'bob@example.com' )
+  or BAIL_OUT('could not make a user to test with');
+Trog::Auth::useradd( 'eve', 'Eve Evilson', 'letmein', ['public'], 'eve@example.com' )
+  or BAIL_OUT('could not make a second user');
+
+subtest 'the key is taken out of the environment' => sub {
+    ok( Trog::Vault::has_key(),       'the key was read' );
+    ok( !exists $ENV{TCMS_VAULT_KEY}, 'and is gone from the environment, so nothing we fork inherits it' );
+    like( Trog::Vault::key_id(), qr/^[0-9a-f]{16}$/, 'and fingerprints to something a row can name' );
+};
+
+subtest 'what a secret looks like on disk' => sub {
+    my ( $ok, $why ) = Trog::Vault::set( 'bob', 'keepass', 'correct horse battery staple' );
+    is( $ok, 1, 'a secret can be stored' ) or diag($why);
+
+    my $dbh  = Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' );
+    my $rows = $dbh->selectall_arrayref( "SELECT * FROM user_secret WHERE username='bob'", { Slice => {} } );
+    is( scalar(@$rows), 1, 'and lands in one row' );
+
+    my $row = $rows->[0];
+    unlike( $row->{ciphertext}, qr/correct horse/, 'which does not contain the secret' );
+    is( length( $row->{salt} ), 32,                    'carries a fresh 32 byte salt' );
+    is( length( $row->{tag} ),  16,                    'and a GCM tag' );
+    is( $row->{key_id},         Trog::Vault::key_id(), 'naming the key it was sealed under' );
+
+    is( Trog::Vault::get( 'bob', 'keepass' ), 'correct horse battery staple', 'and it comes back out' );
+};
+
+subtest 'a fresh salt every write' => sub {
+    my $dbh = Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' );
+
+    Trog::Vault::set( 'bob', 'same', 'the very same secret' );
+    my ($first) = $dbh->selectrow_array("SELECT hex(ciphertext) FROM user_secret WHERE username='bob' AND name='same'");
+    Trog::Vault::set( 'bob', 'same', 'the very same secret' );
+    my ($second) = $dbh->selectrow_array("SELECT hex(ciphertext) FROM user_secret WHERE username='bob' AND name='same'");
+
+    # Same plaintext, same key, different ciphertext -- which is what a random
+    # salt per write buys, and what GCM needs to stay safe.
+    isnt( $first, $second, 'the same secret stored twice does not look the same twice' );
+    is( Trog::Vault::get( 'bob', 'same' ), 'the very same secret', 'and still reads back' );
+};
+
+subtest 'a row cannot be moved or renamed' => sub {
+    my $dbh = Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' );
+
+    # Exactly what somebody with write access to the database would try: take
+    # the admin's sealed passphrase and make it their own.
+    $dbh->do("INSERT OR REPLACE INTO user_secret (username, name, key_id, salt, ciphertext, tag, created) SELECT 'eve', name, key_id, salt, ciphertext, tag, created FROM user_secret WHERE username='bob' AND name='keepass'");
+    is( Trog::Vault::get( 'eve', 'keepass' ), undef, 'a row lifted into another account does not open' );
+
+    $dbh->do("INSERT OR REPLACE INTO user_secret (username, name, key_id, salt, ciphertext, tag, created) SELECT 'bob', 'renamed', key_id, salt, ciphertext, tag, created FROM user_secret WHERE username='bob' AND name='keepass'");
+    is( Trog::Vault::get( 'bob', 'renamed' ), undef, 'nor does one renamed into being the answer to a different question' );
+
+    is( Trog::Vault::get( 'bob', 'keepass' ), 'correct horse battery staple', 'while the row it was copied from is untouched' );
+    $dbh->do("DELETE FROM user_secret WHERE name IN ('renamed') OR username='eve'");
+};
+
+subtest 'and not without the key it was sealed under' => sub {
+    my $dbh = Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' );
+
+    # A different installation's key, which is what a stolen database meets.
+    my $theirs = Trog::Vault::key();
+    {
+        no warnings qw{once};
+        local $Trog::Vault::master = Crypt::PRNG::random_bytes(32);
+        is( Trog::Vault::get( 'bob', 'keepass' ), undef, 'the wrong key opens nothing' );
+
+        my $listed = Trog::Vault::list('bob');
+        my ($keepass) = grep { $_->{name} eq 'keepass' } @$listed;
+        is( $keepass->{readable}, 0, 'and the listing says so rather than pretending' );
+    }
+    is( Trog::Vault::get( 'bob', 'keepass' ), 'correct horse battery staple', 'the right one still does' );
+
+    # Tampering, as opposed to the wrong key: the tag is what notices.
+    $dbh->do("UPDATE user_secret SET ciphertext = ciphertext || X'00' WHERE username='bob' AND name='keepass'");
+    is( Trog::Vault::get( 'bob', 'keepass' ), undef, 'a row somebody edited does not open either' );
+    Trog::Vault::set( 'bob', 'keepass', 'correct horse battery staple' );
+};
+
+subtest 'the listing never shows a value' => sub {
+    my $listed = Trog::Vault::list('bob');
+    ok( scalar(@$listed) >= 2, 'lists what bob has' );
+    foreach my $secret (@$listed) {
+        ok( !exists $secret->{ciphertext}, "$secret->{name} is listed without its ciphertext" );
+        ok( exists $secret->{created},     "$secret->{name} says when it was stored" );
+    }
+    is_deeply( Trog::Vault::list('eve'), [], 'and one user cannot see another\'s' );
+
+    ok( Trog::Vault::forget( 'bob', 'same' ), 'a secret can be forgotten' );
+    is( Trog::Vault::get( 'bob', 'same' ),    undef, 'after which it is gone' );
+    is( Trog::Vault::forget( 'bob', 'same' ), 0,     'and forgetting it twice is not a thing that happened' );
+};
+
+subtest 'a name is a name' => sub {
+    foreach my $bad ( '../../etc/passwd', 'has spaces', '', 'a' x 100, '.hidden' ) {
+        my ( $ok, $why ) = Trog::Vault::set( 'bob', $bad, 'nope' );
+        is( $ok, 0, "'$bad' is refused as a name" );
+    }
+    my ( $ok, $why ) = Trog::Vault::set( 'bob', 'fine', '' );
+    is( $ok, 0, 'and an empty secret is not a secret' );
+};
+
+subtest 'no key, no vault' => sub {
+    no warnings qw{once};
+    local $Trog::Vault::master         = undef;
+    local $Trog::Vault::looked_further = 1;
+
+    ok( !Trog::Vault::has_key(), 'an installation with no key has no vault' );
+    my ( $ok, $why ) = Trog::Vault::set( 'bob', 'nowhere', 'to put it' );
+    is( $ok, 0, 'storing is refused' );
+    like( $why, qr/no vault key/, 'saying why, since this is a thing to go and configure' );
+    is( Trog::Vault::get( 'bob', 'keepass' ), undef, 'and nothing already stored is offered' );
+};
+
+subtest 'a code is worth one thing' => sub {
+    my ( $uri, $qr, $failure, $message, $totp ) = Trog::Auth::totp( 'bob', 'vault.example.com' );
+    ok( $uri, 'bob is enrolled' ) or diag($message);
+
+    my $now  = time();
+    my $code = $totp->expected_totp_code($now);
+
+    my ( $ok, $why ) = Trog::Auth::spend_totp( 'bob', $code );
+    is( $ok, 1, 'the code from their authenticator is accepted' ) or diag($why);
+
+    ( $ok, $why ) = Trog::Auth::spend_totp( 'bob', $code );
+    is( $ok, 0, 'and is not accepted a second time' );
+    like( $why, qr/already been used/, 'saying so, since the answer is to wait thirty seconds' );
+
+    # A code from before the one just spent is also spent, whatever the
+    # arithmetic says: that is what walking the counter forward is for.
+    my $previous = $totp->expected_totp_code( $now - 30 );
+    ( $ok, $why ) = Trog::Auth::spend_totp( 'bob', $previous );
+    is( $ok, 0, 'nor is an older code from inside the tolerance window' );
+
+    ( $ok, $why ) = Trog::Auth::spend_totp( 'bob', '000000' );
+    is( $ok, 0, 'a wrong code is refused' );
+    ( $ok, $why ) = Trog::Auth::spend_totp( 'bob', 'notacode' );
+    is( $ok, 0, 'and so is something that is not a code at all' );
+
+    ( $ok, $why ) = Trog::Auth::spend_totp( 'eve', $totp->expected_totp_code( $now + 30 ) );
+    is( $ok, 0, 'somebody who has not enrolled cannot spend anything' );
+    like( $why, qr/no second factor/, 'and is told that rather than that their code was wrong' );
+
+    # The next window is a new code and works, which is the whole cost of this.
+    ( $ok, $why ) = Trog::Auth::spend_totp( 'bob', $totp->expected_totp_code( $now + 30 ) );
+    is( $ok, 1, 'the next code works' ) or diag($why);
+};
+
+subtest 'passwords are argon2id, and become it' => sub {
+    my $dbh = Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' );
+
+    my ($hash) = $dbh->selectrow_array("SELECT hash FROM user WHERE name='bob'");
+    like( $hash, qr/^\$argon2id\$/, 'a user made today is stored as argon2id' );
+    ok( Trog::Auth::check_password( 'bob',  'hunter2' ), 'and their password checks out' );
+    ok( !Trog::Auth::check_password( 'bob', 'hunter3' ), 'while a wrong one does not' );
+    ok( !Trog::Auth::check_password( 'bob', '' ),        'and neither does nothing at all' );
+
+    # A row as it was before this change: one unstretched sha256 of the password
+    # and the salt beside it.
+    require Digest::SHA;
+    $dbh->do( "UPDATE user SET hash=?, salt=? WHERE name=?", undef, Digest::SHA::sha256( 'letmein' . 'oldsalt' ), 'oldsalt', 'eve' );
+    my ($legacy) = $dbh->selectrow_array("SELECT hash FROM user WHERE name='eve'");
+    unlike( $legacy, qr/^\$argon2/, 'a row from before this reads as the old kind' );
+
+    ok( !Trog::Auth::check_password( 'eve', 'wrong' ), 'which still refuses a wrong password' );
+    ($legacy) = $dbh->selectrow_array("SELECT hash FROM user WHERE name='eve'");
+    unlike( $legacy, qr/^\$argon2/, 'and is left alone when it does' );
+
+    ok( Trog::Auth::check_password( 'eve', 'letmein' ), 'and accepts the right one' );
+    my ($upgraded) = $dbh->selectrow_array("SELECT hash FROM user WHERE name='eve'");
+    like( $upgraded, qr/^\$argon2id\$/, 'rewriting it as argon2id on the way past' );
+    ok( Trog::Auth::check_password( 'eve', 'letmein' ), 'after which the same password still works' );
+
+    # Raising the cost later is a one line change, not a migration, for the same
+    # reason: the next correct password rewrites the row.
+    {
+        no warnings qw{once};
+        local $Trog::Auth::argon2_time = $Trog::Auth::argon2_time + 1;
+        ok( Trog::Auth::check_password( 'eve', 'letmein' ), 'a hash made under weaker parameters still verifies' );
+        my ($rehashed) = $dbh->selectrow_array("SELECT hash FROM user WHERE name='eve'");
+        isnt( $rehashed, $upgraded, 'and is rewritten under the stronger ones' );
+    }
+};
+
+subtest 'logging in spends a code' => sub {
+    my ( $uri, $qr, $failure, $message, $totp ) = Trog::Auth::totp( 'bob', 'vault.example.com' );
+
+    # The subtest above spent the code for the window we are standing in, and
+    # the counter only walks forwards.  Standing here for thirty seconds would
+    # say the same thing and cost thirty seconds.
+    my $dbh = Trog::SQLite::dbh( 'schema/auth.schema', 'config/auth.db' );
+    $dbh->do("DELETE FROM totp_spent WHERE username='bob'");
+
+    my $now  = time();
+    my $code = $totp->expected_totp_code($now);
+
+    is( Trog::Auth::mksession( 'bob', 'hunter2', '' ),    '', 'an enrolled user cannot log in without a code' );
+    is( Trog::Auth::mksession( 'bob', 'wrong',   $code ), '', 'nor with a wrong password' );
+
+    # And a login that failed on the password did not spend the code on the way
+    # past, or a wrong guess would cost the person their next thirty seconds.
+    ok( Trog::Auth::mksession( 'bob', 'hunter2', $code ), 'the right password and a live code get a session' );
+    is( Trog::Auth::mksession( 'bob', 'hunter2', $code ), '', 'and that code cannot be replayed into a second one' );
+};
+
+done_testing();