From 63e756c1a852fe8e17a7cacc403d8cea340779e5 Mon Sep 17 00:00:00 2001
From: Jacob Bachmeyer <jcb@gnu.org>
Date: Wed, 5 Oct 2022 22:48:04 -0500
Subject: [PATCH] Reorganize gatekeeper script to sort subs ahead of their
 callers

Prior to committing, this was validated with:
(DIFF='git diff --cached';
 comm -3 <($DIFF | grep ^- | sed -e 's/^-//' | sort) \
         <($DIFF | grep ^+ | sed -e 's/^+//' | sort) )

The output shows only blank lines, comments, and a diff header were
added, and only a diff header removed, after all lines are sorted
and paired for analysis.  To replicate, change the "git diff" command
to compare this commit with its parent.
---
 gatekeeper.pl | 973 ++++++++++++++++++++++++++------------------------
 1 file changed, 509 insertions(+), 464 deletions(-)

diff --git a/gatekeeper.pl b/gatekeeper.pl
index debcf63..c824519 100755
--- a/gatekeeper.pl
+++ b/gatekeeper.pl
@@ -97,6 +97,11 @@
 # Imported into Git by Jacob Bachmeyer (jcb@gnu.org), July 2020
 # Further changes are tracked in Git.
 
+
+#
+# - Initialization and preliminaries
+#
+
 use strict;
 use warnings;
 
@@ -193,6 +198,38 @@ our $style;
 our $help;
 our $version;
 
+sub usage_information {
+  my $retval = "\n$NAME protocol v$VERSION ($DATE)\n";
+  $retval .= "More information at $URL\n";
+  $retval .= "\nERROR: You have not supplied all required parameters. $NAME takes these arguments:\n\n";
+  $retval .= " $NAME -s <style> [-d <debuglevel>] [-v] [-h]\n\n";
+  $retval .= "  <style>    is the execution 'style'. Call $NAME\n";
+  $retval .= "             without the -s parameter to get a list of possible styles.\n";
+  $retval .= "  -d <debuglevel> (optional) set debug level. 0 means no debugging\n";
+  $retval .= "  -v (optional)  display version information\n";
+  $retval .= "  -h (optional)  display this help screen\n\n";
+  $retval .= "Possible styles:\n\n";
+  $retval .= "  ftp\n";
+  $retval .= "  alpha\n";
+  $retval .= "  distros\n";
+  $retval .= "\n";
+  print $retval;
+  exit;
+}
+
+sub version_information {
+  print "\nThis is $NAME protocol version $VERSION ($DATE)\n";
+  print $COPYRIGHT_NOTICE;
+  print "License: $LICENSE\n";
+  print "More information at $URL\n\n";
+  print 'Running in ', (IN_TEST_MODE ? 'testing' : 'production'),
+    " mode with PATH:\n  ", $ENV{PATH}, "\n\n";
+  print 'Running with @INC:', "\n";
+  print "  $_\n" for @INC;
+  print "\n";
+  exit;
+}
+
 &version_information () if ($version);
 &usage_information() if ($help);
 &usage_information() if (($style ne 'ftp') && ($style ne 'alpha') && ($style ne 'distros'));
@@ -292,196 +329,304 @@ if (IN_TEST_MODE) {	# override the above for testing
 
 my %info;   # package being processed; a global so fatal and mail can use it
 
-exit (&main ());
+
+#
+# - Message reporting and email
+#
 
-sub main
-{
+sub ftp_syslog {
+  my ($priority,$message) = @_;
 
-  # Initialize our syslogging
-  if (IN_TEST_MODE) {
-    $ENV{TEST_SYSLOG_SOCKET} =~ m/^([[:alnum:]\/]+)$/
-      or die "strange test syslog socket";
-    -S $1 or die "test syslog socket is not a socket";
-    setlogsock(unix => $1);
-  }
-  openlog("ftp-upload", 'pid', $facility);
-  ftp_syslog('info', "($log_style) Beginning upload processing run.");
+  # Remove a trailing newline
+  $message =~ s/[\r\n]+$//;
+  # Collapse the message to a single line for syslog
+  $message =~ s/[\r\n]+/ \/ /g;
 
-  # make sure our directories all exist, or it's hopeless.
-  # Use die instead of fatal - this error should "never" happen.
-  for my $dir ($package_config_base, $incoming_dir, $incoming_tmp,
-	 $destfinal, $desttmp) {
-    -d $dir || ftp_die("FATAL: configuration problem, $dir is not a directory");
+  # The syslog function is pretty picky, and (sometimes) dies silently
+  # when using non-valid syslog priorities.
+  # That's why we run it inside an eval, and print out any errors to STDERR.
+  eval {
+    syslog($priority, $message);
+  };
+  if ($@) {
+    print STDERR "$@\n";
   }
-  # the chdir simplifies our filename parsing, so the base names don't
-  # have any directory.
-  chdir ($incoming_dir) || ftp_die("FATAL: chdir($incoming_dir) failed: $!");
-  my @incoming = &scan_incoming ();
+}
 
+sub ftp_warn($) {
+    ftp_syslog('warning', "($log_style) " . $_[0]);
+    warn $_[0];
+}
 
-  # we've moved the files to work on to a new directory.
-  chdir ($incoming_tmp) || ftp_die("FATAL: chdir($incoming_tmp) failed: $!");
+sub ftp_die($;$) {
+    my $msg = shift;
+    my $exitcode = shift;
+    $exitcode ||= 1;
+    ftp_syslog('err', "($log_style) " . $msg);
+    exit $exitcode;
+}
 
-  for my $files (@incoming) {  # each list element is a hash reference.
-    ftp_syslog('info',"($log_style) found directive: $files->{directive}\n");
-    # if we die processing a triplet, the eval allows us to move
-    #   onto the next triplet.
-    eval {
-      # set up the %info variable
-      my $retval = &read_directive_file ($files->{"directive"},$files->{"upload"},$files->{"directive_only"});
+
+#
+# - Package configuration access
+#
 
-      if ($retval == 0) {
-	# do the work
-	&execute_commands($files,%info);
+# Return array of public key files for PACKAGE_NAME.
+#
+sub keyring_file {
+  my ($package_name,$directory) = (shift,shift);
+  my @directory = split(/\//,$directory);
+  my @pubrings = ();
 
-	# report success
-	if (!$files->{"directive_only"}) {
-	  &success_upload($files->{"sig"}, $files->{"upload"},$files->{"directive"});
-	} else {
-	  &success_directive($files->{directive});
-	}
-      }
-    };
-    ftp_warn ("eval failed: $@") if $@;
+  # First of all, add our 'master' keyring, for people with root to the ftp upload mechanism
+  push(@pubrings,$master_keyring);
 
-    # clean up files if we abort while processing a triplet
-    cleanup ($files->{"sig"}, $files->{"upload"}, $files->{"directive"}) if ($@);
-    # clear out the current package that we just finished processing
-    undef %info;
+  # We go through each subdirectory, starting at the lowest subdirectory,
+  # and add each to an array of public key files
+  my $tmp = $directory;
+  while (1) {
+    if (-e "$package_config_base/$tmp/pubring.gpg") {
+      ftp_syslog('debug', "($log_style) DEBUG: " . "found keyring $package_config_base/$tmp/pubring.gpg") if DEBUG;
+      push(@pubrings,"$package_config_base/$tmp/pubring.gpg");
+    }
+    my $tmp2 = $tmp;
+    $tmp2 =~ s/\/[^\/]*$//;
+    last if ($tmp eq $tmp2);
+    $tmp = $tmp2;
   }
-  if ((scalar @incoming) == 0) {
-    ftp_syslog('info', "($log_style) No files found for processing.");
-  } else {
-    ftp_syslog('info', "($log_style) Processing complete: " . (scalar @incoming) . " uploads processed.");
-    system("/usr/local/bin/generate-ftpindex") unless IN_TEST_MODE;
-    ftp_syslog('info', "($log_style) Updated ftpindex");
+  return @pubrings;
+}
+
+sub email_addresses {
+  my ($package_name) = @_;
+  my @ret;
+
+  open (EMAIL_FILE, "<", "$package_config_base/$package_name/email")
+    || &fatal("The directory line should start with the name of the package for which you are trying to upload a file, e.g. gcc, gawk, or gasm. We have no package named '$package_name'. If this is a new GNU package, please ensure that you have registered your GPG key for its uploads, per http://www.gnu.org/prep/maintain/html_node/Automated-Upload-Registration.html. The GPG key must be registered separately for each package, so this needs to be done even if you are already registered for uploading with another package.",1);
+
+  while (<EMAIL_FILE>) {
+    chomp;
+    my $line = $_;
+    next if (grep($_ eq $line,@ret) > 0); # Skip duplicates
+    push (@ret, $line)  if $line =~ /^[[:graph:]]+@[[:graph:]]+$/; # simple sanity check
   }
 
-  # Clean up the incoming directory and the incoming tmp directory - remove files older than a day
-  cleanup_dir($incoming_dir);
-  cleanup_dir($incoming_tmp);
+  close (EMAIL_FILE) || ftp_warn("close($package_config_base/$package_name/email) failed: $!");
 
-  return 0;
-}
+  # Now also look for all maintainer addresses in the maintainers.bypkg file
+  open (EMAIL_FILE, "<", "$maintainers_bypkg");
+  while (<EMAIL_FILE>) {
+    chomp;
+    my @tmp = split(/ - /,$_,2);
+    next unless ($tmp[0] eq $package_name);
+    # The while loop below needs a proper scalar to work.
+    my $e = $tmp[1];
+    while ($e =~ /([[:graph:]]+@[[:graph:]]+)/g) {
+	my $f = $1;
+	$f =~ s/[<>,]//g;
+      push (@ret, $f) unless exists {map { $_ => 1 } @ret}->{$f};
+    }
+  }
+  close (EMAIL_FILE);
 
-sub usage_information {
-  my $retval = "\n$NAME protocol v$VERSION ($DATE)\n";
-  $retval .= "More information at $URL\n";
-  $retval .= "\nERROR: You have not supplied all required parameters. $NAME takes these arguments:\n\n";
-  $retval .= " $NAME -s <style> [-d <debuglevel>] [-v] [-h]\n\n";
-  $retval .= "  <style>    is the execution 'style'. Call $NAME\n";
-  $retval .= "             without the -s parameter to get a list of possible styles.\n";
-  $retval .= "  -d <debuglevel> (optional) set debug level. 0 means no debugging\n";
-  $retval .= "  -v (optional)  display version information\n";
-  $retval .= "  -h (optional)  display this help screen\n\n";
-  $retval .= "Possible styles:\n\n";
-  $retval .= "  ftp\n";
-  $retval .= "  alpha\n";
-  $retval .= "  distros\n";
-  $retval .= "\n";
-  print $retval;
-  exit;
+  return @ret;
 }
 
-sub version_information {
-  print "\nThis is $NAME protocol version $VERSION ($DATE)\n";
-  print $COPYRIGHT_NOTICE;
-  print "License: $LICENSE\n";
-  print "More information at $URL\n\n";
-  print 'Running in ', (IN_TEST_MODE ? 'testing' : 'production'),
-    " mode with PATH:\n  ", $ENV{PATH}, "\n\n";
-  print 'Running with @INC:', "\n";
-  print "  $_\n" for @INC;
-  print "\n";
-  exit;
-}
+
+#
+# - Email
+#
 
-sub archive {
-  my ($dir, $subdir, $file) = @_;
+sub exclude_mail_blacklist {
+    my @emaillist = @_;
+    my @blacklist = ();
+    my @tomail = @emaillist;
+    if (-f $email_blacklist) {
+	open(BLACKLIST, "<$email_blacklist");
+	@blacklist = <BLACKLIST>;
+	close(BLACKLIST);
+	chomp(@blacklist);
 
-  # Abort if file to archive doesn't exist
-  &fatal("$subdir/$file does not exist - can not archive",1) if (!-e "$destfinal/$subdir/$file");
-  my $timestamp = strftime "%Y-%m-%d_%H-%M-%S", localtime;
-  $timestamp .= sprintf("_%09d",rand(1000000000)); # Add a large random number for good measure
-  # Abort if a file with same name exists in the archive
-  &fatal("$subdir/$file exists in archive - can not overwrite",1) if (-e "$olddestfinal/$subdir/$timestamp" . "_$file");
+	my %blacklist = map{$_ => 1 } @blacklist;
+	my %emaillist = map{$_ => 1 } @emaillist;
 
-  my @mkdir_args = ("/bin/mkdir","-p","$olddestfinal/$subdir");
-  &fatal("@mkdir_args failed",0) if system (@mkdir_args) != 0;
-  my @mv_args = ("/bin/mv", "$dir/$file", "$olddestfinal/$subdir/$timestamp" . "_$file");
-  &fatal("@mv_args failed",0) if system (@mv_args) != 0;
-  ftp_syslog('info', "($log_style) archived $dir/$file to $olddestfinal/$subdir/$timestamp" . "_$file");
+	@tomail = grep(!defined $blacklist{$_}, @emaillist);
+    }
 
+    return @tomail;
 }
 
+# Used for both success and failure.
+#
+sub mail {
+  my ($msg) = shift;
+  my ($send_to_user) = shift;
+  my ($subject) = shift;
+  $subject ||= '';
 
-# Actual executing of commands. Respects the cronological order
-# they were specified in, thanks to the 'order' value in the %info
-# hash
-sub execute_commands {
-  my $files = shift;
-  my %info = @_;
+  my @email_list = ($email_always);
+  # Some messages should be sent to the user, some should not
+  push (@email_list, @{$info{email}}) if (defined $info{email} && $send_to_user);
 
-  # This is ugly but necessary.
-  # Delete all info entries that are NOT hashes with an 'order' value
-  # (and hence would mess up the foreach loop below). Make a backup of
-  # the hash first so we can feed the real thing to check_files & install_files
-  my %originfo = %info;
-  delete($info{directory});
-  delete($info{email});
-  delete($info{package});
-  delete($info{version});
-  delete($info{'v1_compat_mode'});
-  delete($info{'replace'});
+  # If this is an e-mail to the uploader, don't send it to the script maintainer.
+  shift(@email_list) if ($send_to_user);
 
-  my $destdir = "$destfinal/$originfo{directory}";
-  foreach my $key (sort { $info{$a}{order} <=> $info{$b}{order} } keys %info) {
-    if ($key eq 'filename') {
-      &check_files($files,%originfo);
-      &install_files($files,%originfo);
-    } elsif ($key =~ /^symlink-(.*)/) {
-      my $target = $1;
-      # Get current working dir
-      my $cwd = getcwd;
-      # Make sure there are no double dots in the path, and that it is absolute.
-      # A bit paranoid, but hey...
-      &fatal("invalid directory $cwd",1,'')
-	if (($cwd =~ /\.\./) || (!($cwd =~ m,^/,)));
-      # Now untaint the getcwd output
-      $cwd =~ /^(.*)$/;
-      $cwd = $1;
+  if ($#email_list == -1) {
+    # Something went wrong, but we can't figure out which package this upload belongs to.
+    # Mention that in the logs, and then mail this to the script maintainer anyway.
+    ftp_syslog('info', "($log_style) No uploader e-mail address(es) to report this error to!");
+    @email_list = ($email_always);
+  }
+  if (NOMAIL) {
+    ftp_syslog('info', "($log_style) NOMAIL is set - not sending email to @email_list");
+  } else {
+    ftp_syslog('info', "($log_style) Sending email to @email_list");
+  }
 
-      chomp($cwd);
-      # change to destination dir
-      chdir($destdir);
-      # if the symlink already exists, remove it
-      if (-l $info{$key}{link}) {
-	unlink($info{$key}{link}) || &fatal("removal of symlink $info{$key}{link} failed: $!",1);
+  my $sender = 'ftp-upload-script@gnu.org';
+  $sender = 'ftp-upload@gnu.org' if ($send_to_user); # We really want replies to go to the ftp-upload queue
+
+  @email_list = exclude_mail_blacklist(@email_list);
+
+  #print STDERR "final emails: @email_list\n";
+  # return @_;
+
+  if (NOMAIL) {
+      if ($subject ne '') {
+	  ftp_syslog('info', "($log_style) Subject: '$subject'");
+      } elsif (defined $info{package}) {
+	  ftp_syslog('info', "($log_style) Subject: $info{package}");
+      } else {
+	  ftp_syslog('warning', "($log_style) Error uploading package: $msg");
+	  ftp_syslog('info', "($log_style) Subject: generic failure");
       }
-      # symlink away!
-      symlink("$target",$info{$key}{link}) || &fatal("creation of symlink $info{$key}{link} to $target in $destdir failed: $!",1);
-      # go back to current working dir
-      ftp_syslog('info', "($log_style) added symlink $destdir/" . $info{$key}{link} . " pointing to $destdir/$target");
-      chdir($cwd) || &fatal("chdir to $cwd failed: $!",1);
-    } elsif ($key =~ /^rmsymlink-(.*)/) {
-      &fatal("refusing to remove a non-symlink file",1) unless -l "$destdir/$1";
-      unlink("$destdir/$1") || &fatal("removal of symlink $1 failed: $!",1);
-      ftp_syslog('info', "($log_style) removed symlink $destdir/$1");
-    } elsif ($key =~ /^archive-(.*)/) {
-      # We now also allow archiving entire directories
-      archive($destdir, $originfo{directory}, "$1.sig") if (! -d "$destdir/$1");
-      archive($destdir, $originfo{directory}, $1);
+      ftp_syslog('info', "($log_style) Body: $msg");
+  } else {
+      my $smtp;
+      if (IN_TEST_MODE) {
+	$smtp = Net::SMTP->new
+	  (Host => 'localhost', Port => $ENV{TEST_SMTP_PORT});
+      } else {
+	$smtp = Net::SMTP->new ("127.0.0.1");
+      }
+      ftp_die("FATAL: SMTP connection failed") unless $smtp;
+
+      $smtp->mail ($sender);
+      $smtp->bcc ($email_always) if ($send_to_user);
+      $smtp->recipient (@email_list, { SkipBad => 1});
+
+      $smtp->data ();
+      $smtp->datasend ("To: " . join (", ", @email_list) . "\r\n");
+      $smtp->datasend ("From: $sender\r\n");
+      $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\r\n");
+      my $mid = Email::MessageID->new;
+      $smtp->datasend("Message-ID: <$mid>\r\n");
+      $smtp->datasend("Date: " . strftime("%a, %e %b %Y %H:%M:%S %z", localtime) . "\r\n");
+      if ($subject ne '') {
+	  $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] $subject");
+	  ftp_syslog('info', "($log_style) Subject: '$subject'");
+      } elsif (defined $info{package}) {
+	  $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] $info{package}");
+	  ftp_syslog('info', "($log_style) Subject: $info{package}");
+      } else {
+	  $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] generic failure");
+	  ftp_syslog('warning', "($log_style) Error uploading package: $msg");
+	  ftp_syslog('info', "($log_style) Subject: generic failure");
+      }
+      $smtp->datasend ("\n\n");
+      ftp_syslog('info', "($log_style) Body: $msg");
+
+      # Wrap message at 78 characters, this is e-mail...
+      $Text::Wrap::columns=78;
+      $smtp->datasend (wrap('','',$msg) . "\n");
+      $smtp->dataend ();
+
+      $smtp->quit ();
     }
+}
+
+sub debug {
+  my $msg = shift;
+  my $package_name = shift;
+
+  if (NOMAIL) {
+      ftp_syslog('info', "($log_style) Subject: [$m_style gnu-ftp-debug] new upload processed: $package_name\nBody: $msg");
+  } else {
+      my $smtp;
+      if (IN_TEST_MODE) {
+	$smtp = Net::SMTP->new
+	  (Host => 'localhost', Port => $ENV{TEST_SMTP_PORT});
+      } else {
+	$smtp = Net::SMTP->new ("127.0.0.1");
+      }
+      ftp_die("FATAL: SMTP connection failed") unless $smtp;
+      $smtp->mail ("ftp-upload-script\@gnu.org");
+      $smtp->recipient ($maintainer_email, { SkipBad => 1});
+
+      $smtp->data ();
+      $smtp->datasend ("To: $maintainer_email\n");
+      $smtp->datasend ("From: ftp-upload-script\@gnu.org\n");
+      $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\n");
+      $smtp->datasend ("Subject: [$m_style gnu-ftp-debug] new upload processed: $package_name");
+      $smtp->datasend ("\n\n");
+      $smtp->datasend ("$msg\n");
+      $smtp->dataend ();
+      $smtp->quit ();
   }
+}
 
-  # We're running in v1 mode.
-  if ($originfo{'v1_compat_mode'}) {
-    &check_files($files,%originfo);
-    &install_files($files,%originfo);
+# Send email with TAINTED_MSG to the ftp maintainers, as well as any
+# address specified for the package.  Rename the bad files with a
+# leading . so we don't try to process them again.  Finally, write the
+# same MSG to stderr and exit badly.
+#
+# It's ok that we quit here without processing every file, because we'll
+# be invoked again from cron in a few minutes and will look further then.
+# The bad . files will eventually get cleaned up via a separate script.
+#
+sub fatal {
+  my ($tainted_msg) = shift;
+  my ($send_to_user) = shift;
+  # If we fail before we have sent a copy of the directive file contents to the maintainer
+  # (when running in DEBUG mode), that copy is passed along, and we can send it from here.
+  my ($directive_file_contents) = shift;
+  my $exit_code = shift;
+
+  $directive_file_contents ||= '';
+  if (($directive_file_contents ne '') && DEBUG) {
+    &mail ($directive_file_contents,0,"debug: directive file contents");
+  }
+
+  ftp_syslog('err', "($log_style) $tainted_msg");
+
+  # Don't let them do perl or shell quoting tricks, but show everything
+  # that's definitely harmless.
+  #
+  $tainted_msg =~  s=[^-.:,/@\w\s]==g;
+  $tainted_msg =~ m=^([-.:,/@\w\s]+)$=;
+  my $msg = $1;
+
+  &mail ($msg,$send_to_user);
+
+  my $pid = open(PWD, "-|");
+  my $cwd;
+
+  if ($pid) {      # parent
+    while (<PWD>) {
+      chomp ($cwd = $_);
+    }
+    close (PWD) || ftp_warn("pwd exited $?");
+  } else {      # child
+    exec ("/bin/pwd") || ftp_die("can't exec pwd: $!");
   }
+  ftp_die("(in $cwd) $msg",$exit_code);
 }
 
 
+#
+# - [SC] Scan for incoming packets
+#
+
 # Read the ftp incoming dir (which is assumed to be the current
 # directory), looking for completed upload triples (the three files
 # described at the beginning).  Ignore if we don't have all three files,
@@ -645,68 +790,10 @@ sub scan_incoming {
   return @ret;
 }
 
-
 
-# Return array of public key files for PACKAGE_NAME.
 #
-sub keyring_file {
-  my ($package_name,$directory) = (shift,shift);
-  my @directory = split(/\//,$directory);
-  my @pubrings = ();
-
-  # First of all, add our 'master' keyring, for people with root to the ftp upload mechanism
-  push(@pubrings,$master_keyring);
-
-  # We go through each subdirectory, starting at the lowest subdirectory,
-  # and add each to an array of public key files
-  my $tmp = $directory;
-  while (1) {
-    if (-e "$package_config_base/$tmp/pubring.gpg") {
-      ftp_syslog('debug', "($log_style) DEBUG: " . "found keyring $package_config_base/$tmp/pubring.gpg") if DEBUG;
-      push(@pubrings,"$package_config_base/$tmp/pubring.gpg");
-    }
-    my $tmp2 = $tmp;
-    $tmp2 =~ s/\/[^\/]*$//;
-    last if ($tmp eq $tmp2);
-    $tmp = $tmp2;
-  }
-  return @pubrings;
-}
-
-sub email_addresses {
-  my ($package_name) = @_;
-  my @ret;
-
-  open (EMAIL_FILE, "<", "$package_config_base/$package_name/email")
-    || &fatal("The directory line should start with the name of the package for which you are trying to upload a file, e.g. gcc, gawk, or gasm. We have no package named '$package_name'. If this is a new GNU package, please ensure that you have registered your GPG key for its uploads, per http://www.gnu.org/prep/maintain/html_node/Automated-Upload-Registration.html. The GPG key must be registered separately for each package, so this needs to be done even if you are already registered for uploading with another package.",1);
-
-  while (<EMAIL_FILE>) {
-    chomp;
-    my $line = $_;
-    next if (grep($_ eq $line,@ret) > 0); # Skip duplicates
-    push (@ret, $line)  if $line =~ /^[[:graph:]]+@[[:graph:]]+$/; # simple sanity check
-  }
-
-  close (EMAIL_FILE) || ftp_warn("close($package_config_base/$package_name/email) failed: $!");
-
-  # Now also look for all maintainer addresses in the maintainers.bypkg file
-  open (EMAIL_FILE, "<", "$maintainers_bypkg");
-  while (<EMAIL_FILE>) {
-    chomp;
-    my @tmp = split(/ - /,$_,2);
-    next unless ($tmp[0] eq $package_name);
-    # The while loop below needs a proper scalar to work.
-    my $e = $tmp[1];
-    while ($e =~ /([[:graph:]]+@[[:graph:]]+)/g) {
-	my $f = $1;
-	$f =~ s/[<>,]//g;
-      push (@ret, $f) unless exists {map { $_ => 1 } @ret}->{$f};
-    }
-  }
-  close (EMAIL_FILE);
-
-  return @ret;
-}
+# - [AN] Authentication
+#
 
 sub parse_directory_line {
   my $tainted_val = shift;
@@ -742,7 +829,65 @@ sub parse_directory_line {
   }
 }
 
-
+sub guess_uploader_email {
+  my $directive_file_contents = shift;
+  if ($directive_file_contents =~ /^Directory:? (.*)$/im) {  # case-insensitive, w or w/o the :
+      parse_directory_line($1, $directive_file_contents,1);
+  }
+}
+
+#
+# Verify that the signature used for the directive file is valid for
+# this package's keyring. We go through all keyring files, starting at the
+# sub-most directory, until we find one that matches (or not!)
+#
+sub verify_keyring {
+  my ($directive_file, $directive_file_contents, @keyrings) = @_;
+
+  my $directive_file_size = -s $directive_file;
+  ftp_syslog('debug', "($log_style) DEBUG: $directive_file size is $directive_file_size") if DEBUG;
+
+  foreach (@keyrings) {
+    # We need what gpgv writes to STDERR to determine the timestamp
+    # Hence the silly trick with storing the return code of gpgv in
+    # the command output
+    my @verify_args = (GPGV_BIN, "--keyring", $_,
+		       $directive_file,"2>&1",";echo \$?");
+
+    my $verify_str = join(' ',@verify_args);
+
+    ($verify_str) = $verify_str =~ /^(.*)$/;
+
+    ftp_syslog('debug',"($log_style) DEBUG: gpgv command line: $verify_str\n")
+      if (DEBUG > 0);
+    my $retval = '';
+    open (GPGV, "$verify_str|")
+      or &fatal("failed to run command: $verify_str",1);
+    while (defined (my $line = <GPGV>)) {
+      $retval .= $line;
+    }
+    close (GPGV) || ftp_warn("gpgv exited $?");
+
+    if (!defined($retval)) {
+      # This is bad - we couldn't even execute the gpgv command properly
+      guess_uploader_email($directive_file_contents);
+      &fatal("gpg verify of directive file failed (error executing gpgv): $!",0,'',2);
+    } elsif ($retval =~ /\n0\n$/s) { # We store the return value of gpgv on the last line of the output
+      ftp_syslog('info', "($log_style) verified against $_\n");
+      return $retval; # We got return value 0 from gpgv -> key verified!
+    } else {
+      # gpgv returned an error - most likely just key not found. Ignore, since we are testing all keyrings.
+    }
+  }
+  guess_uploader_email($directive_file_contents);
+  &fatal("gpg verify of directive file failed",1,'',2);
+}
+
+
+#
+# - [PV] Parsing and Validation
+#
+
 # Return the information for this upload out of DIRECTIVE_FILE --
 # directory and package.  Make sure the key that signed the directive
 # file has permission to write to this package, too.
@@ -1044,62 +1189,11 @@ sub read_directive_file {
   return 0;
 }
 
-sub guess_uploader_email {
-  my $directive_file_contents = shift;
-  if ($directive_file_contents =~ /^Directory:? (.*)$/im) {  # case-insensitive, w or w/o the :
-      parse_directory_line($1, $directive_file_contents,1);
-  }
-}
-
 
 #
-# Verify that the signature used for the directive file is valid for
-# this package's keyring. We go through all keyring files, starting at the
-# sub-most directory, until we find one that matches (or not!)
+# - [AZ] Authorization
 #
-sub verify_keyring {
-  my ($directive_file, $directive_file_contents, @keyrings) = @_;
-
-  my $directive_file_size = -s $directive_file;
-  ftp_syslog('debug', "($log_style) DEBUG: $directive_file size is $directive_file_size") if DEBUG;
-
-  foreach (@keyrings) {
-    # We need what gpgv writes to STDERR to determine the timestamp
-    # Hence the silly trick with storing the return code of gpgv in
-    # the command output
-    my @verify_args = (GPGV_BIN, "--keyring", $_,
-		       $directive_file,"2>&1",";echo \$?");
-
-    my $verify_str = join(' ',@verify_args);
-
-    ($verify_str) = $verify_str =~ /^(.*)$/;
-
-    ftp_syslog('debug',"($log_style) DEBUG: gpgv command line: $verify_str\n")
-      if (DEBUG > 0);
-    my $retval = '';
-    open (GPGV, "$verify_str|")
-      or &fatal("failed to run command: $verify_str",1);
-    while (defined (my $line = <GPGV>)) {
-      $retval .= $line;
-    }
-    close (GPGV) || ftp_warn("gpgv exited $?");
-
-    if (!defined($retval)) {
-      # This is bad - we couldn't even execute the gpgv command properly
-      guess_uploader_email($directive_file_contents);
-      &fatal("gpg verify of directive file failed (error executing gpgv): $!",0,'',2);
-    } elsif ($retval =~ /\n0\n$/s) { # We store the return value of gpgv on the last line of the output
-      ftp_syslog('info', "($log_style) verified against $_\n");
-      return $retval; # We got return value 0 from gpgv -> key verified!
-    } else {
-      # gpgv returned an error - most likely just key not found. Ignore, since we are testing all keyrings.
-    }
-  }
-  guess_uploader_email($directive_file_contents);
-  &fatal("gpg verify of directive file failed",1,'',2);
-}
 
-
 # Before checking the files, move them to a temporary directory.
 #
 # Check that the key is on the keyring for this package, and that
@@ -1148,6 +1242,28 @@ sub check_files {
 
 
 
+#
+# - [EX] Execution
+#
+
+sub archive {
+  my ($dir, $subdir, $file) = @_;
+
+  # Abort if file to archive doesn't exist
+  &fatal("$subdir/$file does not exist - can not archive",1) if (!-e "$destfinal/$subdir/$file");
+  my $timestamp = strftime "%Y-%m-%d_%H-%M-%S", localtime;
+  $timestamp .= sprintf("_%09d",rand(1000000000)); # Add a large random number for good measure
+  # Abort if a file with same name exists in the archive
+  &fatal("$subdir/$file exists in archive - can not overwrite",1) if (-e "$olddestfinal/$subdir/$timestamp" . "_$file");
+
+  my @mkdir_args = ("/bin/mkdir","-p","$olddestfinal/$subdir");
+  &fatal("@mkdir_args failed",0) if system (@mkdir_args) != 0;
+  my @mv_args = ("/bin/mv", "$dir/$file", "$olddestfinal/$subdir/$timestamp" . "_$file");
+  &fatal("@mv_args failed",0) if system (@mv_args) != 0;
+  ftp_syslog('info', "($log_style) archived $dir/$file to $olddestfinal/$subdir/$timestamp" . "_$file");
+
+}
+
 # Install both SIG_FILE and UPLOAD_FILE in $destfinal/$info{directory}.
 # Make the directory if it doesn't exist (for, e.g., a new gcc/x.y.z
 # subdir). When the destination file exists, archive it automatically first.
@@ -1211,8 +1327,77 @@ sub install_files {
   }
 }
 
+# Actual executing of commands. Respects the cronological order
+# they were specified in, thanks to the 'order' value in the %info
+# hash
+sub execute_commands {
+  my $files = shift;
+  my %info = @_;
+
+  # This is ugly but necessary.
+  # Delete all info entries that are NOT hashes with an 'order' value
+  # (and hence would mess up the foreach loop below). Make a backup of
+  # the hash first so we can feed the real thing to check_files & install_files
+  my %originfo = %info;
+  delete($info{directory});
+  delete($info{email});
+  delete($info{package});
+  delete($info{version});
+  delete($info{'v1_compat_mode'});
+  delete($info{'replace'});
+
+  my $destdir = "$destfinal/$originfo{directory}";
+  foreach my $key (sort { $info{$a}{order} <=> $info{$b}{order} } keys %info) {
+    if ($key eq 'filename') {
+      &check_files($files,%originfo);
+      &install_files($files,%originfo);
+    } elsif ($key =~ /^symlink-(.*)/) {
+      my $target = $1;
+      # Get current working dir
+      my $cwd = getcwd;
+      # Make sure there are no double dots in the path, and that it is absolute.
+      # A bit paranoid, but hey...
+      &fatal("invalid directory $cwd",1,'')
+	if (($cwd =~ /\.\./) || (!($cwd =~ m,^/,)));
+      # Now untaint the getcwd output
+      $cwd =~ /^(.*)$/;
+      $cwd = $1;
+
+      chomp($cwd);
+      # change to destination dir
+      chdir($destdir);
+      # if the symlink already exists, remove it
+      if (-l $info{$key}{link}) {
+	unlink($info{$key}{link}) || &fatal("removal of symlink $info{$key}{link} failed: $!",1);
+      }
+      # symlink away!
+      symlink("$target",$info{$key}{link}) || &fatal("creation of symlink $info{$key}{link} to $target in $destdir failed: $!",1);
+      # go back to current working dir
+      ftp_syslog('info', "($log_style) added symlink $destdir/" . $info{$key}{link} . " pointing to $destdir/$target");
+      chdir($cwd) || &fatal("chdir to $cwd failed: $!",1);
+    } elsif ($key =~ /^rmsymlink-(.*)/) {
+      &fatal("refusing to remove a non-symlink file",1) unless -l "$destdir/$1";
+      unlink("$destdir/$1") || &fatal("removal of symlink $1 failed: $!",1);
+      ftp_syslog('info', "($log_style) removed symlink $destdir/$1");
+    } elsif ($key =~ /^archive-(.*)/) {
+      # We now also allow archiving entire directories
+      archive($destdir, $originfo{directory}, "$1.sig") if (! -d "$destdir/$1");
+      archive($destdir, $originfo{directory}, $1);
+    }
+  }
+
+  # We're running in v1 mode.
+  if ($originfo{'v1_compat_mode'}) {
+    &check_files($files,%originfo);
+    &install_files($files,%originfo);
+  }
+}
 
 
+#
+# - Clean up
+#
+
 # Report success and unlink the directive file.
 #
 sub success_upload {
@@ -1259,222 +1444,82 @@ sub cleanup {
     }
 }
 
+
 
-# Send email with TAINTED_MSG to the ftp maintainers, as well as any
-# address specified for the package.  Rename the bad files with a
-# leading . so we don't try to process them again.  Finally, write the
-# same MSG to stderr and exit badly.
 #
-# It's ok that we quit here without processing every file, because we'll
-# be invoked again from cron in a few minutes and will look further then.
-# The bad . files will eventually get cleaned up via a separate script.
+# - Main execution path
 #
-sub fatal {
-  my ($tainted_msg) = shift;
-  my ($send_to_user) = shift;
-  # If we fail before we have sent a copy of the directive file contents to the maintainer
-  # (when running in DEBUG mode), that copy is passed along, and we can send it from here.
-  my ($directive_file_contents) = shift;
-  my $exit_code = shift;
-
-  $directive_file_contents ||= '';
-  if (($directive_file_contents ne '') && DEBUG) {
-    &mail ($directive_file_contents,0,"debug: directive file contents");
-  }
-
-  ftp_syslog('err', "($log_style) $tainted_msg");
-
-  # Don't let them do perl or shell quoting tricks, but show everything
-  # that's definitely harmless.
-  #
-  $tainted_msg =~  s=[^-.:,/@\w\s]==g;
-  $tainted_msg =~ m=^([-.:,/@\w\s]+)$=;
-  my $msg = $1;
 
-  &mail ($msg,$send_to_user);
+exit (&main ());
 
-  my $pid = open(PWD, "-|");
-  my $cwd;
+sub main
+{
 
-  if ($pid) {      # parent
-    while (<PWD>) {
-      chomp ($cwd = $_);
-    }
-    close (PWD) || ftp_warn("pwd exited $?");
-  } else {      # child
-    exec ("/bin/pwd") || ftp_die("can't exec pwd: $!");
+  # Initialize our syslogging
+  if (IN_TEST_MODE) {
+    $ENV{TEST_SYSLOG_SOCKET} =~ m/^([[:alnum:]\/]+)$/
+      or die "strange test syslog socket";
+    -S $1 or die "test syslog socket is not a socket";
+    setlogsock(unix => $1);
   }
-  ftp_die("(in $cwd) $msg",$exit_code);
-}
-
-sub exclude_mail_blacklist {
-    my @emaillist = @_;
-    my @blacklist = ();
-    my @tomail = @emaillist;
-    if (-f $email_blacklist) {
-	open(BLACKLIST, "<$email_blacklist");
-	@blacklist = <BLACKLIST>;
-	close(BLACKLIST);
-	chomp(@blacklist);
-
-	my %blacklist = map{$_ => 1 } @blacklist;
-	my %emaillist = map{$_ => 1 } @emaillist;
-
-	@tomail = grep(!defined $blacklist{$_}, @emaillist);
-    }
-
-    return @tomail;
-}
-
-# Used for both success and failure.
-#
-sub mail {
-  my ($msg) = shift;
-  my ($send_to_user) = shift;
-  my ($subject) = shift;
-  $subject ||= '';
-
-  my @email_list = ($email_always);
-  # Some messages should be sent to the user, some should not
-  push (@email_list, @{$info{email}}) if (defined $info{email} && $send_to_user);
-
-  # If this is an e-mail to the uploader, don't send it to the script maintainer.
-  shift(@email_list) if ($send_to_user);
+  openlog("ftp-upload", 'pid', $facility);
+  ftp_syslog('info', "($log_style) Beginning upload processing run.");
 
-  if ($#email_list == -1) {
-    # Something went wrong, but we can't figure out which package this upload belongs to.
-    # Mention that in the logs, and then mail this to the script maintainer anyway.
-    ftp_syslog('info', "($log_style) No uploader e-mail address(es) to report this error to!");
-    @email_list = ($email_always);
-  }
-  if (NOMAIL) {
-    ftp_syslog('info', "($log_style) NOMAIL is set - not sending email to @email_list");
-  } else {
-    ftp_syslog('info', "($log_style) Sending email to @email_list");
+  # make sure our directories all exist, or it's hopeless.
+  # Use die instead of fatal - this error should "never" happen.
+  for my $dir ($package_config_base, $incoming_dir, $incoming_tmp,
+	 $destfinal, $desttmp) {
+    -d $dir || ftp_die("FATAL: configuration problem, $dir is not a directory");
   }
+  # the chdir simplifies our filename parsing, so the base names don't
+  # have any directory.
+  chdir ($incoming_dir) || ftp_die("FATAL: chdir($incoming_dir) failed: $!");
+  my @incoming = &scan_incoming ();
 
-  my $sender = 'ftp-upload-script@gnu.org';
-  $sender = 'ftp-upload@gnu.org' if ($send_to_user); # We really want replies to go to the ftp-upload queue
-
-  @email_list = exclude_mail_blacklist(@email_list);
 
-  #print STDERR "final emails: @email_list\n";
-  # return @_;
+  # we've moved the files to work on to a new directory.
+  chdir ($incoming_tmp) || ftp_die("FATAL: chdir($incoming_tmp) failed: $!");
 
-  if (NOMAIL) {
-      if ($subject ne '') {
-	  ftp_syslog('info', "($log_style) Subject: '$subject'");
-      } elsif (defined $info{package}) {
-	  ftp_syslog('info', "($log_style) Subject: $info{package}");
-      } else {
-	  ftp_syslog('warning', "($log_style) Error uploading package: $msg");
-	  ftp_syslog('info', "($log_style) Subject: generic failure");
-      }
-      ftp_syslog('info', "($log_style) Body: $msg");
-  } else {
-      my $smtp;
-      if (IN_TEST_MODE) {
-	$smtp = Net::SMTP->new
-	  (Host => 'localhost', Port => $ENV{TEST_SMTP_PORT});
-      } else {
-	$smtp = Net::SMTP->new ("127.0.0.1");
-      }
-      ftp_die("FATAL: SMTP connection failed") unless $smtp;
+  for my $files (@incoming) {  # each list element is a hash reference.
+    ftp_syslog('info',"($log_style) found directive: $files->{directive}\n");
+    # if we die processing a triplet, the eval allows us to move
+    #   onto the next triplet.
+    eval {
+      # set up the %info variable
+      my $retval = &read_directive_file ($files->{"directive"},$files->{"upload"},$files->{"directive_only"});
 
-      $smtp->mail ($sender);
-      $smtp->bcc ($email_always) if ($send_to_user);
-      $smtp->recipient (@email_list, { SkipBad => 1});
+      if ($retval == 0) {
+	# do the work
+	&execute_commands($files,%info);
 
-      $smtp->data ();
-      $smtp->datasend ("To: " . join (", ", @email_list) . "\r\n");
-      $smtp->datasend ("From: $sender\r\n");
-      $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\r\n");
-      my $mid = Email::MessageID->new;
-      $smtp->datasend("Message-ID: <$mid>\r\n");
-      $smtp->datasend("Date: " . strftime("%a, %e %b %Y %H:%M:%S %z", localtime) . "\r\n");
-      if ($subject ne '') {
-	  $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] $subject");
-	  ftp_syslog('info', "($log_style) Subject: '$subject'");
-      } elsif (defined $info{package}) {
-	  $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] $info{package}");
-	  ftp_syslog('info', "($log_style) Subject: $info{package}");
-      } else {
-	  $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] generic failure");
-	  ftp_syslog('warning', "($log_style) Error uploading package: $msg");
-	  ftp_syslog('info', "($log_style) Subject: generic failure");
+	# report success
+	if (!$files->{"directive_only"}) {
+	  &success_upload($files->{"sig"}, $files->{"upload"},$files->{"directive"});
+	} else {
+	  &success_directive($files->{directive});
+	}
       }
-      $smtp->datasend ("\n\n");
-      ftp_syslog('info', "($log_style) Body: $msg");
-
-      # Wrap message at 78 characters, this is e-mail...
-      $Text::Wrap::columns=78;
-      $smtp->datasend (wrap('','',$msg) . "\n");
-      $smtp->dataend ();
-
-      $smtp->quit ();
-    }
-}
-
-sub debug {
-  my $msg = shift;
-  my $package_name = shift;
+    };
+    ftp_warn ("eval failed: $@") if $@;
 
-  if (NOMAIL) {
-      ftp_syslog('info', "($log_style) Subject: [$m_style gnu-ftp-debug] new upload processed: $package_name\nBody: $msg");
+    # clean up files if we abort while processing a triplet
+    cleanup ($files->{"sig"}, $files->{"upload"}, $files->{"directive"}) if ($@);
+    # clear out the current package that we just finished processing
+    undef %info;
+  }
+  if ((scalar @incoming) == 0) {
+    ftp_syslog('info', "($log_style) No files found for processing.");
   } else {
-      my $smtp;
-      if (IN_TEST_MODE) {
-	$smtp = Net::SMTP->new
-	  (Host => 'localhost', Port => $ENV{TEST_SMTP_PORT});
-      } else {
-	$smtp = Net::SMTP->new ("127.0.0.1");
-      }
-      ftp_die("FATAL: SMTP connection failed") unless $smtp;
-      $smtp->mail ("ftp-upload-script\@gnu.org");
-      $smtp->recipient ($maintainer_email, { SkipBad => 1});
-
-      $smtp->data ();
-      $smtp->datasend ("To: $maintainer_email\n");
-      $smtp->datasend ("From: ftp-upload-script\@gnu.org\n");
-      $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\n");
-      $smtp->datasend ("Subject: [$m_style gnu-ftp-debug] new upload processed: $package_name");
-      $smtp->datasend ("\n\n");
-      $smtp->datasend ("$msg\n");
-      $smtp->dataend ();
-      $smtp->quit ();
+    ftp_syslog('info', "($log_style) Processing complete: " . (scalar @incoming) . " uploads processed.");
+    system("/usr/local/bin/generate-ftpindex") unless IN_TEST_MODE;
+    ftp_syslog('info', "($log_style) Updated ftpindex");
   }
-}
-
-sub ftp_warn($) {
-    ftp_syslog('warning', "($log_style) " . $_[0]);
-    warn $_[0];
-}
 
-sub ftp_die($;$) {
-    my $msg = shift;
-    my $exitcode = shift;
-    $exitcode ||= 1;
-    ftp_syslog('err', "($log_style) " . $msg);
-    exit $exitcode;
-}
-
-sub ftp_syslog {
-  my ($priority,$message) = @_;
-
-  # Remove a trailing newline
-  $message =~ s/[\r\n]+$//;
-  # Collapse the message to a single line for syslog
-  $message =~ s/[\r\n]+/ \/ /g;
+  # Clean up the incoming directory and the incoming tmp directory - remove files older than a day
+  cleanup_dir($incoming_dir);
+  cleanup_dir($incoming_tmp);
 
-  # The syslog function is pretty picky, and (sometimes) dies silently
-  # when using non-valid syslog priorities.
-  # That's why we run it inside an eval, and print out any errors to STDERR.
-  eval {
-    syslog($priority, $message);
-  };
-  if ($@) {
-    print STDERR "$@\n";
-  }
+  return 0;
 }
 
 __END__
-- 
2.25.1