From 8bcb137a3bb108e9f43dbcb73c0abae0cce73dd5 Mon Sep 17 00:00:00 2001
From: Jacob Bachmeyer <jcb@gnu.org>
Date: Sat, 12 Nov 2022 23:08:23 -0600
Subject: [PATCH] Add checks that the rename builtin works as expected

The tool assumes that the Perl rename builtin can atomically move files
from the inbox to the scratchpad directory and among the staging, public,
and archive directories.  This commit extends the configuration checks
to confirm that the system can actually move files as expected.
---
 gatekeeper.pl | 70 ++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 66 insertions(+), 4 deletions(-)

diff --git a/gatekeeper.pl b/gatekeeper.pl
index def6114..d97143d 100755
--- a/gatekeeper.pl
+++ b/gatekeeper.pl
@@ -514,15 +514,77 @@ BEGIN {
     unless $pass;
 }
 
-# make sure our directories all exist, or it's hopeless.
-# Use ftp_abort here - this error should "never" happen.
+# Ensure that all configured directories actually exist and that
+# directories required to be on the same filesystem actually are on the
+# same filesystem.  More precisely, ensure that rename works in the
+# circumstances where we assume it to be available.
+#
+# Use ftp_abort here - these errors should "never" happen.
 {
-  our $Inbox_dir; our $Scratch_dir; our $Public_dir; our $Stage_dir;
+  our $Inbox_dir; our $Scratch_dir;
+  our $Stage_dir; our $Public_dir; our $Archive_dir;
+
+  # The actual archive directory will be created if necessary, but we
+  # require its immediate parent to exist and will test moving a file there
+  # instead if the archive directory does not already exist.
+  my $archive_test_dir;
+  if (-d $Archive_dir) { $archive_test_dir = $Archive_dir }
+  else {	# effectively `dirname $Archive_dir`
+    my @archive_dir = File::Spec->splitdir($Archive_dir); pop @archive_dir;
+    $archive_test_dir = File::Spec->catdir(@archive_dir);
+  }
+
   for my $dir ($package_config_base, $Inbox_dir, $Scratch_dir,
-	       $Public_dir, $Stage_dir) {
+	       $Public_dir, $Stage_dir, $archive_test_dir) {
     ftp_abort("FATAL: configuration problem, $dir is not a directory")
       unless -d $dir;
   }
+
+  # Note that the file name used for testing is _not_ a permissible name,
+  # nor can it be produced by cleaning up a file with a permissible name.
+  my $testfilename =
+    '.+gatekeeper.test.'.$$.strftime '.{%Y-%m-%d.%H-%M-%S}', localtime;
+
+  my $infile = File::Spec->catfile($Inbox_dir, $testfilename);
+  my $scratchfile = File::Spec->catfile($Scratch_dir, $testfilename);
+  my $stagefile = File::Spec->catfile($Stage_dir, $testfilename);
+  my $pubfile = File::Spec->catfile($Public_dir, $testfilename);
+  my $arcfile = File::Spec->catfile($archive_test_dir, $testfilename);
+
+  # none of them should exist at the start of the test
+  unlink $infile, $scratchfile, $stagefile, $pubfile, $arcfile;
+
+  # test moving a file from inbox to scratch
+  {
+    sysopen my $test, $infile, O_WRONLY|O_CREAT|O_EXCL
+      or ftp_abort("create test file in inbox: $!");
+    close $test;
+    unless (rename $infile, $scratchfile and -f $scratchfile) {
+      unlink $infile;
+      ftp_abort("FATAL:  could not rename file from inbox to scratchpad: $!");
+    }
+    unlink $scratchfile;	# test complete
+  }
+
+  # The system mv(1) command is used to move files from scratch to staging.
+
+  # test moving a file from stage to public to archive
+  {
+    sysopen my $test, $stagefile, O_WRONLY|O_CREAT|O_EXCL
+      or ftp_abort("create test file in staging directory: $!");
+    close $test;
+    unless (rename $stagefile, $pubfile and -f $pubfile) {
+      unlink $stagefile;
+      ftp_abort("FATAL:  could not rename file from staging to public: $!");
+    }
+    unless (rename $pubfile, $arcfile and -f $arcfile) {
+      unlink $pubfile;
+      ftp_abort("FATAL:  could not rename file from public to archive: $!");
+    }
+    unlink $arcfile;		# test complete
+  }
+  # There is a very small window where someone listing the public directory
+  # might see a test file, but it will not stay for long.
 }
 
 
-- 
2.25.1