From: Jacob Bachmeyer Date: Wed, 15 Mar 2023 02:18:28 +0000 (-0500) Subject: Add initial keymaster administrative tool and associated testsuite X-Git-Url: https://vcs.fsf.org/?a=commitdiff_plain;h=eb35991dcd4796b6d143eec56fd07d1cb3bbe3e0;p=gatekeeper.git Add initial keymaster administrative tool and associated testsuite --- diff --git a/keymaster.pl b/keymaster.pl new file mode 100755 index 0000000..c89c591 --- /dev/null +++ b/keymaster.pl @@ -0,0 +1,1711 @@ +#!/usr/bin/perl +# I like -*- CPerl -*- mode. -- jcb + +use strict; +use warnings; + +use constant VERSION_MESSAGE => < +This is free software: you are free to change and redistribute it. +There is NO WARRANTY, to the extent permitted by law. +See the LICENSE section in the embedded documentation for the full boilerplate. +See the AUTHORS section in the embedded documentation for authorship details. +EOM + +=head1 NAME + +keymaster - key management tool for GNU Secure Software Gatekeeper + +=head1 SYNOPSIS + +keymaster.pl --B [I] + +keymaster.pl --B + +keymaster.pl [-B I] [-B I] I I<[options]> + +keymaster.pl [--B I] [--B I] I I<[options]> + +keymaster.pl B I I... + +keymaster.pl B I... + +keymaster.pl B I I... + +keymaster.pl B --B I... + +keymaster.pl B I I... + +keymaster.pl B I + +keymaster.pl B I I + +keymaster.pl B I... + +keymaster.pl B + +keymaster.pl B + +keymaster.pl B [--B] + +=head1 OPTIONS + +=over + +=item B<--help> + +Show general usage information and exit. + +=item B<--help> I + +Show help for COMMAND and exit. + +=item B<--version> + +Show version information and exit. + +=item B<--conf> I + +=item B<--config> I + +=item B<--configfile> I + +Specify alternate configuration file. Default is C in the +same directory as this tool. + +=item B<--zone> + +Specify the zone to manage. May be omitted if zones are not used in the +configuration. + +=back + +There are also intentionally undocumented options, which can be found in +the source code. + +=head1 DESCRIPTION + +The C tool provides utilities for managing the collection of GPG +keyrings used for access control at a GNU Secure Software Gatekeeper site. + +These utilities also maintain an index of the installed keys for use by the +main gatekeeper program and provide conveniece functions for managing email +notification lists and the email blacklist if the latter is configured. + +This tool is written as a unified script to most easily share common +backend logic across all of the utilities. + +=cut + +use Errno; +use Fcntl qw(O_RDWR O_WRONLY O_CREAT O_EXCL + LOCK_SH LOCK_EX LOCK_UN); +use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG); +use FindBin; +use SDBM_File; +use File::Spec; +use Text::Wrap; +use Pod::Usage; +use Getopt::Long; + +=head1 INTERNALS + +This section catches the internal documentation for internal functions +within the keymaster program. This is for programmers maintaining the +tool itself and these functions may change without notice. + +=cut + +=head2 Error Reporting and General Utilities + +=over + +=item abort $message + +Print MESSAGE to stderr and exit with code 2. This is used for most error +handling in the keymaster, even for reporting exceptions, since the +keymaster is expected to be used by trusted system administrators. + +=cut + +sub abort { + my $message = join ' ', @_; + + print STDERR 'keymaster: ', $message, "\n"; + + exit 2; +} + +=item @unique_list = unique ( @list ) + +Filter LIST to return only unique strings. Analogous to uniq(1) but does +not require LIST be sorted. Order of LIST is preserved; the first +occurrence of each unique value is passed through. + +=cut + +sub unique { + my %filter; + my @ret; + + foreach (@_) { unless ($filter{$_}) { $filter{$_}++; push @ret, $_ } } + + return @ret; +} + +# First pass option parsing + +use constant DEFAULT_CONFIG_FILE => + File::Spec->catfile($FindBin::Bin, 'gatekeeper.conf'); + +our $GPG = '/usr/bin/gpg'; +our %Config = (); our %ZoneConfig = (); +our %OPT = (help => undef, version => 0, + configfile => DEFAULT_CONFIG_FILE, zone => undef, + 'with-gpg' => \$GPG, + ); + +# The first pass only recognizes global options and leaves command-specific +# options in @ARGV. +Getopt::Long::Configure qw(gnu_getopt pass_through); +GetOptions(\%OPT, 'help:s', 'version', + 'configfile|config|conf|c=s', + 'zone|z=s', + 'with-gpg=s', + ); +Getopt::Long::Configure qw(no_pass_through); +# The second pass (in a command handler) will need to recognize all +# options, however. + +if (defined $OPT{help}) { + pod2usage(-verbose => 1, -exitval => 0) if $OPT{help} eq ''; + + # otherwise... + my $handler_name = 'cmd_'.$OPT{help}; + $handler_name =~ s/-/_/g; + + abort "keymaster.pl: unknown command: $OPT{help}\n" + unless defined $::{$handler_name}; + + $OPT{help} =~ s/_/-/g; + pod2usage(-verbose => 99, -exitval => 0, + -sections => ['COMMANDS//'.$OPT{help}]); +} + +if ($OPT{version}) { + my $message = VERSION_MESSAGE; + # per standards.texi, "Standards for Command-Line Interfaces", "--version", + # prune all copyright notices to display only the last year + $message =~ s/(\(C\))[^[:alpha:]]*[^[:digit:]]([[:digit:]]+\s)/$1 $2/g; + print $message; + exit 0 +} + +=item command_usage_error + +Show usage for the selected command and exit with an error return. This is +used when unknown options are given on the command line. + +=cut + +sub command_usage_error () { + our $Command; + $Command =~ s/_/-/g; + pod2usage(-verbose => 99, -exitval => 2, + -sections => ['COMMANDS//'.$Command]); +} + +=back + +=head2 Configuration Utilities + +=over + +=cut + +{ + my @zonelist = (); + + open my $config, '<', $OPT{configfile} + or abort "read config $OPT{configfile}: $!\n"; + + my $section = $Config{''} = {}; + while (<$config>) { + chomp; + next if m/^$/ || m/^\s*#/; # skip blank lines and comments + # collect configured zone names + push @zonelist, $1 if m/^\[zone[. ]([-_.[:alnum:]]+)\]/; + # track sections + if (m/^\[([-_.[:alnum:]]*)\]/) { + $Config{$1} = {} unless $Config{$1}; + $section = $Config{$1}; + } elsif (m/^([-_.[:alnum:]]+)\s*=\s*(.*)$/) { + # store configuration option + $section->{$1} = $2; + } else + { abort "unrecognized configuration line $.: $_" } + } + + close $config; + +=item assert_zone_argument_given_if_needed + +Ensure that a zone was specified on the command line if zones are +configured. + +=cut + + sub assert_zone_argument_given_if_needed () { + my $why = undef; + if (@zonelist and not $OPT{zone}) + { $why = "zones configured but no zone specified" } + elsif ($OPT{zone} and not grep $_ eq $OPT{zone}, @zonelist) + { $why = "unknown zone $OPT{zone}" } + if (defined $why) { + my $zonesmsg = join ' ', 'keymaster: known zones:', @zonelist; + $zonesmsg = 'keymaster: no zones configured' unless @zonelist; + die $why."\n".$zonesmsg."\n"; + } + } + + if (defined $OPT{zone} && $Config{'zone.'.$OPT{zone}}) + { %ZoneConfig = %{$Config{'zone.'.$OPT{zone}}} } + else + { %ZoneConfig = %{$Config{''}} } +} + +=item assert_config_set @items + +Ensure that all ITEMS are set in the active zone configuration. + +=cut + +sub assert_config_set { + foreach my $item (@_) + { die "configuration key $item not set\n" + unless defined $ZoneConfig{$item} } +} + +=back + +=head2 Filesystem Utilities + +=over + +=item @files = grep_subtree { ... } @directories + +Search the filesystem under DIRECTORIES for files matching the predicate, +which is given the filename in C<$_> and the information about the file in +perl's internal stat cache. As an example, to select regular files, use +C<-f _>. + +=cut + +sub grep_subtree (&@) { + my $predicate = shift; + my @directories = @_; + + my @results; + local *_; + + while (my $directory = shift @directories) { + opendir my $dh, $directory + or die "opendir $directory: $!"; + + while (defined($_ = readdir $dh)) { + next if m/^[.]{1,2}$/; + die "cannot stat file $_ in $directory: $!" + unless -e File::Spec->catfile($directory, $_); + push @directories, File::Spec->catdir($directory, $_) + if -d _; + push @results, File::Spec->catfile($directory, $_) + if $predicate->(); + } + + closedir $dh + or die "closedir $directory: $!" + } + + return @results; +} + +=item @files = grep_dir { ... } @directories + +Search the DIRECTORIES given for files matching the predicate, like +C. + +=cut + +sub grep_dir (&@) { + my $predicate = shift; + my @directories = @_; + + my @results; + local *_; + + while (my $directory = shift @directories) { + opendir my $dh, $directory + or die "opendir $directory: $!"; + + while (defined($_ = readdir $dh)) { + next if m/^[.]{1,2}$/; + die "cannot stat file $_ in $directory: $!" + unless -e File::Spec->catfile($directory, $_); + push @results, File::Spec->catfile($directory, $_) + if $predicate->(); + } + + closedir $dh + or die "closedir $directory: $!" + } + + return @results; +} + +=item mkdir_p ( @directory ) + +Ensure that DIRECTORY exists. On POSIX, DIRECTORY may be given as any +number of name fragments containing directory separators as needed. All +elements of DIRECTORY are combined, implicitly inserting directory +separators between each element of DIRECTORY. + +Example: (assuming POSIX) + + mkdir_p '/foo/bar', 'baz', 'quux'; + mkdir_p '/foo/bar', 'baz/quux'; + +Both of these ensure that the directory /foo/bar/baz/quux exists, creating +directories if needed. + +=cut + +sub mkdir_p { + my @dir = map File::Spec->splitdir($_), @_; # split directory name elements + + my @dir_steps; # list of intermediate dirs needed + # for example, creating /foo/bar/baz/quux with an empty /foo populates + # this list with qw( /foo/bar /foo/bar/baz /foo/bar/baz/quux ) on POSIX + + for (@dir_steps = (); @dir && ! -d File::Spec->catdir(@dir); pop @dir) + { unshift @dir_steps, File::Spec->catdir(@dir) } + + mkdir $_ or die "mkdir($_): $!\n" for @dir_steps; +} + +=item resolve_split_name ( @filename ) + +Combine filename components in the same way that C combines its +arguments. The final result is expected to name a file. + +=cut + +sub resolve_split_name { + my $file = pop; + return File::Spec->catfile(map(File::Spec->splitdir($_), @_), $file); +} + +=item resolve_config_name ( $filename ) + +Convert FILENAME to a name within the package configuration tree. +Returns FILENAME unaltered if FILENAME does not name a file within that +tree. + +=cut + +sub resolve_config_name { + my $filename = shift; + + my $vol; my $dir; my $file; my $bvol; my $bdir; my $bfile; + ($vol, $dir, $file) = File::Spec->splitpath($filename); + ($bvol, $bdir, $bfile) = File::Spec->splitpath($ZoneConfig{pkgconfdir}); + + return $filename unless $vol eq $bvol; + + my @dir = File::Spec->splitdir($dir); + my @bdir = File::Spec->splitdir(File::Spec->catdir($bdir,$bfile)); + + while (@dir && @bdir && $dir[0] eq $bdir[0]) { shift @dir; shift @bdir } + + return $filename if @bdir; # FILENAME not actually under pkgconfdir + return File::Spec->catfile(@dir, $file); +} + +=back + +=head2 Low-Level Keyring Index Access Helpers + +These functions manage an SDBM-based index over the collection of keyrings +used for authentication and authorization. File locking with C is +used on a flag file to prevent access collisions with the gatekeeper. The +lock is automatically released when the program exits. + +Note that "key" in this section can have two meanings: a PGP key indexed in +the database or the key half of a key-value pair stored in the database. +Read and think carefully. + +=cut + +use constant KEYIDX_NAME => 'keyindex'; +use constant KEYIDX_REV => 1; + +# Directory names are stored in the index using POSIX syntax. +# File::Spec::Unix is normally loaded as a side-effect of loading +# File::Spec, but this ensures that we will have it. +require File::Spec::Unix; + +=over + +=item keyidx_attach + +Establish the connection to the key index database and acquire the lock. + +=cut + +sub keyidx_attach { + our %KeyIndex; + + assert_config_set 'pkgconfdir'; + my $dbstem = File::Spec->catfile($ZoneConfig{pkgconfdir}, KEYIDX_NAME); + + open KEYIDXLOCK, '+>', $dbstem.'.flag' + or die "open key index lock file: $!"; + flock KEYIDXLOCK, LOCK_EX + or die "lock key index: $!"; + + tie %KeyIndex, 'SDBM_File', $dbstem, O_RDWR|O_CREAT, 0666 + or die "tie key index: $!"; + + $KeyIndex{__index_format_revision} = KEYIDX_REV + unless defined $KeyIndex{__index_format_revision}; + die "key index uses unsupported newer revision ". + $KeyIndex{__index_format_revision} + if $KeyIndex{__index_format_revision} > KEYIDX_REV; +} + +END { + our %KeyIndex; + # This dance ensures that the reference to the tied object behind + # %KeyIndex is dropped before %KeyIndex is untied to avoid a warning. + my $is_tied = defined tied %KeyIndex; + untie %KeyIndex if $is_tied; + # The lock on the flag file is released when the file is implicitly + # closed as this program exits. +} + +=item @values = keyidx_get @keys + +=item keyidx_put $key => $value, $key => $value, ... + +=item keyidx_del @keys + +Low-level access to the keyring index; the keys used at this level encode +the information sought as follows: + +=over + +=item EfEIE + +Set of email addresses associated with a PGP key, by primary key +fingerprint. These are indexed separately for use by the gatekeeper. + +=item UfEIE + +Set of user-id strings associated with a PGP key, by primary key +fingerprint. These include the email addresses. + +=item DfEIE + +Set of directories containing active keyrings (C) containing +copies of a PGP key, by primary key fingerprint. + +=item kfEIE + +Primary PGP key fingerprint for a PGP subkey, by subkey fingerprint. +Primary keys are also indexed here, pointing to thier own fingerprints. + +=item KfEIE + +Set of subkey fingerprints associated with a PGP key, by primary key +fingerprint. + +=item LiEIE + +Set of key fingerprints for keys known to match a PGP long key ID. This +stores a set to allow for key ID collisions as RFC4880 requires. Note that +a subkey ID maps to subkey fingerprints at this stage. + +=back + +These functions translate between these keys and the actual storage in the +SDBM database. A set is accepted/returned as an array reference. The case +of the first letter distinguishes sets from scalar values. + +=cut + +# Sets are serialized using SDBM: KEY-0, KEY-1, ... KEY-N with one item +# under each KEY-n and {put,get,del} performing scatter/gather. + +sub keyidx_get { + my @ret = (); + + our %KeyIndex; + + die "multiple items requested in scalar context" + if @_ > 1 && !wantarray; + + while (@_) { + my $key = shift; + + if ($key =~ m/^[[:upper:]]/) { + my @item = (); + for (my $i = 0; exists $KeyIndex{$key.'-'.$i}; $i++) + { push @item, $KeyIndex{$key.'-'.$i} } + push @ret, \@item; + } elsif ($key =~ m/^[[:lower:]]/) { + push @ret, $KeyIndex{$key}; + } else { + warn "unexpected key $key in keyidx_get"; + push @ret, undef; + } + } + + return wantarray ? @ret : $ret[0]; +} +sub keyidx_put { + die unless scalar @_ % 2 == 0; # paired arguments are required + + our %KeyIndex; + + while (@_) { + my $key = shift; + my $value = shift; + + if ($key =~ m/^[[:upper:]]/) { + # This $value is an arrayref. Eliminate duplicates. + my %have; my $i; + + for ($i = 0; exists $KeyIndex{$key.'-'.$i}; $i++) + { $have{$KeyIndex{$key.'-'.$i}} = 1 } + + foreach my $item (@$value) { + next if $have{$item}; + $KeyIndex{$key.'-'.($i++)} = $item; + } + } elsif ($key =~ m/^[[:lower:]]/) { + die "cannot directly store reference in keyidx_put" + if ref $value; + $KeyIndex{$key} = $value; + } + } +} +sub keyidx_del { + our %KeyIndex; + + while (@_) { + my $key = shift; + + for (my $i = 0; exists $KeyIndex{$key.'-'.$i}; $i++) + { delete $KeyIndex{$key.'-'.$i} } + delete $KeyIndex{$key}; + } +} + +=back + +=head2 List File Management Utilities + +These functions manage lists of items, one per line. This is mostly used +for email addresses. + +=over + +=item @items = list_file_read $filename + +Read the entries in FILENAME and return them as a list. If FILENAME is an +array reference, its elements are combined using C. + +=cut + +sub list_file_read { + my $filename = shift; + + $filename = resolve_split_name @$filename if 'ARRAY' eq ref $filename; + + my @items; + local *_; + + open my $fh, '<', $filename or do { + # a non-existent file is an empty list + if ($!{ENOENT}) { return () } + else { die "$filename: $!" } + }; + while (<$fh>) { chomp; push @items, $_ } + close $fh; + + return @items; +} + +=item list_file_add $filename, @items + +Replace FILENAME with a new copy additionally containing ITEMS. Entries +already present in the file will not be duplicated. If FILENAME is an +array reference, its elements are combined using C. + +=cut + +sub list_file_add { + my $filename = shift; + my @items = @_; + + $filename = resolve_split_name @$filename if ref $filename; + + my $scratchtail = '.'.$$.'-000001'; + my $newfile = 0; + my %haveitems; + local *_; + + open my $in, '<', $filename or do { + if ($!{ENOENT}) { $newfile = 1 } + else { die "$filename: $!" } + }; + my $out; + until (sysopen $out, $filename.$scratchtail, O_WRONLY|O_CREAT|O_EXCL) { + if ($!{EEXIST}) { $scratchtail++ while -e $filename.$scratchtail } + else { die "$filename$scratchtail: $!" } + } + + unless ($newfile) { + while (<$in>) { + chomp; + print $out $_,"\n"; + $haveitems{$_}++; + } + close $in or die "$filename: $!"; + } + + foreach my $item (grep !$haveitems{$_}, @items) { + print $out $item,"\n"; + } + close $out or die "$filename$scratchtail: $!"; + + rename $filename.$scratchtail, $filename + or die "rename $filename$scratchtail to $filename: $!" +} + +=item list_file_remove $filename, @items + +Replace FILENAME with a new copy omitting ITEMS. If FILENAME is an +array reference, its elements are combined using C. + +=cut + +sub list_file_remove { + my $filename = shift; + my %itemfilter = map { $_ => $_ } @_; + + $filename = resolve_split_name @$filename if ref $filename; + + my $scratchtail = '.'.$$.'-000001'; + local *_; + + open my $in, '<', $filename + or die "$filename: $!"; + my $out; + until (sysopen $out, $filename.$scratchtail, O_WRONLY|O_CREAT|O_EXCL) { + if ($!{EEXIST}) { $scratchtail++ while -e $filename.$scratchtail } + else { die "$filename$scratchtail: $!" } + } + + while (<$in>) { + chomp; + print $out $_,"\n" unless defined $itemfilter{$_}; + } + close $in or die "$filename: $!"; + close $out or die "$filename$scratchtail: $!"; + + rename $filename.$scratchtail, $filename + or die "rename $filename$scratchtail to $filename: $!" +} + +=back + +=head2 GPG Interface Helpers + +=over + +=item run_gpg_on $keyring, @arguments + +Run GPG on KEYRING with the provided ARGUMENTS. An exception is thrown if +GPG does not report success. + +This is used to perform actions; use C and C to +obtain information. + +=cut + +sub run_gpg_on { + my $retcode = system $GPG qw/gpg --batch + --no-default-keyring --keyring/ => @_; + + unless ($retcode == 0) { + die "GPG killed by signal ".WTERMSIG($?) if WIFSIGNALED($?); + die "GPG exited with code ".WEXITSTATUS($?) if WIFEXITED($?); + die "unexpected exit code $? from GPG"; + } +} + +=item $pipe = spawn_gpg @arguments + +Spawn a GPG subprocess with the provided ARGUMENTS and return a pipe from +which its output may be read. + +=cut + +sub spawn_gpg { + my $pid = open my $gpg_pipe, '-|', $GPG, @_; + + die "failed to open pipe from GPG: $!" unless defined $pid; + + return $gpg_pipe +} + +=item close_gpg $pipe + +Close a pipe returned from C and verify that GPG has exited +normally. An exception is thrown if GPG does not report success. + +=cut + +sub close_gpg { + my $gpg_pipe = shift; + + unless (close $gpg_pipe) { + die "GPG killed by signal ".WTERMSIG($?) if WIFSIGNALED($?); + die "GPG exited with code ".WEXITSTATUS($?) if WIFEXITED($?); + die "unexpected exit code $? from GPG"; + } +} + +=item copy_gpg_keys $source, $target + +=item copy_gpg_keys $source, @fingerprints, $target + +Transfer one or more GPG keys from keyring SOURCE to keyring TARGET, +leaving the key in SOURCE. This is a Perl implementation equivalent to the +shell pipeline `C | gpg ... --import>`. + +Omitting the FINGERPRINTS list will cause GPG to copy all keys from the +SOURCE keyring to the TARGET keyring. + +=cut + +sub copy_gpg_keys { + my $source_ring = shift; + my $target_ring = pop; + my @keyids = @_; + + pipe my $p_read, my $p_write or die "create pipe: $!"; + + my $cpid_e = fork; + die "fork child for key export: $!" unless defined $cpid_e; + if ($cpid_e == 0) { # in child that will exec gpg --export + close $p_read; + + my $flags; + + unless (open STDOUT, '>&', $p_write) + { warn "set stdout for key export: $!"; exit 127 } + + exec { $GPG } qw/gpg --no-default-keyring --keyring/ => $source_ring, + q/--export/ => @keyids; + warn "exec gpg --export failed: $!"; + exit 127 + } + + my $cpid_i = fork; + die "fork child for key import: $!" unless defined $cpid_i; + if ($cpid_i == 0) { # in child that will exec gpg --import + close $p_write; + + my $flags; + + unless (open STDIN, '<&', $p_read) + { warn "set stdin for key import: $!"; exit 127 } + + exec { $GPG } qw/gpg --no-default-keyring --keyring/ => $target_ring, + q/--import/; + warn "exec gpg --import failed: $!"; + exit 127 + } + + # The parent continues here... + close $p_read; close $p_write; + + # We use a simpler model here, since we are really only trying to set up + # two child processes in a pipeline and what we really care about is that + # both child processes succeed. All errors, whether failure to exec GPG + # or complaints from GPG, can be safely conflated here. + if (waitpid($cpid_i, 0) < 1) { # first, wait for the import to finish + # oops, that was an error + die "unexpected result from waitpid; exit code $?; error: $!" + } + unless ($? == 0) { + die "GPG (--import) killed by signal ".WTERMSIG($?) if WIFSIGNALED($?); + die "GPG (--import) failed with code ".WEXITSTATUS($?) if WIFEXITED($?); + die "unexpected exit code $?" + } + if (waitpid($cpid_e, 0) < 1) { # second, reap the export process + # oops, that was an error + die "unexpected result from waitpid; exit code $?; error: $!" + } + unless ($? == 0) { + die "GPG (--export) killed by signal ".WTERMSIG($?) if WIFSIGNALED($?); + die "GPG (--export) failed with code ".WEXITSTATUS($?) if WIFEXITED($?); + die "unexpected exit code $?" + } +} + + +=back + +=head2 PGP Key Helpers + +=over + +=cut + +{ + package Local::Model::PGPKey; + + use constant { + RING => 0, # arrayref of filenames of keyrings containing this key + TRUST => 1, # trust value from GPG or undef if loaded from index + FPR => 2, # PGP key primary fingerprint + SUBFPR => 3, # array ref of subkey fingerprints + UID => 4, # arrayref of user-id strings + }; + + sub new { + my $class = shift; + my $ob = []; + + while (@_) { + my $opt = shift; + + if ($opt eq 'fingerprint') { $ob->[FPR] = uc shift } + elsif ($opt eq 'subkeyprint') { push @{$ob->[SUBFPR]}, uc shift } + elsif ($opt eq 'user_id') { push @{$ob->[UID]}, shift } + elsif ($opt eq 'keyring') { push @{$ob->[RING]}, shift } + elsif ($opt eq 'trust') { $ob->[TRUST] = shift } + else { die "bogus argument" } + } + + bless $ob, $class + } + +=item @keyrings = $keyspec->keyrings + +Return file names of the keyrings containing the key described by KEYSPEC. +If KEYSPEC was obtained from a keyring file, there will only be one entry +returned. If KEYSPEC was obtained from the index, all keyrings known to +contain this key will be returned. + +The returned file names are normally relative to the package configuration +base directory, but can be absolute if a keyring is somehow not in that +tree. + +=cut + + sub keyrings { @{(shift)->[RING]} } + +=item $is_expired = $keyspec->expired + +=item $is_revoked = $keyspec->revoked + +Return boolean status indicating if GPG reported the key described by +KEYSPEC to be expired or revoked. These will always return the undefined +value if KEYSPEC was obtained from the index. + +=cut + + sub expired { + my $val = (shift)->[TRUST]; + return undef unless defined $val; + return $val =~ m/^e/; + } + sub revoked { + my $val = (shift)->[TRUST]; + return undef unless defined $val; + return $val =~ m/^r/; + } + +=item $fingerprint = $keyspec->fingerprint + +Return the primary PGP key fingerprint for the key described by KEYSPEC. + +=cut + + sub fingerprint { (shift)->[FPR] } + +=item @fingerprints = $keyspec->fingerprints + +Return the primary PGP key fingerprint followed by all subkey fingerprints +for the key described by KEYSPEC. In scalar context, return only the +primary key fingerprint. + +=cut + + sub fingerprints { + my $self = shift; + my @fingerprints; + + push @fingerprints, $self->[FPR] if defined $self->[FPR]; + push @fingerprints, @{$self->[SUBFPR]} if defined $self->[SUBFPR]; + + return wantarray ? @fingerprints : $fingerprints[0]; + } + +=item @emails = $keyspec->emails + +Return the set of email addresses for the key described by KEYSPEC. + +=cut + + sub emails { + my $self = shift; + + my @addresses; + foreach (@{$self->[UID]}) { push @addresses, $1 if m/<([^<>]+)>$/ } + + return @addresses; + } + +=item @uids = $keyspec->user_ids + +Return the set of user-id strings for the key described by KEYSPEC. + +=cut + + sub user_ids { @{(shift)->[UID]} } + +} + +=item $boolean = key_id_match $id, $fingerprint + +Return true if ID matches FINGERPRINT as either an exact match, a prefix of +FINGERPRINT, or a suffix of FINGERPRINT. The arguments are +interchangeable; the longer argument will be taken as the key fingerprint. + +=cut + +sub key_id_match { + my $id; my $fingerprint; + if (length($_[0]) > length($_[1])) { + ($fingerprint, $id) = map uc, @_[0,1]; + } else { + ($id, $fingerprint) = map uc, @_[0,1]; + } + + return + ($id eq $fingerprint + || $id eq substr($fingerprint, 0, length $id) + || $id eq substr($fingerprint, -length $id)) +} + + +=item @keyspecs = keys_from_keyfile $filename + +=item @keyspecs = keys_from_keyring $keyring + +Extract information from primary PGP keys in FILENAME or KEYRING. Multiple +records may be returned in list context if the file or ring contains +multiple keys. In scalar context, returns only information about the first +key found. + +=cut + +sub keys_from_keyring { + my $keyring = shift; + + local *_; + + my $gpg = spawn_gpg qw/--no-default-keyring --keyring/ => $keyring, + qw/--list-keys --fixed-list-mode + --with-fingerprint --with-fingerprint --with-colons/; + + my $relkeyring = resolve_config_name $keyring; + my @ksfields; + + my $fingerprint_type = 'fingerprint'; + while (<$gpg>) { + my @field = split /:/; + + if ($field[0] eq 'uid') + { push @{$ksfields[-1]}, user_id => $field[9] } + elsif ($field[0] eq 'fpr') + { push @{$ksfields[-1]}, $fingerprint_type => $field[9] } + elsif ($field[0] eq 'pub') { + # start reading a new key + push @ksfields, [ keyring => $relkeyring, trust => $field[1] ]; + $fingerprint_type = 'fingerprint'; + } elsif ($field[0] eq 'sub') { + # switch to collecting subkey fingerprints + $fingerprint_type = 'subkeyprint'; + } + } + + close_gpg $gpg; + + my @keys = map Local::Model::PGPKey->new(@$_), @ksfields; + + return wantarray ? @keys : $keys[0]; +} + +sub keys_from_keyfile { + my $keyfilename = shift; + + my $scratch_keyring; + { my $i = 0; + do { $scratch_keyring = + File::Spec->catfile(File::Spec->curdir(), + "keymaster-scratch-ring.$$.".($i++).'.gpg') } + while (-e $scratch_keyring); + } + + run_gpg_on $scratch_keyring, q/--import/ => $keyfilename; + + my @results = keys_from_keyring $scratch_keyring; + + unlink $scratch_keyring; + + return wantarray ? @results : $results[0]; +} + +=back + +=head2 High-Level Keyring Index Access + +=over + +=item keyidx_store @keyspecs + +Add the information from KEYSPECs to the PGP key index. + +=cut + +sub keyidx_store { + my @elems; + + foreach my $keyspec (@_) { + my @subfprs = $keyspec->fingerprints; + my $pri_fpr = shift @subfprs; + + my @ringdirs = grep defined, map { + my $dir; my $file; + (undef, $dir, $file) = File::Spec->splitpath($_); + my @dirs = File::Spec->splitdir($dir); + pop @dirs while $dirs[-1] eq ''; + $file eq 'pubring.gpg' ? File::Spec::Unix->catdir(@dirs) : undef + } $keyspec->keyrings; + + push @elems, 'Ef'.$pri_fpr => [$keyspec->emails]; + push @elems, 'Uf'.$pri_fpr => [$keyspec->user_ids]; + push @elems, 'Df'.$pri_fpr => \@ringdirs; + push @elems, 'Kf'.$pri_fpr => \@subfprs; + push @elems, 'kf'.$_ => $pri_fpr, + 'Li'.substr($_,-16) => [$_], 'Li'.substr($_,-8) => [$_] + for $pri_fpr, @subfprs; + } + + keyidx_put @elems; +} + +=item $keyspec = keyidx_fetch fingerprint => $fingerprint + +Reconstitute a KEYSPEC from the key index for the key with FINGERPRINT. +The FINGERPRINT used for the search may be a subkey fingerprint; the +returned KEYSPEC will describe the associated primary key. + +=cut + +sub keyidx_fetch { + my $search_mode = shift; + + my $fingerprint; + + if ($search_mode eq 'fingerprint') { + $fingerprint = shift; + } else + { die "unsupported search mode $search_mode in keyidx_fetch" } + + my $pri_fpr = keyidx_get 'kf'.$fingerprint; + return undef unless defined $pri_fpr; + + my @info = keyidx_get 'Uf'.$pri_fpr, 'Kf'.$pri_fpr, 'Df'.$pri_fpr; + # $info[0] -- user-ids $info[2] -- directories + # $info[1] -- subkey fingerprints all are arrayrefs + + return Local::Model::PGPKey->new + (fingerprint => $pri_fpr, + (map { + user_id => $_ } @{$info[0]}), + (map { + subkeyprint => $_ } @{$info[1]}), + (map { + keyring => File::Spec->catfile(File::Spec::Unix->splitdir($_), + 'pubring.gpg') } @{$info[2]})); +} + +=item keyidx_expunge fingerprint => @fingerprints + +Remove all information about all keys indicated by FINGERPRINTS from the +key index. Removing information about a subkey will also remove all +records of the primary key and all other subkeys of that key. + +=cut + +sub keyidx_expunge { + my $search_mode = shift; + + my @fingerprints; + + if ($search_mode eq 'fingerprint') { + @fingerprints = unique @_; + } else + { die "unsupported search mode $search_mode in keyidx_expunge" } + + my @pri_fpr = keyidx_get map 'kf'.$_, @fingerprints; + foreach my $pri_fpr (@pri_fpr) { + my $sub_fprs = keyidx_get 'Kf'.$pri_fpr; + + my $others_by_lid = keyidx_get 'Li'.substr($pri_fpr,-16); + my $others_by_sid = keyidx_get 'Li'.substr($pri_fpr,-8); + my @others_by_lid = grep $_ ne $pri_fpr, @$others_by_lid; + my @others_by_sid = grep $_ ne $pri_fpr, @$others_by_sid; + + keyidx_del 'Uf'.$pri_fpr, 'Ef'.$pri_fpr, 'Kf'.$pri_fpr, 'Df'.$pri_fpr, + 'Li'.substr($pri_fpr,-16), 'Li'.substr($pri_fpr,-8), + map 'kf'.$_, ($pri_fpr, @$sub_fprs); + keyidx_put 'Li'.substr($pri_fpr,-16) => \@others_by_lid if @others_by_lid; + keyidx_put 'Li'.substr($pri_fpr,-8) => \@others_by_sid if @others_by_sid; + } + +} + +=back + +=head1 COMMANDS + +This section catches the documentation for the individual commands and is +also used for the online help facility. + +=head2 Email Notification Management + +=head3 notify-email + +=over + +=item notify-email I I... + +=back + +Add EMAIL addresses to the list of addresses to be notified of uploads +affecting DIRECTORY and subdirectories thereof. + +=cut + +sub cmd_notify_email { + assert_zone_argument_given_if_needed; + assert_config_set 'pkgconfdir'; + GetOptions() or command_usage_error; + + my $directory = shift @ARGV; + + mkdir_p $ZoneConfig{pkgconfdir}, $directory; + + list_file_add [$ZoneConfig{pkgconfdir}, $directory, 'email'], @ARGV; + + return 0; +} + +=head3 blacklist-email + +=over + +=item blacklist-email I... + +=back + +Add EMAIL addresses to the global blacklist. This feature is intended to +suppress email messages to no-longer-valid addresses on PGP keys that +remain valid. + +=cut + +sub cmd_blacklist_email { + GetOptions() or command_usage_error; + + die "email blacklist not configured\n" + unless defined $Config{email} && defined $Config{email}{blacklist}; + + list_file_add $Config{email}{blacklist}, @ARGV; + + return 0; +} + +=head3 remove-email + +=over + +=item remove-email I I... + +=item remove-email --blacklist I... + +=back + +In the first form, remove EMAIL addresses from the set of addresses +notified of uploads to DIRECTORY. A diagnostic is produced if any EMAIL +addresses are not on the list for DIRECTORY and/or are on the list for a +parent directory. + +In the second form, remove EMAIL addresses from the global blacklist. A +diagnostic is produced if any EMAIL addresses are not on the global +blacklist. + +=cut + +sub cmd_remove_email { + my $use_blacklist = 0; + GetOptions(blacklist => \$use_blacklist) or command_usage_error; + + my $filename; + + if ($use_blacklist) { + die "email blacklist not configured\n" + unless defined $Config{email} && defined $Config{email}{blacklist}; + $filename = $Config{email}{blacklist}; + } else { + assert_zone_argument_given_if_needed; + assert_config_set 'pkgconfdir'; + my $directory = shift @ARGV; + $filename = [$ZoneConfig{pkgconfdir}, $directory, 'email']; + + my @dirs = File::Spec->splitdir($directory); + while (pop @dirs) { + my $dir = File::Spec->catdir(@dirs); + my %list = map { $_ => 1 } + list_file_read [$ZoneConfig{pkgconfdir}, $dir, 'email']; + foreach my $address (@ARGV) { + warn fill('keymaster: ', ' 'x12, <<"EOM")."\n" if $list{$address}; +address $address is also listed in parent directory $dir and will therefore +continue to receive notifications for uploads affecting $directory +EOM + } + } + } + + { + my %current = map { $_ => 1 } list_file_read $filename; + + foreach my $address (@ARGV) + { warn "keymaster: address $address not found or already removed\n" + unless $current{$address} } + } + + list_file_remove $filename, @ARGV; + + return 0; +} + +=head3 + +=head2 Keyring Management + +=head3 register-key + +=over + +=item register-key I I... + +=back + +Add keys (in KEYFILEs) authorized to upload to DIRECTORY and subdirectories +thereof. + +=cut + +sub cmd_register_key { + assert_zone_argument_given_if_needed; + assert_config_set 'pkgconfdir'; + GetOptions() or command_usage_error; + keyidx_attach; + + my $directory = shift @ARGV; + + mkdir_p $ZoneConfig{pkgconfdir}, $directory; + + my $keyring = resolve_split_name + ($ZoneConfig{pkgconfdir}, $directory, 'pubring.gpg'); + + run_gpg_on $keyring, q/--import/ => @ARGV; + + # Index keys for $directory; the indexing logic coalesces duplicate + # entries, so doing it this way avoids creating a scratch keyring. + keyidx_store keys_from_keyring $keyring; + + return 0; +} + +=head3 update-key + +=over + +=item update-key I + +=back + +Re-import KEYFILE into all keyrings that currently contain a key found in +KEYFILE. This can be used to import revocation certificates, extend +expiration times on active keys, add or revoke signatures on keys, or +anything else C can do. + +=cut + +sub cmd_update_key { + assert_zone_argument_given_if_needed; + GetOptions() or command_usage_error; + keyidx_attach; + + my $keyfile = shift @ARGV; + + die "PGP keyfile $keyfile does not exist\n" + unless -f $keyfile; + + my @keyspecs = keys_from_keyfile $keyfile; + + # The simple re-import we currently do would spread permissions if + # KEYFILE contains multiple keys: *all* keys in KEYFILE would get all + # permissions that *any* key in KEYFILE previously had. + die "PGP keyfile $keyfile contains multiple keys\n" + if scalar @keyspecs > 1; + + { + my $keyspec = $keyspecs[0]; + + my $have_key = keyidx_fetch fingerprint => $keyspec->fingerprint; + foreach my $keyring ($have_key->keyrings) { + my $ringfile = resolve_split_name($ZoneConfig{pkgconfdir}, $keyring); + run_gpg_on $ringfile, q/--import/ => $keyfile; + keyidx_store keys_from_keyring $ringfile; + } + } + + return 0; +} + +=head3 withdraw-key + +=over + +=item withdraw-key I I + +Immediately transfer the key with FINGERPRINT from the active keyring +(C) to the archival keyring (C) in DIRECTORY. +This revokes access to DIRECTORY for that key. + +The full PGP key fingerprint is required; a short or long key ID will not +be resolved to a fingerprint. + +=back + +=cut + +sub cmd_withdraw_key { + assert_zone_argument_given_if_needed; + assert_config_set 'pkgconfdir'; + GetOptions() or command_usage_error; + keyidx_attach; + + my $directory = shift @ARGV; + my $fingerprint = uc shift @ARGV; + + my $keyring = resolve_split_name($directory, 'pubring.gpg'); + my $oldring = resolve_split_name($directory, 'oldring.gpg'); + my $abskeyring = resolve_split_name + ($ZoneConfig{pkgconfdir}, $directory, 'pubring.gpg'); + my $absoldring = resolve_split_name + ($ZoneConfig{pkgconfdir}, $directory, 'oldring.gpg'); + + my $keyspec = keyidx_fetch fingerprint => $fingerprint; + die "key fingerprint $fingerprint not known\n" + unless $keyspec; + die "key fingerprint $fingerprint not found in $directory\n" + unless grep $keyring eq $_, $keyspec->keyrings; + + if (1 == scalar $keyspec->keyrings) { + # The easy way: this is the only/last use of this key, so removing it + # from this directory is removing it from the system. + keyidx_expunge fingerprint => $fingerprint; + } else { + # The hard way: the key remains valid in other directories. + my $dirs = keyidx_get 'Df'.$fingerprint; + my $db_dir = File::Spec::Unix->catdir(File::Spec->splitdir($directory)); + keyidx_del 'Df'.$fingerprint; + keyidx_put 'Df'.$fingerprint => [grep $db_dir ne $_, @$dirs]; + } + + copy_gpg_keys $abskeyring, $fingerprint, $absoldring; + run_gpg_on $abskeyring, q/--delete-key/ => $fingerprint; + + return 0; +} + +=head3 find-keys + +=over + +=item find-keys I... + +=back + +Search all registered keys for any keys matching a provided key ID or +fingerprint fragment. Each fragment must be a string of hex digits and is +matched (case-insensitive) as either prefix, suffix, or exact match to the +fingerprints of all keys in the index. + +All matched keys and the permissions granted to them are reported. + +=cut + +sub cmd_find_keys { + assert_zone_argument_given_if_needed; + assert_config_set 'pkgconfdir'; + GetOptions() or command_usage_error; + keyidx_attach; + + my @search = map uc, @ARGV; + my @matches; + { # scan the index directly + our %KeyIndex; + foreach my $fpr (keys %KeyIndex) { + next unless $fpr =~ s/^kf//; # remove prefix and select records + push @matches, $fpr if grep key_id_match($_, $fpr), @search; + } + } + + my @keyspecs = map { [$_, keyidx_fetch fingerprint => $_] } @matches; + foreach my $keyrec (@keyspecs) { + my $keyspec = $keyrec->[1]; + + if ($keyrec->[0] eq $keyspec->fingerprint) + { print 'Found key fingerprint ',$keyspec->fingerprint,":\n" } + else + { print 'Found subkey fingerprint ',$keyrec->[0],"\n", + ' of primary key with fingerprint ',$keyspec->fingerprint,":\n" } + print " + $_\n" for $keyspec->user_ids; + print " Permitted for uploads to:\n"; + foreach my $keyring ($keyspec->keyrings) { + my $confdir; (undef, $confdir, undef) = File::Spec->splitpath($keyring); + my @confdir = File::Spec->splitdir($confdir); + pop @confdir while $confdir[-1] eq ''; + print " - ",File::Spec->catdir(@confdir), "\n"; + } + } + + return 0; +} + +=head3 cleanup-keys + +=over + +=item cleanup-keys + +=back + +Scan the package configuration and locate all keys on active keyrings +(C) that have expired or been revoked. Transfer these keys to +archival keyrings (C) and remove them from the index. + +=cut + +sub cmd_cleanup_keys { + assert_zone_argument_given_if_needed; + assert_config_set 'pkgconfdir'; + GetOptions() or command_usage_error; + keyidx_attach; + + my @pubrings = + grep_subtree { m/^pubring\.gpg$/ && -f _ } $ZoneConfig{pkgconfdir}; + + my @dropkeys; + foreach my $pubring (@pubrings) { + my $oldring; + { my $dir; + (undef, $dir, undef) = File::Spec->splitpath($pubring); + $oldring = File::Spec->catfile($dir, 'oldring.gpg') } + + my @keyspecs = keys_from_keyring $pubring; + my @movekeys = map $_->fingerprint, + grep $_->expired || $_->revoked, @keyspecs; + + if (@movekeys) { + copy_gpg_keys $pubring, @movekeys, $oldring; + run_gpg_on $pubring, q/--delete-key/ => $_ for @movekeys; + + push @dropkeys, @movekeys; + } + } + keyidx_expunge fingerprint => @dropkeys if @dropkeys; + + return 0; +} + +=head3 collect-keys + +=over + +=item collect-keys + +=back + +Scan the package configuration and collect all keys into per-project and +master keyrings. The collected keyrings are intended for publication, +including both active and expired (but not withdrawn) keys, and are +produced in the configured published key directory. + +If the current directory already contains a set of collected keyrings, any +keys on source keyrings newer than the appropriate collected keyring will +be re-imported to that collected keyring. In this way, collected keyrings +only grow; if a key must be removed from publication, delete the relevant +collected keyrings and they will be regenerated. + +=cut + +sub cmd_collect_keys { + assert_zone_argument_given_if_needed; + assert_config_set 'pkgconfdir', 'keypubdir'; + GetOptions() or command_usage_error; + + # Each per-project key ring depends on all pubring and oldring files in + # the project subtree, and the master key ring depends on all per-project + # key rings. Avoid doing more work than actually needed. + + mkdir_p $ZoneConfig{keypubdir}; + + my @project_dirs = grep_dir { -d _ } $ZoneConfig{pkgconfdir}; + + foreach my $project_dir (@project_dirs) { + my $project = (File::Spec->splitdir($project_dir))[-1]; + my $project_ring = File::Spec->catfile($ZoneConfig{keypubdir}, + $project.'.pub.ring.gpg'); + my $project_ring_timestamp = -e $project_ring ? (stat(_))[9] : 0; + my @new_keyrings = grep_subtree + { m/^(?:pub|old)ring\.gpg$/ && -f _ + && (((stat(_))[9]) > $project_ring_timestamp) } $project_dir; + + copy_gpg_keys $_, $project_ring for @new_keyrings; + } + + my $master_ring = + File::Spec->catfile($ZoneConfig{keypubdir}, 'pub.ring.gpg'); + my $master_ring_timestamp = -e $master_ring ? (stat(_))[9] : 0; + my @new_project_keyrings = grep_dir + { m/\.pub\.ring\.gpg$/ && -f _ + && (((stat(_))[9]) > $master_ring_timestamp)} $ZoneConfig{keypubdir}; + copy_gpg_keys $_, $master_ring for @new_project_keyrings; + + return 0; +} + +=head3 rebuild-key-index + +=over + +=item rebuild-key-index [--B] + +=back + +Scan the package configuration tree and index all active keyrings found. +Emits running progress reports if the C<--progress> option is given. + +=cut + +sub cmd_rebuild_key_index { + assert_zone_argument_given_if_needed; + assert_config_set 'pkgconfdir'; + my $show_progress = 0; + GetOptions(progress => \$show_progress) or command_usage_error; + + $| = 1; + + print 'scanning tree for keyrings... ' if $show_progress; + my @keyrings = + grep_subtree { m/^pubring\.gpg$/ && -f _ } $ZoneConfig{pkgconfdir}; + print "done\n" if $show_progress; + + { # backup the existing index; this should also preserve the old data in + # case the gatekeeper is holding the lock + my @dbfiles = + grep_dir { KEYIDX_NAME eq substr($_, 0, length(KEYIDX_NAME)) } + $ZoneConfig{pkgconfdir}; + + if (@dbfiles) { + print 'moving existing index to backup... ' if $show_progress; + foreach my $file (@dbfiles) + { rename $file, $file.'~' or die "rename $file for backup: $!" } + print "done\n" if $show_progress; + } + } + keyidx_attach; + + for (my $i = 0; $i <= $#keyrings; $i++) { + print "\rindexing keyrings... ", 1+$i, '/', 1+$#keyrings, ' ' + if $show_progress; + keyidx_store keys_from_keyring $keyrings[$i]; + } + print "done\n" if $show_progress; + + return 0; +} + +# ---------------------------------------- +# Command Dispatch +# ---------------------------------------- + +our $Command = shift; + +abort "keymaster.pl: no command given; try --help\n" + unless $Command; + +$Command =~ s/-/_/g; + +if (defined $::{'cmd_'.$Command}) + { eval { exit $::{'cmd_'.$Command}->() }; abort $@ } +else { + $Command =~ s/_/-/g; + abort "keymaster.pl: unknown command: $Command\n" +} + +__END__ + +=head1 AUTHORS + +Jacob Bachmeyer (jcb@gnu.org), with reference to older tools written by +Ward Vandewege (ward@gnu.org) and baughj or lacking authorship records. + +=head1 LICENSE + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . + +=cut diff --git a/testsuite/keymaster.all/10_basic.exp b/testsuite/keymaster.all/10_basic.exp new file mode 100644 index 0000000..f8da4f7 --- /dev/null +++ b/testsuite/keymaster.all/10_basic.exp @@ -0,0 +1,80 @@ +# Tests for keymaster command dispatch and scaffolding + +# Copyright (C) 2023 Jacob Bachmeyer +# +# This file is part of a testsuite for the GNU Secure Software Gatekeeper. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# ---------------------------------------- + +with_test_environment tenv "# no configuration" { + run_keymaster "no command" {2 {"no command given"}} $tenv + + run_keymaster "no config file" {2 {"read config"}} $tenv \ + --conf=bogus-file.conf + + run_keymaster "test --version" \ + {0 {{^keymaster \(GNU Secure Software Gatekeeper\)}}} $tenv \ + --version + + run_keymaster "test --help" \ + {0 {{--help.*Show general usage information} + {--version.*Show version information}}} $tenv \ + --help + + run_keymaster "bogus command" \ + {2 {"unknown command: bogus-command"}} $tenv \ + bogus-command + + run_keymaster "bogus command" \ + {2 {"unknown command: bogus-command"}} $tenv \ + --help bogus-command + + foreach command { + notify-email blacklist-email remove-email + register-key update-key withdraw-key + find-keys cleanup-keys collect-keys rebuild-key-index + } { + run_keymaster "test --help" \ + [list 0 [list "^\\s+${command}:\\s+${command}"]] $tenv \ + --help $command + } +} + +with_test_environment tenv "[]=bogus-configuration-item" { + run_keymaster "invalid configuration" \ + {2 {"unrecognized configuration line"}} $tenv +} + +with_test_environment tenv {# test configuration (for coverage) + \[zone.foo\] + pkgconfdir = abc + + \[zone.bar\] + pkgconfdir = def + + \[zone.foo\] + pkgstatedir = ghi + + \[zone.bar\] + pkgstatedir = jkl +} { + run_keymaster "no command with zones enabled (code coverage)" \ + {2 {"no command given"}} $tenv +} + +# ---------------------------------------- + +# EOF diff --git a/testsuite/keymaster.all/11_email.exp b/testsuite/keymaster.all/11_email.exp new file mode 100644 index 0000000..756671f --- /dev/null +++ b/testsuite/keymaster.all/11_email.exp @@ -0,0 +1,274 @@ +# Tests for manipulations of email address lists + +# Copyright (C) 2023 Jacob Bachmeyer +# +# This file is part of a testsuite for the GNU Secure Software Gatekeeper. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# ---------------------------------------- + +array set configuration_file { + plain {# test configuration + pkgconfdir = [file join $tenv packages] + } + missing-blacklist {# test configuration + pkgconfdir = [file join $tenv packages] + + \[email\] + } + blacklist {# test configuration + pkgconfdir = [file join $tenv packages] + + \[email\] + blacklist = [file join $tenv email.blacklist] + } +} + +with_test_environment tenv $configuration_file(plain) { + run_keymaster "blacklist-email: blacklist not configured" \ + {2 {"blacklist not configured"}} $tenv \ + blacklist-email foo@example.org + run_keymaster "remove-email: blacklist not configured" \ + {2 {"blacklist not configured"}} $tenv \ + remove-email --blacklist foo@example.org +} + +with_test_environment tenv $configuration_file(missing-blacklist) { + run_keymaster "blacklist-email: blacklist not configured" \ + {2 {"blacklist not configured"}} $tenv \ + blacklist-email foo@example.org + run_keymaster "remove-email: blacklist not configured" \ + {2 {"blacklist not configured"}} $tenv \ + remove-email --blacklist foo@example.org +} + +with_test_environment tenv $configuration_file(plain) { + foreach command {notify-email blacklist-email remove-email} { + run_keymaster "$command: unknown option" \ + {2 {{^Unknown option:}}} $tenv \ + $command --bogus-argument-for-testing-error + } +} + +with_test_environment tenv "# empty" { + foreach command {notify-email remove-email} { + run_keymaster "$command: missing pkgconfdir" \ + {2 {"pkgconfdir not set"}} $tenv \ + $command foo foo@example.org + } +} + +# ---------------------------------------- +# notify-email and remove-email + +do_package_test "notify-email: create list (and package)" \ + $configuration_file(plain) { + expecting {0 {{^$}}} run { notify-email foo quux@example.org } + yields { + foo { email { quux@example.org } } + } + } + +do_package_test "notify-email: create subdir email list" \ + $configuration_file(plain) { + packages { + foo { email { quux@example.org } } + } + + expecting {0 {{^$}}} run { notify-email foo/bar quux@example.net } + + yields { + foo { email { quux@example.org } } + foo/bar { email { quux@example.net } } + } + } + +do_package_test "notify-email: add duplicate address" \ + $configuration_file(plain) { + packages { + foo { email { quux@example.org } } + foo/bar { email { quux@example.net } } + } + + expecting {0 {{^$}}} run { notify-email foo quux@example.org } + + yields { + foo { email { quux@example.org } } + foo/bar { email { quux@example.net } } + } + } + +do_package_test "notify-email: add new address" \ + $configuration_file(plain) { + packages { + foo { email { quux@example.org } } + foo/bar { email { quux@example.net } } + } + + expecting {0 {{^$}}} run { notify-email foo bax@example.org } + + yields { + foo { email { quux@example.org bax@example.org } } + foo/bar { email { quux@example.net } } + } + } + +do_package_test "remove-email: remove last address in subdir" \ + $configuration_file(plain) { + packages { + foo { email { quux@example.org } } + foo/bar { email { quux@example.net } } + } + + expecting {0 {{^$}}} run { remove-email foo/bar quux@example.net } + + yields { + foo { email { quux@example.org } } + foo/bar { email { } } + } + } + +do_package_test "remove-email: remove redundant address" \ + $configuration_file(plain) { + packages { + foo { email { quux@example.org } } + foo/bar { email { quux@example.org } } + } + + expecting {0 {{also listed in}}} + run { remove-email foo/bar quux@example.org } + + yields { + foo { email { quux@example.org } } + foo/bar { email { } } + } + } + +do_package_test "remove-email: remove non-existent address" \ + $configuration_file(plain) { + packages { + foo { email { quux@example.org } } + foo/bar { email { quux@example.net } } + } + + expecting {0 {{address quux@example.com not found}}} + run { remove-email foo/bar quux@example.com } + + yields { + foo { email { quux@example.org } } + foo/bar { email { quux@example.net } } + } + } + +do_package_test "remove-email: remove address actually on parent directory" \ + $configuration_file(plain) { + packages { + foo { email { quux@example.org } } + foo/bar { email { quux@example.net } } + } + + expecting {0 {{address quux@example.org not found} + {also listed in}}} + run { remove-email foo/bar quux@example.org } + + yields { + foo { email { quux@example.org } } + foo/bar { email { quux@example.net } } + } + } + +# ---------------------------------------- +# blacklist-email and remove-email --blacklist + +with_test_environment tenv $configuration_file(blacklist) { + run_keymaster "email blacklist: create file" {0 {{^$}}} $tenv \ + blacklist-email foo@example.org + + check_list_file_contents "email blacklist: create file" \ + [file join $tenv email.blacklist] { + foo@example.org + } +} + +with_test_environment tenv $configuration_file(blacklist) { + put_file [file join $tenv email.blacklist] \ + "foo@example.org\n" + + run_keymaster "email blacklist: add address" {0 {{^$}}} $tenv \ + blacklist-email bar@example.org + + check_list_file_contents "email blacklist: add address" \ + [file join $tenv email.blacklist] { + foo@example.org bar@example.org + } + +} + +with_test_environment tenv $configuration_file(blacklist) { + put_file [file join $tenv email.blacklist] \ + "foo@example.org\n" + + run_keymaster "email blacklist: add duplicate address" \ + {0 {{^$}}} $tenv \ + blacklist-email foo@example.org + + check_list_file_contents "email blacklist: add duplicate address" \ + [file join $tenv email.blacklist] { + foo@example.org + } + +} + +with_test_environment tenv $configuration_file(blacklist) { + put_file [file join $tenv email.blacklist] \ + "foo@example.org\nbar@example.org\n" + + run_keymaster "email blacklist: remove address" {0 {{^$}}} $tenv \ + remove-email --blacklist foo@example.org + + check_list_file_contents "email blacklist: remove address" \ + [file join $tenv email.blacklist] { + bar@example.org + } + +} + +with_test_environment tenv $configuration_file(blacklist) { + put_file [file join $tenv email.blacklist] \ + "foo@example.org\n" + + run_keymaster "email blacklist: remove non-existent address" \ + {0 {{address bar@example.org not found}}} $tenv \ + remove-email --blacklist bar@example.org + + check_list_file_contents "email blacklist: remove non-existent address" \ + [file join $tenv email.blacklist] { + foo@example.org + } +} + +with_test_environment tenv $configuration_file(blacklist) { + put_file [file join $tenv email.blacklist] "foo@example.org\n" + + run_keymaster "email blacklist: remove last address" {0 {{^$}}} $tenv \ + remove-email --blacklist foo@example.org + + check_list_file_contents "email blacklist: remove last address" \ + [file join $tenv email.blacklist] { } +} + +# ---------------------------------------- + +#EOF diff --git a/testsuite/keymaster.all/12_keys.exp b/testsuite/keymaster.all/12_keys.exp new file mode 100644 index 0000000..90f9e70 --- /dev/null +++ b/testsuite/keymaster.all/12_keys.exp @@ -0,0 +1,849 @@ +# Tests for manipulations of keyrings + +# Copyright (C) 2023 Jacob Bachmeyer +# +# This file is part of a testsuite for the GNU Secure Software Gatekeeper. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# ---------------------------------------- + +array set configuration_file { + plain {# test configuration + pkgconfdir = [file join $tenv packages] + keypubdir = [file join $tenv keyrings] + } +} + +# ---------------------------------------- + +with_test_environment tenv $configuration_file(plain) { + foreach command { + register-key update-key withdraw-key + find-keys cleanup-keys collect-keys rebuild-key-index + } { + run_keymaster "$command: unknown option" {2 {{^Unknown option:}}} $tenv \ + $command --bogus-argument-for-testing-error + } +} + +with_test_environment tenv "# empty" { + foreach command { + register-key update-key withdraw-key + } { + run_keymaster "$command: missing pkgconfdir" \ + {2 {"pkgconfdir not set"}} $tenv $command foo 1234 + } + + run_keymaster "find-keys: missing pkgconfdir" \ + {2 {"pkgconfdir not set"}} $tenv find-keys 1234 + + foreach command { + cleanup-keys collect-keys rebuild-key-index + } { + run_keymaster "$command: missing pkgconfdir" \ + {2 {"pkgconfdir not set"}} $tenv $command + } +} + +# ---------------------------------------- +# register-key + +do_package_test "register-key: add first key" $configuration_file(plain) { + packages { foo { email { quux@example.org } } } + + keyfile bar.key + keys { { id 1001 name "bar " } } + + expecting {0 {{^$}}} run { register-key foo bar.key } + + yields { + foo { + email { quux@example.org } + keys { { id 1001 name "bar " } } + } + } +} + +do_package_test "register-key: add second key" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { { id 1001 name "bar " } } + } + } + + keyfile baz.key + keys { { id 1002 name "baz " } } + + expecting {0 {{^$}}} run { register-key foo baz.key } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + } +} + +do_package_test "register-key: add subdir key" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + } + + keyfile quux.key + keys { { id 1003 name "quux " } } + + expecting {0 {{^$}}} run { register-key foo/quux quux.key } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + } +} + +do_package_test "register-key: add key with subkey" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { { id 1001 name "bar " } } + } + } + + keyfile baz.key + keys { + { id 1002 name "baz " } + { id 2002 name "baz " subkey-of 1002 } + } + + expecting {0 {{^$}}} run { register-key foo/baz baz.key } + + yields { + foo { + email { quux@example.org } + keys { { id 1001 name "bar " } } + } + foo/baz { + keys { + { id 1002 name "baz " } + { id 2002 name "baz " subkey-of 1002 } + } + } + } +} + +# ---------------------------------------- +# update-key + +do_package_test "update-key: reject missing file" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { { id 1001 name "bar " } } + } + } + + expecting {2 {"does not exist"}} + run { update-key foo.key } + + yields { + foo { + email { quux@example.org } + keys { { id 1001 name "bar " } } + } + } +} + +do_package_test "update-key: reject multiple keys" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { { id 1001 name "bar " } } + } + } + + keyfile barbaz.key + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + + expecting {2 {"contains multiple keys"}} + run { update-key barbaz.key } + + yields { + foo { + email { quux@example.org } + keys { { id 1001 name "bar " } } + } + } +} + +do_package_test "update-key: add subkey" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + + keyfile bazsub.key + keys { + { id 1002 name "baz " } + { id 2002 name "baz " subkey-of 1002 } + } + + expecting {0 {{^$}}} run { update-key bazsub.key } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + { id 2002 name "baz " subkey-of 1002 } + } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { + { id 1002 name "baz " } + { id 2002 name "baz " subkey-of 1002 } + } + } + } +} + +do_package_test "update-key: revocation" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + + keyfile revbar.key + keys { { id 1001 name "bar " is revoked } } + + expecting {0 {{^$}}} run { update-key revbar.key } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " is revoked } + { id 1002 name "baz " } + } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " is revoked } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } +} + +# ---------------------------------------- +# withdraw-key + +do_package_test "withdraw-key: error: not known" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + } + + expecting {2 {"key fingerprint" "not known"}} + run { withdraw-key foo/quux 0000000000000000000000000000000000001006 } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + } +} + +do_package_test "withdraw-key: error: not found" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + } + + expecting {2 {"key fingerprint" "not found in foo/quux"}} + run { withdraw-key foo/quux 0000000000000000000000000000000000001001 } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + } +} + +do_package_test "withdraw-key: only occurrence" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + } + + expecting {0 {{^$}}} + run { withdraw-key foo/quux 0000000000000000000000000000000000001003 } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + } + yields-old-keys { + foo/quux { { id 1003 name "quux " } } + } +} + +do_package_test "withdraw-key: other places remain" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + + expecting {0 {{^$}}} + run { withdraw-key foo 0000000000000000000000000000000000001002 } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + yields-old-keys { + foo { { id 1002 name "baz " } } + } +} + +# ---------------------------------------- +# find-keys + +do_package_test "find-keys" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + + expecting {0 + { {fingerprint 0{36}1001:[\r\n\s]+[+] bar } + {(?x)[\r\n\s]+Permit[^:]+:[\r\n\s]+ + -\sfoo[\r\n\s]+-\sbar[\r\n\s]+} + {fingerprint 0{36}1002:[\r\n\s]+[+] baz } + {(?x)[\r\n\s]+Permit[^:]+:[\r\n\s]+ + -\sfoo[\r\n\s]+-\sbaz[\r\n\s]+} + {fingerprint 0{36}1003:[\r\n\s]+[+] quux } + {(?x)[\r\n\s]+Permit[^:]+:[\r\n\s]+ + -\sfoo/quux[\r\n\s]+} + }} run { find-keys 0000 } + + expecting {0 + { {fingerprint 0{36}1002:[\r\n\s]+[+] baz } + {(?x)[\r\n\s]+Permit[^:]+:[\r\n\s]+ + -\sfoo[\r\n\s]+-\sbaz[\r\n\s]+} + {fingerprint 0{36}1003:[\r\n\s]+[+] quux } + {(?x)[\r\n\s]+Permit[^:]+:[\r\n\s]+ + -\sfoo/quux[\r\n\s]+} + }} run { find-keys 1002 00001003 } + + expecting {0 + { {fingerprint 0{36}1001:[\r\n\s]+[+] bar } + {(?x)[\r\n\s]+Permit[^:]+:[\r\n\s]+ + -\sfoo[\r\n\s]+-\sbar[\r\n\s]+} + }} run { find-keys 0000000000000000000000000000000000001001 } +} + +do_package_test "find-keys" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + { id 2002 name "baz " subkey-of 1002 } + } + } + } + + expecting {0 + { {fingerprint 0{36}1001:[\r\n\s]+[+] bar } + {(?x)[\r\n\s]+Permit[^:]+:[\r\n\s]+ + -\sfoo[\r\n\s]+} + {fingerprint 0{36}1002:[\r\n\s]+[+] baz } + {(?x)[\r\n\s]+Permit[^:]+:[\r\n\s]+ + -\sfoo[\r\n\s]+} + {subkey fingerprint 0{36}2002[\r\n\s]+of primary[^0]+0{36}1002:} + }} run { find-keys 0000 } + +} + +# ---------------------------------------- +# cleanup-keys + +do_package_test "cleanup-keys: nothing to do" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + + expecting {0 {{^$}}} run { cleanup-keys } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } +} + +do_package_test "cleanup-keys: move expired key" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " expired "1 week ago" } + { id 1002 name "baz " } + } + } + bar { + email { bar@example.org } + keys { + { id 1001 name "bar " expired "1 week ago" } + } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + + expecting {0 {{^$}}} run { cleanup-keys } + + yields { + foo { + email { quux@example.org } + keys { { id 1002 name "baz " } } + } + bar { + email { bar@example.org } + keys { } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + yields-old-keys { + foo { { id 1001 name "bar " expired "1 week ago" } } + bar { { id 1001 name "bar " expired "1 week ago" } } + } +} + +do_package_test "cleanup-keys: move revoked key" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " is revoked } + { id 1002 name "baz " } + } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " is revoked } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + + expecting {0 {{^$}}} run { cleanup-keys } + + yields { + foo { + email { quux@example.org } + keys { { id 1002 name "baz " } } + } + bar { + email { bar@example.org } + keys { } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + yields-old-keys { + foo { { id 1001 name "bar " is revoked } } + bar { { id 1001 name "bar " is revoked } } + } +} + +do_package_test "cleanup-keys: move revoked key with colliding short ID" \ + $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 00001001 name "bar " is revoked } + { id 100001001 name "foo " } + } + } + } + + expecting {0 {{^$}}} run { cleanup-keys } + + yields { + foo { + email { quux@example.org } + keys { + { id 100001001 name "foo " } + } + } + } + yields-old-keys { + foo { { id 1001 name "bar " is revoked } } + } + } +# A similar test for colliding long keyID values is not possible because +# the mock GPG infrastructure assumes that long keyID values are unique. + +# ---------------------------------------- +# collect-keys + +do_package_test "collect-keys: basic" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + package-old-keys { + foo { { id 1000 name "quux " } } + } + + expecting {0 {{^$}}} run { collect-keys } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + yields-old-keys { + foo { { id 1000 name "quux " } } + } + + yields-collected-keys { + foo { + { id 1000 name "quux " } + { id 1001 name "bar " } + { id 1002 name "baz " } + { id 1003 name "quux " } + } + bar { { id 1001 name "bar " } } + baz { { id 1002 name "baz " } } + } +} + +# ---------------------------------------- +# rebuild-key-index + +do_package_test "rebuild-key-index: simple" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + + expecting {0 {{^$}}} run { rebuild-key-index } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } +} + +do_package_test "rebuild-key-index: progress" $configuration_file(plain) { + packages { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } + + expecting {0 + { {scanning tree for keyrings....done} + {moving existing index to backup....done} + {indexing keyrings....1/4} {indexing keyrings....2/4} + {indexing keyrings....3/4} {indexing keyrings....4/4 done} + }} run { rebuild-key-index --progress } + + yields { + foo { + email { quux@example.org } + keys { + { id 1001 name "bar " } + { id 1002 name "baz " } + } + } + foo/quux { + keys { { id 1003 name "quux " } } + } + bar { + email { bar@example.org } + keys { { id 1001 name "bar " } } + } + baz { + email { baz@example.org } + keys { { id 1002 name "baz " } } + } + } +} + +# ---------------------------------------- + +#EOF diff --git a/testsuite/lib/exec/sdbmdump.pl b/testsuite/lib/exec/sdbmdump.pl new file mode 100755 index 0000000..7fc5074 --- /dev/null +++ b/testsuite/lib/exec/sdbmdump.pl @@ -0,0 +1,47 @@ +#!/usr/bin/perl +# -*- CPerl -*- + +# Copyright (C) 2023 Jacob Bachmeyer +# +# This file is part of a testsuite for the GNU Secure Software Gatekeeper. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +use strict; +use warnings; + +# Simple SDBM dump tool; accepts a filename on the command line. + +use Fcntl; +use SDBM_File; + +if (@ARGV != 1) { + print STDERR "usage: sdbmdump.pl \n"; + exit 2; +} + +my $DB_File = shift; +my %DB; + +tie %DB, 'SDBM_File', $DB_File, O_RDONLY, 0 + or die "tie SDBM $DB_File to hash: $!"; + +foreach my $key (sort keys %DB) + { print "$key:\n $DB{$key}\n" } + +untie %DB; + +exit 0; + +__END__ diff --git a/testsuite/lib/exec/sdbmload.pl b/testsuite/lib/exec/sdbmload.pl new file mode 100755 index 0000000..0b4235c --- /dev/null +++ b/testsuite/lib/exec/sdbmload.pl @@ -0,0 +1,61 @@ +#!/usr/bin/perl +# -*- CPerl -*- + +# Copyright (C) 2023 Jacob Bachmeyer +# +# This file is part of a testsuite for the GNU Secure Software Gatekeeper. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +use strict; +use warnings; + +# Simple SDBM load tool; accepts a filename on the command line and prompts +# for key-value pairs from STDIN. + +use Fcntl; +use SDBM_File; + +if (@ARGV != 1) { + print STDERR "usage: sdbmload.pl \n"; + exit 2; +} + +my $DB_File = shift; +my %DB; + +tie %DB, 'SDBM_File', $DB_File, O_RDWR | O_CREAT, 0666 + or die "tie SDBM $DB_File to hash: $!"; + +$| = 1; + +print STDOUT "Key> " if -t; +while () { + chomp; + last if $_ eq ''; + + my $key = $_; + print STDOUT "Value> " if -t; + my $value = ; + chomp $value; + + $DB{$key} = $value; + print STDOUT "Key> " if -t; +} + +untie %DB; + +exit 0; + +__END__ diff --git a/testsuite/lib/keyindex.exp b/testsuite/lib/keyindex.exp new file mode 100644 index 0000000..b38b329 --- /dev/null +++ b/testsuite/lib/keyindex.exp @@ -0,0 +1,176 @@ +# DejaGnu library file for PGP key index facility + +# Copyright (C) 2023 Jacob Bachmeyer +# +# This file is part of a testsuite for the GNU Secure Software Gatekeeper. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +# Generate an association list mapping mid-level database keys to sets of +# values for the keys described in a package configuration description. +# The order of the entries in the returned list is not significant, nor is +# the order of the entries in a set significant. +# +# Call as: +# index_packlist_keys { +# some-package-name { +# ... +# keys { } +# } +# some-package-name/subdir { ... } +# } +proc index_packlist_keys { packlist } { + array set index { __index_format_revision 1 } + + foreach { packdir data } $packlist { + array unset packset + array set packset { keys {} } + array set packset $data + + foreach keycell $packset(keys) { + array unset keyrec + array set keyrec $keycell + set fpr [string toupper [format {%040s} $keyrec(id)]] + + lappend index(Li[string range $fpr 32 end]) $fpr + lappend index(Li[string range $fpr 24 end]) $fpr + if { [info exists keyrec(subkey-of)] } { + set index(kf${fpr}) \ + [string toupper [format {%040s} $keyrec(subkey-of)]] + lappend index(Kf[string toupper \ + [format {%040s} $keyrec(subkey-of)]]) $fpr + } else { + set index(kf${fpr}) $fpr + lappend index(Df${fpr}) $packdir + lappend index(Uf${fpr}) $keyrec(name) + if { [regexp {<([^@]+@[^>]+)>$} $keyrec(name) -> email] } { + lappend index(Ef${fpr}) $email + } + } + } + } + + array set dedup {} + array set result {} + foreach key [array names index] { + if { [llength $index($key)] > 1 } { + foreach item $index($key) { + if { ![info exists dedup($key,$item)] } { + set dedup($key,$item) 1 + lappend result($key) $item + } + } + } else { + set result($key) $index($key) + } + } + + return [array get result] +} + +# Read the given key index database and verify that it describes the keys +# in the provided package configuration description. +proc check_key_index { testname indexname packlist } { + global PERL + + set runcmd \ + [list spawn $PERL \ + [testsuite file -source -top lib exec sdbmdump.pl] $indexname] + verbose -log $runcmd + eval $runcmd + + expect { + -re {^([^:]+):\r*\n[[:space:]]+([^\r\n]+)\r*\n} { + set key $expect_out(1,string) + set value $expect_out(2,string) + + if { [regexp {^([[:upper:]].[[:xdigit:]]+)-([[:digit:]]+)?$} \ + $key -> basekey seq] } { + # one item from a set + lappend have_index($basekey) $value + } else { + # unique entry, not part of a set + set have_index($key) $value + } + + exp_continue + } + eof { wait } + } + + array set want_index [index_packlist_keys $packlist] + + set have_keys [lsort [array names have_index]] + set want_keys [lsort [array names want_index]] + + if { $have_keys ne $want_keys } { + # test failed with early bailout + verbose -log "key list mismatch" + verbose -log " want: $want_keys" + verbose -log " have: $have_keys" + fail $testname + return + } + + set result pass + foreach key $want_keys { + if { [lsort $want_index($key)] ne [lsort $have_index($key)] } { + set result fail + verbose -log "value mismatch at key $key" + verbose -log " want: $want_index($key)" + verbose -log " have: $have_index($key)" + } + } + + $result $testname +} + +# Store key index information according to the provided package +# configuration description. +proc write_key_index { indexname packlist } { + global PERL + + array set index [index_packlist_keys $packlist] + + set runcmd \ + [list spawn $PERL \ + [testsuite file -source -top lib exec sdbmload.pl] $indexname] + verbose -log $runcmd + eval $runcmd + + foreach key [lsort [array names index]] { + if { [regexp {^[[:upper:]]} $key] } { + # store list value + for { set i 0 } { $i < [llength $index($key)] } { incr i } { + set item [lindex $index($key) $i] + expect -ex "Key> " { send "${key}-$i" } + expect -ex "${key}-$i" { send "\n" } + expect -ex "Value> " { send $item } + expect -ex $item { send "\n" } + expect -ex "\n" + } + } else { + # store scalar value + expect -ex "Key> " { send $key } + expect -ex $key { send "\n" } + expect -ex "Value> " { send $index($key) } + expect -ex $index($key) { send "\n" } + expect -ex "\n" + } + } + + close +} + +#EOF diff --git a/testsuite/lib/keymaster.exp b/testsuite/lib/keymaster.exp new file mode 100644 index 0000000..9a10872 --- /dev/null +++ b/testsuite/lib/keymaster.exp @@ -0,0 +1,364 @@ +# DejaGnu tool init file for GNU Secure Software Gatekeeper admin tool + +# Copyright (C) 2021, 2022, 2023 Jacob Bachmeyer +# +# This file is part of a testsuite for the GNU Secure Software Gatekeeper. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +set KEYMASTER_TOOL [file join $srcdir keymaster.pl] +if { ! [info exists PERL] } { set PERL perl } +if { ! [info exists CHECK_COVERAGE] } { set CHECK_COVERAGE no } + +set TEST_BASE [file join \ + [file dirname [testsuite file -object -top]] test.tmp] +set TENV_STEM [file join $TEST_BASE tenv] + +# invoked by DejaGnu framework when a failure is recorded +proc keymaster_count_failures { args } { + global keymaster_failure_count + incr keymaster_failure_count +} +set local_record_procs(fail) keymaster_count_failures + +proc get_file { file } { + set chan [open $file r] + set ret [read -nonewline $chan] + close $chan + return $ret +} +proc put_file { file string } { + set chan [open $file w] + puts -nonewline $chan $string + close $chan +} +proc age_file { file to } { + file mtime $file [clock scan $to] +} + +proc new_work_area { stem } { + set count 1 + set name "${stem}.1" + while { [file exists $name] } { + incr count + set name "${stem}.${count}" + } + + return $name +} + +proc new_test_environment { } { + global TENV_STEM + set name [new_work_area $TENV_STEM] + + global keymaster_failure_count + set keymaster_failure_count 0 + + make_test_environment $name + return $name +} +proc close_test_environment { name } { + global keymaster_failure_count + # delete the environment iff no tests failed + if { $keymaster_failure_count == 0 } { + file delete -force -- $name + } +} + +proc write_test_config { base_dir config } { + put_file [file join $base_dir test.conf] \ + [regsub -all -line -- {^[ \t]+} [uplevel 1 subst [list $config]] ""] +} + +proc make_test_environment { base_dir } { + file mkdir $base_dir + file mkdir [file join $base_dir packages] +} + +proc with_test_environment { env_name config body } { + upvar 1 $env_name test_env + + set test_env [new_test_environment] + + uplevel 1 [list write_test_config $test_env $config] + + uplevel 1 $body + + close_test_environment $test_env + + verbose -log " [string repeat - 40]" +} + +load_lib mockgpg.exp +load_lib keyindex.exp + +# make_test_keyrings /some/dir/some/where { +# some-package-name { +# { id +# name [is ] +# subkey-of +# expires }... +# } +# some-package-name/po { +# +# } +# } +proc make_test_keyrings { base_dir keylist } { + # file names could be properly split, instead of relying on passed in + # slashes being correct for writing the file, but this is unlikely to + # ever run on a non-POSIX system, and they are correct on POSIX + foreach { package keys } $keylist { + file mkdir [file join $base_dir packages $package] + write_test_keyring \ + [file join $base_dir packages $package pubring.gpg] $keys + } +} + +# register_test_packages /some/dir/some/where { +# some-package-name { +# email { ... } +# keys { +# +# } +# maintainers { ">... } +# } +# ... +# } +proc register_test_packages { base_dir packlist } { + set havekeys no + foreach { package info } $packlist { + file mkdir [file join $base_dir packages $package] + foreach { element value } $info { switch $element { + email { + set c [open [file join $base_dir packages $package email] w] + foreach address $value { puts $c $address } + close $c + } + keys { + write_test_keyring \ + [file join $base_dir packages $package pubring.gpg] $value + set havekeys yes + } + maintainers { + set c [open [file join $base_dir m.bypkg] a] + puts -nonewline $c [format "%s - " $package] + puts $c [join $value ", "] + close $c + } + } } + } + if { $havekeys } { + write_key_index [file join $base_dir packages keyindex] $packlist + } +} + +proc run_keymaster { test expected base_dir args } { + global spawn_id + global KEYMASTER_TOOL PERL CHECK_COVERAGE + + # stabilize test names by inverting name mapping from do_package_test + if { [uplevel {array exists filemap}] } { + foreach { key value } [uplevel {array get filemap}] { + set invfilemap($value) $key + } + foreach arg $args { + if { [info exists invfilemap($arg)] } { + lappend name_args $invfilemap($arg) + } else { + lappend name_args $arg + } + } + } else { + set name_args $args + } + + lappend res + set runcmd [list spawn $PERL] + if { $CHECK_COVERAGE } { + lappend runcmd -MDevel::Cover=-silent,1 + } + lappend runcmd $KEYMASTER_TOOL \ + --config [file normalize [file join $base_dir test.conf]] \ + --with-gpg=[testsuite file -source -top lib exec mockgpg] + verbose -log "$runcmd $args" + eval $runcmd $args + # collect any output produced + set output "" + expect { + -re {.+} { + append output $expect_out(buffer) + exp_continue + } + eof + } + set res [wait] + + set expected_ret [lindex $expected 0] + + set result unresolved + append test ": run: keymaster $name_args" + + if { [lindex $res 2] ne 0 } { + verbose -log "wait returned: $res" + set result unresolved + } elseif { [lindex $res 3] eq $expected_ret } { + set result pass + } else { + verbose -log "unexpected return code from keymaster; \ + want $expected_ret; have [lindex $res 3]" + set result fail + } + + if { [llength $expected] > 1 } { + foreach pattern [lindex $expected 1] { + if { ![regexp -- $pattern $output] } { + verbose -log "expected re {$pattern} did not match output" + set result fail + } + } + } + + $result $test +} + +proc check_list_file_contents { test file items } { + lappend linelist + set chan [open $file] + while { [gets $chan line] >= 0 } { lappend linelist $line } + close $chan + + if { [lsort $items] eq [lsort $linelist] } { + pass $test + } else { + verbose -log "sorted list mismatch\n \ + want: [lsort $items]\n \ + have: [lsort $linelist]" + fail $test + } +} + +# analyze_test_packages "test name" /some/dir/some/where { +# some-package-name { +# email { ... } +# keys { +# +# } +# } +# some-package-name/subdir { ... } +# ... +# } +proc analyze_test_packages { testname base_dir packlist } { + foreach { package info } $packlist { + foreach { element value } $info { switch $element { + email { + check_list_file_contents "$testname: email for $package" \ + [file join $base_dir packages $package email] $value + } + keys { + check_test_keyring "$testname: keys for $package" \ + [file join $base_dir packages $package pubring.gpg] $value + } + } } + } + if { [file exists [file join $base_dir packages keyindex.flag]] } { + check_key_index "$testname: key index contents" \ + [file join $base_dir packages keyindex] $packlist + } +} + +# analyze_collected_keys "test name" /some/dir/some/where { +# some-package-name { } +# another-package { } +# } +proc analyze_collected_keys { testname base_dir keymap } { + foreach { package keys } $keymap { + check_test_keyring "$testname: collected keys for $package" \ + [file join $base_dir keyrings "${package}.pub.ring.gpg"] $keys + foreach key $keys { set dedup([lsort $key]) $key } + } + foreach { tag key } [array get dedup] { lappend allkeys $key } + check_test_keyring "$testname: collected master keyring" \ + [file join $base_dir keyrings pub.ring.gpg] $allkeys +} + +proc do_package_test { testname config infolist } { + with_test_environment tenv $config { + foreach { tag data } $infolist { + switch -- $tag { + packages { register_test_packages $tenv $data } + yields { analyze_test_packages $testname $tenv $data } + + keyfile { + set filemap($data) [file join $tenv $data] + set keyfile $filemap($data) + } + keys { write_test_keyring $keyfile $data } + + expecting { set expected $data } + run { + set args [list] + foreach arg $data { + if { [info exists filemap($arg)] } { + lappend args $filemap($arg) + } else { + lappend args $arg + } + } + eval [list run_keymaster $testname $expected $tenv] $args + } + + package-old-keys { + foreach { package keys } $data { + write_test_keyring \ + [file join $tenv packages $package oldring.gpg] \ + $keys + } + } + package-collected-keys { + foreach { package keys } $data { + write_test_keyring \ + [file join $tenv keyrings \ + "${package}.pub.ring.gpg"] $keys + } + } + yields-old-keys { + foreach { package keys } $data { + check_test_keyring "$testname: old keys for $package" \ + [file join $tenv packages $package oldring.gpg] \ + $keys + } + } + yields-collected-keys { + analyze_collected_keys $testname $tenv $data + } + + default { error "unknown tag: $tag" } + } + } + } +} + +proc keymaster_exit {} { + # clean up test environment tree + global TEST_BASE + catch {file delete -- $TEST_BASE} +} +proc keymaster_version {} { + global KEYMASTER_TOOL PERL + + puts "" + exec -- $PERL $KEYMASTER_TOOL --version >@ stdout +} + +#EOF