From b90818011f26ffb59d6d05991f621f4d697eafe0 Mon Sep 17 00:00:00 2001 From: Jacob Bachmeyer Date: Wed, 21 Jun 2023 23:48:28 -0500 Subject: [PATCH] Move directive parsing into packet objects This commit also adds accessor methods for fields previously extracted from the operation list header and moves all email address collection to the report phase. --- gatekeeper.pl | 142 ++++++++++++++++++++---------- testsuite/lib/tool/gatekeeper.exp | 4 +- 2 files changed, 97 insertions(+), 49 deletions(-) diff --git a/gatekeeper.pl b/gatekeeper.pl index 28ec647..816277e 100755 --- a/gatekeeper.pl +++ b/gatekeeper.pl @@ -1031,9 +1031,9 @@ END package Local::Exception::directive_syntax; {our @ISA = qw(Local::Exception)} - sub directory { (shift)->{directory} } + sub target_directory { (shift)->{target_directory} } - sub trace { (shift)->{trace} } + sub trace { (shift)->{trace} } sub trace_msg { return join("\n", map join(': ', @$_), @{(shift)->{trace}})."\n" } @@ -1630,23 +1630,68 @@ sub find_package { if (ref $_[0]) { @files = @{$_[0]} } else { @files = @_ } - bless {files => \@files}, $class + my $stem = $files[0]; + # find the longest common prefix of all file names + foreach my $file (@files) { # for each file name... + # ... trim from the stem until it is a prefix + substr($stem, -1, 1, '') + until substr($file, 0, length $stem) eq $stem; + } + + bless { files => \@files, stem => $stem }, $class } # scaffolding for now... sub files { @{(shift)->{files}} } + sub file_name_stem { (shift)->{stem} } sub has_uploaded_file { return 0 } + + sub target_directory; + sub target_filename; + sub target_filepair; # always FILE, FILE.sig, in that order + + sub parse; } { package Local::Packet::Directive; {our @ISA = qw(Local::Packet)} - sub file_name_stem { substr(((shift)->files)[0],0,-(length '.directive.asc')) } + BEGIN { *throw = \&::throw } sub directive_file_name { ((shift)->files)[0] } + sub parse { + my $self = shift; + + ::ftp_syslog info => 'found directive: '.$self->directive_file_name; + + $self->{directive_text} = ::slurp_clearsigned_message + (File::Spec->catfile(::CONF_DIR_Scratch, $self->directive_file_name)); + + # This would imply that the directive file did not contain a signed + # message. There is nothing further to do. + throw directive_syntax => trace => [], target_directory => undef, + summary => + 'directive file '.$self->directive_file_name.' has no signature' + if $self->{directive_text} eq ''; + + $self->{directive} = ::read_directive_from_string($self->{directive_text}); + + $self->{oplist} = ::interpret_directive($self->{directive}); + + ::validate_directive($self, $self->{oplist}); + } + + sub target_directory { (shift)->{oplist}->[0][1]->{directory} } + sub target_filename { (shift)->{oplist}->[0][1]->{filename} } + + sub target_filepair { + my $filename = (shift)->target_filename; + return $filename, $filename.'.sig'; + } + } { @@ -2094,7 +2139,8 @@ sub interpret_directive { if (@errors) { throw directive_syntax => - trace => \@trace, summary => $errors[0], directory => $header{directory}; + trace => \@trace, summary => $errors[0], + target_directory => $header{directory}; } return \@ops; @@ -2102,9 +2148,8 @@ sub interpret_directive { =item validate_directive ( $packet, $oplist ) -Validate the commands in OPLIST as applicable to PACKET. PACKET is an -arrayref listing the files considered to be in this packet. OPLIST is an -operation list arrayref. +Validate the commands in OPLIST as applicable to PACKET. PACKET is a +packet object. OPLIST is an operation list arrayref. An exception is thrown if validation fails. @@ -2132,12 +2177,12 @@ sub validate_directive { unless ($#$ops > 0) { if (not $packet->has_uploaded_file) { throw directive_syntax => - trace => [], directory => $op_header->{directory}, + trace => [], target_directory => $op_header->{directory}, summary => 'nothing to do - no commands in directive file'; } else { # Provide a different message if this looks like an upload packet. throw directive_syntax => - trace => [], directory => $op_header->{directory}, + trace => [], target_directory => $op_header->{directory}, summary => "no filename element in $stem.directive.asc." .' Upgrade to the latest version! ' .'See http://www.gnu.org/prep/maintain/maintain.html'; @@ -3139,14 +3184,10 @@ my @packets; } foreach my $packet (@packets) { # each list element is an array reference - my $stem = $packet->file_name_stem; - ftp_syslog info => 'found directive: '.$packet->directive_file_name; - # variables preserved for the report if an exception is thrown my $directive_text; my $directive; my $oplist; my $op_header; my $dsig_info; # directive signature information my $fsig_info; # file signature information - my @email_addresses; # addresses to receive copies of report my $complete = 0; # direct flag to indicate successful processing # scaffolding to be cleaned up as the internal API is improved @@ -3163,33 +3204,20 @@ foreach my $packet (@packets) { # each list element is an array reference eval { # trap exceptions encountered while processing a packet local $Phase = 'PS'; - $directive_text = slurp_clearsigned_message - (File::Spec->catfile(CONF_DIR_Scratch, $packet->directive_file_name)); + $packet->parse; - # This would imply that the directive file did not contain a signed - # message. There is nothing further to do. - throw directive_syntax => trace => [], directory => undef, - summary => - 'directive file '.$packet->directive_file_name.' has no signature' - if $directive_text eq ''; - - $directive = read_directive_from_string($directive_text); - - $oplist = interpret_directive($directive); + # scaffolding to be cleaned up later + $directive_text = $packet->{directive_text}; + $directive = $packet->{directive}; + $oplist = $packet->{oplist}; $op_header = $oplist->[0][1]; - push @email_addresses, - directory_email_addresses($op_header->{directory}); - - validate_directive($packet, $oplist); - - my @directory = File::Spec::Unix->splitdir($op_header->{directory}); - $Phase = 'AA'; + # Check that we have a keyring for this package: - my @keyrings = directory_keyrings($op_header->{directory}); + my @keyrings = directory_keyrings($packet->target_directory); unless (@keyrings) { - my $package = directory_package_name($op_header->{directory}); + my $package = directory_package_name($packet->target_directory); throw package_configuration => package_name => $package, summary => "no keyring for package $package" } @@ -3208,13 +3236,14 @@ foreach my $packet (@packets) { # each list element is an array reference # There is a file associated with this upload; verify its signature now. $fsig_info = verify_detached_signature - (File::Spec->catfile(CONF_DIR_Scratch, $op_header->{filename}), - File::Spec->catfile(CONF_DIR_Scratch, $op_header->{filename}.'.sig'), + (map(File::Spec->catfile(CONF_DIR_Scratch, $_), + $packet->target_filepair), @keyrings); throw signature_error => sig_info => $fsig_info, - summary => "gpg verify of upload file ($op_header->{filename}) failed" - if $fsig_info->{exitcode} != 0 || defined $fsig_info->{TILT}; + summary => + 'gpg verify of upload file ('.$packet->target_filename.') failed' + if $fsig_info->{exitcode} != 0 || defined $fsig_info->{TILT}; throw signature_error => sig_info => $fsig_info, summary => "gpg verification problem: could not extract timestamp" unless defined $fsig_info->{sig_creation}; @@ -3227,9 +3256,11 @@ foreach my $packet (@packets) { # each list element is an array reference # If the upload carries a file, check it for known Automake CVE issues. check_automake_vulnerabilities - (File::Spec->catfile(CONF_DIR_Scratch, $op_header->{filename})) + (File::Spec->catfile(CONF_DIR_Scratch, $packet->target_filename)) if find_directive_elements($directive, 'filename'); + my @directory = File::Spec::Unix->splitdir($packet->target_directory); + # If the upload installs a file, check if the final file exists; if so, # require the 'replace' option to be set. foreach my $step (@$oplist) { @@ -3261,12 +3292,12 @@ foreach my $packet (@packets) { # each list element is an array reference # Do we need a subdirectory on CONF_DIR_Staging as well? Can't quite # picture when we'd have a collision, so skip that for now. move_filepair - (CONF_DIR_Scratch, $op_header->{filename}, CONF_DIR_Staging); + (CONF_DIR_Scratch, $packet->target_filename, CONF_DIR_Staging); } foreach my $step (@{$oplist}[1..$#$oplist]) { # skip the header if ($step->[0] eq 'install') { - execute_install(\@directory, $step, $op_header->{filename}); + execute_install(\@directory, $step, $packet->target_filename); } elsif ($step->[0] eq 'symlink') { execute_symlink(\@directory, $step); } elsif ($step->[0] eq 'rmsymlink') { @@ -3296,6 +3327,8 @@ foreach my $packet (@packets) { # each list element is an array reference defined $op_header->{package} ? $op_header->{package} : ''); + my @email_addresses = directory_email_addresses($packet->target_directory); + # Successfully verifying a signature also yields a key fingerprint. push @email_addresses, keyidx_email($dsig_info->{key_fingerprint}); push @email_addresses, keyidx_email($fsig_info->{key_fingerprint}) @@ -3322,9 +3355,29 @@ foreach my $packet (@packets) { # each list element is an array reference my $E = $@; # preserve the exception, since many functions use eval + my @email_addresses; + + if ($E->can('target_directory') && $E->target_directory) { + # In some cases, notably when a directive_syntax exception is thrown, + # the target directory may not have been set on the packet object, + # but the exception carries that information instead. + push @email_addresses, + directory_email_addresses($E->target_directory); + } elsif ($packet->target_directory) { + # If the exception does not carry a target directory, then that + # field should have been set on the packet object. + push @email_addresses, + directory_email_addresses($packet->target_directory); + } + # Otherwise, we do not have a target directory at all, which probably + # has something to do with the exception we are handling... + my $have_any_directive_signature = 0; { my @fprs; # scratchpad for key fingerprints of valid signatures + # scaffolding to be removed later + $directive_text = $packet->{directive_text} unless $directive_text; + last unless $directive_text; # skip if no signature at all my $key_id; @@ -3380,11 +3433,6 @@ foreach my $packet (@packets) { # each list element is an array reference if (ref $E) { # Processing explicitly threw an exception if ($E->type_p('directive_syntax')) { - # If a directive_syntax exception is thrown, we may not have the - # email addresses corresponding to the target directory in the list - # and may not even have a target directory. - push @email_addresses, directory_email_addresses($E->directory) - if $E->directory; mail join("\n",$E->summary,'',$E->trace_msg), to => \@email_addresses, subject => $op_header->{package}; } elsif ($E->type_p('package_configuration')) { diff --git a/testsuite/lib/tool/gatekeeper.exp b/testsuite/lib/tool/gatekeeper.exp index 8238987..d7a166e 100644 --- a/testsuite/lib/tool/gatekeeper.exp +++ b/testsuite/lib/tool/gatekeeper.exp @@ -375,9 +375,9 @@ proc analyze_log { base_dir name assess } { set A(start) 1 exp_continue } - -re {^gatekeeper\[[0-9]+\]: \(Test\)\ + -re {^gatekeeper\[[0-9]+\]: \(Test\) \[PS\]\ found directive: ([^\r\n]+)} { - # from main script, top of file processing loop + # from directive packet parse method, at start set A(found,$expect_out(1,string)) 1 exp_continue } -- 2.25.1