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.
return @ret;
}
+sub parse_directory_line {
+ my $tainted_val = shift;
+ my $directive_file_contents = 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;
+
+ # 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"};
+
+ $info{"directory"} = $val; # ok.
+ ($info{"package"} = $val) =~ s,/.*$,,; # top-level name, no subdir
+ # Set email addresses
+ push (@{$info{email}}, email_addresses ($info{package}));
+}
\f
# Return the information for this upload out of DIRECTIVE_FILE --
# 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
}
close(TMP);
- my $tmp_retval = &verify_keyring($directive_file,@tmp_keyrings);
+ 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;
# to upload a directive file only to archive/create symlinks/remove symlinks
my $filename_required = 1;
- # 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
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,$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;
-
- # 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"};
-
- $info{"directory"} = $val; # ok.
- ($info{"package"} = $val) =~ s,/.*$,,; # top-level name, no subdir
- # Set email addresses
- push (@{$info{email}}, email_addresses ($info{package}));
+ parse_directory_line($tainted_val, $directive_file_contents);
} 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.
&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. After this point, we don't need to pass the
if ! $info{"version"};
}
- my $retval = &verify_keyring($directive_file,@keyrings);
+ 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
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);
+ }
+}
+
\f
#
# Verify that the signature used for the directive file is valid for
# sub-most directory, until we find one that matches (or not!)
#
sub verify_keyring {
- my ($directive_file, @keyrings) = @_;
+ 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
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: $!",1);
} 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!
}
}
+ guess_uploader_email($directive_file_contents);
&fatal("gpg verify of directive file failed",1);
}
# 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
$smtp->bcc ($email_always) if ($send_to_user);
$smtp->recipient (@email_list, { SkipBad => 1});
- ftp_syslog('info', "($log_style) Sending email to @email_list");
$smtp->data ();
$smtp->datasend ("To: " . join (", ", @email_list) . "\n");
$smtp->datasend ("From: $sender\n");
projects / gatekeeper.git / commitdiff