From 085cb01f1828d77352dc8a0c2ba51ce588d1f8f2 Mon Sep 17 00:00:00 2001 From: unknown Date: Fri, 6 Apr 2007 14:57:13 -0500 Subject: [PATCH] Import version as of 2007-04-06 for upload-ftp-v1.1.pl --- upload-ftp-v1.1.pl | 114 ++++++++++++++++++++++++++++++--------------- 1 file changed, 77 insertions(+), 37 deletions(-) diff --git a/upload-ftp-v1.1.pl b/upload-ftp-v1.1.pl index 068b1f9..98810cf 100755 --- a/upload-ftp-v1.1.pl +++ b/upload-ftp-v1.1.pl @@ -95,7 +95,7 @@ my $V1_COMPAT_ALLOWED = 1; my $NAME = 'upload-ftp-v1.1.pl'; my $VERSION = '1.1'; # This is the protocol version -my $DATE = '2006/12/04 11:00:44'; +my $DATE = '2007/04/06 15:56:44'; my $AUTHOR = "the Free Software Foundation "; my $COPYRIGHT = "2003-2006"; my $LICENSE = "GPL - http://www.fsf.org/licenses/gpl.txt"; @@ -453,7 +453,6 @@ sub keyring_file { last if ($tmp eq $tmp2); $tmp = $tmp2; } - return @pubrings; } @@ -483,8 +482,7 @@ sub email_addresses { # 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 -{ +sub read_directive_file { my ($directive_file) = shift; my ($uploaded_file) = shift; my ($directive_only) = shift; @@ -509,10 +507,16 @@ sub read_directive_file # For debugging purposes, see below my $directive_file_contents = ''; + my @lines = (); my $cnt = 0; # Keep track of the order of directives... while () { my $line = $_; + $directive_file_contents .= $line; + push(@lines,$line); + } + + 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 @@ -528,22 +532,21 @@ sub read_directive_file # will be escaped before signing a message that contains it next if (!$signed); - $directive_file_contents .= $line; my ($tainted_cmd,$tainted_val) = split(' ',$line,2); if ($tainted_cmd =~ /^Directory:?$/i) { # case-insensitive, w or w/o the : # 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",1); + $tainted_val =~ m,^(\w[-.\w]*(/\w[-.\w]*)*)$, || &fatal("invalid directory $tainted_val",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 /'s is too many, in $val",1) if $slash_count > 3; + &fatal("$slash_count slashes is too many, in $val",1,$directive_file_contents) if $slash_count > 3; # Only let them specify one directory directive. - &fatal("invalid second directory $val, have $info{directory}",1) + &fatal("invalid second directory $val, have $info{directory}",1,$directive_file_contents) if exists $info{"directory"}; $info{"directory"} = $val; # ok. @@ -552,64 +555,84 @@ sub read_directive_file push (@{$info{email}}, email_addresses ($info{package})); } 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); + $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("invalid second filename $val, have $info{filename}",1) + &fatal("invalid second filename $val, have $info{filename}",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); + $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 right now! - &fatal("invalid version $val, not supported",1) if ($val ne '1.1'); + &fatal("invalid version $val, not supported",1,$directive_file_contents) if ($val ne '1.1'); # Only let them specify one version directive. - &fatal("invalid second version $val, have $info{version}",1) if exists $info{"version"}; + &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); + $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) if ($target =~ /\.\./); + &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); + $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) if ($val =~ /\.\./); + &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); + $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) if ($val =~ /\.\./); + &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 } else { - &fatal("unrecognized directive $_",1); + &fatal("unrecognized directive ($tainted_cmd)",1,$directive_file_contents); } } close (DIRECTIVE_FILE) || ftp_warn("close($directive_file) failed: $!"); - # Phone home. E-mail the contents of the directive file to the maintainer, for - # debugging purposes. + # 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. - &fatal("no directory directive specified in $directive_file",1) - if ! $info{"directory"}; + # They have to specify a directory directive. + if (!$info{"directory"}) { + # Now, this is tricky. We don't know whose project this file belongs to, + # because the 'directory:' line is messed up or not there. Ideally we'd + # like to let the uploader know that something went wrong though. So let's + # see if we can match the signature against one of our public keyrings. + my @keyrings; + open(TMP,"/usr/bin/find $package_config_base -name pubring.gpg|"); + while() { + chomp(); + push(@keyrings,$_); + } + close(TMP); + + my $retval = &verify_keyring($directive_file,@keyrings); + push(@{$info{email}},$1) if ($retval =~ /Good signature from .*?<(.*?)>/); + + # Now send the warning to the upload-ftp script maintainer, and the person + # who signed the file, if we know who it is. + &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_COMAT_ALLOWED is true, AND if the only directive is a 'directory'. + # 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 @@ -770,7 +793,10 @@ sub verify_keyring { my $verify_str = join(' ',@verify_args); - my $retval = `$verify_str`; + ($verify_str) = $verify_str =~ /^(.*)$/; + + my $retval = `$verify_str`; + if (!defined($retval)) { # This is bad - we couldn't even execute the gpgv command properly &fatal("gpg verify of directive file failed: $!",1); @@ -924,6 +950,15 @@ 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. + my ($directive_file_contents) = shift; + $directive_file_contents ||= ''; + if (($directive_file_contents ne '') && $DEBUG) { + &mail ($directive_file_contents,0,"debug: directive file contents"); + } + print STDERR "$tainted_msg\n"; # Don't let them do perl or shell quoting tricks, but show everything @@ -932,7 +967,7 @@ sub fatal { $tainted_msg =~ s=[^-.:,/@\w\s]==g; $tainted_msg =~ m=^([-.:,/@\w\s]+)$=; my $msg = $1; - + &mail ($msg,$send_to_user); ftp_syslog('err', "($log_style) $msg"); @@ -941,13 +976,12 @@ sub fatal { my $cwd; if ($pid) { # parent - while () { - chomp ($cwd = $_); - } - close (PWD) || ftp_warn("pwd exited $?"); + while () { + chomp ($cwd = $_); + } + close (PWD) || ftp_warn("pwd exited $?"); } else { # child - exec ("/bin/pwd") - || ftp_die("can't exec pwd: $!"); + exec ("/bin/pwd") || ftp_die("can't exec pwd: $!"); } ftp_die("(in $cwd) $msg"); } @@ -957,16 +991,19 @@ sub fatal { 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); - # print "final emails: @email_list\n"; + # print STDERR "final emails: @email_list\n"; # return @_; 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 (@email_list, { SkipBad => 1}); @@ -974,7 +1011,10 @@ sub mail { $smtp->datasend ("To: " . join (", ", @email_list) . "\n"); $smtp->datasend ("From: ftp-upload-script\@gnu.org\n"); $smtp->datasend ("Reply-To: ftp-upload\@gnu.org\n"); - if (defined $info{package}) { + if ($subject ne '') { + $smtp->datasend ("Subject: [gnu-ftp-upload] $subject"); + ftp_syslog('info', "($log_style) Sending e-mail with subject: '$subject'"); + } elsif (defined $info{package}) { $smtp->datasend ("Subject: [gnu-ftp-upload] $info{package}"); ftp_syslog('info', "($log_style) " . $info{package} . ": $msg"); } else { -- 2.25.1