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

bin/tcms-vault-key tested for a key with -e, and then opened the path
with '>'.  Anything created at that path between the two steps was
truncated and replaced.  -e also follows a symlink, so a dangling
symlink at the path passed the test, and open then created the file at
the symlink's target.  The file was created with the mode that the umask
allowed, often 0644, and was made 0600 only after the key was written.
For that interval, anyone on the machine could read the key.

One sysopen with O_CREAT|O_EXCL and mode 0600 now does the test and the
creation together.  It does not follow a symlink, and the key is never
in a file that others can read.  The umask can only remove bits, so the
chmod after it had no work left to do, and it is gone.  The key is now
$Trog::Vault::key_bytes long, the length that the vault reads, not a
second 32.

No test ran this script before.  t/bin-tcms-vault-key.t runs it in a
sandbox with umask 0.  It asks Trog::Vault whether it can use the key,
and it makes sure that a second run, and a run over a dangling symlink,
are refused with exit 2.  The old script passed the first two subtests
and failed the last one, because it wrote the key through the symlink.

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

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