\f
#
-# - Package configuration access
+# - GPG helpers
#
-# Return array of public key files for PACKAGE_NAME.
-#
-sub keyring_file {
- my $package_name = shift;
- my $directory = shift;
+=item $text = slurp_clearsigned_message ( $filename )
- my @directory = split(/\//,$directory);
- my @pubrings = ();
+Read the first PGP-clearsigned message from the file FILENAME and return
+it, complete with all headers and the full signature block.
- # First of all, add our 'master' keyring, for people with root to the ftp
- # upload mechanism
- push(@pubrings,$master_keyring);
+The returned string is tainted.
- # 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") {
- ftp_syslog('debug', "DEBUG: "
- . "found keyring $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;
- }
- return @pubrings;
-}
+=cut
-sub email_addresses {
- my $package_name = shift;
- my @ret;
+sub slurp_clearsigned_message {
+ my $filename = shift;
- open (EMAIL_FILE, "<", "$package_config_base/$package_name/email")
- or fatal(<<"END",1);
-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'. If this is a new GNU package, please ensure that you
-have registered your GPG key for its uploads, per
-http://www.gnu.org/prep/maintain/html_node/Automated-Upload-Registration.html.
+ local *_;
+ my @lines;
-The GPG key must be registered separately for each package, so this needs
-to be done even if you are already registered for uploading with another
-package.
-END
+ # Note that the loops below preserve line endings.
- 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
+ open my $handle, '<', $filename
+ or die "open($filename) failed: $!";
+ # First, we find the PGP signature headers.
+ while (<$handle>) {
+ last if m/^-----BEGIN PGP SIGNED MESSAGE-----\s*\r*\n$/;
+ # RFC4880 allows trailing whitespace on marker lines.
}
-
- close (EMAIL_FILE)
- or ftp_warn("close($package_config_base/$package_name/email) failed: $!");
-
- # Now also look for all maintainer addresses in the maintainers.bypkg file
- open (EMAIL_FILE, "<", "$maintainers_bypkg");
- while (<EMAIL_FILE>) {
- chomp;
- my @tmp = split(/ - /,$_,2);
- next unless ($tmp[0] eq $package_name);
- # The while loop below needs a proper scalar to work.
- my $e = $tmp[1];
- while ($e =~ /([[:graph:]]+@[[:graph:]]+)/g) {
- my $f = $1;
- $f =~ s/[<>,]//g;
- push (@ret, $f) unless exists {map { $_ => 1 } @ret}->{$f};
- }
+ return '' unless defined $_; # no signed message at all?
+ @lines = ($_); # store the header
+ # We are now in the armor headers.
+ while (<$handle>) {
+ push @lines, $_;
+ # According to RFC4880, there must be exactly one empty line to
+ # separate the signed message from the armor headers.
+ last if m/^$/;
}
- close (EMAIL_FILE);
+ # We are now looking at the signed message text and signature.
+ while (<$handle>) {
+ push @lines, $_;
+ last if m/^-----END PGP SIGNATURE-----\s*\r*\n$/;
+ }
+ close $handle
+ or die "close($filename) failed: $!";
- return @ret;
+ return join('', @lines);
}
-\f
-#
-# - Email
-#
+=item $results = verify_clearsigned_message ( $text, @keyrings )
-sub exclude_mail_blacklist {
- my @emaillist = @_;
- my @blacklist = ();
- my @tomail = @emaillist;
- if (-f $email_blacklist) {
- open(BLACKLIST, "<$email_blacklist");
- @blacklist = <BLACKLIST>;
- close(BLACKLIST);
- chomp(@blacklist);
+Verify the PGP-clearsigned message in TEXT, using a key from KEYRINGS. The
+TEXT may be tainted, but the list of KEYRINGS must be untainted.
- my %blacklist = map{$_ => 1 } @blacklist;
- my %emaillist = map{$_ => 1 } @emaillist;
+The message signature should be considered verified iff C<exitcode> is zero
+and C<TILT> is not defined in the returned hashref.
- @tomail = grep(!defined $blacklist{$_}, @emaillist);
- }
+The return value is a hashref containing:
- return @tomail;
-}
+=over
-# Used for both success and failure.
-#
-sub mail {
- my $msg = shift;
- my $send_to_user = shift;
- my $subject = shift;
- $subject ||= '';
+=item TILT
- 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);
+An arrayref of reasons the results should be considered invalid. This key
+will not exist if the verification was successful and trustworthy.
- # If this is an e-mail to the uploader, don't send it to the script
- # maintainer.
- shift(@email_list) if ($send_to_user);
+The presense of this key in the returned hashref indicates that we saw
+something very wrong from gpgv. Note that our handling is fairly paranoid,
+for example, multiple signatures on the input will result in this being
+set, as we assume that gpgv has been somehow subverted if more than one
+verification result is returned.
- 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',
- "No uploader e-mail address(es) to report this error to!");
- @email_list = ($email_always);
- }
- if (NOMAIL) {
- ftp_syslog('info',
- "NOMAIL is set - not sending email to @email_list");
- } else {
- ftp_syslog('info', "Sending email to @email_list");
- }
+=item exitcode
- 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
+The exit status from gpgv. This will be zero if gpgv considers the
+signature valid.
- @email_list = exclude_mail_blacklist(@email_list);
+=item raw_output
- #print STDERR "final emails: @email_list\n";
- # return @_;
+=item raw_log
- if (NOMAIL) {
- if ($subject ne '') {
- ftp_syslog('info', "Subject: '$subject'");
- } elsif (defined $info{package}) {
- ftp_syslog('info', "Subject: $info{package}");
- } else {
- ftp_syslog('warning', "Error uploading package: $msg");
- ftp_syslog('info', "Subject: generic failure");
- }
- ftp_syslog('info', "Body: $msg");
- } else {
- my $smtp;
- if (IN_TEST_MODE) {
- $smtp = Net::SMTP->new
- (Host => 'localhost', Port => $ENV{TEST_SMTP_PORT});
- } else {
- $smtp = Net::SMTP->new ("127.0.0.1");
- }
- ftp_abort("FATAL: SMTP connection failed") unless $smtp;
+=item raw_status
- $smtp->mail($sender);
- $smtp->bcc($email_always) if ($send_to_user);
- $smtp->recipient(@email_list, { SkipBad => 1});
+The complete collected output, log, and status buffers.
- $smtp->data();
- $smtp->datasend("To: " . join (", ", @email_list) . "\r\n");
- $smtp->datasend("From: $sender\r\n");
- $smtp->datasend("Reply-To: ftp-upload\@gnu.org\r\n");
- my $mid = Email::MessageID->new;
- $smtp->datasend("Message-ID: <$mid>\r\n");
- $smtp->datasend("Date: "
- . strftime("%a, %e %b %Y %H:%M:%S %z", localtime)
- . "\r\n");
- if ($subject ne '') {
- $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] $subject");
- ftp_syslog('info', "Subject: '$subject'");
- } elsif (defined $info{package}) {
- $smtp->datasend("Subject: [$m_style gnu-ftp-upload] $info{package}");
- ftp_syslog('info', "Subject: $info{package}");
- } else {
- $smtp->datasend("Subject: [$m_style gnu-ftp-upload] generic failure");
- ftp_syslog('warning', "Error uploading package: $msg");
- ftp_syslog('info', "Subject: generic failure");
- }
- $smtp->datasend ("\n\n");
- ftp_syslog('info', "Body: $msg");
+=item key_longid
- # Wrap message at 78 characters, this is e-mail...
- $Text::Wrap::columns=78;
- $smtp->datasend (wrap('','',$msg) . "\n");
- $smtp->dataend();
+The 64-bit long key ID of the key that signed TEXT, if available.
- $smtp->quit();
- }
-}
+=item key_fingerprint
-sub debug {
- my $msg = shift;
- my $package_name = shift;
+The fingerprint of the PGP key that signed TEXT, if available.
- if (NOMAIL) {
- ftp_syslog('info', "Subject: [$m_style gnu-ftp-debug] "
- ."new upload processed: $package_name\nBody: $msg");
- } else {
- my $smtp;
- if (IN_TEST_MODE) {
- $smtp = Net::SMTP->new
- (Host => 'localhost', Port => $ENV{TEST_SMTP_PORT});
- } else {
- $smtp = Net::SMTP->new ("127.0.0.1");
- }
- ftp_abort("FATAL: SMTP connection failed") unless $smtp;
- $smtp->mail ("ftp-upload-script\@gnu.org");
- $smtp->recipient ($maintainer_email, { SkipBad => 1});
+=item sig_creation
- $smtp->data();
- $smtp->datasend("To: $maintainer_email\n");
- $smtp->datasend("From: ftp-upload-script\@gnu.org\n");
- $smtp->datasend("Reply-To: ftp-upload\@gnu.org\n");
- $smtp->datasend("Subject: [$m_style gnu-ftp-debug] "
- ."new upload processed: $package_name");
- $smtp->datasend("\n\n");
- $smtp->datasend("$msg\n");
- $smtp->dataend();
- $smtp->quit();
- }
-}
+Epoch timestamp of signature.
-# Send email with TAINTED_MSG to the ftp maintainers, as well as any
-# address specified for the package. Rename the bad files with a
-# leading . so we don't try to process them again. Finally, write the
-# same MSG to stderr and exit badly.
-#
-# It's ok that we quit here without processing every file, because we'll
-# be invoked again from cron in a few minutes and will look further then.
-# The bad . files will eventually get cleaned up via a separate script.
-#
-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;
- my $exit_code = shift;
+=item sig_expiration
- $directive_file_contents ||= '';
- if (($directive_file_contents ne '') && DEBUG) {
- mail ($directive_file_contents,0,"debug: directive file contents");
- }
+Epoch timestamp at which the signature expires, if the signature expires.
+This key is only present if the signature has an expiration date.
- ftp_syslog('err', "$tainted_msg");
+=back
- # Don't let them do perl or shell quoting tricks, but show everything
- # that's definitely harmless.
- #
- $tainted_msg =~ s=[^-.:,/@\w\s]==g;
- $tainted_msg =~ m=^([-.:,/@\w\s]+)$=;
- my $msg = $1;
+The C<raw_*> fields in the returned hashref are tainted; the extracted
+values are untainted. The C<TILT> field, if present, is untainted.
- mail ($msg,$send_to_user);
+=cut
- my $pid = open(PWD, "-|");
- my $cwd;
+sub verify_clearsigned_message {
+ my $text = shift;
+ my @keyrings = @_;
- if ($pid) { # parent
- while (<PWD>) {
- chomp ($cwd = $_);
- }
- close (PWD) or ftp_warn("pwd exited $?");
- } else { # child
- exec ("/bin/pwd") or ftp_abort("can't exec pwd: $!");
- }
- ftp_abort("(in $cwd) $msg",$exit_code);
-}
+ ftp_syslog('debug', 'DEBUG: message size is '.length($text)) if DEBUG;
-\f
-#
-# - Directive reader and parsing helpers
-#
+ # We need a few pipes:
+ # - clearsigned message to gpgv stdin
+ # - output from gpgv stdout/stderr
+ # - log from gpgv --logger-fd
+ # - status from gpgv --status-fd
+ # - a flag pipe to indicate successful exec or carry an error
-=item $directive = read_directive ( $handle )
+ # The three output streams from gpgv must be kept separate, or
+ # CVE-2018-12020 "SigSpoof" issues can occur. Worse, the gpgv status
+ # output must be examined with care, as there has been at least one bug
+ # (CVE-2022-34903) whereby GPG could be tricked to emit arbitrary output
+ # on the status pipe.
+ pipe my $gpgv_stdin, my $gpgv_stdin_source
+ or ftp_abort('failed to create pipe for gpgv stdin');
+ pipe my $gpgv_output, my $gpgv_output_sink
+ or ftp_abort('failed to create pipe for gpgv output');
+ pipe my $gpgv_log, my $gpgv_log_sink
+ or ftp_abort('failed to create pipe for gpgv log');
+ pipe my $gpgv_status, my $gpgv_status_sink
+ or ftp_abort('failed to create pipe for gpgv status');
+ pipe my $gpgv_flag, my $gpgv_flag_sink
+ or ftp_abort('failed to create pipe for gpgv flag');
-Read a PGP-clearsigned directive from the provided handle, which must be
-open for reading. The handle is assumed to be positioned at the start of
-the file. This function will search for the PGP header and stop reading at
-the signature.
+ # ensure autoflush on writes to gpgv
+ { my $outhandle = select $gpgv_stdin_source; $| = 1; select $outhandle }
-The return value is an arrayref of key/value arrayrefs representing the
-directive elements in the first PGP-clearsigned message found while reading
-from HANDLE. The values in the returned structure are tainted.
+ my @gpgv_args = ( GPGV_BIN,
+ '--logger-fd', fileno $gpgv_log_sink,
+ '--status-fd', fileno $gpgv_status_sink );
+ push @gpgv_args, '--keyring', $_ for @keyrings;
+ push @gpgv_args, '-';
-=cut
+ ftp_syslog('debug', 'DEBUG: gpgv command line: '.join(' ', @gpgv_args))
+ if DEBUG;
-sub read_directive {
- my $directive = shift;
+ my $pid = fork;
+ ftp_abort('failed to fork child for gpgv')
+ unless defined $pid;
- local *_;
- my @records = ();
+ unless ($pid) {
+ # We are in the child process...
+ close $gpgv_stdin_source;
+ close $gpgv_output; close $gpgv_log;
+ close $gpgv_status; close $gpgv_flag;
- # First, we find the PGP signature header.
- while (<$directive>) {
- chomp; s/\r+$//; # remove line ending, including DOS type
- last if m/^-----BEGIN PGP SIGNED MESSAGE-----\s*$/;
- # RFC4880 allows trailing whitespace on marker lines.
- }
- # We are now in the armor headers.
- while (<$directive>) {
- chomp; s/\r+$//; # remove line ending, including DOS type
- # According to RFC4880, there must be exactly one empty line to
- # separate the signed message from the armor headers.
- last if m/^$/;
+ our $AbortPipe = $gpgv_flag_sink; # pipe to parent
+ our $AbortExitCode = 120; # arbitrary 7-bit exit code
+ # no need to use local here; this process will either exec or abort
+
+ # Adjust close-on-exec flags:
+ my $flags;
+ # - clear on status and log sinks
+ $flags = fcntl $gpgv_status_sink, F_GETFD, 0
+ or ftp_abort("ERR: fcntl F_GETFD on status: $!");
+ fcntl $gpgv_status_sink, F_SETFD, $flags & ~FD_CLOEXEC
+ or ftp_abort("ERR: fcntl F_SETFD on status: $!");
+ $flags = fcntl $gpgv_log_sink, F_GETFD, 0
+ or ftp_abort("ERR: fcntl F_GETFD on log: $!");
+ fcntl $gpgv_log_sink, F_SETFD, $flags & ~FD_CLOEXEC
+ or ftp_abort("ERR: fcntl F_SETFD on log: $!");
+ # - set on flag pipe sink
+ $flags = fcntl $gpgv_flag_sink, F_GETFD, 0
+ or ftp_abort("ERR: fcntl F_GETFD on flag: $!");
+ fcntl $gpgv_flag_sink, F_SETFD, $flags | FD_CLOEXEC
+ or ftp_abort("ERR: fcntl F_SETFD on flag: $!");
+
+ # Prepare STDIN/STDOUT/STDERR
+ open STDIN, '<&', $gpgv_stdin or ftp_abort("ERR: set stdin: $!");
+ open STDOUT, '>&', $gpgv_output_sink or ftp_abort("ERR: set stdout: $!");
+ open STDERR, '>&', $gpgv_output_sink or ftp_abort("ERR: set stderr: $!");
+
+ # Exec gpgv
+ exec { GPGV_BIN } @gpgv_args or ftp_abort("ERR: $!");
}
- # We are now looking at the signed message text.
- while (<$directive>) {
- chomp; s/\r+$//; # remove line ending, including DOS type
- s/^\s+//; s/\s+$//; # trim leading and trailing whitespace
- last if m/^-----BEGIN PGP SIGNATURE-----$/;
+ # The parent continues here...
+ close $gpgv_stdin;
+ close $gpgv_output_sink; close $gpgv_log_sink;
+ close $gpgv_status_sink; close $gpgv_flag_sink;
- unless (/^$/) { # ignore blank lines
- push @records, [split /\s+/,$_,2];
- $records[-1][0] =~ s/\s*:$//; # trim trailing colon on key
+ # This is a bit tricky: we need to know if gpgv could not be run, so we
+ # have an extra pipe that will either report an error or be closed if the
+ # exec succeeds in the child process.
+ while (defined(my $err = <$gpgv_flag>)) {
+ chomp $err;
+ if ($err =~ m/^ERR: (.*)$/) {
+ # This is bad - we couldn't even execute the gpgv command properly
+ guess_uploader_email($text);
+ fatal("gpg verify of directive file failed (error executing gpgv): $1",
+ 0,'',2);
}
}
- # That is all: we have reached the signature and are done.
- return \@records;
-}
+ close $gpgv_flag; # child has closed its end one way or another
-=item $directive = read_directive_from_file ( $filename )
+ foreach my $cell ([$gpgv_stdin_source, 'message'], [$gpgv_output, 'output'],
+ [$gpgv_log, 'log'], [$gpgv_status, 'status']) {
+ my $flags = fcntl $cell->[0], F_GETFL, 0
+ or ftp_abort("gpgv: fcntl F_GETFL $cell->[1]: $!");
+ fcntl $cell->[0], F_SETFL, $flags | O_NONBLOCK
+ or ftp_abort("gpgv: fcntl F_SETFL $cell->[1]: $!");
+ }
-Read a PGP-clearsigned directive file and return an arrayref of key/value
-pair arrayrefs representing the directive elements in the signed portion of
-the file FILENAME. Any text in the file not within the first clearsigned
-message is ignored.
+ local $SIG{PIPE} = sub { ftp_abort('gpgv exited unexpectedly') };
+ my $Rchk = ''; my $Wchk = '';
+ vec($Wchk, (fileno $gpgv_stdin_source), 1) = 1;
+ vec($Rchk, (fileno $_), 1) = 1 for ($gpgv_output, $gpgv_log, $gpgv_status);
+ my $Rrdy = ''; my $Wrdy = '';
+ my $raw_output = ''; my $raw_log = ''; my $raw_status = '';
+ pos $text = 0; # use this slot to store a position because we can
+ do {
+ foreach my $cell ([$gpgv_output, \$raw_output], [$gpgv_log, \$raw_log],
+ [$gpgv_status, \$raw_status]) {
+ if (vec($Rrdy, (fileno $cell->[0]), 1)) {
+ my $eof; # defined and zero at eof
+ 1 while
+ $eof = sysread $cell->[0], ${$cell->[1]}, 128, length ${$cell->[1]};
+ vec($Rchk, (fileno $cell->[0]), 1) = 0 if defined $eof && $eof == 0;
+ }
+ }
-The values returned from this procedure are tainted.
+ if (defined fileno $gpgv_stdin_source
+ && vec($Wrdy, (fileno $gpgv_stdin_source), 1)) {
+ my $err = syswrite $gpgv_stdin_source, $text, 128, pos $text;
+ pos $text += $err if defined $err;
+ unless (pos $text < length $text) {
+ vec($Wchk, (fileno $gpgv_stdin_source), 1) = 0;
+ close $gpgv_stdin_source;
+ }
+ }
-=cut
+ select $Rrdy=$Rchk, $Wrdy=$Wchk, undef, undef
+ if grep vec($Rchk, (fileno $_), 1),
+ $gpgv_output, $gpgv_log, $gpgv_status;
+ } while (grep vec($Rchk, (fileno $_), 1),
+ $gpgv_output, $gpgv_log, $gpgv_status);
-sub read_directive_from_file {
- my $filename = shift;
+ close $gpgv_stdin_source; close $gpgv_output;
+ close $gpgv_log; close $gpgv_status;
+ waitpid $pid, 0; # reap child that ran gpgv
- open my $handle, '<', $filename
- or die "open($filename) failed: $!";
- my $records = read_directive($handle);
- close $handle
- or die "close($filename) failed: $!";
+ # Prepare the return structure
+ my %ret = (exitcode => $?, raw_output => $raw_output,
+ raw_log => $raw_log, raw_status => $raw_status);
- return $records;
-}
+ # Analyze the results
-=item $directive = read_directive_from_string ( $text )
+ # CVE-2022-34903 caused GPG to dump a chunk of its heap to the status fd,
+ # and, eventually, segfault upon reaching unallocated address space.
+ # This had two recognizable consequences:
+ # - The GPG process dies with SIGSEGV.
+ # - The status output very likely contains multiple NUL bytes.
+ push @{$ret{TILT}}, 'gpgv died on signal '.WTERMSIG($ret{exitcode})
+ if WIFSIGNALED($ret{exitcode});
+ for (qw(output log status))
+ { push @{$ret{TILT}}, "gpgv $_ contained NUL byte"
+ if $ret{'raw_'.$_} =~ m/\0/ }
-Read a PGP-clearsigned directive and return an arrayref of key/value pair
-arrayrefs representing the directive elements in the signed portion of the
-provided TEXT. Any text not within the first clearsigned message is
-ignored. This function uses Perl's support for in-memory files.
+ local *_;
+ # counters
+ my $intro_status = 0; my $check_status = 0; my $verdict_status = 0;
-The values returned from this procedure are tainted.
+ open my $status, '<', \$ret{raw_status}
+ or ftp_abort('open in-memory file for gpgv status');
+ while (<$status>) {
+ chomp;
+ unless (m/^\[GNUPG:\] /g) {
+ push @{$ret{TILT}}, "gpgv status line lacks required prefix";
+ last; # stop parsing if an invalid line is found
+ }
-=cut
+ if (m/\GNEWSIG/gc) {
+ $intro_status++; # Note that NEWSIG is optional
+ } elsif (m/\G(GOOD|EXP|EXPKEY|REVKEY|BAD|ERR)SIG ([[:xdigit:]]+) /gc) {
+ # $1 -- result tag $2 -- long ID or fingerprint
+ # The next field is the primary username, except ERRSIG, but there is
+ # no guarantee that the primary UID will contain an email address.
+ if (length($2) > 16) { # We have a key fingerprint
+ $ret{key_fingerprint} = $2;
+ $ret{key_longid} = substr $2,-16;
+ } else { # We only have a long key ID
+ $ret{key_longid} = $2;
+ }
-sub read_directive_from_string {
- my $text = shift;
+ if ($1 eq 'BAD') {
+ $verdict_status++;
+ push @{$ret{TILT}}, 'gpgv reported a bad signature, but exited zero'
+ if 0 == $ret{exitcode};
+ } elsif ($1 eq 'ERR') { # an ERRSIG line
+ $verdict_status++;
+ if (m/\G(\d+)\s(\d+)\s([[:xdigit:]]{2})\s([-:T[:digit:]Z+]+)\s(\d+)
+ /gcx) {
+ # $1 -- pubkey algorithm $2 -- digest algorithm
+ # $3 -- timestamp $4 -- result code
+ ftp_abort('gpgv returned an ISO8601 timestamp; implementation needed')
+ if $3 =~ m/T/;
+ $ret{sig_creation} = $3;
+ } else
+ { push @{$ret{TILT}}, 'gpgv ERRSIG line failed parsing' }
- open my $handle, '<', \$text
- or die "open memory file failed: $!";
- my $records = read_directive($handle);
- close $handle
- or die "close memory file failed: $!";
+ push @{$ret{TILT}}, 'gpgv reported an error, but exited zero'
+ if 0 == $ret{exitcode};
+ } else { # GOODSIG/EXPSIG/EXPKEYSIG/REVKEYSIG
+ $check_status++;
+ }
+ } elsif (m/\G(VALID)SIG\s([[:xdigit:]]+)\s(\d{4}-\d{2}-\d{2})\s
+ ([-:T[:digit:]Z+]+)\s([-:T[:digit:]Z+]+)\s(\d+)\s(\S+)\s
+ (\d+)\s(\d+)\s([[:xdigit:]]{2})\s([[:xdigit:]]+)
+ /gcx) {
+ $verdict_status++;
+ # $1 -- valid tag $2 -- key fingerprint
+ # $3 -- signature date $4 -- signature timestamp
+ # $5 -- expiration timestamp $6 -- signature version
+ # $7 -- reserved $8 -- pubkey algorithm
+ # $9 -- digest algorithm $10 -- signature class
+ # $11 -- primary key fingerprint
+ $ret{key_fingerprint} = $2;
+ $ret{key_longid} = substr $2,-16;
+ ftp_abort('gpgv returned an ISO8601 timestamp; implementation needed')
+ if $4 =~ m/T/ || $5 =~ m/T/;
+ $ret{sig_creation} = $4;
+ # GPG reports 0 if the signature does not expire
+ $ret{sig_expiration} = $5 if $5 > 0;
+ }
+ }
+ close $status or ftp_abort('close in-memory file for gpgv status');
- return $records;
+ push @{$ret{TILT}}, 'gpgv reported more than one signature'
+ if $intro_status > 1;
+ push @{$ret{TILT}}, 'gpgv reported more than one signature check'
+ if $check_status > 1;
+ push @{$ret{TILT}}, 'gpgv reported more than one signature verdict'
+ if $verdict_status > 1;
+ push @{$ret{TILT}}, 'gpgv reported no signature verdict at all'
+ if $verdict_status < 1;
+
+ return \%ret;
}
-=item $text = slurp_clearsigned_message ( $filename )
+\f
+#
+# - Package configuration access
+#
-Read the first PGP-clearsigned message from the file FILENAME and return
-it, complete with all headers and the full signature block.
+# Return array of public key files for PACKAGE_NAME.
+#
+sub keyring_file {
+ my $package_name = shift;
+ my $directory = shift;
-The returned string is tainted.
+ my @directory = split(/\//,$directory);
+ my @pubrings = ();
-=cut
+ # First of all, add our 'master' keyring, for people with root to the ftp
+ # upload mechanism
+ push(@pubrings,$master_keyring);
-sub slurp_clearsigned_message {
- my $filename = shift;
+ # 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") {
+ ftp_syslog('debug', "DEBUG: "
+ . "found keyring $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;
+ }
+ return @pubrings;
+}
- local *_;
- my @lines;
+sub email_addresses {
+ my $package_name = shift;
+ my @ret;
- # Note that the loops below preserve line endings.
+ open (EMAIL_FILE, "<", "$package_config_base/$package_name/email")
+ or fatal(<<"END",1);
+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'. If this is a new GNU package, please ensure that you
+have registered your GPG key for its uploads, per
+http://www.gnu.org/prep/maintain/html_node/Automated-Upload-Registration.html.
- open my $handle, '<', $filename
- or die "open($filename) failed: $!";
- # First, we find the PGP signature headers.
- while (<$handle>) {
- last if m/^-----BEGIN PGP SIGNED MESSAGE-----\s*\r*\n$/;
- # RFC4880 allows trailing whitespace on marker lines.
- }
- return '' unless defined $_; # no signed message at all?
- @lines = ($_); # store the header
- # We are now in the armor headers.
- while (<$handle>) {
- push @lines, $_;
- # According to RFC4880, there must be exactly one empty line to
- # separate the signed message from the armor headers.
- last if m/^$/;
+The GPG key must be registered separately for each package, so this needs
+to be done even if you are already registered for uploading with another
+package.
+END
+
+ 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
}
- # We are now looking at the signed message text and signature.
- while (<$handle>) {
- push @lines, $_;
- last if m/^-----END PGP SIGNATURE-----\s*\r*\n$/;
+
+ close (EMAIL_FILE)
+ or ftp_warn("close($package_config_base/$package_name/email) failed: $!");
+
+ # Now also look for all maintainer addresses in the maintainers.bypkg file
+ open (EMAIL_FILE, "<", "$maintainers_bypkg");
+ while (<EMAIL_FILE>) {
+ chomp;
+ my @tmp = split(/ - /,$_,2);
+ next unless ($tmp[0] eq $package_name);
+ # The while loop below needs a proper scalar to work.
+ my $e = $tmp[1];
+ while ($e =~ /([[:graph:]]+@[[:graph:]]+)/g) {
+ my $f = $1;
+ $f =~ s/[<>,]//g;
+ push (@ret, $f) unless exists {map { $_ => 1 } @ret}->{$f};
+ }
}
- close $handle
- or die "close($filename) failed: $!";
+ close (EMAIL_FILE);
- return join('', @lines);
+ return @ret;
}
-=item @values = find_directive_elements ( $directive, $key )
-
-Search the DIRECTIVE arrayref for KEY elements and return their associated
-values. An empty list is returned if no KEY elements are found in
-DIRECTIVE. The KEY comparison is case-insensitive.
+\f
+#
+# - Email
+#
-The values returned from this procedure are tainted.
+sub exclude_mail_blacklist {
+ my @emaillist = @_;
+ my @blacklist = ();
+ my @tomail = @emaillist;
+ if (-f $email_blacklist) {
+ open(BLACKLIST, "<$email_blacklist");
+ @blacklist = <BLACKLIST>;
+ close(BLACKLIST);
+ chomp(@blacklist);
-=cut
+ my %blacklist = map{$_ => 1 } @blacklist;
+ my %emaillist = map{$_ => 1 } @emaillist;
-sub find_directive_elements {
- my $directive = shift;
- my $key = lc shift;
+ @tomail = grep(!defined $blacklist{$_}, @emaillist);
+ }
- return map $_->[1], grep lc($_->[0]) eq $key, @$directive;
+ return @tomail;
}
-=item $directory = find_directory ( $directive )
+# Used for both success and failure.
+#
+sub mail {
+ my $msg = shift;
+ my $send_to_user = shift;
+ my $subject = shift;
+ $subject ||= '';
-Extract the destination directory name from the parsed DIRECTIVE arrayref.
-An exception is thrown if DIRECTIVE does not contain exactly one
-"directory" element or if the value of that element is not acceptable.
+ 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);
-The value returned from this procedure is untainted.
+ # If this is an e-mail to the uploader, don't send it to the script
+ # maintainer.
+ shift(@email_list) if ($send_to_user);
-=cut
+ 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',
+ "No uploader e-mail address(es) to report this error to!");
+ @email_list = ($email_always);
+ }
+ if (NOMAIL) {
+ ftp_syslog('info',
+ "NOMAIL is set - not sending email to @email_list");
+ } else {
+ ftp_syslog('info', "Sending email to @email_list");
+ }
-sub find_directory {
- my $directive = shift;
+ 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 @values = find_directive_elements($directive, 'directory');
+ @email_list = exclude_mail_blacklist(@email_list);
- die "Only one directory directive is allowed per directive file."
- if scalar @values > 1;
- die "no directory directive specified"
- unless @values;
+ #print STDERR "final emails: @email_list\n";
+ # return @_;
- die "invalid directory $values[0]"
- unless $values[0] =~ m/^($RE_filename_relative)$/;
+ if (NOMAIL) {
+ if ($subject ne '') {
+ ftp_syslog('info', "Subject: '$subject'");
+ } elsif (defined $info{package}) {
+ ftp_syslog('info', "Subject: $info{package}");
+ } else {
+ ftp_syslog('warning', "Error uploading package: $msg");
+ ftp_syslog('info', "Subject: generic failure");
+ }
+ ftp_syslog('info', "Body: $msg");
+ } else {
+ my $smtp;
+ if (IN_TEST_MODE) {
+ $smtp = Net::SMTP->new
+ (Host => 'localhost', Port => $ENV{TEST_SMTP_PORT});
+ } else {
+ $smtp = Net::SMTP->new ("127.0.0.1");
+ }
+ ftp_abort("FATAL: SMTP connection failed") unless $smtp;
- return $values[0];
-}
+ $smtp->mail($sender);
+ $smtp->bcc($email_always) if ($send_to_user);
+ $smtp->recipient(@email_list, { SkipBad => 1});
-=item $package = find_package ( $directive )
+ $smtp->data();
+ $smtp->datasend("To: " . join (", ", @email_list) . "\r\n");
+ $smtp->datasend("From: $sender\r\n");
+ $smtp->datasend("Reply-To: ftp-upload\@gnu.org\r\n");
+ my $mid = Email::MessageID->new;
+ $smtp->datasend("Message-ID: <$mid>\r\n");
+ $smtp->datasend("Date: "
+ . strftime("%a, %e %b %Y %H:%M:%S %z", localtime)
+ . "\r\n");
+ if ($subject ne '') {
+ $smtp->datasend ("Subject: [$m_style gnu-ftp-upload] $subject");
+ ftp_syslog('info', "Subject: '$subject'");
+ } elsif (defined $info{package}) {
+ $smtp->datasend("Subject: [$m_style gnu-ftp-upload] $info{package}");
+ ftp_syslog('info', "Subject: $info{package}");
+ } else {
+ $smtp->datasend("Subject: [$m_style gnu-ftp-upload] generic failure");
+ ftp_syslog('warning', "Error uploading package: $msg");
+ ftp_syslog('info', "Subject: generic failure");
+ }
+ $smtp->datasend ("\n\n");
+ ftp_syslog('info', "Body: $msg");
-Extract the package name from the parsed DIRECTIVE arrayref. An exception
-is thrown if DIRECTIVE does not contain exactly one "directory" element or
-if the value of that element is not a relative file name.
+ # Wrap message at 78 characters, this is e-mail...
+ $Text::Wrap::columns=78;
+ $smtp->datasend (wrap('','',$msg) . "\n");
+ $smtp->dataend();
-The value returned from this procedure is untainted.
+ $smtp->quit();
+ }
+}
-=cut
+sub debug {
+ my $msg = shift;
+ my $package_name = shift;
-sub find_package {
- # The package name is the first directory named in the directory element.
- my @dirs = File::Spec::Unix->splitdir(find_directory(@_));
- return $dirs[0];
+ if (NOMAIL) {
+ ftp_syslog('info', "Subject: [$m_style gnu-ftp-debug] "
+ ."new upload processed: $package_name\nBody: $msg");
+ } else {
+ my $smtp;
+ if (IN_TEST_MODE) {
+ $smtp = Net::SMTP->new
+ (Host => 'localhost', Port => $ENV{TEST_SMTP_PORT});
+ } else {
+ $smtp = Net::SMTP->new ("127.0.0.1");
+ }
+ ftp_abort("FATAL: SMTP connection failed") unless $smtp;
+ $smtp->mail ("ftp-upload-script\@gnu.org");
+ $smtp->recipient ($maintainer_email, { SkipBad => 1});
+
+ $smtp->data();
+ $smtp->datasend("To: $maintainer_email\n");
+ $smtp->datasend("From: ftp-upload-script\@gnu.org\n");
+ $smtp->datasend("Reply-To: ftp-upload\@gnu.org\n");
+ $smtp->datasend("Subject: [$m_style gnu-ftp-debug] "
+ ."new upload processed: $package_name");
+ $smtp->datasend("\n\n");
+ $smtp->datasend("$msg\n");
+ $smtp->dataend();
+ $smtp->quit();
+ }
}
-\f
+# Send email with TAINTED_MSG to the ftp maintainers, as well as any
+# address specified for the package. Rename the bad files with a
+# leading . so we don't try to process them again. Finally, write the
+# same MSG to stderr and exit badly.
#
-# - [SC] Scan for incoming packets
+# It's ok that we quit here without processing every file, because we'll
+# be invoked again from cron in a few minutes and will look further then.
+# The bad . files will eventually get cleaned up via a separate script.
#
+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;
+ my $exit_code = shift;
-# Read the ftp incoming dir (which is assumed to be the current
-# directory), looking for completed upload triples (the three files
-# described at the beginning). Ignore if we don't have all three files,
-# or if any of the files are still open, or if the filenames are dubious
-# -- things'll get cleaned up as needed separately.
+ $directive_file_contents ||= '';
+ if (($directive_file_contents ne '') && DEBUG) {
+ mail ($directive_file_contents,0,"debug: directive file contents");
+ }
+
+ ftp_syslog('err', "$tainted_msg");
+
+ # Don't let them do perl or shell quoting tricks, but show everything
+ # that's definitely harmless.
+ #
+ $tainted_msg =~ s=[^-.:,/@\w\s]==g;
+ $tainted_msg =~ m=^([-.:,/@\w\s]+)$=;
+ my $msg = $1;
+
+ mail ($msg,$send_to_user);
+
+ my $pid = open(PWD, "-|");
+ my $cwd;
+
+ if ($pid) { # parent
+ while (<PWD>) {
+ chomp ($cwd = $_);
+ }
+ close (PWD) or ftp_warn("pwd exited $?");
+ } else { # child
+ exec ("/bin/pwd") or ftp_abort("can't exec pwd: $!");
+ }
+ ftp_abort("(in $cwd) $msg",$exit_code);
+}
+
+\f
#
-# If we accept a triplet, we rename the files into a temporary
-# directory. This is to avoid attackers overwriting files as or after
-# we check them. This is redundant protection -- the ftp config on
-# ftp.gnu.org does not allow overwrites or deletes.
+# - Directive reader and parsing helpers
#
-=item @files = scan_incoming ( $directory )
+=item $directive = read_directive ( $handle )
-Scan DIRECTORY for newly-arrived uploaded files. Remove blatantly bogus
-files, ignore acceptable files that are either still open or recently
-modified, and return a list of filenames for further processing.
+Read a PGP-clearsigned directive from the provided handle, which must be
+open for reading. The handle is assumed to be positioned at the start of
+the file. This function will search for the PGP header and stop reading at
+the signature.
+
+The return value is an arrayref of key/value arrayrefs representing the
+directive elements in the first PGP-clearsigned message found while reading
+from HANDLE. The values in the returned structure are tainted.
=cut
-sub scan_incoming {
- my $directory = shift;
+sub read_directive {
+ my $directive = shift;
local *_;
+ my @records = ();
- my $time_bar = time - 120;
- my @trash; my $badname_count = 0;
- my %possible;
- # Get list of all possible files from incoming dir.
- #
- opendir INCOMING, $directory
- or ftp_abort("FATAL opendir($directory) failed: $!");
- ENT: while (defined($_ = readdir INCOMING)) {
- next ENT if m/^[.]{1,2}$/; # skip . and .. entries
- # require acceptable filenames
- unless (length($_) <= MAX_FILE_NAME_LEN && /^($RE_filename_here)$/) {
- m/^(.*)$/; # untaint the value
- push @trash, File::Spec->catfile($directory, $1); $badname_count++;
- # This is safe for unlink (which is all we will do with @trash)
- # because the filename came from a directory entry, so it must be a
- # valid filename and cannot indicate directory traversal.
- next ENT
- }
- my $ent = $1; # if we get here, $RE_filename_here matched above
- # $_ remains tainted, but $ent is an untainted (and safe) copy
+ # First, we find the PGP signature header.
+ while (<$directive>) {
+ chomp; s/\r+$//; # remove line ending, including DOS type
+ last if m/^-----BEGIN PGP SIGNED MESSAGE-----\s*$/;
+ # RFC4880 allows trailing whitespace on marker lines.
+ }
+ # We are now in the armor headers.
+ while (<$directive>) {
+ chomp; s/\r+$//; # remove line ending, including DOS type
+ # According to RFC4880, there must be exactly one empty line to
+ # separate the signed message from the armor headers.
+ last if m/^$/;
+ }
+ # We are now looking at the signed message text.
+ while (<$directive>) {
+ chomp; s/\r+$//; # remove line ending, including DOS type
+ s/^\s+//; s/\s+$//; # trim leading and trailing whitespace
- # Examine the file; this populates an internal cache in perl.
- unless (stat(File::Spec->catfile($directory, $ent))) {
- ftp_syslog('warning', "could not stat($ent), skipping");
- next ENT
- }
+ last if m/^-----BEGIN PGP SIGNATURE-----$/;
- # Do not consider files that have been modified in the last 2 minutes.
- # This is an extra safety check to avoid trying to process files that
- # are still being uploaded. (use stat cache)
- if (TSTAMPCHECK) {
- if ((stat(_))[9] >= $time_bar) {
- ftp_syslog('debug', "DEBUG: "
- ."$ent has been modified in the last 2 minutes, skipping")
- if DEBUG;
- next ENT
- }
+ unless (/^$/) { # ignore blank lines
+ push @records, [split /\s+/,$_,2];
+ $records[-1][0] =~ s/\s*:$//; # trim trailing colon on key
}
+ }
+ # That is all: we have reached the signature and are done.
+ return \@records;
+}
- # check for overlength directives and signatures (use stat cache)
- if (/[.]directive[.]asc$/ && -f _ && ((-s _) >= MAX_DIRECTIVE_SIZE)) {
- ftp_syslog('info', "Overlength directive file ($ent) trashcanned");
- push @trash, File::Spec->catfile($directory, $ent);
- next ENT
- } elsif (/[.]sig$/ && -f _ && ((-s _) >= MAX_SIGNATURE_SIZE)) {
- ftp_syslog('info', "Overlength signature file ($ent) trashcanned");
- push @trash, File::Spec->catfile($directory, $ent);
- next ENT
- }
+=item $directive = read_directive_from_file ( $filename )
- ftp_syslog('debug', "DEBUG: uploaded file to check: $ent") if DEBUG;
- $possible{$ent} = 1;
- }
- closedir INCOMING
- or ftp_abort("FATAL: closedir($directory) failed: $!");
+Read a PGP-clearsigned directive file and return an arrayref of key/value
+pair arrayrefs representing the directive elements in the signed portion of
+the file FILENAME. Any text in the file not within the first clearsigned
+message is ignored.
- # dispose of any garbage files
- ftp_syslog('info', "$badname_count files with bogus names were trashcanned")
+The values returned from this procedure are tainted.
+
+=cut
+
+sub read_directive_from_file {
+ my $filename = shift;
+
+ open my $handle, '<', $filename
+ or die "open($filename) failed: $!";
+ my $records = read_directive($handle);
+ close $handle
+ or die "close($filename) failed: $!";
+
+ return $records;
+}
+
+=item $directive = read_directive_from_string ( $text )
+
+Read a PGP-clearsigned directive and return an arrayref of key/value pair
+arrayrefs representing the directive elements in the signed portion of the
+provided TEXT. Any text not within the first clearsigned message is
+ignored. This function uses Perl's support for in-memory files.
+
+The values returned from this procedure are tainted.
+
+=cut
+
+sub read_directive_from_string {
+ my $text = shift;
+
+ open my $handle, '<', \$text
+ or die "open memory file failed: $!";
+ my $records = read_directive($handle);
+ close $handle
+ or die "close memory file failed: $!";
+
+ return $records;
+}
+
+=item @values = find_directive_elements ( $directive, $key )
+
+Search the DIRECTIVE arrayref for KEY elements and return their associated
+values. An empty list is returned if no KEY elements are found in
+DIRECTIVE. The KEY comparison is case-insensitive.
+
+The values returned from this procedure are tainted.
+
+=cut
+
+sub find_directive_elements {
+ my $directive = shift;
+ my $key = lc shift;
+
+ return map $_->[1], grep lc($_->[0]) eq $key, @$directive;
+}
+
+=item $directory = find_directory ( $directive )
+
+Extract the destination directory name from the parsed DIRECTIVE arrayref.
+An exception is thrown if DIRECTIVE does not contain exactly one
+"directory" element or if the value of that element is not acceptable.
+
+The value returned from this procedure is untainted.
+
+=cut
+
+sub find_directory {
+ my $directive = shift;
+
+ my @values = find_directive_elements($directive, 'directory');
+
+ die "Only one directory directive is allowed per directive file."
+ if scalar @values > 1;
+ die "no directory directive specified"
+ unless @values;
+
+ die "invalid directory $values[0]"
+ unless $values[0] =~ m/^($RE_filename_relative)$/;
+
+ return $values[0];
+}
+
+=item $package = find_package ( $directive )
+
+Extract the package name from the parsed DIRECTIVE arrayref. An exception
+is thrown if DIRECTIVE does not contain exactly one "directory" element or
+if the value of that element is not a relative file name.
+
+The value returned from this procedure is untainted.
+
+=cut
+
+sub find_package {
+ # The package name is the first directory named in the directory element.
+ my @dirs = File::Spec::Unix->splitdir(find_directory(@_));
+ return $dirs[0];
+}
+
+\f
+#
+# - [SC] Scan for incoming packets
+#
+
+# Read the ftp incoming dir (which is assumed to be the current
+# directory), looking for completed upload triples (the three files
+# described at the beginning). Ignore if we don't have all three files,
+# or if any of the files are still open, or if the filenames are dubious
+# -- things'll get cleaned up as needed separately.
+#
+# If we accept a triplet, we rename the files into a temporary
+# directory. This is to avoid attackers overwriting files as or after
+# we check them. This is redundant protection -- the ftp config on
+# ftp.gnu.org does not allow overwrites or deletes.
+#
+
+=item @files = scan_incoming ( $directory )
+
+Scan DIRECTORY for newly-arrived uploaded files. Remove blatantly bogus
+files, ignore acceptable files that are either still open or recently
+modified, and return a list of filenames for further processing.
+
+=cut
+
+sub scan_incoming {
+ my $directory = shift;
+
+ local *_;
+
+ my $time_bar = time - 120;
+ my @trash; my $badname_count = 0;
+ my %possible;
+ # Get list of all possible files from incoming dir.
+ #
+ opendir INCOMING, $directory
+ or ftp_abort("FATAL opendir($directory) failed: $!");
+ ENT: while (defined($_ = readdir INCOMING)) {
+ next ENT if m/^[.]{1,2}$/; # skip . and .. entries
+ # require acceptable filenames
+ unless (length($_) <= MAX_FILE_NAME_LEN && /^($RE_filename_here)$/) {
+ m/^(.*)$/; # untaint the value
+ push @trash, File::Spec->catfile($directory, $1); $badname_count++;
+ # This is safe for unlink (which is all we will do with @trash)
+ # because the filename came from a directory entry, so it must be a
+ # valid filename and cannot indicate directory traversal.
+ next ENT
+ }
+ my $ent = $1; # if we get here, $RE_filename_here matched above
+ # $_ remains tainted, but $ent is an untainted (and safe) copy
+
+ # Examine the file; this populates an internal cache in perl.
+ unless (stat(File::Spec->catfile($directory, $ent))) {
+ ftp_syslog('warning', "could not stat($ent), skipping");
+ next ENT
+ }
+
+ # Do not consider files that have been modified in the last 2 minutes.
+ # This is an extra safety check to avoid trying to process files that
+ # are still being uploaded. (use stat cache)
+ if (TSTAMPCHECK) {
+ if ((stat(_))[9] >= $time_bar) {
+ ftp_syslog('debug', "DEBUG: "
+ ."$ent has been modified in the last 2 minutes, skipping")
+ if DEBUG;
+ next ENT
+ }
+ }
+
+ # check for overlength directives and signatures (use stat cache)
+ if (/[.]directive[.]asc$/ && -f _ && ((-s _) >= MAX_DIRECTIVE_SIZE)) {
+ ftp_syslog('info', "Overlength directive file ($ent) trashcanned");
+ push @trash, File::Spec->catfile($directory, $ent);
+ next ENT
+ } elsif (/[.]sig$/ && -f _ && ((-s _) >= MAX_SIGNATURE_SIZE)) {
+ ftp_syslog('info', "Overlength signature file ($ent) trashcanned");
+ push @trash, File::Spec->catfile($directory, $ent);
+ next ENT
+ }
+
+ ftp_syslog('debug', "DEBUG: uploaded file to check: $ent") if DEBUG;
+ $possible{$ent} = 1;
+ }
+ closedir INCOMING
+ or ftp_abort("FATAL: closedir($directory) failed: $!");
+
+ # dispose of any garbage files
+ ftp_syslog('info', "$badname_count files with bogus names were trashcanned")
if $badname_count;
ftp_syslog('info', "Trashcanned files removed")
if unlink @trash;
}
}
-=item $results = verify_clearsigned_message ( $text, @keyrings )
-
-Verify the PGP-clearsigned message in TEXT, using a key from KEYRINGS. The
-TEXT may be tainted, but the list of KEYRINGS must be untainted.
-
-The message signature should be considered verified iff C<exitcode> is zero
-and C<TILT> is not defined in the returned hashref.
-
-The return value is a hashref containing:
-
-=over
-
-=item TILT
-
-An arrayref of reasons the results should be considered invalid. This key
-will not exist if the verification was successful and trustworthy.
-
-The presense of this key in the returned hashref indicates that we saw
-something very wrong from gpgv. Note that our handling is fairly paranoid,
-for example, multiple signatures on the input will result in this being
-set, as we assume that gpgv has been somehow subverted if more than one
-verification result is returned.
-
-=item exitcode
-
-The exit status from gpgv. This will be zero if gpgv considers the
-signature valid.
-
-=item raw_output
-
-=item raw_log
-
-=item raw_status
-
-The complete collected output, log, and status buffers.
-
-=item key_longid
-
-The 64-bit long key ID of the key that signed TEXT, if available.
-
-=item key_fingerprint
-
-The fingerprint of the PGP key that signed TEXT, if available.
-
-=item sig_creation
-
-Epoch timestamp of signature.
-
-=item sig_expiration
-
-Epoch timestamp at which the signature expires, if the signature expires.
-This key is only present if the signature has an expiration date.
-
-
-=back
-
-The C<raw_*> fields in the returned hashref are tainted; the extracted
-values are untainted. The C<TILT> field, if present, is untainted.
-
-=cut
-
-sub verify_clearsigned_message {
- my $text = shift;
- my @keyrings = @_;
-
- ftp_syslog('debug', 'DEBUG: message size is '.length($text)) if DEBUG;
-
- # We need a few pipes:
- # - clearsigned message to gpgv stdin
- # - output from gpgv stdout/stderr
- # - log from gpgv --logger-fd
- # - status from gpgv --status-fd
- # - a flag pipe to indicate successful exec or carry an error
-
- # The three output streams from gpgv must be kept separate, or
- # CVE-2018-12020 "SigSpoof" issues can occur. Worse, the gpgv status
- # output must be examined with care, as there has been at least one bug
- # (CVE-2022-34903) whereby GPG could be tricked to emit arbitrary output
- # on the status pipe.
- pipe my $gpgv_stdin, my $gpgv_stdin_source
- or ftp_abort('failed to create pipe for gpgv stdin');
- pipe my $gpgv_output, my $gpgv_output_sink
- or ftp_abort('failed to create pipe for gpgv output');
- pipe my $gpgv_log, my $gpgv_log_sink
- or ftp_abort('failed to create pipe for gpgv log');
- pipe my $gpgv_status, my $gpgv_status_sink
- or ftp_abort('failed to create pipe for gpgv status');
- pipe my $gpgv_flag, my $gpgv_flag_sink
- or ftp_abort('failed to create pipe for gpgv flag');
-
- # ensure autoflush on writes to gpgv
- { my $outhandle = select $gpgv_stdin_source; $| = 1; select $outhandle }
-
- my @gpgv_args = ( GPGV_BIN,
- '--logger-fd', fileno $gpgv_log_sink,
- '--status-fd', fileno $gpgv_status_sink );
- push @gpgv_args, '--keyring', $_ for @keyrings;
- push @gpgv_args, '-';
-
- ftp_syslog('debug', 'DEBUG: gpgv command line: '.join(' ', @gpgv_args))
- if DEBUG;
-
- my $pid = fork;
- ftp_abort('failed to fork child for gpgv')
- unless defined $pid;
-
- unless ($pid) {
- # We are in the child process...
- close $gpgv_stdin_source;
- close $gpgv_output; close $gpgv_log;
- close $gpgv_status; close $gpgv_flag;
-
- our $AbortPipe = $gpgv_flag_sink; # pipe to parent
- our $AbortExitCode = 120; # arbitrary 7-bit exit code
- # no need to use local here; this process will either exec or abort
-
- # Adjust close-on-exec flags:
- my $flags;
- # - clear on status and log sinks
- $flags = fcntl $gpgv_status_sink, F_GETFD, 0
- or ftp_abort("ERR: fcntl F_GETFD on status: $!");
- fcntl $gpgv_status_sink, F_SETFD, $flags & ~FD_CLOEXEC
- or ftp_abort("ERR: fcntl F_SETFD on status: $!");
- $flags = fcntl $gpgv_log_sink, F_GETFD, 0
- or ftp_abort("ERR: fcntl F_GETFD on log: $!");
- fcntl $gpgv_log_sink, F_SETFD, $flags & ~FD_CLOEXEC
- or ftp_abort("ERR: fcntl F_SETFD on log: $!");
- # - set on flag pipe sink
- $flags = fcntl $gpgv_flag_sink, F_GETFD, 0
- or ftp_abort("ERR: fcntl F_GETFD on flag: $!");
- fcntl $gpgv_flag_sink, F_SETFD, $flags | FD_CLOEXEC
- or ftp_abort("ERR: fcntl F_SETFD on flag: $!");
-
- # Prepare STDIN/STDOUT/STDERR
- open STDIN, '<&', $gpgv_stdin or ftp_abort("ERR: set stdin: $!");
- open STDOUT, '>&', $gpgv_output_sink or ftp_abort("ERR: set stdout: $!");
- open STDERR, '>&', $gpgv_output_sink or ftp_abort("ERR: set stderr: $!");
-
- # Exec gpgv
- exec { GPGV_BIN } @gpgv_args or ftp_abort("ERR: $!");
- }
-
- # The parent continues here...
- close $gpgv_stdin;
- close $gpgv_output_sink; close $gpgv_log_sink;
- close $gpgv_status_sink; close $gpgv_flag_sink;
-
- # This is a bit tricky: we need to know if gpgv could not be run, so we
- # have an extra pipe that will either report an error or be closed if the
- # exec succeeds in the child process.
- while (defined(my $err = <$gpgv_flag>)) {
- chomp $err;
- if ($err =~ m/^ERR: (.*)$/) {
- # This is bad - we couldn't even execute the gpgv command properly
- guess_uploader_email($text);
- fatal("gpg verify of directive file failed (error executing gpgv): $1",
- 0,'',2);
- }
- }
- close $gpgv_flag; # child has closed its end one way or another
-
- foreach my $cell ([$gpgv_stdin_source, 'message'], [$gpgv_output, 'output'],
- [$gpgv_log, 'log'], [$gpgv_status, 'status']) {
- my $flags = fcntl $cell->[0], F_GETFL, 0
- or ftp_abort("gpgv: fcntl F_GETFL $cell->[1]: $!");
- fcntl $cell->[0], F_SETFL, $flags | O_NONBLOCK
- or ftp_abort("gpgv: fcntl F_SETFL $cell->[1]: $!");
- }
-
- local $SIG{PIPE} = sub { ftp_abort('gpgv exited unexpectedly') };
- my $Rchk = ''; my $Wchk = '';
- vec($Wchk, (fileno $gpgv_stdin_source), 1) = 1;
- vec($Rchk, (fileno $_), 1) = 1 for ($gpgv_output, $gpgv_log, $gpgv_status);
- my $Rrdy = ''; my $Wrdy = '';
- my $raw_output = ''; my $raw_log = ''; my $raw_status = '';
- pos $text = 0; # use this slot to store a position because we can
- do {
- foreach my $cell ([$gpgv_output, \$raw_output], [$gpgv_log, \$raw_log],
- [$gpgv_status, \$raw_status]) {
- if (vec($Rrdy, (fileno $cell->[0]), 1)) {
- my $eof; # defined and zero at eof
- 1 while
- $eof = sysread $cell->[0], ${$cell->[1]}, 128, length ${$cell->[1]};
- vec($Rchk, (fileno $cell->[0]), 1) = 0 if defined $eof && $eof == 0;
- }
- }
-
- if (defined fileno $gpgv_stdin_source
- && vec($Wrdy, (fileno $gpgv_stdin_source), 1)) {
- my $err = syswrite $gpgv_stdin_source, $text, 128, pos $text;
- pos $text += $err if defined $err;
- unless (pos $text < length $text) {
- vec($Wchk, (fileno $gpgv_stdin_source), 1) = 0;
- close $gpgv_stdin_source;
- }
- }
-
- select $Rrdy=$Rchk, $Wrdy=$Wchk, undef, undef
- if grep vec($Rchk, (fileno $_), 1),
- $gpgv_output, $gpgv_log, $gpgv_status;
- } while (grep vec($Rchk, (fileno $_), 1),
- $gpgv_output, $gpgv_log, $gpgv_status);
-
- close $gpgv_stdin_source; close $gpgv_output;
- close $gpgv_log; close $gpgv_status;
- waitpid $pid, 0; # reap child that ran gpgv
-
- # Prepare the return structure
- my %ret = (exitcode => $?, raw_output => $raw_output,
- raw_log => $raw_log, raw_status => $raw_status);
-
- # Analyze the results
-
- # CVE-2022-34903 caused GPG to dump a chunk of its heap to the status fd,
- # and, eventually, segfault upon reaching unallocated address space.
- # This had two recognizable consequences:
- # - The GPG process dies with SIGSEGV.
- # - The status output very likely contains multiple NUL bytes.
- push @{$ret{TILT}}, 'gpgv died on signal '.WTERMSIG($ret{exitcode})
- if WIFSIGNALED($ret{exitcode});
- for (qw(output log status))
- { push @{$ret{TILT}}, "gpgv $_ contained NUL byte"
- if $ret{'raw_'.$_} =~ m/\0/ }
-
- local *_;
- # counters
- my $intro_status = 0; my $check_status = 0; my $verdict_status = 0;
-
- open my $status, '<', \$ret{raw_status}
- or ftp_abort('open in-memory file for gpgv status');
- while (<$status>) {
- chomp;
- unless (m/^\[GNUPG:\] /g) {
- push @{$ret{TILT}}, "gpgv status line lacks required prefix";
- last; # stop parsing if an invalid line is found
- }
-
- if (m/\GNEWSIG/gc) {
- $intro_status++; # Note that NEWSIG is optional
- } elsif (m/\G(GOOD|EXP|EXPKEY|REVKEY|BAD|ERR)SIG ([[:xdigit:]]+) /gc) {
- # $1 -- result tag $2 -- long ID or fingerprint
- # The next field is the primary username, except ERRSIG, but there is
- # no guarantee that the primary UID will contain an email address.
- if (length($2) > 16) { # We have a key fingerprint
- $ret{key_fingerprint} = $2;
- $ret{key_longid} = substr $2,-16;
- } else { # We only have a long key ID
- $ret{key_longid} = $2;
- }
-
- if ($1 eq 'BAD') {
- $verdict_status++;
- push @{$ret{TILT}}, 'gpgv reported a bad signature, but exited zero'
- if 0 == $ret{exitcode};
- } elsif ($1 eq 'ERR') { # an ERRSIG line
- $verdict_status++;
- if (m/\G(\d+)\s(\d+)\s([[:xdigit:]]{2})\s([-:T[:digit:]Z+]+)\s(\d+)
- /gcx) {
- # $1 -- pubkey algorithm $2 -- digest algorithm
- # $3 -- timestamp $4 -- result code
- ftp_abort('gpgv returned an ISO8601 timestamp; implementation needed')
- if $3 =~ m/T/;
- $ret{sig_creation} = $3;
- } else
- { push @{$ret{TILT}}, 'gpgv ERRSIG line failed parsing' }
-
- push @{$ret{TILT}}, 'gpgv reported an error, but exited zero'
- if 0 == $ret{exitcode};
- } else { # GOODSIG/EXPSIG/EXPKEYSIG/REVKEYSIG
- $check_status++;
- }
- } elsif (m/\G(VALID)SIG\s([[:xdigit:]]+)\s(\d{4}-\d{2}-\d{2})\s
- ([-:T[:digit:]Z+]+)\s([-:T[:digit:]Z+]+)\s(\d+)\s(\S+)\s
- (\d+)\s(\d+)\s([[:xdigit:]]{2})\s([[:xdigit:]]+)
- /gcx) {
- $verdict_status++;
- # $1 -- valid tag $2 -- key fingerprint
- # $3 -- signature date $4 -- signature timestamp
- # $5 -- expiration timestamp $6 -- signature version
- # $7 -- reserved $8 -- pubkey algorithm
- # $9 -- digest algorithm $10 -- signature class
- # $11 -- primary key fingerprint
- $ret{key_fingerprint} = $2;
- $ret{key_longid} = substr $2,-16;
- ftp_abort('gpgv returned an ISO8601 timestamp; implementation needed')
- if $4 =~ m/T/ || $5 =~ m/T/;
- $ret{sig_creation} = $4;
- # GPG reports 0 if the signature does not expire
- $ret{sig_expiration} = $5 if $5 > 0;
- }
- }
- close $status or ftp_abort('close in-memory file for gpgv status');
-
- push @{$ret{TILT}}, 'gpgv reported more than one signature'
- if $intro_status > 1;
- push @{$ret{TILT}}, 'gpgv reported more than one signature check'
- if $check_status > 1;
- push @{$ret{TILT}}, 'gpgv reported more than one signature verdict'
- if $verdict_status > 1;
- push @{$ret{TILT}}, 'gpgv reported no signature verdict at all'
- if $verdict_status < 1;
-
- return \%ret;
-}
-
\f
#
# - [PV] Parsing and Validation
projects / gatekeeper.git / commitdiff