--- /dev/null
+#!/usr/bin/perl
+# I like -*- CPerl -*- mode. -- jcb
+
+use strict;
+use warnings;
+
+use constant VERSION_MESSAGE => <<EOM;
+keymaster (GNU Secure Software Gatekeeper) 0.0-pre
+Copyright (C) 2023 Jacob Bachmeyer
+License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>
+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<help> [I<command>]
+
+keymaster.pl --B<version>
+
+keymaster.pl [-B<c> I<file>] [-B<z> I<zone>] I<command> I<[options]>
+
+keymaster.pl [--B<conf> I<file>] [--B<zone> I<zone>] I<command> I<[options]>
+
+keymaster.pl B<notify-email> I<directory> I<email>...
+
+keymaster.pl B<blacklist-email> I<email>...
+
+keymaster.pl B<remove-email> I<directory> I<email>...
+
+keymaster.pl B<remove-email> --B<blacklist> I<email>...
+
+keymaster.pl B<register-key> I<directory> I<keyfile>...
+
+keymaster.pl B<update-key> I<keyfile>
+
+keymaster.pl B<withdraw-key> I<directory> I<fingerprint>
+
+keymaster.pl B<find-keys> I<ID-or-fingerprint-fragment>...
+
+keymaster.pl B<cleanup-keys>
+
+keymaster.pl B<collect-keys>
+
+keymaster.pl B<rebuild-key-index> [--B<progress>]
+
+=head1 OPTIONS
+
+=over
+
+=item B<--help>
+
+Show general usage information and exit.
+
+=item B<--help> I<command>
+
+Show help for COMMAND and exit.
+
+=item B<--version>
+
+Show version information and exit.
+
+=item B<--conf> I<file>
+
+=item B<--config> I<file>
+
+=item B<--configfile> I<file>
+
+Specify alternate configuration file. Default is C<gatekeeper.conf> 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<keymaster> 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<grep_subtree>.
+
+=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<mkdir_p> 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<flock> 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 EfE<lt>I<PGP primary key fingerprint>E<gt>
+
+Set of email addresses associated with a PGP key, by primary key
+fingerprint. These are indexed separately for use by the gatekeeper.
+
+=item UfE<lt>I<PGP primary key fingerprint>E<gt>
+
+Set of user-id strings associated with a PGP key, by primary key
+fingerprint. These include the email addresses.
+
+=item DfE<lt>I<PGP primary key fingerprint>E<gt>
+
+Set of directories containing active keyrings (C<pubring.gpg>) containing
+copies of a PGP key, by primary key fingerprint.
+
+=item kfE<lt>I<PGP key fingerprint>E<gt>
+
+Primary PGP key fingerprint for a PGP subkey, by subkey fingerprint.
+Primary keys are also indexed here, pointing to thier own fingerprints.
+
+=item KfE<lt>I<PGP primary key fingerprint>E<gt>
+
+Set of subkey fingerprints associated with a PGP key, by primary key
+fingerprint.
+
+=item LiE<lt>I<PGP key ID>E<gt>
+
+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<resolve_split_name>.
+
+=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<resolve_split_name>.
+
+=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<resolve_split_name>.
+
+=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<spawn_gpg> and C<close_gpg> 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<spawn_gpg> 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 ... --export I<fingerprints> | 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<directory> I<email>...
+
+=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<email>...
+
+=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<directory> I<email>...
+
+=item remove-email --blacklist I<email>...
+
+=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<directory> I<keyfile>...
+
+=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<keyfile>
+
+=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<gpg --import> 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<directory> I<fingerprint>
+
+Immediately transfer the key with FINGERPRINT from the active keyring
+(C<pubring.gpg>) to the archival keyring (C<oldring.gpg>) 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<key-ID-or-fingerprint-fragment>...
+
+=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<pubring.gpg>) that have expired or been revoked. Transfer these keys to
+archival keyrings (C<oldring.gpg>) 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<progress>]
+
+=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 <http://www.gnu.org/licenses/>.
+
+=cut
--- /dev/null
+# 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 <http://www.gnu.org/licenses/>.
+
+# ----------------------------------------
+
+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 <bar@example.org>" } }
+
+ expecting {0 {{^$}}} run { register-key foo bar.key }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ }
+}
+
+do_package_test "register-key: add second key" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ }
+
+ keyfile baz.key
+ keys { { id 1002 name "baz <baz@example.org>" } }
+
+ expecting {0 {{^$}}} run { register-key foo baz.key }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ }
+}
+
+do_package_test "register-key: add subdir key" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ }
+
+ keyfile quux.key
+ keys { { id 1003 name "quux <quux@example.org>" } }
+
+ expecting {0 {{^$}}} run { register-key foo/quux quux.key }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ }
+}
+
+do_package_test "register-key: add key with subkey" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ }
+
+ keyfile baz.key
+ keys {
+ { id 1002 name "baz <baz@example.org>" }
+ { id 2002 name "baz <baz@example.org>" subkey-of 1002 }
+ }
+
+ expecting {0 {{^$}}} run { register-key foo/baz baz.key }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ foo/baz {
+ keys {
+ { id 1002 name "baz <baz@example.org>" }
+ { id 2002 name "baz <baz@example.org>" 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 <bar@example.org>" } }
+ }
+ }
+
+ expecting {2 {"does not exist"}}
+ run { update-key foo.key }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ }
+}
+
+do_package_test "update-key: reject multiple keys" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ }
+
+ keyfile barbaz.key
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+
+ expecting {2 {"contains multiple keys"}}
+ run { update-key barbaz.key }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ }
+}
+
+do_package_test "update-key: add subkey" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+
+ keyfile bazsub.key
+ keys {
+ { id 1002 name "baz <baz@example.org>" }
+ { id 2002 name "baz <baz@example.org>" subkey-of 1002 }
+ }
+
+ expecting {0 {{^$}}} run { update-key bazsub.key }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ { id 2002 name "baz <baz@example.org>" subkey-of 1002 }
+ }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys {
+ { id 1002 name "baz <baz@example.org>" }
+ { id 2002 name "baz <baz@example.org>" subkey-of 1002 }
+ }
+ }
+ }
+}
+
+do_package_test "update-key: revocation" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+
+ keyfile revbar.key
+ keys { { id 1001 name "bar <bar@example.org>" is revoked } }
+
+ expecting {0 {{^$}}} run { update-key revbar.key }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" is revoked }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" is revoked } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+}
+
+# ----------------------------------------
+# withdraw-key
+
+do_package_test "withdraw-key: error: not known" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ }
+
+ expecting {2 {"key fingerprint" "not known"}}
+ run { withdraw-key foo/quux 0000000000000000000000000000000000001006 }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ }
+}
+
+do_package_test "withdraw-key: error: not found" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ }
+
+ 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 <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ }
+}
+
+do_package_test "withdraw-key: only occurrence" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ }
+
+ expecting {0 {{^$}}}
+ run { withdraw-key foo/quux 0000000000000000000000000000000000001003 }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ }
+ yields-old-keys {
+ foo/quux { { id 1003 name "quux <quux@example.org>" } }
+ }
+}
+
+do_package_test "withdraw-key: other places remain" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+
+ expecting {0 {{^$}}}
+ run { withdraw-key foo 0000000000000000000000000000000000001002 }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+ yields-old-keys {
+ foo { { id 1002 name "baz <baz@example.org>" } }
+ }
+}
+
+# ----------------------------------------
+# find-keys
+
+do_package_test "find-keys" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+
+ expecting {0
+ { {fingerprint 0{36}1001:[\r\n\s]+[+] bar <bar@example.org>}
+ {(?x)<bar@example.org>[\r\n\s]+Permit[^:]+:[\r\n\s]+
+ -\sfoo[\r\n\s]+-\sbar[\r\n\s]+}
+ {fingerprint 0{36}1002:[\r\n\s]+[+] baz <baz@example.org>}
+ {(?x)<baz@example.org>[\r\n\s]+Permit[^:]+:[\r\n\s]+
+ -\sfoo[\r\n\s]+-\sbaz[\r\n\s]+}
+ {fingerprint 0{36}1003:[\r\n\s]+[+] quux <quux@example.org>}
+ {(?x)<quux@example.org>[\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 <baz@example.org>}
+ {(?x)<baz@example.org>[\r\n\s]+Permit[^:]+:[\r\n\s]+
+ -\sfoo[\r\n\s]+-\sbaz[\r\n\s]+}
+ {fingerprint 0{36}1003:[\r\n\s]+[+] quux <quux@example.org>}
+ {(?x)<quux@example.org>[\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 <bar@example.org>}
+ {(?x)<bar@example.org>[\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 <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ { id 2002 name "baz <baz@example.org>" subkey-of 1002 }
+ }
+ }
+ }
+
+ expecting {0
+ { {fingerprint 0{36}1001:[\r\n\s]+[+] bar <bar@example.org>}
+ {(?x)<bar@example.org>[\r\n\s]+Permit[^:]+:[\r\n\s]+
+ -\sfoo[\r\n\s]+}
+ {fingerprint 0{36}1002:[\r\n\s]+[+] baz <baz@example.org>}
+ {(?x)<baz@example.org>[\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 <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+
+ expecting {0 {{^$}}} run { cleanup-keys }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+}
+
+do_package_test "cleanup-keys: move expired key" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" expired "1 week ago" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ bar {
+ email { bar@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" expired "1 week ago" }
+ }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+
+ expecting {0 {{^$}}} run { cleanup-keys }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+ yields-old-keys {
+ foo { { id 1001 name "bar <bar@example.org>" expired "1 week ago" } }
+ bar { { id 1001 name "bar <bar@example.org>" 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 <bar@example.org>" is revoked }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" is revoked } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+
+ expecting {0 {{^$}}} run { cleanup-keys }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+ yields-old-keys {
+ foo { { id 1001 name "bar <bar@example.org>" is revoked } }
+ bar { { id 1001 name "bar <bar@example.org>" 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 <bar@example.org>" is revoked }
+ { id 100001001 name "foo <foo@example.org>" }
+ }
+ }
+ }
+
+ expecting {0 {{^$}}} run { cleanup-keys }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 100001001 name "foo <foo@example.org>" }
+ }
+ }
+ }
+ yields-old-keys {
+ foo { { id 1001 name "bar <bar@example.org>" 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 <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+ package-old-keys {
+ foo { { id 1000 name "quux <quux@example.org>" } }
+ }
+
+ expecting {0 {{^$}}} run { collect-keys }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+ yields-old-keys {
+ foo { { id 1000 name "quux <quux@example.org>" } }
+ }
+
+ yields-collected-keys {
+ foo {
+ { id 1000 name "quux <quux@example.org>" }
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ { id 1003 name "quux <quux@example.org>" }
+ }
+ bar { { id 1001 name "bar <bar@example.org>" } }
+ baz { { id 1002 name "baz <baz@example.org>" } }
+ }
+}
+
+# ----------------------------------------
+# rebuild-key-index
+
+do_package_test "rebuild-key-index: simple" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+
+ expecting {0 {{^$}}} run { rebuild-key-index }
+
+ yields {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+}
+
+do_package_test "rebuild-key-index: progress" $configuration_file(plain) {
+ packages {
+ foo {
+ email { quux@example.org }
+ keys {
+ { id 1001 name "bar <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+
+ 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 <bar@example.org>" }
+ { id 1002 name "baz <baz@example.org>" }
+ }
+ }
+ foo/quux {
+ keys { { id 1003 name "quux <quux@example.org>" } }
+ }
+ bar {
+ email { bar@example.org }
+ keys { { id 1001 name "bar <bar@example.org>" } }
+ }
+ baz {
+ email { baz@example.org }
+ keys { { id 1002 name "baz <baz@example.org>" } }
+ }
+ }
+}
+
+# ----------------------------------------
+
+#EOF
--- /dev/null
+# 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 <http://www.gnu.org/licenses/>.
+
+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 <subkey-long-ID>
+# name <user> [is <state>]
+# subkey-of <prikey-long-ID>
+# expires <expiration> }...
+# }
+# some-package-name/po {
+# <keylist for mockgpg.exp:write_test_keyring>
+# }
+# }
+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 { <email address>... }
+# keys {
+# <keylist for mockgpg.exp:write_test_keyring>
+# }
+# maintainers { <PGP "Name <email>">... }
+# }
+# ...
+# }
+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 { <email address>... }
+# keys {
+# <keylist for mockgpg.exp:check_test_keyring>
+# }
+# }
+# 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 { <keylist for mockgpg.exp:check_test_keyring> }
+# another-package { <keylist for mockgpg.exp:check_test_keyring> }
+# }
+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
projects / gatekeeper.git / commitdiff