From cb57100fe7f167ad577baa2bb3e5c677934b8d13 Mon Sep 17 00:00:00 2001 From: Jacob Bachmeyer Date: Wed, 26 Oct 2022 18:55:11 -0500 Subject: [PATCH] Reorganize gatekeeper to collect generic GPG support functions Prior to committing, this was validated with: (DIFF='git diff --cached'; comm -3 <($DIFF | grep ^- | sed -e 's/^-//' | sort) \ <($DIFF | grep ^+ | sed -e 's/^+//' | sort) ) The output shows only blank lines, comments, and a diff header were added, and only a diff header removed, after all lines are sorted and paired for analysis. To replicate, change the "git diff" command to compare this commit with its parent. --- gatekeeper.pl | 1516 +++++++++++++++++++++++++------------------------ 1 file changed, 760 insertions(+), 756 deletions(-) diff --git a/gatekeeper.pl b/gatekeeper.pl index ddd50a1..be1f4a7 100755 --- a/gatekeeper.pl +++ b/gatekeeper.pl @@ -521,578 +521,887 @@ for my $dir ($package_config_base, $incoming_dir, $incoming_tmp, # -# - 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 () { - 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 () { - 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); } - -# -# - 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 = ; - 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 is zero +and C 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 fields in the returned hashref are tainted; the extracted +values are untainted. The C 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 () { - 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; - -# -# - 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 ) + +# +# - 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 () { + 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 () { + 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. + +# +# - 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 = ; + 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(); + } } - +# 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 () { + 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); +} + + # -# 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]; +} + + +# +# - [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; @@ -1306,311 +1615,6 @@ sub guess_uploader_email { } } -=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 is zero -and C 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 fields in the returned hashref are tainted; the extracted -values are untainted. The C 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; -} - # # - [PV] Parsing and Validation -- 2.25.1