+++ /dev/null
-#!/usr/bin/perl -Tw
-
-#
-# Take files that have been uploaded via ftp and move them into place on
-# ftp.gnu.org.
-#
-
-
-# This program is free software: you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 3 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-#
-# Short overview
-#
-# We expect to find (1) a directive file, specifying the directory to
-# store into (syntax details later); (2) the actual file to be
-# distributed (no signature); (3) a detached signature for (2).
-#
-# For instance:
-# foo-1.2.tar.gz.directive.asc, signed (gpg --clearsign) ASCII text
-# about what to do with the other two files.
-# foo-1.2.tar.gz, the file to upload (could be anything) with no sig.
-# foo-1.2.tar.gz.sig, detached binary signature (gpg -b) for uploaded file.
-#
-# The directive file must always contain a 'directory', 'version' and
-# 'filename' directive, unless when run in compatibility mode ($V1_COMPAT_MODE
-# is set), in which case directive files with only a 'directory' directive are
-# allowed.
-#
-# Alternatively, we expect to find only a directive file. This file must have
-# a name that ends in 'directive.asc', and must contain one or more of these
-# directives: 'symlink', 'rmsymlink' and 'archive', in addition to the obligatory
-# 'directory' and 'version' directives. A 'filename' directive is not allowed.
-#
-# A 'comment' directive is always allowed.
-#
-# Permissions of directives are controlled on a per package basis. For each
-# package, one or more seperate GPG public keyrings are maintained. All signed
-# files that are part of a triplet must be signed by a permitted key for the
-# specific package named in the directive file. Each package is only allowed
-# write access to its own directory (with the same name as the package) within
-# the public ftp hierarchy. Write access to subdirectories of that directory is
-# allowed. Limiting write access to specific directories on a per package basis
-# minimizes the impact from the compromise of a maintainer's GPG private key. The
-# public keyrings form a hierarchy where keys in superdirectories can apply to
-# files uploaded to subdirectories. Example:
-#
-# Jim can only upload to aspell/dict/en so his key is located in
-# packages/aspell/dict/en/pubring.gpg. Paul can upload to any aspell
-# directory so his key is in packages/aspell/pubring.gpg. When Paul
-# uploads a file to aspell/dict/en it looks for his key in
-# packages/aspell/dict/en/pubring.gpg first, then finds it in
-# packages/aspell/pubring.gpg.
-#
-# Package config files are:
-# 1. $package_config_base/$package_name/pubring.gpg
-# GNUPG public keyring. For a given package, the directive
-# file and file to be uploaded, must be signed with a key from
-# the package's keyring.
-# If a file is to be uploaded into a subdirectory of the package
-# directory, the subdirectory in the package config directory will
-# be checked for a pubring.gpg first, going up to the parent directory
-# until a match is found.
-# 2. $package_config_base/$package_name/email
-# Email addresses that are sent mail when uploads succeed or
-# fail for a given package. One email address per line.
-#
-# This is written for use with ftp instead of as a cgi script because we
-# don't want to run an httpd on ftp.gnu.org. In general, it tries to do
-# the minimum possible.
-#
-# We execute gpgv, lsof, mkdir, mv, pwd and tar. Executions are such that
-# it's not possible for the shell to be invoked. We make use of Perl
-# module Net::SMTP to send email.
-#
-# Originally written by Karl Berry (karl@gnu.org), October 2003.
-# Additional changes by Paul Fisher (rao@gnu.org), November 2003
-# Additional functionality (v1.1) by Ward Vandewege (ward@gnu.org), May 2004
-# Additional changes (syslog) by Justin Baugh (baughj@gnu.org), August 2005
-# Additional testing and bugfixes by Ward Vandewege (ward@gnu.org), Apr 2006 - Jan 2010
-
-use strict;
-use Net::SMTP;
-use Date::Manip;
-use Sys::Syslog qw(:DEFAULT setlogsock);
-use Getopt::Long;
-use Text::Wrap;
-use POSIX qw(strftime);
-use Cwd;
-use Email::MessageID;
-umask (022);
-
-$ENV{"LC_ALL"} = "C"; # do not think about multibyte characters
-
-# Clean env so we can run subprograms, notably gpgv and lsof.
-$ENV{"PATH"} = "/usr/bin:/bin:/usr/sbin";
-delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
-
-my $V1_COMPAT_ALLOWED = 0;
-
-my $NAME = 'upload-ftp-v1.1.pl';
-my $VERSION = '1.1'; # This is the protocol version
-my $DATE = '2010/04/14 12:23:29';
-my $AUTHOR = "Free Software Foundation <sysadmin\@gnu.org>";
-my $COPYRIGHT = "2003-2010";
-my $LICENSE = "GPLv3 or later - http://www.fsf.org/licenses/gpl.txt";
-my $URL = "http://www.gnu.org/prep/maintain/html_node/Automated-FTP-Uploads.html";
-
-my $style = '';
-my $help = '';
-my $version = '';
-# Set this to 1 or higher to get debug output in the log file.
-my $DEBUG = 1;
-
-my $NOMAIL = 0;
-
-GetOptions ("style=s" => \$style, "debug=i" => \$DEBUG, "help" => \$help, "version" => \$version);
-
-&version_information () if ($version);
-&usage_information() if ($help);
-&usage_information() if (($style ne 'ftp') && ($style ne 'alpha') && ($style ne 'distros'));
-
-my $m_style = 'ftp';
-$m_style = 'alpha' if ($style eq 'alpha');
-$m_style = 'gnu+linux-distros' if ($style eq 'distros');
-
-# Settings to configure:
-my $package_config_base = "/home/gatekpr/packages";
-# where ftpd deposits the files for us to look at:
-my $incoming_dir = "/home/upload/incoming/$m_style";
-# private dir on SAME FILESYSTEM as $incoming_dir:
-my $incoming_tmp = "/var/tmp/$m_style-in";
-# top-level public ftp dir for installing files:
-my $destfinal = "/home/$m_style/gnu";
-$destfinal = "/home/ftp/$m_style" if ($m_style eq 'gnu+linux-distros'); # The distros go here
-# private dir on SAME FILESYSTEM as $destfinal:
-my $olddestfinal = "/home/gatekpr/$m_style-archived";
-# private dir on SAME FILESYSTEM as $destfinal:
-my $desttmp = "/var/tmp/$m_style-out";
-
-my $master_keyring = "/home/gatekpr/etc/master_pubring.gpg";
-
-# We sometimes want to exclude e-mail addresses from being emailed.
-# Specifically, e-mail addresses we import from gpg keys - keys are still valid
-# but associated e-mail addresses are not. Ward, 2011-02-08.
-my $email_blacklist = "/home/gatekpr/etc/email_blacklist";
-
-# List of all package maintainers
-my $maintainers_bypkg = "/home/gatekpr/etc/maintainers.bypkg";
-
-my $log_style = 'GNU';
-$log_style = 'Alpha' if ($style eq 'alpha');
-$log_style = 'Distros' if ($style eq 'distros');
-
-# maintainer e-mail address
-my $maintainer_email = "ftp-upload-report\@gnu.org";
-
-my $serials_path = "/home/gatekpr/etc/upload-ftp-serials.txt";
-
-my $email_always = 'ftp-upload-script@gnu.org'; # e.g., ftp-upload@gnu.org
-
-# syslog destination
-my $facility = "LOCAL5";
-
-my %info; # package being processed; a global so fatal and mail can use it
-
-exit (&main ());
-
-sub main
-{
-
- # Initialize our syslogging
- setlogsock('unix');
- openlog("ftp-upload", 'pid', $facility);
- ftp_syslog('info', "($log_style) Beginning upload processing run.");
-
- # 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 ();
-
-
- # we've moved the files to work on to a new directory.
- chdir ($incoming_tmp) || ftp_die("FATAL: chdir($incoming_tmp) failed: $!");
-
- 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"});
-
- if ($retval == 0) {
- # do the work
- &execute_commands($files,%info);
-
- # report success
- if (!$files->{"directive_only"}) {
- &success_upload($files->{"sig"}, $files->{"upload"},$files->{"directive"});
- } else {
- &success_directive($files->{directive});
- }
- }
- };
- ftp_warn ("eval failed: $@") if $@;
-
- # 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 {
- ftp_syslog('info', "($log_style) Processing complete: " . (scalar @incoming) . " uploads processed.");
- }
-
- # Clean up the incoming directory and the incoming tmp directory - remove files older than a day
- cleanup_dir($incoming_dir);
- cleanup_dir($incoming_tmp);
-
- return 0;
-}
-
-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 (c) $COPYRIGHT by $AUTHOR\n";
- print "License: $LICENSE\n";
- print "More information at $URL\n\n";
- exit;
-}
-
-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");
-
-}
-
-
-# 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
-# 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,
-# or if any of the files are still open, or if the filenames are dubious
-# -- things'll get cleaned up as needed separately.
-#
-# If we accept a triplet, we rename the files into a temporary
-# directory. This is to avoid attackers overwriting files as or after
-# we check them. This is redundant protection -- the ftp config on
-# ftp.gnu.org does not allow overwrites or deletes.
-#
-sub scan_incoming {
- my @ret;
- my %possible;
- # Get list of all possible files from incoming dir.
- #
- opendir (INCOMING, $incoming_dir)
- || ftp_die("FATAL opendir($incoming_dir) failed: $!");
- while (my $tainted_ent = readdir (INCOMING)) {
- # don't look at files with a leading dot or dash, but allow those chars
- # subsequently. Omit files containing any other weird characters.
- next unless $tainted_ent =~ /^([\w_+][-.\w_+~]*)$/;
- my $ent = $1;
-
- # Don't look at files with really long names, either.
- next if length ($ent) > 100;
- $possible{$ent} = 1;
- }
- closedir (INCOMING) || ftp_die("FATAL: closedir($incoming_dir) failed: $!");
- # No possible files found, so return before we call lsof
- return @ret unless %possible;
- # Determine if any of those possible files are open. We find the
- # possible files before running lsof (partly) to avoid a race
- # condition. (If we ran lsof on the whole directory first, a new file
- # might be uploaded and possibly be processed even though it was open.)
- #
- my %open;
- #
- # BTW, lsof -F0n mistakenly backslash-escapes newlines; fortunately,
- # we've already excluded filenames containing whitespace so this
- # cannot cause trouble. We use -F0n anyway, though, for redundant
- # protection against strange filenames.
- #
- # We do have prepend $incoming_dir to make the possible names
- # absolute, since lsof outputs absolute names.
- #
-
- my @lsof_args = ("/usr/bin/lsof", "-Fn",
- map { "$incoming_dir/$_" } keys %possible);
- my $pid = open (LSOF, "-|");
-
- if ($pid) { # parent
- while (defined (my $line = <LSOF>)) {
- next unless $line =~ /^n${incoming_dir}\/(.+)$/; # only look at the name lines.
- delete ($possible{$1}) || ftp_warn("WARNING: lsof found unrequested but open $1?!");
- }
- close (LSOF);
- } else { # child
- exec (@lsof_args) || ftp_die("FATAL: cannot exec lsof: $!");
- }
-
- # For each remaining possibility, do some more checks
- for my $ent (keys %possible) {
- my $base = $ent;
- my $sig = "$base.sig";
- my $directive = "$base.directive.asc";
- my $bare_base = $base;
- $bare_base =~ s/\.directive\.asc$//g;
-
- # work on this triple, if all three files exist, and the signature
- # and directive files aren't huge. We want to exclude huge files
- # here, before even reading the directive file; otherwise, perl could
- # consume lots of memory reading it.
- if (exists($possible{$base}) && exists($possible{$sig}) && exists($possible{$directive})
- && (-s $directive < 50*1024) && (-s $sig < 50*1024)) {
- push (@ret, { "directive" => $directive, "sig" => $sig,
- "upload" => $base, "directive_only" => 0 });
- ftp_syslog('info', "($log_style) processing [$directive:$sig:$base]");
-
- # Do atomic rename to temp incoming directory before reading
- # anything, for safety.
- #
- for my $f (($directive, $sig, $base)) {
- rename ($f, "$incoming_tmp/$f")
- || &fatal("rename $incoming_dir/$f to $incoming_tmp/$f failed: $!",0);
- }
-
- # don't bother to try any part of this triple again.
- delete $possible{$base};
- delete $possible{$sig};
- delete $possible{$directive};
- } elsif (exists($possible{$base}) && !exists($possible{"$bare_base.sig"}) && ($base =~ /\.directive\.asc$/)) {
-
- # Here we have a potential problem. It's possible that we are seeing a
- # directive file that belongs to a triplet the rest of which has not been
- # uploaded yet. If so, we should ignore this file and not move it to
- # $incoming_dir. This means we need to read the file and see if there is a
- # 'filename:' directive.
-
- my $racecondition = 0;
- open(TMP,$base);
- while (<TMP>) {
- if (/^Filename:/i) {
- $racecondition = 1;
- last;
- }
- }
- close(TMP);
-
- if ($racecondition) {
- # Most likely a race condition. We've found a directive file but not the accompanying file(s).
- # Just ignore this directive file for now.
- ftp_syslog('info',"($log_style) Found directive file with filename directive ($base), but no accompanying files. Ignoring directive file in this run.");
- } else {
- # Directive file only, no actual file to deal with
- # This can happen when dealing with symlink/rmsymlink/archive options
- push (@ret, { "directive" => $base, "sig" => '',
- "upload" => '', "directive_only" => 1 });
- # Do atomic rename to temp incoming directory before reading
- # anything, for safety.
- rename ($base, "$incoming_tmp/$base")
- || &fatal("rename $incoming_dir/$base to $incoming_tmp/$base failed: $!",0);
- }
- delete $possible{$base};
- } elsif ((-f $directive) && ((-s $directive) >= 50*1024)) {
- rename ("$incoming_dir/$directive", "$incoming_dir/.$directive");
- ftp_syslog('info', "($log_style) $directive larger than 50KB");
- &fatal("The directive file $directive is larger than 50KB. This can not be correct, ignoring upload.",0);
- } elsif ((-f $sig) && ((-s $sig) >= 50*1024)) {
- rename ("$incoming_dir/$sig", "$incoming_dir/.$sig");
- ftp_syslog('info', "($log_style) $directive or $sig larger than 50KB");
- &fatal("The signature file $sig is larger than 50KB. This can not be correct, ignoring upload.",0);
- }
- }
-
- 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 $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'.",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;
-}
-
-sub parse_directory_line {
- my $tainted_val = shift;
- my $directive_file_contents = shift;
- $tainted_val =~ s/ *$//; # Throw away trailing whitespace
- # $do_not_fail is set to 1 if this sub is called as a last resort in an attempt to find *someone* to report an error to.
- # When it is set, this sub will not die with &fatal.
- my $do_not_fail = shift;
- # Can't let it start with - . / or contain strange characters.
- # This disallows .. as a file name component since no component
- # can start with a . at all.
- $tainted_val =~ m,^(\w[-.\w]*(/\w[-.\w]*)*)$, || &fatal("invalid directory $tainted_val\n$directive_file_contents",1,$directive_file_contents);
- my $val = $1; # so far so good
-
- # A couple of subdir levels are ok, but don't allow hundreds.
- my $slash_count = ($val =~ tr,/,/,);
- &fatal("$slash_count slashes is too many, in $val",1,$directive_file_contents) if ($slash_count > 3 and not $do_not_fail);
-
- # Only let them specify one directory directive.
- &fatal("Only one directory directive is allowed per directive file. Error at directory directive: $val",1,$directive_file_contents)
- if (exists $info{"directory"} and not $do_not_fail);
-
-
- $info{"directory"} = $val; # ok.
- ($info{"package"} = $val) =~ s,/.*$,,; # top-level name, no subdir
- # Set email addresses
- my @a = email_addresses($info{package});
- foreach my $address (@a) {
- push (@{$info{email}}, $address) unless (grep($_ eq $address,@{$info{email}}) > 0); # Do not include duplicates
- }
-}
-
-\f
-# 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.
-#
-# We assume DIRECTIVE_FILE is clear-signed (gpg --clearsign). Among
-# other things, this lets us use gpgv everywhere, for paranoia's sake.
-#
-sub read_directive_file {
- my ($directive_file) = shift;
- my ($uploaded_file) = shift;
- my ($directive_only) = shift;
-
- # We default to v1.1
- $info{'v1_compat_mode'} = 0;
-
- # For debugging purposes, see below
- my $directive_file_contents = '';
- my @lines = ();
-
- # Read the contents of the directive file. We require one
- # non-white non-pgp line:
- # Directory: dirname[/subdirname]
- #
- open (DIRECTIVE_FILE, "<", $directive_file)
- || ftp_die("FATAL: open($directive_file) failed: $!");
- my $cnt = 0; # Keep track of the order of directives...
- while (<DIRECTIVE_FILE>) {
- my $line = $_;
- $directive_file_contents .= $line;
- push(@lines,$line);
- }
- close (DIRECTIVE_FILE) || ftp_warn("close($directive_file) failed: $!");
-
- # If we don't know whose project this file belongs to, because the
- # 'directory:' line is messed up or not there, we'd still like to let the
- # uploader know something went wrong. So let's see if we can match the
- # directive file signature against one of our public keyrings.
- my @tmp_keyrings;
- open(TMP,"/usr/bin/find $package_config_base -name pubring.gpg|");
- while(<TMP>) {
- chomp();
- push(@tmp_keyrings,$_);
- }
- close(TMP);
-
- my $tmp_retval = &verify_keyring($directive_file,$directive_file_contents,@tmp_keyrings);
- push(@{$info{email}},$1) if ($tmp_retval =~ /Good signature from .*?<(.*?)>/);
-
- my $signed = 0;
- # If there is a command in the directive that doesn't require an actual file to work
- # on, we won't require the filename line in the directive file. This will allow people
- # to upload a directive file only to archive/create symlinks/remove symlinks
- my $filename_required = 1;
-
- foreach my $line (@lines) {
- $line =~ s/\r\n/\n/g; # deal with dos-based line endings...
- $line =~ s/\s+$/\n/; # Some people like to put spaces after their commands
- $line =~ s/^\s+//; # Or even *before* their commands
- last if ($line =~ /^-----BEGIN PGP SIGNATURE/);
- if ($line =~ /^-----BEGIN PGP SIGNED MESSAGE-----$/) {
- $signed = 1;
- next;
- }
- next if ($line =~ /^Hash:/);
- next if ($line =~ /^\s*$/);
- # Just make sure we don't parse any lines that are NOT part of the signed message!
- # GPG will make sure that a line that looks like "-----BEGIN PGP SIGNED MESSAGE-----"
- # will be escaped before signing a message that contains it
- next if (!$signed);
-
-
- my ($tainted_cmd,$tainted_val) = split(' ',$line,2);
- if ($tainted_cmd =~ /^Directory:?$/i) { # case-insensitive, w or w/o the :
- parse_directory_line($tainted_val, $directive_file_contents,0);
- } elsif ($tainted_cmd =~ /^Filename:?$/i) { # case-insensitive, w or w/o the :
- # We use the same filename restrictions as scan_incoming
- $tainted_val =~ /^([\w_+][-.\w_+~]*)$/ || &fatal("invalid filename $tainted_val",1,$directive_file_contents);
- my $val = $1; # so far so good
-
- # Only let them specify one filename directive.
- &fatal("Only one filename directive is allowed per directive file. Error at filename directive: $val.",1,$directive_file_contents)
- if exists $info{"filename"};
-
- $info{"filename"} = {"value" => $val, "order" => $cnt++}; # ok.
- } elsif ($tainted_cmd =~ /^Version:?$/i) { # case-insensitive, w or w/o the :
- $tainted_val =~ /^(\d+\.\d+)$/ || &fatal("invalid version $tainted_val",1,$directive_file_contents);
- my $val = $1; # so far so good
-
- # We only support version 1.1/1.2 right now!
- &fatal("invalid version $val, not supported",1,$directive_file_contents) if (($val ne '1.1') and ($val ne '1.2'));
-
- # Only let them specify one version directive.
- &fatal("invalid second version $val, have $info{version}",1,$directive_file_contents) if exists $info{"version"};
-
- $info{"version"} = $val; #ok.
- } elsif ($tainted_cmd =~ /^symlink:?$/i) { # case-insensitive, w or w/o the :
- $tainted_val =~ /^([\w_+][-.\w_+\/]*)\s+([\w_+][-.\w_+\/]*)$/ || &fatal("invalid parameters for symlink command: $tainted_val",1,$directive_file_contents);
- my ($target,$link) = ($1,$2); # so far so good
- &fatal("invalid parameters for symlink command(2): $tainted_val",1,$directive_file_contents) if ($target =~ /\.\./);
- $info{"symlink-$target"} = {"link" => $link, "order" => $cnt++}; #ok.
- } elsif ($tainted_cmd =~ /^rmsymlink:?$/i) { # case-insensitive, w or w/o the :
- $tainted_val =~ /^([\w_+][-.\w_+\/]*)$/ || &fatal("invalid parameters for rmsymlink command: $tainted_val",1,$directive_file_contents);
- my $val = $1; # so far so good
- &fatal("invalid parameters for rmsymlink command(2): $tainted_val",1,$directive_file_contents) if ($val =~ /\.\./);
- $info{"rmsymlink-$1"} = {"order" => $cnt++}; #ok.
- } elsif ($tainted_cmd =~ /^archive:?$/i) { # case-insensitive, w or w/o the :
- $tainted_val =~ /^([\w_+][-.\w_+\/]*)$/ || &fatal("invalid parameters for archive command: $tainted_val",1,$directive_file_contents);
- my $val = $1; # so far so good
- &fatal("invalid parameters for archive command(2): $tainted_val",1,$directive_file_contents) if ($val =~ /\.\./);
-
- $info{"archive-$1"} = {"order" => $cnt++}; #ok.
- } elsif ($tainted_cmd =~ /^replace:?$/i) { # case-insensitive, w or w/o the :
- # This command is only supported from v1.2
- $tainted_val =~ /^(true|false)$/ || &fatal("invalid parameters for replace command: $tainted_val",1,$directive_file_contents);
- $info{"replace"} = $1; #ok.
- } elsif ($tainted_cmd =~ /^comment:?$/i) { # case-insensitive, w or w/o the :
- # Comments are ok, we ignore them
- } else {
- &fatal("Invalid directive line:\n\n $tainted_cmd $tainted_val",1,$directive_file_contents);
- }
- }
-
- $info{'v1_compat_mode'} = 0;
-
- if (exists($info{"replace"}) and (($info{'v1_compat_mode'} == 1) or ($info{"version"} eq '1.1'))) {
- &fatal("invalid directive 'replace', not supported prior to version 1.2",1,$directive_file_contents);
- }
-
- # Phone home. E-mail the contents of the directive file to the maintainer,
- # for debugging purposes. After this point, we don't need to pass the
- # $directive_file_contents to any subsequent &fatal calls.
- if (defined $info{'package'}) {
- debug($directive_file_contents, $info{'package'}) if $DEBUG;
- } else {
- debug($directive_file_contents, '') if $DEBUG;
- }
-
- # They have to specify a directory directive.
- if (!$info{"directory"}) {
- # Send the warning to the upload-ftp script maintainer, and the person who
- # signed the file, if we were able to extract that from the signature on
- # the directive file.
- &fatal("no directory directive specified in $directive_file",1);
- }
-
- # There are a few possibilities regarding the 'filename' directive
- # 1. It exists in the directive file - there is no problem
- # 2. It doesn't exist in the directive file
- # In that case, we need to double check a few things.
- # This is permitted IF $V1_COMPAT_ALLOWED is true, AND if the only directive is a 'directory'.
- # (for backwards compatibility with older versions of the script)
- # It is also permitted if the directive file contains commands that don't require
- # a filename - currently symlink, rmsymlink, and archive - and only the directive file was
- # uploaded
- if (!exists($info{filename})) {
- my $directory_command_only = 1;
- foreach (keys %info) {
- $directory_command_only = 0 if (($_ ne 'directory') && ($_ ne 'package') && ($_ ne 'version') && ($_ ne 'v1_compat_mode') && ($_ ne 'email'));
- }
- # This is where we would check for commands that require a file.
- # In this version (1.1), there are none, so all we do is check
- # that only the directive file was uploaded
-
- if (!$directive_only) {
- # We have three files
- # Are we in version 1.0 compatibility mode?
- if ($V1_COMPAT_ALLOWED) {
- # We're in backwards compatibility mode
- # That means: three files, and ONLY a directory directive in the directive file
- $info{'v1_compat_mode'} = 1;
- if ($directory_command_only == 0) {
- &fatal("no filename directive specified in $directive_file",1)
- } else {
- ftp_syslog('info',"($log_style) running in legacy V1 compatibility mode");
- }
- } elsif (!$V1_COMPAT_ALLOWED) {
- # This is not allowed - we require a filename directive. No backwards compatibility.
- &fatal("no filename directive specified in $directive_file. Upgrade to the latest version! See http://www.gnu.org/prep/maintain/maintain.html",1)
- }
- } else {
- # We only have a directive file
- # Do we have something to do?
- &fatal("nothing to do - no commands in directive file",1) if ($directory_command_only == 1);
- }
- $filename_required = 0;
- }
- ftp_syslog('info',"($log_style) running in v1.1 mode") if (!$info{'v1_compat_mode'});
-
- # Configuration must exist for the package
- -d $package_config_base . '/' . $info{"package"}
- || &fatal("no configuration directory for package $info{package}",0);
-
- # Check that we have a keyring for this package:
- my @keyrings = &keyring_file ($info{package},$info{directory});
- &fatal("no keyring for package $info{package}",0) if ($#keyrings < 0);
-
- if ($filename_required) {
- # Ben Pfaff <blp@cs.stanford.edu> wrote:
- # First, "gpg -b" doesn't verify that the filename of the signed
- # data is correct. This means that I can rename gcc-1.2.3.tar.gz
- # to gcc-3.4.5.tar.gz and the signature will still verify
- # correctly. This opens up the possibility for confusion, but in
- # itself it's not a huge deal.
- #
- # To fix this, we require a 'filename:' line in the directive file
- # that needs to match the name of the uploaded file.
-
- # Filename has to match the name of the uploaded file
- &fatal("The filename directive does not match name of the uploaded file.\n\n Filename directive: $info{filename}{value}\n Uploaded file: $uploaded_file\n",1)
- if ($uploaded_file ne $info{filename}{value});
-
- # Filename has to match the name of this directive file (a bit paranoid, but hey...)
- &fatal("filename $info{filename}{value} does not match name of directive file $directive_file",1)
- if ($directive_file ne "$info{filename}{value}.directive.asc");
- }
-
- # They have to specify a version unless we're in 1.0 compatibility mode
- if (!$info{'v1_compat_mode'}) {
- &fatal("no version directive specified in $directive_file",1)
- if ! $info{"version"};
- }
-
- my $retval = &verify_keyring($directive_file,$directive_file_contents,@keyrings);
-
- # Now check that the timestamp of signing for the directive is not older
- # than the one for the last file that was uploaded
- # This is only relevant when a 'filename' directive is present, hence the
- # test of the $filename_required variable.
- if (($retval =~ /Signature made (.*?) using/) && ($filename_required)) {
- my $timestr = $1;
- # If the time/date string starts with a weekday (e.g. "Wed Apr 28 16:40:03 2004 EDT"),
- # chop off the weekday - Date::Manip doesn't like it
- $timestr =~ s/^[a-z]+? ([a-z]+)/$1/i;
-
- # We need to convert time/date strings like "Apr 28 16:40:03 2004 EDT" into
- # "Apr 28 16:40:03 2004 EDT" for Date::Manip to understand them...
- $timestr =~ s/^([a-z]+? +\d{1,2}) (\d{2}:\d{2}:\d{2}) (\d{4}) (.*)$/$1 $3 $2 $4/i;
-
- my $date = ParseDate($timestr);
- my $epoch = UnixDate($date,"%s");
-
- # Verify that this timestamp is not too far in the future. We allow a discrepancy of 1 day so we don't have to worry about timezones
- my $now = time();
- if ($epoch > ($now + 24*3600)) {
- &fatal("GPG signed upload from the future - not allowed. Please make sure your clock is set correctly, resign the directive file, and upload again. You may have to wait 24 hours before re-uploading if you do not change the filename for your triplet.",1);
- }
-
- # Now we need to flock the our 'serials' file;
- # verify the epoch value there/update it, etc.
- my %serials = ();
- my @serials = ();
-
- if (!-e $serials_path) {
- open(SERIALS,">$serials_path");
- flock(SERIALS,2); # Take exclusive lock
- } else {
- open(SERIALS,"+<$serials_path");
- flock(SERIALS,2); # Take exclusive lock
- @serials = <SERIALS>;
- foreach (@serials) {
- my ($tmp1,$tmp2) = /(.*?):(.*?)\n/;
- $tmp1 =~ s/\s+//g;
- $tmp2 =~ s/\s+//g;
- $serials{$tmp1} = $tmp2;
- }
- }
- seek(SERIALS,0,0);
- my $full_filename = $info{"directory"} . '/' . $uploaded_file;
- $full_filename =~ s/\/\//\//g; # Just in case...
-
- # Verify that this is really a new version of the file!
- if (exists($serials{$full_filename}) && ($serials{$full_filename} >= $epoch)) {
- flock(SERIALS,4); # Release lock
- &fatal("GPG signed upload older than/same timestamp as existing version - not allowed. In other words, the filenames for the triplet you have uploaded are an exact match for a triplet that has been uploaded in the past, and the directive file that you just uploaded has been signed before or at the same time as the directive file for the triplet that was uploaded earlier. Most likely, you are re-uploading an old triplet.",1);
- }
-
- $serials{$full_filename} = $epoch;
-
- foreach my $key (keys %serials) {
- print SERIALS "$key:$serials{$key}\n";
- }
-
- flock(SERIALS,4); # Release lock
- close(SERIALS);
- } elsif ($filename_required) {
- &fatal("gpg verification problem: could not extract timestamp",1);
- }
-
- 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!)
-#
-sub verify_keyring {
- my ($directive_file, $directive_file_contents, @keyrings) = @_;
- 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 = ("/usr/bin/gpgv", "--keyring", $_,
- $directive_file,"2>&1",";echo \$?");
-
- my $verify_str = join(' ',@verify_args);
-
- ($verify_str) = $verify_str =~ /^(.*)$/;
-
- ftp_syslog('info',"$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
-# SIG_FILE and UPLOAD_FILE are good.
-#
-sub check_files {
- my $files = shift;
- my %info = @_;
-
- my ($sig_file,$upload_file) = ($files->{"sig"}, $files->{"upload"});
-
- my @keyrings = &keyring_file ($info{package},$info{directory});
- &fatal("no keyring for package $info{package}",0) if ($#keyrings < 0);
-
- my $valid = 0;
- foreach my $keyring (@keyrings) {
- # Verify that the file has been correctly signed with a valid signature.
- my @verify_args = ("/usr/bin/gpgv", "--keyring", $keyring,
- $sig_file, $upload_file);
- if (!system (@verify_args)) {
- $valid = 1;
- last;
- }
- }
- $valid
- or &fatal("gpg verify of upload file ($upload_file) failed",1);
-
- # Reject an upload tarball if it contains a Makefile.in vulnerable
- # as described in CVE-2009-4029.
- # http://thread.gmane.org/gmane.comp.sysutils.autotools.announce/131
- if ($upload_file =~ /\.(tar|)(\.|$)|\.t[bglx]z|\.tbz2$/) {
- # First check if the file contains any Makefile.in files
- ftp_syslog('debug', "($log_style) DEBUG: testing $upload_file for presence of Makefile.in") if $DEBUG;
- my $tar_cmd = "/bin/tar -tf $upload_file";
- open (TAR, "$tar_cmd|")
- or &fatal("failed to run command: $tar_cmd",1);
- my $found_makefile = 0;
- while (defined (my $line = <TAR>)) {
- if ($line =~ /Makefile.in/i) {
- $found_makefile = 1;
- last;
- }
- }
- close(TAR); # We don't care about errors here; the pipe can cause non-zero exit codes when tar is unhappy that it's asked to stop
- return if (!$found_makefile);
- # If it does, check inside them
- ftp_syslog('debug', "($log_style) DEBUG: found Makefile.in, testing for CVE-2009-4029 and CVE-2012-3386") if $DEBUG;
- $tar_cmd = "/bin/tar --to-stdout -x -f $upload_file 'Makefile.in' --wildcards '*/Makefile.in' 2>/dev/null";
- open (TAR, "$tar_cmd|")
- or &fatal("failed to run command: $tar_cmd",1);
- my $found_cve_2009_4029 = 0;
- my $found_cve_2012_3386 = 0;
- my $error_string = '';
- while (defined (my $line = <TAR>)) {
- if ($line =~ /perm -777 -exec chmod a\+rwx|chmod 777 \$\(distdir\)/) {
- $found_cve_2009_4029 = 1;
- }
- if ($line =~ /chmod a\+w \$\(distdir\)/) {
- $found_cve_2012_3386 = 1;
- }
- }
- close(TAR); # We don't care about errors here; the pipe can cause non-zero exit codes when tar is unhappy that it's asked to stop
-
- # Because CVE-2012-3386 was not fixed until 1.11.6 / 1.12.2, we point people to that version instead
- # of 1.11.1, which fixes CVE-2009-4029. Ward, 2012-07-20
- $found_cve_2009_4029 and $error_string .= "upload rejected: $upload_file contains a vulnerable "
- . "Makefile.in (CVE-2009-4029);\n"
- . "Regenerate it with automake 1.11.6 / 1.12.2 or newer.\n\n";
-
- $found_cve_2012_3386 and $error_string .= "upload rejected: $upload_file contains a vulnerable "
- . "Makefile.in (CVE-2012-3386);\n"
- . "Regenerate it with automake 1.11.6 / 1.12.2 or newer.\n\n";
-
- ($found_cve_2009_4029 or $found_cve_2012_3386) and &fatal($error_string,1,'',3);
-
- }
- ftp_syslog('debug', "($log_style) DEBUG: tested negative for CVE-2009-4029 and CVE-2012-3386") if $DEBUG;
-}
-
-
-\f
-# 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.
-#
-sub install_files {
- my $files = shift;
- my %info = @_;
-
- my ($sig_file,$upload_file) = ($files->{"sig"}, $files->{"upload"});
- my $destdir = "$destfinal/$info{directory}";
- # File::Path is 200 lines of Perl and requires reading an external
- # text file. In my mind, it is a toss-up as to whether that or
- # forking the system mkdir is safer. We could debate endlessly,
- # change it if you like, let's move on ...
- my @mkdir_args = ("/bin/mkdir", "-p", $destdir);
- system (@mkdir_args);
- -d $destdir || &fatal("no directory $destdir",1);
-
- my ($t1, $t2) = (0,0);
-
- # We now allow overwriting of files - without warning!!
- if (-e "$destdir/$sig_file") {
- if (not exists($info{'replace'}) or ($info{'replace'} ne 'true')) {
- &fatal("This signature file exists: $destdir/$sig_file, if you want to replace the pair please use the 'replace' directive",1);
- } else {
- archive($destdir, $info{directory}, $sig_file);
- ftp_syslog('info', "($log_style) archived and overwrote $destdir/$sig_file with uploaded version");
- $t1 = 1;
- }
- }
- if (-e "$destdir/$upload_file") {
- if (not exists($info{'replace'}) or ($info{'replace'} ne 'true')) {
- &fatal("This file exists: $destdir/$upload_file, if you want to replace the pair please use the 'replace' directive",1);
- } else {
- archive($destdir, $info{directory}, $upload_file);
- ftp_syslog('info', "($log_style) overwrote $destdir/$upload_file with uploaded version");
- $t2 = 1;
- }
- }
- my $notification_str = '';
- $notification_str .= "Archived and overwrote $destdir/$sig_file with uploaded version\n" if ($t1);
- $notification_str .= "Archived and overwrote $destdir/$upload_file with uploaded version\n" if ($t2);
- &mail ($notification_str) if ($notification_str ne '');
-
- # Do we need a subdirectory on $desttmp as well? Can't quite picture
- # when we'd have a collision, so skip that for now.
- #
- for my $f (($sig_file, $upload_file)) {
- my @mv_args = ("/bin/mv", $f, "$desttmp/$f");
- &fatal("@mv_args failed",0) if system (@mv_args) != 0;
- }
-
- # Do atomic rename (if the system crashes between or during the mv's,
- # too bad :). This is so we don't ever have a partial file that could
- # be found by mirrors, etc.
- #
- for my $f (($sig_file, $upload_file)) {
- chmod 0644, "$desttmp/$f";
- rename ("$desttmp/$f", "$destdir/$f")
- || &fatal("rename($desttmp/$f, $destdir/$f) failed: $!",0);
- }
-}
-
-
-\f
-# Report success and unlink the directive file.
-#
-sub success_upload {
- my ($sig_file,$upload_file,$directive_file) = @_;
-
- &mail ("upload of $upload_file and $sig_file complete",1);
-
- unlink ($directive_file) || ftp_warn("unlink($directive_file) failed: $!");
-}
-
-sub success_directive {
- my ($directive_file) = shift;
- &mail ("processing of $directive_file complete",1);
- unlink ($directive_file) || ftp_warn("unlink($directive_file) failed: $!");
-}
-
-sub cleanup_dir {
- my $dir = shift;
- opendir(DIR, $dir) || ftp_die("Can’t opendir $dir in cleanup_dir: $!");
- my @files = grep { ! /^\./ && -f "$dir/$_" } readdir(DIR);
- closedir DIR;
-
- foreach my $file (@files) {
- my @tmp = stat("$dir/$file");
- $file =~ /^(.*)$/; $file = $1;
- my $mtime = $tmp[9];
- $mtime =~ /^(.*)$/; $mtime = $1;
- ftp_syslog('debug',"($log_style) DEBUG: Removing $file, older than 24 hours (mtime: $tmp[9])\n") if ((time() > ($tmp[9]+24*3600)) && ($DEBUG > 0));
- unlink ("$dir/.$file"); # don't worry if it doesn't exist
- rename ("$dir/$file", "$dir/.$file") if (time() > ($mtime+24*3600));
- }
-}
-
-sub cleanup {
- for my $dir ($incoming_dir, $incoming_tmp, $desttmp) {
- for my $f (@_) {
- ftp_syslog('debug',"($log_style) DEBUG: cleaning up $dir/$f\n") if ($DEBUG > 1);
- # if we quit early enough, they might not be there.
- next unless defined $f && -e "$dir/$f";
-
- unlink ("$dir/.$f"); # don't worry if it doesn't exist
- rename ("$dir/$f", "$dir/.$f"); # save one backup
- }
- }
-}
-
-\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.
-#
-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);
-}
-
-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);
-
- 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);
- }
- ftp_syslog('info', "($log_style) Sending email to @email_list");
-
- 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");
- }
- ftp_syslog('info', "($log_style) Body: $msg");
- } else {
- my $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 = 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 ();
- }
-}
-
-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) = @_;
- # 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";
- }
-}
-
-__END__
projects / gatekeeper.git / commitdiff