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 <sysadmin\@gnu.org>";
my $COPYRIGHT = "2003-2006";
my $LICENSE = "GPL - http://www.fsf.org/licenses/gpl.txt";
last if ($tmp eq $tmp2);
$tmp = $tmp2;
}
-
return @pubrings;
}
# 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;
# For debugging purposes, see below
my $directive_file_contents = '';
+ my @lines = ();
my $cnt = 0; # Keep track of the order of directives...
while (<DIRECTIVE_FILE>) {
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
# 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.
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(<TMP>) {
+ 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
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);
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
$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");
my $cwd;
if ($pid) { # parent
- chomp ($cwd = $_);
- }
- close (PWD) || ftp_warn("pwd exited $?");
+ while (<PWD>) {
+ 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");
}
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});
$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 {
projects / gatekeeper.git / commitdiff