From c50ba7dfe0e50decc0295832f55e69852332428a Mon Sep 17 00:00:00 2001 From: unknown Date: Wed, 14 Apr 2010 11:25:02 -0500 Subject: [PATCH] Import version as of 2010-04-14 for upload-ftp-v1.1.pl --- upload-ftp-v1.1.pl | 536 +++++++++++++++++++++++---------------------- 1 file changed, 273 insertions(+), 263 deletions(-) diff --git a/upload-ftp-v1.1.pl b/upload-ftp-v1.1.pl index 8df14a8..d573ec5 100755 --- a/upload-ftp-v1.1.pl +++ b/upload-ftp-v1.1.pl @@ -48,10 +48,10 @@ # 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 it's own directory (with the same name as the package) within +# 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 -# minizes the impact from the compromise of a maintainer's GPG private key. The +# 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: # @@ -96,6 +96,7 @@ use Sys::Syslog qw(:DEFAULT setlogsock); use Getopt::Long; use Text::Wrap; use POSIX qw(strftime); +use Cwd; use Email::MessageID; umask (022); @@ -109,7 +110,7 @@ my $V1_COMPAT_ALLOWED = 1; my $NAME = 'upload-ftp-v1.1.pl'; my $VERSION = '1.1'; # This is the protocol version -my $DATE = '2010/01/26 16:13:29'; +my $DATE = '2010/04/14 12:23:29'; my $AUTHOR = "Free Software Foundation "; my $COPYRIGHT = "2003-2010"; my $LICENSE = "GPLv3 or later - http://www.fsf.org/licenses/gpl.txt"; @@ -141,7 +142,7 @@ my $incoming_dir = "/home/upload/incoming/$m_style"; 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 +$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: @@ -178,10 +179,9 @@ sub main # 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) { + $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: $!"); @@ -196,20 +196,20 @@ sub main # 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 != -1) { - # 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}); - } - } + # 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 $@; @@ -241,13 +241,13 @@ sub usage_information { $retval .= " -d (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"; + $retval .= "Possible styles:\n\n"; + $retval .= " ftp\n"; + $retval .= " alpha\n"; + $retval .= " distros\n"; + $retval .= "\n"; print $retval; - exit; + exit; } sub version_information { @@ -259,12 +259,12 @@ sub version_information { } sub archive { - my ($dir, $subdir, $file) = @_; + 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 + $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"); @@ -303,16 +303,21 @@ sub execute_commands { } elsif ($key =~ /^symlink-(.*)/) { my $target = $1; # Get current working dir - my $cwd = `/bin/pwd`; - $cwd =~ m,^(/[^\.\.]*)$, || &fatal("invalid directory $cwd",1,''); # Just make sure there are no double dots - $cwd = $1; # so far so good, untainted + 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); + 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); @@ -324,17 +329,17 @@ sub execute_commands { 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 + # 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'}) { + # We're running in v1 mode. + if ($originfo{'v1_compat_mode'}) { &check_files($files,%originfo); &install_files($files,%originfo); - } + } } @@ -360,7 +365,7 @@ sub scan_incoming { 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_\+\~]*)$/; + next unless $tainted_ent =~ /^([\w_+][-.\w_+~]*)$/; my $ent = $1; # Don't look at files with really long names, either. @@ -368,7 +373,6 @@ sub scan_incoming { $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; @@ -389,16 +393,16 @@ sub scan_incoming { # my @lsof_args = ("/home/gatekpr/bin/lsof", "-Fn", - map { "$incoming_dir/$_" } keys %possible); + map { "$incoming_dir/$_" } keys %possible); my $pid = open (LSOF, "-|"); - if ($pid) { # parent + if ($pid) { # parent while (defined (my $line = )) { - next unless $line =~ /^n${incoming_dir}\/(.+)$/; # only look at the name lines. - delete ($possible{$1}) || ftp_warn("WARNING: lsof found unrequested but open $1?!"); + 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 + } else { # child exec (@lsof_args) || ftp_die("FATAL: cannot exec lsof: $!"); } @@ -407,8 +411,8 @@ sub scan_incoming { my $base = $ent; my $sig = "$base.sig"; my $directive = "$base.directive.asc"; - my $bare_base = $base; - $bare_base =~ s/\.directive\.asc$//g; + 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 @@ -418,14 +422,14 @@ sub scan_incoming { && (-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]"); + 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); + || &fatal("rename $incoming_dir/$f to $incoming_tmp/$f failed: $!",0); } # don't bother to try any part of this triple again. @@ -434,46 +438,46 @@ sub scan_incoming { 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 () { - 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); - } + # 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 () { + 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); - } + 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; @@ -486,43 +490,43 @@ sub scan_incoming { sub keyring_file { my ($package_name,$directory) = (shift,shift); my @directory = split(/\//,$directory); - my @pubrings = (); + my @pubrings = (); - # First of all, add our 'master' keyring, for people with root to the ftp upload mechanism - push(@pubrings,$master_keyring); + # 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 + # 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") { + 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; + } + my $tmp2 = $tmp; + $tmp2 =~ s/\/[^\/]*$//; + last if ($tmp eq $tmp2); + $tmp = $tmp2; } - return @pubrings; + return @pubrings; } sub email_addresses { - my ($package_name) = @_; - my @ret; + 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); + 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 () { - chomp; + while () { + chomp; my $line = $_; next if (grep($_ eq $line,@ret) > 0); # Skip duplicates - push (@ret, $line) if $line =~ /^[[:graph:]]+@[[:graph:]]+$/; # simple sanity check - } + push (@ret, $line) if $line =~ /^[[:graph:]]+@[[:graph:]]+$/; # simple sanity check + } - close (EMAIL_FILE) || ftp_warn("close($package_config_base/$package_name/email) failed: $!"); - return @ret; + close (EMAIL_FILE) || ftp_warn("close($package_config_base/$package_name/email) failed: $!"); + return @ret; } sub parse_directory_line { @@ -569,12 +573,12 @@ sub read_directive_file { my ($uploaded_file) = shift; my ($directive_only) = shift; - # We default to v1.1 - $info{'v1_compat_mode'} = 0; + # We default to v1.1 + $info{'v1_compat_mode'} = 0; - # For debugging purposes, see below - my $directive_file_contents = ''; - my @lines = (); + # 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: @@ -584,26 +588,26 @@ sub read_directive_file { || ftp_die("FATAL: open($directive_file) failed: $!"); my $cnt = 0; # Keep track of the order of directives... while () { - my $line = $_; - $directive_file_contents .= $line; - push(@lines,$line); - } + 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() { - 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 .*?<(.*?)>/); + # 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() { + 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 @@ -611,8 +615,8 @@ sub read_directive_file { # 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... + 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/); @@ -630,10 +634,10 @@ sub read_directive_file { 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); + 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); + $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. @@ -653,40 +657,40 @@ sub read_directive_file { $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); + $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); + $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); + $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 =~ /^comment:?$/i) { # case-insensitive, w or w/o the : - # Comments are ok, we ignore them + # Comments are ok, we ignore them } else { &fatal("unrecognized directive ($tainted_cmd)",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. - debug($directive_file_contents) if $DEBUG; + # 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. + 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); - } + # 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 @@ -708,16 +712,16 @@ sub read_directive_file { if (!$directive_only) { # We have three files - # Are we in version 1.0 compatibility mode? + # 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; + # 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"); - } + } 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 v1.1! See http://www.gnu.org/prep/maintain/maintain.html",1) @@ -729,7 +733,7 @@ sub read_directive_file { } $filename_required = 0; } - ftp_syslog('info',"($log_style) running in v1.1 mode") if (!$info{'v1_compat_mode'}); + 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"} @@ -741,7 +745,7 @@ sub read_directive_file { if ($filename_required) { # Ben Pfaff wrote: - # First, `gpg -b' doesn't verify that the filename of the signed + # 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 @@ -784,11 +788,11 @@ sub read_directive_file { 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)) { + # 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. @@ -835,10 +839,10 @@ sub read_directive_file { } sub guess_uploader_email { - my $directive_file_contents = shift; + 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); - } + parse_directory_line($1, $directive_file_contents,1); + } } @@ -848,33 +852,39 @@ sub guess_uploader_email { # 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 ($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 =~ /^(.*)$/; + ($verify_str) = $verify_str =~ /^(.*)$/; ftp_syslog('info',"$verify_str\n") if ($DEBUG > 0); - my $retval = `$verify_str`; + my $retval = ''; + open (GPGV, "$verify_str|") + or &fatal("failed to run command: $verify_str",1); + while (defined (my $line = )) { + $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"); + # 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); + } 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); } @@ -897,7 +907,7 @@ sub check_files { 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); + $sig_file, $upload_file); if (!system (@verify_args)) { $valid = 1; last; @@ -936,11 +946,11 @@ sub check_files { 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 + 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 $found_bad and &fatal("upload rejected: $upload_file contains a vulnerable " - . "Makefile.in (CVE-2009-4029);\n" - . "Regenerate it with automake 1.11.1 or newer.",1,'',3); + . "Makefile.in (CVE-2009-4029);\n" + . "Regenerate it with automake 1.11.1 or newer.",1,'',3); } ftp_syslog('debug', "($log_style) DEBUG: tested negative for CVE-2009-4029") if $DEBUG; } @@ -965,23 +975,23 @@ sub install_files { system (@mkdir_args); -d $destdir || &fatal("no directory $destdir",1); - my ($t1, $t2) = (0,0); + my ($t1, $t2) = (0,0); # We now allow overwriting of files - without warning!! - if (-e "$destdir/$sig_file") { - 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") { - 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 ''); + if (-e "$destdir/$sig_file") { + 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") { + 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. @@ -1021,32 +1031,32 @@ sub success_directive { } 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)); - } + 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 - } + 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 + } } } @@ -1063,17 +1073,17 @@ sub cleanup { 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. + # 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"); - } + $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"); + ftp_syslog('err', "($log_style) $tainted_msg"); # Don't let them do perl or shell quoting tricks, but show everything # that's definitely harmless. @@ -1087,12 +1097,12 @@ sub fatal { my $pid = open(PWD, "-|"); my $cwd; - if ($pid) { # parent + if ($pid) { # parent while () { chomp ($cwd = $_); } close (PWD) || ftp_warn("pwd exited $?"); - } else { # child + } else { # child exec ("/bin/pwd") || ftp_die("can't exec pwd: $!"); } ftp_die("(in $cwd) $msg",$exit_code); @@ -1104,37 +1114,37 @@ sub mail { my ($msg) = shift; my ($send_to_user) = shift; my ($subject) = shift; - $subject ||= ''; + $subject ||= ''; my @email_list = ($email_always); - # Some messages should be sent to the user, some should not + # 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 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"); + 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 + 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 # print STDERR "final emails: @email_list\n"; # return @_; if ($NOMAIL) { - if ($subject ne '') { - ftp_syslog('info', "($log_style) Subject: '$subject'"); + if ($subject ne '') { + ftp_syslog('info', "($log_style) Subject: '$subject'"); } elsif (defined $info{package}) { - ftp_syslog('info', "($log_style) Subject: $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('warning', "($log_style) Error uploading package: $msg"); + ftp_syslog('info', "($log_style) Subject: generic failure"); } ftp_syslog('info', "($log_style) Body: $msg"); } else { @@ -1152,16 +1162,16 @@ sub mail { my $mid = Email::MessageID->new; $smtp->datasend("Message-ID: <$mid>\r\n"); $smtp->datasend("Date: " . strftime("%a, %b %e %Y %H:%M:%S %z", localtime) . "\r\n"); - if ($subject ne '') { + if ($subject ne '') { $smtp->datasend ("Subject: [gnu-ftp-upload] $subject"); - ftp_syslog('info', "($log_style) Subject: '$subject'"); + ftp_syslog('info', "($log_style) Subject: '$subject'"); } elsif (defined $info{package}) { $smtp->datasend ("Subject: [gnu-ftp-upload] $info{package}"); - ftp_syslog('info', "($log_style) Subject: $info{package}"); + ftp_syslog('info', "($log_style) Subject: $info{package}"); } else { $smtp->datasend ("Subject: [gnu-ftp-upload] generic failure"); - ftp_syslog('warning', "($log_style) Error uploading package: $msg"); - ftp_syslog('info', "($log_style) Subject: 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"); @@ -1176,7 +1186,7 @@ sub mail { } sub debug { - my $msg = shift; + my $msg = shift; if ($NOMAIL) { ftp_syslog('info', "($log_style) Subject: [$m_style gnu-ftp-debug] new upload processed\nBody: $msg"); @@ -1212,16 +1222,16 @@ sub ftp_die($$) { } 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"; - } + 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"; + } } # Local Variables: -- 2.25.1