# 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:
#
use Getopt::Long;
use Text::Wrap;
use POSIX qw(strftime);
+use Cwd;
use Email::MessageID;
umask (022);
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 <sysadmin\@gnu.org>";
my $COPYRIGHT = "2003-2010";
my $LICENSE = "GPLv3 or later - http://www.fsf.org/licenses/gpl.txt";
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:
# 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: $!");
# 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 $@;
$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";
+ $retval .= "Possible styles:\n\n";
+ $retval .= " ftp\n";
+ $retval .= " alpha\n";
+ $retval .= " distros\n";
+ $retval .= "\n";
print $retval;
- exit;
+ exit;
}
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");
} 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);
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);
- }
+ }
}
\f
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.
$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;
#
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 = <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?!");
+ 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: $!");
}
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
&& (-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.
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);
- }
+ # 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);
- }
+ 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;
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 (<EMAIL_FILE>) {
- chomp;
+ 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
- }
+ 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 {
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:
|| 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);
- }
+ 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 .*?<(.*?)>/);
+ # 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
# 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/);
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.
$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
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)
}
$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"}
if ($filename_required) {
# Ben Pfaff <blp@cs.stanford.edu> 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
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.
}
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);
+ }
}
\f
# 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 = <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");
+ # 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);
}
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;
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;
}
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.
}
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
+ }
}
}
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.
my $pid = open(PWD, "-|");
my $cwd;
- if ($pid) { # parent
+ if ($pid) { # parent
while (<PWD>) {
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);
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 {
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");
}
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");
}
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:
projects / gatekeeper.git / commitdiff