3 # caff -- CA - Fire and Forget
6 # Copyright (c) 2004, 2005 Peter Palfrader <peter@palfrader.org>
7 # Copyright (c) 2005 Christoph Berg <cb@df7cb.de>
11 # Redistribution and use in source and binary forms, with or without
12 # modification, are permitted provided that the following conditions
14 # 1. Redistributions of source code must retain the above copyright
15 # notice, this list of conditions and the following disclaimer.
16 # 2. Redistributions in binary form must reproduce the above copyright
17 # notice, this list of conditions and the following disclaimer in the
18 # documentation and/or other materials provided with the distribution.
19 # 3. The name of the author may not be used to endorse or promote products
20 # derived from this software without specific prior written permission.
22 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
23 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
24 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
25 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
26 # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
27 # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
31 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
37 caff -- CA - Fire and Forget
43 =item B<caff> [-eEmMRS] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]
49 CA Fire and Forget is a script that helps you in keysigning. It takes a list
50 of keyids on the command line, fetches them from a keyserver and calls GnuPG so
51 that you can sign it. It then mails each key to all its email addresses - only
52 including the one UID that we send to in each mail, pruned from all but self
53 sigs and sigs done by you.
59 =item B<-e>, B<--export-old>
61 Export old signatures. Default is to ask the user for each old signature.
63 =item B<-E>, B<--no-export-old>
65 Do not export old signatures. Default is to ask the user for each old
68 =item B<-m>, B<--mail>
70 Send mail after signing. Default is to ask the user for each uid.
72 =item B<-M>, B<--no-mail>
74 Do not send mail after signing. Default is to ask the user for each uid.
76 =item B<-R>, B<--no-download>
78 Do not retrieve the key to be signed from a keyserver.
80 =item B<-S>, B<--no-sign>
84 =item B<-u> I<yourkeyid>, B<--local-user> I<yourkeyid>
86 Select the key that is used for signing, in case you have more than one key.
94 =item $HOME/.caffrc - configuration file
98 =head1 CONFIGURATION FILE OPTIONS
100 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
104 $CONFIG{owner} = q{Peter Palfrader};
105 $CONFIG{email} = q{peter@palfrader.org};
106 $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
108 =head2 Required basic settings
112 =item B<owner> [string]
114 Your name. B<REQUIRED>.
116 =item B<email> [string]
118 Your email address, used in From: lines. B<REQUIRED>.
120 =item B<keyid> [list of keyids]
122 A list of your keys. This is used to determine which signatures to keep
123 in the pruning step. If you select a key using B<-u> it has to be in
124 this list. B<REQUIRED>.
126 =head2 General settings
128 =item B<caffhome> [string]
130 Base directory for the files caff stores. Default: B<$HOME/.caff/>.
132 =head2 GnuPG settings
134 =item B<gpg> [string]
136 Path to the GnuPG binary. Default: B<gpg>.
138 =item B<gpg-sign> [string]
140 Path to the GnuPG binary which is used to sign keys. Default: what
143 =item B<gpg-delsig> [string]
145 Path to the GnuPG binary which is used to split off signatures. This was
146 needed while the upstream GnuPG was not fixed. Default: what B<gpg>
149 =item B<secret-keyring> [string]
151 Path to your secret keyring. Default: B<$HOME/.gnupg/secring.gpg>.
153 =item B<also-encrypt-to> [keyid]
155 An additional keyid to encrypt messages to. Default: none.
157 =item B<gpg-sign-args> [string]
159 Additional arguments to pass to gpg. Default: none.
161 =head2 Keyserver settings
163 =item B<keyserver> [string]
165 Keyserver to download keys from. Default: B<subkeys.pgp.net>.
167 =item B<no-download> [boolean]
169 If true, then skip the step of fetching keys from the keyserver.
172 =head2 Signing settings
174 =item B<no-sign> [boolean]
176 If true, then skip the signing step. Default: B<0>.
178 =item B<export-sig-age> [seconds]
180 Don't export UIDs by default, on which your latest signature is older
181 than this age. Default: B<24*60*60> (i.e. one day).
185 =item B<mail> [boolean]
187 Do not prompt for sending mail, just do it. Default: B<0>.
189 =item B<no-mail> [boolean]
191 Do not prompt for sending mail. The messages are still written to
192 $CONFIG{caffhome}/keys/. Default: B<0>.
194 =item B<mail-template> [string]
196 Email template which is used as the body text for the email sent out
197 instead of the default text if specified. The following perl variables
198 can be used in the template:
202 =item B<{owner}> [string]
204 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
206 =item B<{key}> [string]
208 The keyid of the key you signed.
210 =item B<{@uids}> [array]
212 The UIDs for which signatures are included in the mail.
216 =item B<bcc> [string]
218 Address to send blind carbon copies to when sending mail.
227 =item Peter Palfrader <peter@palfrader.org>
229 =item Christoph Berg <cb@df7cb.de>
235 http://pgp-tools.alioth.debian.org/
243 use File
::Temp
qw{tempdir
};
249 use GnuPG
::Interface
;
252 my $REVISION = '$Rev$';
253 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
254 my $VERSION = "0.0.0.$REVISION_NUMER";
257 my $config = $ENV{'HOME'} . '/.caffrc';
258 -f
$config or die "No file $config present. See caff(1).\n";
259 unless (scalar eval `cat $config`) {
260 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
263 $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
264 die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
265 die ("email is not defined.\n") unless defined $CONFIG{'email'};
266 die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
267 die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
268 for my $keyid (@
{$CONFIG{'keyid'}}) {
269 $keyid =~ /^[A-Fa-f0-9]{16}$/ or die ("key $keyid is not a long (16 digit) keyid.\n");
271 @
{$CONFIG{'keyid'}} = map { uc } @
{$CONFIG{'keyid'}};
272 $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
273 $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
274 $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
275 $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
276 $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
277 $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
278 $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
279 $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
280 $CONFIG{'mail-template'} = <<'EOM' unless defined $CONFIG{'mail-template'};
283 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
284 {foreach $uid (@uids) {
285 $OUT .= "\t".$uid."\n";
286 };} of your key {$key} signed by me.
288 Note that I did not upload your key to any keyservers.
289 If you have multiple user ids, I sent the signature for each user id
290 separately to that user id's associated email address. You can import
291 the signatures by running each through `gpg --import`.
293 If you want this new signature to be available to others, please upload
294 it yourself. With GnuPG this can be done using
295 gpg --keyserver subkeys.pgp.net --send-key {$key}
297 If you have any questions, don't hesitate to ask.
306 print "[NOTICE] $line\n";
310 print "[INFO] $line\n";
314 #print "[DEBUG] $line\n";
318 #print "[trace] $line\n";
322 #print "[trace2] $line\n";
327 stdin
=> IO
::Handle
->new(),
328 stdout
=> IO
::Handle
->new(),
329 stderr
=> IO
::Handle
->new(),
330 status
=> IO
::Handle
->new() );
331 my $handles = GnuPG
::Handles
->new( %fds );
332 return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
335 sub readwrite_gpg
($$$$$%) {
336 my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
338 trace
("Entering readwrite_gpg.");
340 my ($first_line, undef) = split /\n/, $in;
341 debug
("readwrite_gpg sends ".(defined $first_line ?
$first_line : "<nothing>"));
343 local $INPUT_RECORD_SEPARATOR = undef;
344 my $sout = IO
::Select
->new();
345 my $sin = IO
::Select
->new();
348 trace
("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ?
$statusfd : 'undef').".");
350 $inputfd->blocking(0);
351 $stdoutfd->blocking(0);
352 $statusfd->blocking(0) if defined $statusfd;
353 $stderrfd->blocking(0);
354 $sout->add($stdoutfd);
355 $sout->add($stderrfd);
356 $sout->add($statusfd) if defined $statusfd;
359 my ($stdout, $stderr, $status) = ("", "", "");
360 my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
361 trace
("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
363 my $readwrote_stuff_this_time = 0;
364 my $do_not_wait_on_select = 0;
365 my ($readyr, $readyw, $written);
366 while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
367 if (defined $exitwhenstatusmatches) {
368 if ($status =~ /$exitwhenstatusmatches/m) {
369 trace
("readwrite_gpg found match on $exitwhenstatusmatches");
370 if ($readwrote_stuff_this_time) {
371 trace
("read/write some more\n");
372 $do_not_wait_on_select = 1;
374 trace
("that's it in our while loop.\n");
380 $readwrote_stuff_this_time = 0;
381 trace
("select waiting for ".($sout->count())." fds.");
382 ($readyr, $readyw, undef) = IO
::Select
::select($sout, $sin, undef, $do_not_wait_on_select ?
0 : 1);
383 trace
("ready: write: ".(defined $readyw ?
scalar @
$readyw : 0 )."; read: ".(defined $readyr ?
scalar @
$readyr : 0));
384 for my $wfd (@
$readyw) {
385 $readwrote_stuff_this_time = 1;
386 if (length($in) != $offset) {
387 trace
("writing to $wfd.");
388 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
391 if ($offset == length($in)) {
392 trace
("writing to $wfd done.");
393 unless ($options{'nocloseinput'}) {
395 trace
("$wfd closed.");
402 next unless (defined(@
$readyr)); # Wait some more.
404 for my $rfd (@
$readyr) {
405 $readwrote_stuff_this_time = 1;
407 trace
("reading from $rfd done.");
412 trace
("reading from $rfd.");
413 if ($rfd == $stdoutfd) {
415 trace2
("stdout is now $stdout\n================");
418 if (defined $statusfd && $rfd == $statusfd) {
420 trace2
("status is now $status\n================");
423 if ($rfd == $stderrfd) {
425 trace2
("stderr is now $stderr\n================");
430 trace
("readwrite_gpg done.");
431 return ($stdout, $stderr, $status);
435 my ($question, $default, $forceyes, $forceno) = @_;
436 return $default if $forceyes and $forceno;
437 return 1 if $forceyes;
438 return 0 if $forceno;
441 print $question,' ',($default ?
'[Y/n]' : '[y/N]'), ' ';
444 last if ((defined $answer) && (length $answer <= 1));
448 my $result = $default;
449 $result = 1 if $answer =~ /y/i;
450 $result = 0 if $answer =~ /n/i;
458 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
459 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
460 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
461 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
462 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
465 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.";
467 my $KEYSBASE = $CONFIG{'caffhome'}.'/keys';
468 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
470 -d
$KEYSBASE || mkpath
($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
471 -d
$GNUPGHOME || mkpath
($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
474 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
475 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
480 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.\n";
484 my ($fd, $exitcode) = @_;
486 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
487 print $fd "Consult the manual page for more information.\n";
492 # export key $keyid from $gnupghome
495 my ($gnupghome, $keyid) = @_;
497 my $gpg = GnuPG
::Interface
->new();
498 $gpg->call( $CONFIG{'gpg'} );
499 $gpg->options->hash_init(
500 'homedir' => $gnupghome,
502 $gpg->options->meta_interactive( 0 );
503 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
504 my $pid = $gpg->export_keys(handles
=> $handles, command_args
=> [ $keyid ]);
505 my ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
512 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
515 my ($gnupghome, $asciikey) = @_;
517 my $gpg = GnuPG
::Interface
->new();
518 $gpg->call( $CONFIG{'gpg'} );
519 $gpg->options->hash_init( 'homedir' => $gnupghome );
520 $gpg->options->meta_interactive( 0 );
521 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
522 my $pid = $gpg->import_keys(handles
=> $handles);
523 my ($stdout, $stderr, $status) = readwrite_gpg
($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
526 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
534 # Send an email to $address. If $can_encrypt is true then the mail
535 # will be PGP/MIME encrypted to $longkeyid.
537 # $longkeyid, $uid, and @attached will be used in the email and the template.
539 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
540 sub send_mail
($$$@
) {
541 my ($address, $can_encrypt, $key_id, @keys) = @_;
543 my $template = Text
::Template
->new(TYPE
=> 'STRING', SOURCE
=> $CONFIG{'mail-template'})
544 or die "Error creating template: $Text::Template::ERROR";
547 for my $key (@keys) {
548 push @uids, $key->{'text'};
550 my $message = $template->fill_in(HASH
=> { key
=> $key_id,
552 owner
=> $CONFIG{'owner'}})
553 or die "Error filling template in: $Text::Template::ERROR";
555 my $message_entity = MIME
::Entity
->build(
556 Type
=> "text/plain",
558 Disposition
=> 'inline',
562 for my $key (@keys) {
563 $message_entity->attach(
564 Type
=> "application/pgp-keys",
565 Disposition
=> 'attachment',
567 Description
=> "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
568 Data
=> $key->{'key'},
569 Filename
=> "0x$key_id.".$key->{'serial'}.".asc");
573 my $message = $message_entity->stringify();
575 my $gpg = GnuPG
::Interface
->new();
576 $gpg->call( $CONFIG{'gpg'} );
577 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
578 'extra_args' => '--always-trust',
580 $gpg->options->meta_interactive( 0 );
581 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
582 $gpg->options->push_recipients( $key_id );
583 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
584 my $pid = $gpg->encrypt(handles
=> $handles);
585 my ($stdout, $stderr, $status) = readwrite_gpg
($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
588 warn ("No data from gpg for list-key $key_id\n");
593 $message_entity = MIME
::Entity
->build(
594 Type
=> 'multipart/encrypted; protocol="application/pgp-encrypted"');
596 $message_entity->attach(
597 Type
=> "application/pgp-encrypted",
598 Disposition
=> 'attachment',
600 Data
=> "Version: 1\n");
602 $message_entity->attach(
603 Type
=> "application/octet-stream",
604 Filename
=> 'msg.asc',
605 Disposition
=> 'inline',
610 $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
611 $message_entity->head->add("To", $address);
612 $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
613 $message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
614 $message_entity->head->add("User-Agent", $USER_AGENT);
615 $message_entity->send();
616 $message_entity->stringify();
620 # clean up a UID so that it can be used on the FS.
622 sub sanitize_uid
($) {
626 $good_uid =~ tr
#/:\\#_#;
627 trace2
("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
631 sub delete_signatures
($$$$$$) {
632 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;
634 my $signed_by_me = 0;
636 my ($stdout, $stderr, $status) =
637 readwrite_gpg
("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_DELSIG_PROMPT, nocloseinput
=> 1);
639 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
640 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
641 my @sigline = grep { /^sig/ } (split /\n/, $stdout);
642 $stdout =~ s/\n/\\n/g;
643 notice
("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
644 my $line = pop @sigline;
646 if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
647 debug
("[sigremoval] doing line $line.");
648 my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
649 if ($signer eq $longkeyid) {
650 debug
("[sigremoval] selfsig ($signer).");
652 } elsif (grep { $signer eq $_ } @
{$keyids}) {
653 debug
("[sigremoval] signed by us ($signer).");
655 $signed_by_me = $signed_by_me > $created ?
$signed_by_me : $created;
657 debug
("[sigremoval] not interested in that sig ($signer).");
661 debug
("[sigremoval] no sig line here, only got: ".$stdout);
663 ($stdout, $stderr, $status) =
664 readwrite_gpg
($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput
=> 1);
667 return $signed_by_me;
676 Getopt
::Long
::config
('bundling');
678 '-h' => \
$params->{'help'},
679 '--help' => \
$params->{'help'},
680 '--version' => \
$params->{'version'},
681 '-V' => \
$params->{'version'},
682 '-u=s' => \
$params->{'local-user'},
683 '--local-user=s' => \
$params->{'local-user'},
684 '-e' => \
$params->{'export-old'},
685 '--export-old' => \
$params->{'export-old'},
686 '-E' => \
$params->{'no-export-old'},
687 '--no-export-old' => \
$params->{'no-export-old'},
688 '-m' => \
$params->{'mail'},
689 '--mail' => \
$params->{'mail'},
690 '-M' => \
$params->{'no-mail'},
691 '--no-mail' => \
$params->{'no-mail'},
692 '-R' => \
$params->{'no-download'},
693 '--no-download' => \
$params->{'no-download'},
694 '-S' => \
$params->{'no-sign'},
695 '--no-sign' => \
$params->{'no-sign'},
699 if ($params->{'help'}) {
702 if ($params->{'version'}) {
706 usage
(\
*STDERR
, 1) unless scalar @ARGV >= 1;
710 if ($params->{'local-user'}) {
711 $USER = $params->{'local-user'};
713 unless ($USER =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}|[A-Z0-9]{40})$/i) {
714 print STDERR
"-u $USER is not a keyid.\n";
720 for my $keyid (@ARGV) {
722 unless ($keyid =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}||[A-Z0-9]{40})$/i) {
723 print STDERR
"$keyid is not a keyid.\n";
726 push @KEYIDS, uc($keyid);
729 $CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
730 $CONFIG{'no-mail'} = $params->{'no-mail'} if defined $params->{'no-mail'};
731 $CONFIG{'mail'} = $params->{'mail'} if defined $params->{'mail'};
732 $CONFIG{'no-sign'} = $params->{'no-sign'} if defined $params->{'no-sign'};
738 my $gpg = GnuPG
::Interface
->new();
739 $gpg->call( $CONFIG{'gpg'} );
740 $gpg->options->hash_init(
741 'homedir' => $GNUPGHOME,
742 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
743 $gpg->options->meta_interactive( 0 );
744 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
745 $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
746 my $pid = $gpg->list_public_keys(handles
=> $handles, command_args
=> $CONFIG{'keyid'});
747 my ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
750 warn ("No data from gpg for list-key\n");
753 foreach my $keyid (@
{$CONFIG{'keyid'}}) {
754 unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
755 info
("Importing $keyid");
756 system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME";
760 #############################
761 # receive keys from keyserver
762 #############################
764 if ($CONFIG{'no-download'}) {
765 @keyids_ok = @KEYIDS;
767 info
("fetching keys, this will take a while...");
769 my $gpg = GnuPG
::Interface
->new();
770 $gpg->call( $CONFIG{'gpg'} );
771 $gpg->options->hash_init(
772 'homedir' => $GNUPGHOME,
773 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
774 $gpg->options->meta_interactive( 0 );
775 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
776 my $pid = $gpg->recv_keys(handles
=> $handles, command_args
=> [ @KEYIDS ]);
777 my ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
780 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
783 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
784 my %local_keyids = map { $_ => 1 } @KEYIDS;
785 for my $line (split /\n/, $status) {
786 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
787 my $imported_key = $1;
788 my $whole_fpr = $imported_key;
789 my $long_keyid = substr($imported_key, -16);
790 my $short_keyid = substr($imported_key, -8);
792 for my $spec (($whole_fpr, $long_keyid, $short_keyid)) {
793 $speced_key = $spec if $local_keyids{$spec};
795 unless ($speced_key) {
796 notice
("Imported unexpected key; got: $imported_key\n");
799 debug
("Imported $imported_key for $speced_key");
800 delete $local_keyids{$speced_key};
801 unshift @keyids_ok, $imported_key;
802 } elsif ($line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) /) {
804 notice
("got unknown reply from gpg: $line");
807 if (scalar %local_keyids) {
808 notice
("Import failed for: ". (join ' ', keys %local_keyids).".");
809 exit 1 unless ask
("Some keys could not be imported - continue anyway?", 0);
813 unless (@keyids_ok) {
814 notice
("No keys to sign found");
821 unless ($CONFIG{'no-sign'}) {
822 info
("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
823 for my $keyid (@keyids_ok) {
825 push @command, $CONFIG{'gpg-sign'};
826 push @command, '--local-user', $USER if (defined $USER);
827 push @command, "--homedir=$GNUPGHOME";
828 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
829 push @command, '--edit', $keyid;
830 push @command, 'sign';
831 push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
832 print join(' ', @command),"\n";
841 for my $keyid (@keyids_ok) {
844 my $gpg = GnuPG
::Interface
->new();
845 $gpg->call( $CONFIG{'gpg'} );
846 $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
847 $gpg->options->meta_interactive( 0 );
848 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
849 $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
850 my $pid = $gpg->list_public_keys(handles
=> $handles, command_args
=> [ $keyid ]);
851 my ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
854 warn ("No data from gpg for list-key $keyid\n");
857 my @publine = grep { /^pub/ } (split /\n/, $stdout);
858 if (scalar @publine == 0) {
859 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
862 my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
863 if (scalar @publine > 0) {
864 warn ("More than one key matched $keyid. Try to specify the long keyid or fingerprint\n");
867 unless (defined $longkeyid) {
868 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
871 unless (defined $flags) {
872 warn ("Didn't find flags in --list-key of key $keyid.\n");
875 my $can_encrypt = $flags =~ /E/;
879 my $asciikey = export_key
($GNUPGHOME, $keyid);
880 if ($asciikey eq '') {
881 warn ("No data from gpg for export $keyid\n");
888 my $this_uid_text = '';
890 debug
("Doing key $keyid, uid $uid_number");
891 my $tempdir = tempdir
( "caff-$keyid-XXXXX", DIR
=> '/tmp/', CLEANUP
=> 1);
893 # import into temporary gpghome
894 ###############################
895 my $result = import_key
($tempdir, $asciikey);
897 warn ("Could not import $keyid into temporary gnupg.\n");
903 $gpg = GnuPG
::Interface
->new();
904 $gpg->call( $CONFIG{'gpg-delsig'} );
905 $gpg->options->hash_init(
906 'homedir' => $tempdir,
907 'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
908 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds
();
909 $pid = $gpg->wrap_call(
910 commands
=> [ '--edit' ],
911 command_args
=> [ $keyid ],
912 handles
=> $handles );
914 debug
("Starting edit session");
915 ($stdout, $stderr, $status) = readwrite_gpg
('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
919 my $number_of_subkeys = 0;
924 debug
("Parsing stdout output.");
925 for my $line (split /\n/, $stdout) {
926 debug
("Checking line $line");
927 my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
928 if ($type eq 'sub') {
929 $number_of_subkeys++;
931 next unless ($type eq 'uid' || $type eq 'uat');
932 debug
("line is interesting.");
933 if ($uid_number != $i) {
934 debug
("mark for deletion.");
935 readwrite_gpg
("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
940 $this_uid_text = ($type eq 'uid') ?
$uidtext : '[attribute]';
941 $is_uat = $type eq 'uat';
945 debug
("Parsing stdout output done.");
947 debug
("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
948 info
("key $keyid done.");
952 my $prune_some_sigs_on_uid;
953 my $prune_all_sigs_on_uid;
955 debug
("handling attribute userid of key $keyid.");
956 if ($uid_number == 1) {
957 debug
(" attribute userid is #1, unmarking #2 for deletion.");
958 readwrite_gpg
("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
960 $prune_some_sigs_on_uid = 1;
961 $prune_all_sigs_on_uid = 2;
963 debug
("attribute userid is not #1, unmarking #1 for deletion.");
964 readwrite_gpg
("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
966 $prune_some_sigs_on_uid = 2;
967 $prune_all_sigs_on_uid = 1;
970 $prune_some_sigs_on_uid = 1;
974 debug
("need to delete $delete_some uids.");
975 readwrite_gpg
("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_DELUID_PROMPT, nocloseinput
=> 1);
976 readwrite_gpg
("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
981 if ($number_of_subkeys > 0) {
982 for (my $i=1; $i<=$number_of_subkeys; $i++) {
983 readwrite_gpg
("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
985 readwrite_gpg
("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput
=> 1);
986 readwrite_gpg
("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1);
991 readwrite_gpg
("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1); # mark uid for delsig
992 my $signed_by_me = delete_signatures
($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
993 readwrite_gpg
("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1); # unmark uid from delsig
994 if (defined $prune_all_sigs_on_uid) {
995 readwrite_gpg
("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1); # mark uid for delsig
996 delete_signatures
($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
997 readwrite_gpg
("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches
=> $KEYEDIT_PROMPT, nocloseinput
=> 1); # unmark uid from delsig
1001 readwrite_gpg
("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
1004 my $asciikey = export_key
($tempdir, $keyid);
1005 if ($asciikey eq '') {
1006 warn ("No data from gpg for export $keyid\n");
1010 if ($signed_by_me) {
1011 if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
1012 my $write = ask
("Signature on $this_uid_text is old. Export?", 0, $params->{'export-old'}, $params->{'no-export-old'});
1015 my $keydir = "$KEYSBASE/$DATE_STRING";
1016 -d
$keydir || mkpath
($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
1018 my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid
($this_uid_text).".asc";
1019 open (KEY
, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
1020 print KEY
$asciikey;
1023 push @UIDS, { text
=> $this_uid_text, key
=> $asciikey, serial
=> $uid_number, "is_uat" => $is_uat };
1025 info
("$longkeyid $uid_number $this_uid_text done.");
1027 info
("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
1031 if (scalar @UIDS == 0) {
1032 info
("found no signed uids for $keyid");
1034 next if $CONFIG{'no-mail'}; # do not send mail
1037 for my $uid (@UIDS) {
1038 trace
("UID: $uid->{'text'}\n");
1039 if ($uid->{'is_uat'}) {
1040 my $attach = ask
("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
1041 push @attached, $uid if $attach;
1042 } elsif ($uid->{'text'} !~ /@/) {
1043 my $attach = ask
("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
1044 push @attached, $uid if $attach;
1048 notice
("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
1049 for my $uid (@UIDS) {
1050 if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1051 my $address = $uid->{'text'};
1052 $address =~ s/.*<(.*)>.*/$1/;
1053 if (ask
("Send mail to '$address' for $uid->{'text'}?", 1, $CONFIG{'mail'})) {
1054 my $mail = send_mail
($address, $can_encrypt, $longkeyid, $uid, @attached);
1056 my $keydir = "$KEYSBASE/$DATE_STRING";
1057 my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid
($uid->{'text'});
1058 open (KEY
, ">$mailfile") or die ("Cannot open $mailfile: $!\n");