# Imported into Git by Jacob Bachmeyer (jcb@gnu.org), July 2020
# Further changes are tracked in Git.
+\f
+#
+# - Initialization and preliminaries
+#
+
use strict;
use warnings;
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'));
my %info; # package being processed; a global so fatal and mail can use it
-exit (&main ());
+\f
+#
+# - 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"});
+\f
+#
+# - 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;
-}
+\f
+#
+# - 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);
}
\f
+#
+# - [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,
return @ret;
}
-
\f
-# 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;
}
}
-\f
+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);
+}
+
+\f
+#
+# - [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.
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);
- }
-}
-
\f
#
-# 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);
-}
-\f
# Before checking the files, move them to a temporary directory.
#
# Check that the key is on the keyring for this package, and that
\f
+#
+# - [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.
}
}
+# 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);
+ }
+}
\f
+#
+# - Clean up
+#
+
# Report success and unlink the directive file.
#
sub success_upload {
}
}
+
\f
-# 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__
projects / gatekeeper.git / commitdiff