signing-party 2.7-1 / usr / bin / gpgsigs

#!/usr/bin/perl

# $Id: gpgsigs 900 2018-01-29 10:33:26Z guilhem $

# See the pod documentation at the end of this file for author,
# copyright, and licence information.
#
# Changelog:
# 0.1
# 0.2 2005-05-14 cb:
#   * use the user's normal keyring to find signatures
#   * support for multiple user keys
#   * better charset conversion
#   * pod documentation
# see the Debian changelog for further changes.

my $VERSION = qq$Rev: 900 $;

use strict;
use warnings;
use Encode ();
use I18N::Langinfo 'langinfo';
use English '-no_match_vars';
use IPC::Open3;
use Getopt::Long;
use File::Temp;
use IO::Handle;
use IO::Select;
use GnuPG::Interface;


sub version($)
{
	my ($fd) = @_;

	print $fd <<EOF;
gpgsigs $VERSION- https://pgp-tools.alioth.debian.org/
  (c) 2004 Uli Martens <uli\@youam.net>
  (c) 2004, 2005 Peter Palfrader <peter\@palfrader.org>
  (c) 2004, 2005, 2006, 2007 Christoph Berg <cb\@df7cb.de>
  (c) 2014, 2015 Guilhem Moulin <guilhem\@debian.org>
EOF
}

sub usage($$)
{
	my ($fd, $error) = @_;

	version($fd);
	print $fd <<EOF;

Usage: $PROGRAM_NAME [-r] [-t <charset>] <keyid> <keytxt> [<outfile>]

keyid is a long or short keyid (e.g. DE7AAF6E94C09C7F or 94C09C7F) or a
key fingerprint
separate multiple keyids with ','
-r            call gpg --recv-keys before proceeding
-f <charset>  convert <keytxt> from charset
-t <charset>  convert UIDs to charset in output
--refresh     regenerate UID lists on keys
--latex       generate LaTeX output including photo IDs
EOF
	exit $error;
}


my ($fromcharset, $charset, $recv_keys, $refresh, $latex);
Getopt::Long::config('bundling');
GetOptions(
	'-f=s' => \$fromcharset,
	'-t=s' => \$charset,
	r => \$recv_keys,
	refresh => \$refresh,
	latex => \$latex,
	help => sub { usage(*STDOUT, 0); },
	version => sub { version(*STDOUT); exit 0;},
) or usage(*STDERR, 1);


# charset conversion
$fromcharset //= langinfo(I18N::Langinfo::CODESET());
$charset //= langinfo(I18N::Langinfo::CODESET());
my $locale = Encode::find_encoding($charset);

# parse options
my @mykeys = split /,/, uc(shift @ARGV);
my $keytxt = (shift @ARGV) || usage(*STDERR, 1);
my $outfile = (shift @ARGV) || '-';

map { y/ //d if /^(?:[0-9A-F]{4} ){5}(?: [0-9A-F]{4}){5}$/; # remove spaces in fprs
	  /^[0-9A-F]{40}$/ ? s/.{24}// : s/^0x//i;
	} @mykeys;

if (!@mykeys || scalar @ARGV) {
	usage(*STDERR, 1);
}
foreach my $falsekey (grep { $_ !~ /^([0-9A-F]{16}|[0-9A-F]{8})$/ } @mykeys) {
	print STDERR "Invalid keyid $falsekey given\n";
	usage(*STDERR, 1);
}

-r $keytxt or die ("$keytxt does not exist\n");


# get list of keys in file (from fingerprints if available)
my (@keys, @shortkeys);
open (TXT, '<', $keytxt) or die ("Cannot open $keytxt\n");
while (<TXT>) {
	if ( m/^pub {2,}[^ \/]+\/(?:0x)?([0-9A-F]{8}|[0-9A-F]{16}) [0-9]{4}-[0-9]{2}-[0-9]{2}/ ) {
		push @shortkeys, $1;
	} elsif ( m/^ {5,}(?:Key fingerprint = )?((?:[0-9A-F]{4} ){5}(?: [0-9A-F]{4}){5}|[0-9A-F]{40})$/ ) {
		push @keys, substr ($1 =~ y/ //dr, -16);
	}
}
close TXT;
@keys = @shortkeys unless @keys;


# get all known signatures
if ($recv_keys) {
	print STDERR "Requesting keys from keyserver\n";
	system $ENV{GNUPGBIN} // 'gpg', '--recv-keys', @keys;
}

my $now = time;
print STDERR "Running --list-sigs, this may take a while ";

my $photos = $latex ? File::Temp::->new(TMPDIR => 1) : '/dev/null';
my $gpg = GnuPG::Interface::->new();
$gpg->call( $ENV{GNUPGBIN} ) if defined $ENV{GNUPGBIN};
# we need --attribute-{fd,file} and --status-{fd,file} to get the
# correct attribute size
$gpg->options->hash_init( 'extra_args' => [ '--attribute-file', $photos,
											qw/ --list-options show-sig-subpackets
												--no-auto-check-trustdb
												--fixed-list-mode --with-colons/ ]
						, 'meta_interactive' => 0 );

my $stdout = IO::Handle::->new();
my $status = IO::Handle::->new();
my $handles = GnuPG::Handles::->new( stdout => $stdout, status => $status );
my $pid = $gpg->list_sigs( handles => $handles, command_args => [ @mykeys, @keys ] );

$_->blocking(0) for ($stdout, $status);
my $output = IO::Select::->new();
$output->add($stdout, $status);

my (%keys, %uids, @photos, %sigs, %revs);
my ($key, $uid, $sig); # current context

my ($oldstdout, $oldstatus) = ('', '');
while ($output->count() > 0) {
	foreach my $fd (@{(IO::Select::select($output))[0]}) { # reader
		if ($fd->eof) {
			$output->remove($fd);
			close $fd;
			next;
		}
		if ($fd == $stdout) {
			while (<$fd>) {
				if ($oldstdout) { # prepend unfinished output
					$_ = $oldstdout . $_;
					$oldstdout = '';
				}
				if (!/\n\z/) { # there is more coming
					$oldstdout = $_;
					next;
				}
				chomp;
				undef $sig unless /^spk:/;
				if (/^pub:([^:]+):(?:[^:]*:){2}([0-9A-F]{16}):(?:[^:]*:){6}([^:]+)/) {
					undef $uid;
					$key = $2;
					if ($1 =~ /[ir]/ or $3 =~ /D/ ) {
						warn "Ignoring unusable key $key.\n";
						undef $key;
						last;
					}
					$keys{$key} = [];
					print STDERR '.';
					@mykeys = map { substr($key,-8) eq $_ ? $key : $_ } @mykeys;
					next;
				}
				next unless $key; # nothing to do on revoked keys
				if (/^(uid|uat):([^:]+):(?:[^:]*:){5}([0-9A-F]{40}):[^:]*:([^:]+)/) {
					undef $uid;
					next if $2 =~ /[er]/;

					$uid = $3; # use the hash to have proper distinction between UATs
					if ($1 eq 'uid') {
						my $text = $4;
						$text =~ s/\\x(\p{AHex}{2})/ chr(hex($1)) /ge;
						# --with-colons always outputs UTF-8
						$uids{$key}->{$uid} = { type => 'uid', text => $locale->encode(Encode::decode_utf8($text)) };
					}
					else {
						# we can't rely on $4 for the size: get it from
						# the status fd instead
						$uids{$key}->{$uid} = { type => 'uat' };
					}
					push @{$keys{$key}}, $uid; # preserve order
					next;
				}
				next unless defined $uid; # nothing to do on revoked uids
				if (/^sig:(?:[^:]*:){3}([0-9A-F]{16}):(\d+):(\d*):(?:[^:]*:){3}(1[0-3][lx])(?::.*)?$/) {
					if (!grep { $1 =~ /$_$/ or $key =~ /$_$/ } @mykeys) {
						$sig = []; # $key is not ours, and the signer isn't us: don't waste resources
					} else {
						$sigs{$key}->{$uid}->{$1} //= [];
						$sig = $sigs{$key}->{$uid}->{$1};
						push @$sig, { created => $2, expiring => $3, class => $4, revocable => 1 };
					}
					next;
				}
				if (/^spk:7:1:1:%0([01])$/ and @$sig) {
					# mark the last sig as revocable (1) or not (0)
					$sig->[$#$sig]->{revocable} = $1;
					next;
				}
				if (/^rev:(?:[^:]*:){3}([0-9A-F]{16}):(\d+):(?:[^:]*:){4}30x(?::.*)?$/) {
					$revs{$key}->{$uid}->{$1} = $2 # keep only the most recent revocation cert
						unless defined $revs{$key}->{$uid}->{$1} and $revs{$key}->{$uid}->{$1} > $2;
					next;
				}
				if (/^sub:/) {
					undef $uid;
					next;
				}
				if (!/^(?:rvk|tru|fpr|spk):/) { # revoke/revoker/trust/fpr
					warn "Unknown value: '$_', key: ".($key // 'none')."\n";
				}
			}
		}
		elsif ($fd == $status) {
			while (<$fd>) {
				if ($oldstatus) { # prepend unfinished output
					$_ = $oldstatus . $_;
					$oldstatus = '';
				}
				if (!/\n\z/) { # there is more coming
					$oldstatus = $_;
					next;
				}
				chomp;
				# see /usr/share/doc/gnupg/DETAILS.gz
				if (/^\[GNUPG:\] ATTRIBUTE [0-9A-F]{24}([0-9A-F]{16}) (\d+) (\d+) (\d+) (\d+) \d+ \d+ (\d+)$/) {
					my $ignore = ($3 == 1 and $4 == 1 and $5 == 1) ? 0 : 1;
					push @photos, {key => $1, size => $2, revoked => $6 & 0x02, ignore => $ignore};
					next;
				}
				if (!/^\[GNUPG:\] (?:KEYEXPIRED \d+|SIGEXPIRED(?: deprecated-use-keyexpired-instead)?|KEY_CONSIDERED [0-9A-F]{40} \d+)$/) {
					warn "Unknown value: '$_'";
				}
			}
		}
	}
}
warn "Parsing gpg's output went wrong.\n" if $oldstdout or $oldstatus;
waitpid $pid, 0;
die if $?;
close $_ for ($stdout, $status);

my $photosfd;
if ($latex) {
	open $photosfd, '<:raw', $photos or die "Couldn't open: $!";
}

# get photo sizes and split $photos if $latex
foreach my $photo (@photos) {
	my $chunk;
	if ($latex) {
		my $got = read $photosfd, $chunk, $photo->{size} or die "Couldn't read: $!";
		warn "Read $photo->{size} bytes but got $got bytes.\n" if $got != $photo->{size};
	}

	next if $photo->{revoked} or $photo->{ignore}; # ignore revoked attributes

	my $key = $photo->{key};
	my @uats = grep { $uids{$key}->{$_}->{type} eq 'uat' } @{$keys{$key}};
	my @found = grep { !defined $uids{$key}->{$_}->{text} } @uats;
	my $size = $photo->{size} - 16; # remove the header part
	unless (@found) {
		warn "No more UAT was found on $key, but there is an image of size $size that belongs to that key.\n";
		next;
	}
	my $uat = $uids{$key}->{shift @found};
	$uat->{text} = "[jpeg image of size $size]";

	if ($latex) {
		$uat->{file} = "${key}_".($#uats - $#found).".jpg";
		my $pid = open my $pic, '|-', 'convert', 'jpg:-', '-density', 90, $uat->{file} or die "Can't run convert(1)\n";
		print $pic (substr $chunk, 16);
		close $pic;
		waitpid $pid, 0;
		warn "convert(1) exited with value ".($? >> 8)."\n" if $?;
	}
}
close $photosfd if $latex;

# collapse sigs following RFC 4880
while (my ($key, $uids) = each %sigs) {
	while (my ($uid, $signers) = each %$uids) {
		while (my ($signer, $sigs) = each %$signers) {
			my $lastrev = $revs{$key}->{$uid}->{$signer};
			my $class;
			my @sigs;

			# remove expired signatures
			@sigs = grep {!$_->{expiring} or $now < $_->{expiring}} @$sigs;
			$class = 'X' if !$class and !@sigs; # eXpired

			# remove revoked signatures (but keep signatures issued after the last revocation cert)
			@sigs = grep {!$_->{revocable} or $lastrev < $_->{created}} @sigs if $lastrev;
			$class = 'R' if !$class and !@sigs; # Revoked

			unless ($class) {
				# only non-expired, non-revoked sigs are left in @sigs.
				@sigs = grep { $_->{class} =~ /x$/ } @sigs; # grep for exportable sigs
				if (@sigs) {
					# we take the one with the best level
					@sigs = sort { $a->{class} cmp $b->{class} } @sigs;
					my $s = pop @sigs;
					if ($s->{expiring}) {
						$class = 'x';
					}
					else {
						$class = $s->{class} =~ s/1([0-3])./$1/r;
						$class = 'S' if $class eq '0';
					}
				} else {
					$class = 'L';
				}
			}
			undef $sigs;
			$signers->{$signer} = $class;
		}
	}
}

sub getChecksum ($$) {
	my ($algo, $infile) = @_;
	my $pid = open MD, '-|', $ENV{GNUPGBIN} // 'gpg', qw/--with-colons --print-md/, $algo, $infile or warn "Can't get gpg $algo digest\n";
	my $digest = <MD>;
	waitpid $pid, 0;
	warn "gpg(1) exited with value ".($? >> 8)."\n" if $?;
	close MD;
	return $1 if $digest and $digest =~ /:([0-9A-F]+):[^:]*$/;
}


# write out result
sub print_tag {
	my ($key, $uid) = @_;
	my $r = '(';
	$r .= $sigs{$key}->{$uid}->{$_} // ' ' for @mykeys;
	$r .= ')';
	return $r;
}

$key = undef;
$uid = undef;
my $line = 0;
my $keys = 0;
print STDERR "\nAnnotating $keytxt, writing into $outfile\n";
open (TXT, '<', $keytxt) or die ("Cannot open $keytxt\n");
$outfile eq '-' ? *WRITE = *STDOUT :
	open (WRITE, '>', $outfile) or die ("Cannot open $outfile for writing\n");

if ($latex) {
	print WRITE <<'EOF';
\documentclass{article}
\usepackage[margin=2cm]{geometry}
\usepackage{alltt}
\usepackage{graphicx}
\usepackage{ifluatex,ifxetex}
\ifnum 0\ifxetex 1\fi\ifluatex 1\fi=0
  \usepackage[utf8x]{inputenc}
\else
  \usepackage[log-declarations=false]{xparse}
  \usepackage{fontspec}
  \setmonofont{Noto Mono}
  \ifxetex
    \usepackage[quiet]{xeCJK}
    \CJKfontspec{Noto Sans Mono CJK TC}
    \CJKfontspec{Noto Sans Mono CJK SC}
    \CJKfontspec{Noto Sans Mono CJK JP}
    \CJKfontspec{Noto Sans Mono CJK KR}
  \fi
\fi
\begin{document}
\begin{alltt}
EOF
}

while (<TXT>) {
	$line++;
	if (/^(\S+) Checksum:/) {
		my $algo = uc $1;
		my $md = getChecksum($algo, $keytxt);
		if ($md) {
			my $r = $_;
			while ( /^(?:.*_)?$/ ) {
				$line++;
				$_ = <TXT>;
				$r .= $_;
			}
			my $n = $r =~ y/_//;
			my $k = $n / length($md);
			if (int($k) * length($md) != $n) {
				warn "Skipping $algo digest value (invalid fill-in length)\n";
			} else {
				my $w = '_' x $k;
				$r =~ s/\Q$w\E/%c/g;
				$r = sprintf($r, unpack ("C*", $md));
			}
			print WRITE $r;
			next;
		}
	}

	if ( m/^[0-9]+\s+\[ \] Fingerprint OK/ ){
		if ($latex) {
			if ($keys > 0) {
				print WRITE "\\end{samepage}\n";
			}
			print WRITE "\\begin{samepage}\n";
			++$keys;
		}
		print WRITE;
		next;
	}

	if ( m/^pub {2,}[^ \/]+\/(?:0x)?([0-9A-F]{8}|[0-9A-F]{16}) [0-9]{4}-[0-9]{2}-[0-9]{2}/ ) {
		$key = $1;
		print WRITE;
		next;
	}

	if ( m/^ {5,}(?:Key fingerprint = )?((?:[0-9A-F]{4} ){5}(?: [0-9A-F]{4}){5}|[0-9A-F]{40})$/ ) {
		# derive the keyid from the fingerprint if available
		$key = substr $1 =~ y/ //dr, -16;
		print WRITE;
		my $inc = "";
		foreach my $mykey (@mykeys) {
			foreach my $myuid (@{$keys{$mykey}}) {
				$inc .= $sigs{$mykey}->{$myuid}->{$key} // ' ';
			}
		}
		print WRITE "[$inc] incoming signatures\n" if $inc =~ /\S/;
		if ($refresh or $latex) {
			foreach my $uid (@{$keys{$key}}) {
				next unless defined $uids{$key}->{$uid}->{text};
				my $tag = print_tag($key, $uid);
				if (!$latex) {
					print WRITE $tag .' '. $uids{$key}->{$uid}->{text},"\n";
				} else {
					for (my $i = 0; $i < length $uids{$key}->{$uid}->{text}; $i+=78) {
						print WRITE ($i ? ' ' x length $tag : $tag ), ' ',
									substr ($uids{$key}->{$uid}->{text}, $i, 78), "\n";
					}
				}
				if ($latex and $uids{$key}->{$uid}->{type} eq 'uat') {
					print WRITE "\\begin{flushright}\n";
					print WRITE "\\includegraphics[height=3cm]{$uids{$key}->{$uid}->{file}}\n";
					print WRITE "\\end{flushright}\n";
				}
			}
		}
		next;

	}
	if ( m/^uid +(.*)$/ ) {
		next if $refresh or $latex;
		my $uid = $locale->encode( Encode::decode($fromcharset, $1) );
		unless (defined $key) {
			warn "key is undefined - input text is possibly malformed near line $line\n";
			next;
		};
		my @h = grep { $uids{$key}->{$_}->{text} eq $uid } @{$keys{$key}};
		if (@h) {
			# if there are multiple matches we can't distinguish them
			print WRITE print_tag($key, pop @h)." $uid\n";
		} else {
			warn "uid '$uid' not found on key $key\n";
			print WRITE "(" . (' ' x @mykeys) . ") $uid\n";
		}
		next;
	}
	if ( /^(?:-+|_+)$/ and $latex ) {
		$_ = "\n\\hrule\n";
	}
	print WRITE;
}
close TXT;

if ($latex and $keys > 0) {
	print WRITE "\\end{samepage}\n";
}

print WRITE "Legend:\n";
my $num_myuids = 0;
foreach my $i (0 .. $#mykeys) {
	print WRITE '  (' . ' 'x$i . 'S' . ' 'x(@mykeys-$i-1) . ") signed with $mykeys[$i] $uids{$mykeys[$i]}->{$keys{$mykeys[$i]}->[0]}->{text}\n";
	$num_myuids += @{$keys{$mykeys[$i]}};
}
my $i = 0;
foreach my $mykey (@mykeys) {
	foreach my $myuid (@{$keys{$mykey}}) {
		print WRITE "  [" . ' 'x$i . 'S' . ' 'x($num_myuids-$i-1) . "] has signed $mykey $uids{$mykey}->{$myuid}->{text}\n";
		$i++;
	}
}

print WRITE <<'EOF';

Signature types:
  R  Revoked signature
  X  Expired signature
  L  Local (non-exportable) signature
  x  Exportable signature with an expiration date in the future
  S  Non-expiring, exportable signature with certification level 0
  1  Non-expiring, exportable signature with certification level 1
  2  Non-expiring, exportable signature with certification level 2
  3  Non-expiring, exportable signature with certification level 3
EOF


if ($latex) {
	print WRITE <<'EOF';
\end{alltt}
\end{document}
EOF
}

close WRITE;

__END__

=head1 NAME

B<gpgsigs> - annotate list of GnuPG keys with already done signatures

=head1 SYNOPSIS

B<gpgsigs> [I<options>] I<keyid>I<[>B<,>I<keyidI<[>B<,>I<...>I<]>>I<]> F<keytxt> [F<outfile>]

=head1 DESCRIPTION

B<gpgsigs> was written to assist the user in signing keys during a keysigning
party. It takes as input a file containing keys in C<gpg --list-keys> format
and prepends every line with a tag indicating if the user has already signed
that uid. When the file contains C<ALGO Checksum:> lines and placeholders
(C<__ __>), the checksum is inserted. ALGO can be set to the following algorithms:
MD5 SHA1 SHA256 or RIPEMD160.

=head1 OPTIONS

=over

=item B<-r>

Call I<gpg --recv-keys> before creating the output.

=item B<-f> I<charset>

Convert F<keytxt> from I<charset>. The default is ISO-8859-1.

=item B<-t> I<charset>

Convert UIDs to I<charset>. The default is derived from LC_ALL, LC_CTYPE, and
LANG, and if all these are unset, the default is ISO-8859-1.

=item B<--refresh>

Refresh the UID lists per key from gpg. Useful when UIDs were added or revoked
since the input text was generated.

=item B<--latex>

Generate LaTeX output, including photo IDs. Implies B<--refresh>.
B<Note:> This writes jpg files to the current directory.

=item I<keyid>

Use this keyid (8 or 16 bytes, or full fingerprint) for annotation.
Multiple keyids can be separated by a comma (B<,>).

=item F<keytxt>

Read input from F<keytxt>.

=item F<outfile>

Write output to F<outfile>. Default is stdout.

=back

=head1 ENVIRONMENT

=over

=item I<HOME>

The default home directory.

=item I<GNUPGBIN>

The gpg binary.  Default: C<"gpg">.

=item I<GNUPGHOME>

The default working directory for gpg.  Default: C<$HOME/.gnupg>.

=back

=head1 EXAMPLES

The following key signing parties are using B<gpgsigs>:

http://www.palfrader.org/ksp-lt2k4.html

http://www.palfrader.org/ksp-lt2k5.html

=head1 BUGS

B<GnuPG> is known to change its output format quite often. This version has
been tested with gpg 1.4.18 and gpg 2.0.26. YMMV.

=head1 SEE ALSO

gpg(1), caff(1).

https://pgp-tools.alioth.debian.org/

=head1 AUTHORS AND COPYRIGHT

(c) 2004 Uli Martens <uli@youam.net>

(c) 2004, 2005 Peter Palfrader <peter@palfrader.org>

(c) 2004, 2005, 2006, 2007 Christoph Berg <cb@df7cb.de>

(c) 2014, 2015 Guilhem Moulin <guilhem@debian.org>

=head1 LICENSE

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:

1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

3. The name of the author may not be used to endorse or promote products
derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.