Merge pull request #378 from Troglodyne-Internet-Widgets/vault-key-exclusive

Create the vault key file exclusively, and private from the moment it exists

bin/tcms-vault-key

@@ -8,6 +8,7 @@ use FindBin::libs;
 
 use Crypt::Misc  ();
 use Crypt::PRNG  ();
+use Fcntl        qw{O_CREAT O_EXCL O_WRONLY};
 use Getopt::Long qw{GetOptions};
 
 use Trog::Vault ();
@@ -82,17 +83,20 @@ USAGE
     exit( $help ? 0 : 2 );
 }
 
-# Printed and exited rather than died, so that it exits 2: refusing to clobber a
-# key is not a crash.
-if ( -e $Trog::Vault::key_file ) {    # Refusing to overwrite the one thing that cannot be regenerated
+# One call that creates the key, private from the start, and fails if anything,
+# even a dangling symlink, is already at that path.
+my $fh;
+if ( !sysopen( $fh, $Trog::Vault::key_file, O_WRONLY | O_CREAT | O_EXCL, oct('600') ) ) {
+    die "Could not write $Trog::Vault::key_file: $!\n" unless $!{EEXIST};
+
+    # Printed and exited rather than died, so that it exits 2: refusing to
+    # clobber the one thing that cannot be regenerated is not a crash.
     print {*STDERR} "There is already a key at $Trog::Vault::key_file.  Move it out of the way if you really mean to replace it, and read what that costs first: perldoc bin/tcms-vault-key\n";    ## no critic (ProhibitPrintSTDERR) -- for whoever ran this
     exit 2;
 }
 
-open( my $fh, '>', $Trog::Vault::key_file ) or die "Could not write $Trog::Vault::key_file: $!\n";
-print {$fh} Crypt::Misc::encode_b64( Crypt::PRNG::random_bytes(32) ) . "\n";
-close($fh)                                  or die "Could not write $Trog::Vault::key_file: $!\n";
-chmod( oct('600'), $Trog::Vault::key_file ) or die "Could not chmod $Trog::Vault::key_file: $!\n";
+print {$fh} Crypt::Misc::encode_b64( Crypt::PRNG::random_bytes($Trog::Vault::key_bytes) ) . "\n";
+close($fh) or die "Could not write $Trog::Vault::key_file: $!\n";
 
 print <<"SAID";
 Wrote $Trog::Vault::key_file.  Restart tCMS to pick it up.

t/bin-tcms-vault-key.t

@@ -0,0 +1,82 @@
+#!/usr/bin/env perl
+
+# bin/tcms-vault-key writes the one secret that cannot be regenerated, so this
+# runs it the way a person would and asks Trog::Vault whether it can use the
+# result.
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use FindBin;
+use FindBin::libs;
+
+use Test::More;
+use File::Slurper ();
+use IPC::Run3();
+
+our ( $REPO, $ROOT, $OLDCWD );
+
+BEGIN {
+    require Cwd;
+    require File::Path;
+    require File::Temp;
+
+    $REPO   = Cwd::abs_path("$FindBin::Bin/..");
+    $OLDCWD = Cwd::getcwd();
+    $ROOT   = File::Temp::tempdir( 'tcms-vault-key-XXXXXX', TMPDIR => 1, CLEANUP => 1 );
+
+    $ENV{HOME} = $ROOT;
+    delete $ENV{CREDENTIALS_DIRECTORY};
+    delete $ENV{TPSGI_VAULT_KEY};
+    File::Path::make_path("$ROOT/config");
+
+    chdir($ROOT) or die "could not chdir to the sandbox: $!";
+}
+
+END {
+    chdir($OLDCWD) if $OLDCWD;
+}
+
+# After the sandbox, because it takes the key out of the environment as it loads.
+use Trog::Vault ();
+
+my $key_file = $Trog::Vault::key_file;
+
+# Its exit code, and everything it printed.
+sub vault_key () {
+    my $out = q{};
+    IPC::Run3::run3( [ $^X, "-I$REPO/lib", "$REPO/bin/tcms-vault-key", '--file' ], \undef, \$out, \$out );
+    return ( $? >> 8, $out );
+}
+
+subtest 'a key where there was none' => sub {
+
+    # The umask that removes nothing, so the mode is the one the script asked for.
+    my $umask = umask(0);
+    my ( $code, $said ) = vault_key();
+    umask($umask);
+
+    is( $code,                                                  0,                       'it writes one' ) or diag($said);
+    is( sprintf( '%04o', ( stat $key_file )[2] & oct('7777') ), '0600',                  'that only its owner can read' );
+    is( length( Trog::Vault::key() // q{} ),                    $Trog::Vault::key_bytes, 'and that the vault can use' );
+};
+
+subtest 'a key that is already there' => sub {
+    my $before = File::Slurper::read_binary($key_file);
+    my ( $code, $said ) = vault_key();
+    is( $code, 2, 'it is refused' );
+    like( $said, qr/already[ ]a[ ]key/, 'and says so' );
+    is( File::Slurper::read_binary($key_file), $before, 'and is left alone' );
+};
+
+subtest 'a dangling symlink where the key goes' => sub {
+    unlink($key_file)                       or die "could not clear the key: $!";
+    symlink( "$ROOT/elsewhere", $key_file ) or die "could not plant the symlink: $!";
+
+    my ( $code, $said ) = vault_key();
+    is( $code, 2, 'it is refused' ) or diag($said);
+    ok( !-e "$ROOT/elsewhere", 'and nothing is written where it points' );
+};
+
+done_testing();