]> git.sthu.org Git - pgp-tools.git/blob - caff/caff
2b5b41e42cb9d9ea16bb5e1ebb5aa894ba95a54b
[pgp-tools.git] / caff / caff
1 #!/usr/bin/perl -w
2
3 # caff -- CA - Fire and Forget
4 # $Id$
5 #
6 # Copyright (c) 2004, 2005, 2006 Peter Palfrader <peter@palfrader.org>
7 # Copyright (c) 2005, 2006 Christoph Berg <cb@df7cb.de>
8 #
9 # All rights reserved.
10 #
11 # Redistribution and use in source and binary forms, with or without
12 # modification, are permitted provided that the following conditions
13 # are met:
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.
21 #
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.
32
33 =pod
34
35 =head1 NAME
36
37 caff -- CA - Fire and Forget
38
39 =head1 SYNOPSIS
40
41 =over
42
43 =item B<caff> [-eEmMRS] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]
44
45 =back
46
47 =head1 DESCRIPTION
48
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. The mailed key is encrypted with itself as a means
54 to verify that key belongs to the recipient.
55
56 =head1 OPTIONS
57
58 =over
59
60 =item B<-e>, B<--export-old>
61
62 Export old signatures. Default is to ask the user for each old signature.
63
64 =item B<-E>, B<--no-export-old>
65
66 Do not export old signatures. Default is to ask the user for each old
67 signature.
68
69 =item B<-m>, B<--mail>
70
71 Send mail after signing. Default is to ask the user for each uid.
72
73 =item B<-M>, B<--no-mail>
74
75 Do not send mail after signing. Default is to ask the user for each uid.
76
77 =item B<-R>, B<--no-download>
78
79 Do not retrieve the key to be signed from a keyserver.
80
81 =item B<-S>, B<--no-sign>
82
83 Do not sign the keys.
84
85 =item B<-u> I<yourkeyid>, B<--local-user> I<yourkeyid>
86
87 Select the key that is used for signing, in case you have more than one key.
88 To sign with multiple keys at once, separate multiple keyids by comma.
89
90 =item B<--key-file> I<file>
91
92 Import keys from file. Can be supplied more than once.
93
94 =back
95
96 =head1 FILES
97
98 =over
99
100 =item $HOME/.caffrc - configuration file
101
102 =item $HOME/.caff/keys/yyyy-mm-dd/ - processed keys
103
104 =item $HOME/.caff/gnupghome/ - caff's working dir for gpg
105
106 =item $HOME/.caff/gnupghome/gpg.conf - gpg configuration
107
108 useful options include use-agent, keyserver-options, default-cert-level, etc.
109
110 =back
111
112 =head1 CONFIGURATION FILE OPTIONS
113
114 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
115 The file is generated when it does not exist.
116
117 Example:
118
119 $CONFIG{owner} = q{Peter Palfrader};
120 $CONFIG{email} = q{peter@palfrader.org};
121 $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
122
123 =head2 Required basic settings
124
125 =over
126
127 =item B<owner> [string]
128
129 Your name. B<REQUIRED>.
130
131 =item B<email> [string]
132
133 Your email address, used in From: lines. B<REQUIRED>.
134
135 =item B<keyid> [list of keyids]
136
137 A list of your keys. This is used to determine which signatures to keep
138 in the pruning step. If you select a key using B<-u> it has to be in
139 this list. B<REQUIRED>.
140
141 =head2 General settings
142
143 =item B<caffhome> [string]
144
145 Base directory for the files caff stores. Default: B<$HOME/.caff/>.
146
147 =head2 GnuPG settings
148
149 =item B<gpg> [string]
150
151 Path to the GnuPG binary. Default: B<gpg>.
152
153 =item B<gpg-sign> [string]
154
155 Path to the GnuPG binary which is used to sign keys. Default: what
156 B<gpg> is set to.
157
158 =item B<gpg-delsig> [string]
159
160 Path to the GnuPG binary which is used to split off signatures. This was
161 needed while the upstream GnuPG was not fixed. Default: what B<gpg>
162 is set to.
163
164 =item B<secret-keyring> [string]
165
166 Path to your secret keyring. Default: B<$HOME/.gnupg/secring.gpg>.
167
168 =item B<also-encrypt-to> [keyid, or list of keyids]
169
170 Additional keyids to encrypt messages to. Default: none.
171
172 =item B<gpg-sign-args> [string]
173
174 Additional arguments to pass to gpg. Default: none.
175
176 =head2 Keyserver settings
177
178 =item B<keyserver> [string]
179
180 Keyserver to download keys from. Default: B<subkeys.pgp.net>.
181
182 =item B<no-download> [boolean]
183
184 If true, then skip the step of fetching keys from the keyserver.
185 Default: B<0>.
186
187 =item B<key-files> [list of files]
188
189 A list of files containing keys to be imported.
190
191 =head2 Signing settings
192
193 =item B<no-sign> [boolean]
194
195 If true, then skip the signing step. Default: B<0>.
196
197 =item B<ask-sign> [boolean]
198
199 If true, then pause before continuing to the signing step.
200 This is useful for offline signing. Default: B<0>.
201
202 =item B<export-sig-age> [seconds]
203
204 Don't export UIDs by default, on which your latest signature is older
205 than this age. Default: B<24*60*60> (i.e. one day).
206
207 =item B<local-user> [keyid, or list of keyids]
208
209 Select the key that is used for signing, in case you have more than one key.
210 With multiple keyids, sign with each key in turn.
211
212 =head2 Mail settings
213
214 =item B<mail> [boolean]
215
216 Do not prompt for sending mail, just do it. Default: B<0>.
217
218 =item B<no-mail> [boolean]
219
220 Do not prompt for sending mail. The messages are still written to
221 $CONFIG{caffhome}/keys/. Default: B<0>.
222
223 =item B<mail-template> [string]
224
225 Email template which is used as the body text for the email sent out
226 instead of the default text if specified. The following perl variables
227 can be used in the template:
228
229 =over
230
231 =item B<{owner}> [string]
232
233 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
234
235 =item B<{key}> [string]
236
237 The keyid of the key you signed.
238
239 =item B<{@uids}> [array]
240
241 The UIDs for which signatures are included in the mail.
242
243 =back
244
245 =item B<reply-to> [string]
246
247 Add a Reply-To: header to messages sent. Default: none.
248
249 =item B<bcc> [string]
250
251 Address to send blind carbon copies to when sending mail.
252 Default: none.
253
254 =item B<mailer-send> [array]
255
256 Parameters to pass to Mail::Mailer.
257 This could for example be
258
259 $CONFIG{mailer-send} = [ 'smtp', Server => 'mail.server', Auth => ['user', 'pass'] ]
260
261 to use the perl SMTP client or
262
263 $CONFIG{mailer-send} = [ 'sendmail', '-o8' ]
264
265 to pass arguments to the sendmail program.
266 For more information run C<< perldoc Mail::Mailer >>.
267 Setting this option is strongly discouraged. Fix your local MTA
268 instead.
269 Default: none.
270
271 =back
272
273 =head1 AUTHORS
274
275 =over
276
277 =item Peter Palfrader <peter@palfrader.org>
278
279 =item Christoph Berg <cb@df7cb.de>
280
281 =back
282
283 =head1 WEBSITE
284
285 http://pgp-tools.alioth.debian.org/
286
287 =head1 SEE ALSO
288
289 gpg(1), pgp-clean(1), /usr/share/doc/signing-party/caff/caffrc.sample.
290
291 =cut
292
293 use strict;
294 use IO::Handle;
295 use English;
296 use File::Path;
297 use File::Temp qw{tempdir};
298 use Text::Template;
299 use MIME::Entity;
300 use Encode;
301 use Fcntl;
302 use IO::Select;
303 use Getopt::Long;
304 use GnuPG::Interface;
305
306 my %CONFIG;
307 my $REVISION = '$Rev$';
308 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
309 my $VERSION = "0.0.0.$REVISION_NUMER";
310
311
312
313 sub mywarn($) {
314 my ($line) = @_;
315 print "[WARN] $line\n";
316 };
317 sub notice($) {
318 my ($line) = @_;
319 print "[NOTICE] $line\n";
320 };
321 sub info($) {
322 my ($line) = @_;
323 print "[INFO] $line\n";
324 };
325 sub debug($) {
326 my ($line) = @_;
327 #print "[DEBUG] $line\n";
328 };
329 sub trace($) {
330 my ($line) = @_;
331 #print "[trace] $line\n";
332 };
333 sub trace2($) {
334 my ($line) = @_;
335 #print "[trace2] $line\n";
336 };
337
338
339 sub generate_config() {
340 notice("Error: \$LOGNAME is not set.\n") unless defined $ENV{'LOGNAME'};
341 my $gecos = defined $ENV{'LOGNAME'} ? (getpwnam($ENV{LOGNAME}))[6] : undef;
342 my $email;
343 my @keys;
344 # BSD does not have hostname -f, so we try without -f first
345 my $hostname = `hostname`;
346 $hostname = `hostname -f` unless $hostname =~ /\./;
347 chomp $hostname;
348 my ($Cgecos,$Cemail,$Ckeys) = ('','','');
349
350 if (defined $gecos) {
351 $gecos =~ s/,.*//;
352
353 my $gpg = GnuPG::Interface->new();
354 $gpg->call( 'gpg' );
355 $gpg->options->hash_init(
356 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
357 $gpg->options->meta_interactive( 0 );
358 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
359 my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $gecos ]);
360 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
361 waitpid $pid, 0;
362
363 if ($stdout eq '') {
364 warn ("No data from gpg for list-key\n"); # There should be at least 'tru:' everywhere.
365 };
366
367 @keys = ($stdout =~ /^pub:[^r:]*:(?:[^:]*:){2,2}([^:]+):/mg);
368 unless (scalar @keys) {
369 info("Error: No keys were found using \"gpg --list-public-keys '$gecos'\".");
370 @keys = qw{0123456789abcdef 89abcdef76543210};
371 $Ckeys = '#';
372 }
373 ($email) = ($stdout =~ /^uid:.*<(.+?@.+?)>.*:/m);
374 unless (defined $email) {
375 info("Error: No email address was found using \"gpg --list-public-keys '$gecos'\".");
376 $email = $ENV{'LOGNAME'}.'@'.$hostname;
377 $Cemail = '#';
378 }
379 } else {
380 $gecos = 'Unknown Caff User';
381 $email = $ENV{'LOGNAME'}.'@'.$hostname;
382 @keys = qw{0123456789abcdef 89abcdef76543210};
383 ($Cgecos,$Cemail,$Ckeys) = ('#','#','#');
384 };
385
386 my $template = <<EOT;
387 # .caffrc -- vim:ft=perl:
388 # This file is in perl(1) format - see caff(1) for details.
389
390 $Cgecos\$CONFIG{'owner'} = '$gecos';
391 $Cemail\$CONFIG{'email'} = '$email';
392 #\$CONFIG{'reply-to'} = 'foo\@bla.org';
393
394 # You can get your long keyid from
395 # gpg --with-colons --list-key <yourkeyid|name|emailaddress..>
396 #
397 # If you have a v4 key, it will simply be the last 16 digits of
398 # your fingerprint.
399 #
400 # Example:
401 # \$CONFIG{'keyid'} = [ qw{FEDCBA9876543210} ];
402 # or, if you have more than one key:
403 # \$CONFIG{'keyid'} = [ qw{0123456789ABCDEF 89ABCDEF76543210} ];
404 $Ckeys\$CONFIG{'keyid'} = [ qw{@keys} ];
405
406 # Select this/these keys to sign with
407 #\$CONFIG{'local-user'} = [ qw{@keys} ];
408
409 # Additionally encrypt messages for these keyids
410 #\$CONFIG{'also-encrypt-to'} = [ qw{@keys} ];
411
412 # Mail template to use for the encrypted part
413 #\$CONFIG{'mail-template'} = << 'EOM';
414 EOT
415
416 $template .= "#$_" foreach <DATA>;
417 $template .= "#EOM\n";
418 return $template;
419 };
420
421 sub check_executable($$) {
422 # (GnuPG::Interface gives lousy errors when the gpg binary isn't found,
423 # so we want to check manually.)
424 my ($purpose, $fn) = @_;
425 # Only check provided fnames with a slash in them.
426 return unless defined $fn;
427 if ($fn =~ m!/!) {
428 die ("$PROGRAM_NAME: $purpose executable '$fn' not found.\n") unless -x $fn;
429 } else {
430 for my $p (split(':', $ENV{PATH})) {
431 return if -x "$p/$fn";
432 };
433 die ("$PROGRAM_NAME: $purpose executable '$fn' not found on path.\n") unless -x $fn;
434 };
435 };
436
437 sub load_config() {
438 my $config = $ENV{'HOME'} . '/.caffrc';
439 unless (-f $config) {
440 print "No configfile $config present, I will use this template:\n";
441 my $template = generate_config();
442 print "$template\nPlease edit $config and run caff again.\n";
443 open F, ">$config" or die "$config: $!";
444 print F $template;
445 close F;
446 exit(1);
447 }
448 unless (scalar eval `cat $config`) {
449 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
450 };
451
452 $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
453 die ("$PROGRAM_NAME: owner is not defined in $config.\n") unless defined $CONFIG{'owner'};
454 die ("$PROGRAM_NAME: email is not defined in $config.\n") unless defined $CONFIG{'email'};
455 die ("$PROGRAM_NAME: keyid is not defined in $config.\n") unless defined $CONFIG{'keyid'};
456 die ("$PROGRAM_NAME: keyid is not an array ref in $config.\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
457 for my $keyid (@{$CONFIG{'keyid'}}) {
458 $keyid =~ /^[A-F0-9]{16}$/i or die ("$PROGRAM_NAME: key $keyid is not a long (16 digit) keyid in $config.\n");
459 };
460 @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
461 $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
462 $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
463 $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
464 $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
465 $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
466 check_executable("gpg", $CONFIG{'gpg'});
467 check_executable("gpg-sign", $CONFIG{'gpg-sign'});
468 check_executable("gpg-delsig", $CONFIG{'gpg-delsig'});
469 $CONFIG{'secret-keyring'} = ($ENV{'GNUPGHOME'} || "$ENV{'HOME'}/.gnupg") . '/secring.gpg'
470 unless defined $CONFIG{'secret-keyring'};
471 $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
472 $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
473 $CONFIG{'key-files'} = () unless defined $CONFIG{'key-files'};
474 $CONFIG{'mailer-send'} = [] unless defined $CONFIG{'mailer-send'};
475 die ("$PROGRAM_NAME: mailer-send is not an array ref in $config.\n") unless (ref $CONFIG{'mailer-send'} eq 'ARRAY');
476 unless (defined $CONFIG{'mail-template'}) {
477 $CONFIG{'mail-template'} .= $_ foreach <DATA>;
478 }
479 };
480
481 sub make_gpg_fds() {
482 my %fds = (
483 stdin => IO::Handle->new(),
484 stdout => IO::Handle->new(),
485 stderr => IO::Handle->new(),
486 status => IO::Handle->new() );
487 my $handles = GnuPG::Handles->new( %fds );
488 return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
489 };
490
491 sub readwrite_gpg($$$$$%) {
492 my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
493
494 trace("Entering readwrite_gpg.");
495
496 my ($first_line, undef) = split /\n/, $in;
497 debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
498
499 local $INPUT_RECORD_SEPARATOR = undef;
500 my $sout = IO::Select->new();
501 my $sin = IO::Select->new();
502 my $offset = 0;
503
504 trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
505
506 $inputfd->blocking(0);
507 $stdoutfd->blocking(0);
508 $statusfd->blocking(0) if defined $statusfd;
509 $stderrfd->blocking(0);
510 $sout->add($stdoutfd);
511 $sout->add($stderrfd);
512 $sout->add($statusfd) if defined $statusfd;
513 $sin->add($inputfd);
514
515 my ($stdout, $stderr, $status) = ("", "", "");
516 my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
517 trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
518
519 my $readwrote_stuff_this_time = 0;
520 my $do_not_wait_on_select = 0;
521 my ($readyr, $readyw, $written);
522 while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
523 if (defined $exitwhenstatusmatches) {
524 if ($status =~ /$exitwhenstatusmatches/m) {
525 trace("readwrite_gpg found match on $exitwhenstatusmatches");
526 if ($readwrote_stuff_this_time) {
527 trace("read/write some more\n");
528 $do_not_wait_on_select = 1;
529 } else {
530 trace("that's it in our while loop.\n");
531 last;
532 }
533 };
534 };
535
536 $readwrote_stuff_this_time = 0;
537 trace("select waiting for ".($sout->count())." fds.");
538 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
539 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
540 for my $wfd (@$readyw) {
541 $readwrote_stuff_this_time = 1;
542 if (length($in) != $offset) {
543 trace("writing to $wfd.");
544 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
545 $offset += $written;
546 };
547 if ($offset == length($in)) {
548 trace("writing to $wfd done.");
549 unless ($options{'nocloseinput'}) {
550 close $wfd;
551 trace("$wfd closed.");
552 };
553 $sin->remove($wfd);
554 $sin = undef;
555 }
556 }
557
558 next unless (defined(@$readyr)); # Wait some more.
559
560 for my $rfd (@$readyr) {
561 $readwrote_stuff_this_time = 1;
562 if ($rfd->eof) {
563 trace("reading from $rfd done.");
564 $sout->remove($rfd);
565 close($rfd);
566 next;
567 }
568 trace("reading from $rfd.");
569 if ($rfd == $stdoutfd) {
570 $stdout .= <$rfd>;
571 trace2("stdout is now $stdout\n================");
572 next;
573 }
574 if (defined $statusfd && $rfd == $statusfd) {
575 $status .= <$rfd>;
576 trace2("status is now $status\n================");
577 next;
578 }
579 if ($rfd == $stderrfd) {
580 $stderr .= <$rfd>;
581 trace2("stderr is now $stderr\n================");
582 next;
583 }
584 }
585 }
586 trace("readwrite_gpg done.");
587 return ($stdout, $stderr, $status);
588 };
589
590 sub ask($$;$$) {
591 my ($question, $default, $forceyes, $forceno) = @_;
592 my $answer;
593 my $yn = $default ? '[Y/n]' : '[y/N]';
594 while (1) {
595 print $question,' ',$yn, ' ';
596 if ($forceyes && $forceno) {
597 print "$default (from config/command line)\n";
598 return $default;
599 };
600 if ($forceyes) {
601 print "YES (from config/command line)\n";
602 return 1;
603 };
604 if ($forceno) {
605 print "NO (from config/command line)\n";
606 return 0;
607 };
608
609 $answer = <STDIN>;
610 if (!defined $answer) {
611 $OUTPUT_AUTOFLUSH = 1;
612 die "\n\n".
613 "End of STDIN reached. Are you using xargs? Caff wants to read from STDIN,\n".
614 "so you can't really use it with xargs. A patch against caff to read from\n".
615 "the terminal would be appreciated.\n".
616 "For now instead of cat keys | xargs caff do caff `cat keys`\n";
617 };
618 chomp $answer;
619 last if ((length $answer == 0) || ($answer =~ m/^[yYnN]$/) );
620 print "What about $yn is so hard to understand?\nAnswer with either 'n' or 'y' or just press enter for the default.\n";
621 sleep 1;
622 };
623 my $result = $default;
624 $result = 1 if $answer =~ /y/i;
625 $result = 0 if $answer =~ /n/i;
626 return $result;
627 };
628
629
630
631
632
633 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
634 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
635 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
636 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
637 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
638
639 load_config;
640 my $USER_AGENT = "caff $VERSION - http://pgp-tools.alioth.debian.org/";
641
642 my $KEYSBASE = $CONFIG{'caffhome'}.'/keys';
643 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
644
645 -d $KEYSBASE || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
646 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
647
648 my $NOW = time;
649 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
650 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
651
652
653 sub version($) {
654 my ($fd) = @_;
655 print $fd "caff $VERSION - (c) 2004, 2005, 2006 Peter Palfrader et al.\n";
656 };
657
658 sub usage($$) {
659 my ($fd, $exitcode) = @_;
660 version($fd);
661 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
662 print $fd "Consult the manual page for more information.\n";
663 exit $exitcode;
664 };
665
666 ######
667 # export key $keyid from $gnupghome
668 ######
669 sub export_key($$) {
670 my ($gnupghome, $keyid) = @_;
671
672 my $gpg = GnuPG::Interface->new();
673 $gpg->call( $CONFIG{'gpg'} );
674 if (defined $gnupghome) {
675 $gpg->options->hash_init(
676 'homedir' => $gnupghome,
677 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
678 'armor' => 1 );
679 } else {
680 $gpg->options->hash_init(
681 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
682 'armor' => 1 );
683 };
684 $gpg->options->meta_interactive( 0 );
685 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
686 my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
687 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
688 waitpid $pid, 0;
689
690 return $stdout;
691 };
692
693 ######
694 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
695 ######
696 sub import_key($$) {
697 my ($gnupghome, $asciikey) = @_;
698
699 my $gpg = GnuPG::Interface->new();
700 $gpg->call( $CONFIG{'gpg'} );
701 $gpg->options->hash_init(
702 'homedir' => $gnupghome,
703 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ] );
704 $gpg->options->meta_interactive( 0 );
705 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
706 my $pid = $gpg->import_keys(handles => $handles);
707 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
708 waitpid $pid, 0;
709
710 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
711 return undef;
712 };
713 return 1;
714 };
715
716
717 ######
718 # Send an email to $address. If $can_encrypt is true then the mail
719 # will be PGP/MIME encrypted to $longkeyid.
720 #
721 # $longkeyid, $uid, and @attached will be used in the email and the template.
722 ######
723 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
724 sub send_mail($$$@) {
725 my ($address, $can_encrypt, $key_id, @keys) = @_;
726
727 my $template = Text::Template->new(TYPE => 'STRING', SOURCE => $CONFIG{'mail-template'})
728 or die "Error creating template: $Text::Template::ERROR";
729
730 my @uids;
731 for my $key (@keys) {
732 push @uids, $key->{'text'};
733 };
734 my $message = $template->fill_in(HASH => { key => $key_id,
735 uids => \@uids,
736 owner => $CONFIG{'owner'}})
737 or die "Error filling template in: $Text::Template::ERROR";
738
739 my $message_entity = MIME::Entity->build(
740 Type => "text/plain",
741 Charset => "utf-8",
742 Disposition => 'inline',
743 Data => $message);
744
745 my @key_entities;
746 for my $key (@keys) {
747 $message_entity->attach(
748 Type => "application/pgp-keys",
749 Disposition => 'attachment',
750 Encoding => "7bit",
751 Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).'), signed by 0x'.$CONFIG{'keyid'}[0],
752 Data => $key->{'key'},
753 Filename => "0x$key_id.".$key->{'serial'}.".signed-by-0x".$CONFIG{'keyid'}[0].".asc");
754 };
755
756 if ($can_encrypt) {
757 my $message = $message_entity->stringify();
758
759 my $gpg = GnuPG::Interface->new();
760 $gpg->call( $CONFIG{'gpg'} );
761 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
762 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
763 'armor' => 1 );
764 $gpg->options->meta_interactive( 0 );
765 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
766 $gpg->options->push_recipients( $key_id );
767 if (defined $CONFIG{'also-encrypt-to'}) {
768 if (ref($CONFIG{'also-encrypt-to'})) {
769 $gpg->options->push_recipients($_)
770 foreach @{$CONFIG{'also-encrypt-to'}};
771 } else {
772 $gpg->options->push_recipients($CONFIG{'also-encrypt-to'});
773 }
774 }
775 my $pid = $gpg->encrypt(handles => $handles);
776 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
777 waitpid $pid, 0;
778 if ($stdout eq '') {
779 warn ("No data from gpg for list-key $key_id\n");
780 next;
781 };
782 $message = $stdout;
783
784 $message_entity = MIME::Entity->build(
785 Type => 'multipart/encrypted; protocol="application/pgp-encrypted"',
786 Encoding => '7bit');
787
788 $message_entity->attach(
789 Type => "application/pgp-encrypted",
790 Disposition => 'attachment',
791 Encoding => "7bit",
792 Data => "Version: 1\n");
793
794 $message_entity->attach(
795 Type => "application/octet-stream",
796 Filename => 'msg.asc',
797 Disposition => 'inline',
798 Encoding => "7bit",
799 Data => $message);
800 };
801
802 $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
803 $message_entity->head->add("To", $address);
804 $message_entity->head->add("From", '"'.Encode::encode('MIME-Q', $CONFIG{'owner'}).'" <'.$CONFIG{'email'}.'>');
805 $message_entity->head->add("Reply-To", $CONFIG{'reply-to'}) if defined $CONFIG{'reply-to'};
806 $message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
807 $message_entity->head->add("User-Agent", $USER_AGENT);
808 mywarn("You have set arguments to pass to Mail::Mailer. Better fix your MTA. (Also, Mail::Mailer's error reporting is non existant, so it won't tell you when it doesn't work.)") if (scalar @{$CONFIG{'mailer-send'}} > 0);
809 $message_entity->send(@{$CONFIG{'mailer-send'}});
810 $message_entity->stringify();
811 };
812
813 ######
814 # clean up a UID so that it can be used on the FS.
815 ######
816 sub sanitize_uid($) {
817 my ($uid) = @_;
818
819 my $good_uid = $uid;
820 $good_uid =~ tr#/:\\#_#;
821 trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
822 return $good_uid;
823 };
824
825 sub delete_signatures($$$$$$) {
826 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;
827
828 my $signed_by_me = 0;
829
830 my ($stdout, $stderr, $status) =
831 readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
832
833 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
834 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
835 my @sigline = grep { /^sig/ } (split /\n/, $stdout);
836 $stdout =~ s/\n/\\n/g;
837 notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
838 my $line = pop @sigline;
839 my $answer = "no";
840 if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
841 debug("[sigremoval] doing line $line.");
842 my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
843 if ($signer eq $longkeyid) {
844 debug("[sigremoval] selfsig ($signer).");
845 $answer = "no";
846 } elsif (grep { $signer eq $_ } @{$keyids}) {
847 debug("[sigremoval] signed by us ($signer).");
848 $answer = "no";
849 $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
850 } else {
851 debug("[sigremoval] not interested in that sig ($signer).");
852 $answer = "yes";
853 };
854 } else {
855 debug("[sigremoval] no sig line here, only got: ".$stdout);
856 };
857 ($stdout, $stderr, $status) =
858 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
859 };
860
861 return $signed_by_me;
862 };
863
864
865 ###################
866 # argument handling
867 ###################
868 my @KEYIDS;
869 my $params;
870
871 Getopt::Long::config('bundling');
872 if (!GetOptions (
873 '-h' => \$params->{'help'},
874 '--help' => \$params->{'help'},
875 '--version' => \$params->{'version'},
876 '-V' => \$params->{'version'},
877 '-u=s' => \$params->{'local-user'},
878 '--local-user=s' => \$params->{'local-user'},
879 '-e' => \$params->{'export-old'},
880 '--export-old' => \$params->{'export-old'},
881 '-E' => \$params->{'no-export-old'},
882 '--no-export-old' => \$params->{'no-export-old'},
883 '-m' => \$params->{'mail'},
884 '--mail' => \$params->{'mail'},
885 '-M' => \$params->{'no-mail'},
886 '--no-mail' => \$params->{'no-mail'},
887 '-R' => \$params->{'no-download'},
888 '--no-download' => \$params->{'no-download'},
889 '-S' => \$params->{'no-sign'},
890 '--no-sign' => \$params->{'no-sign'},
891 '--key-file=s@' => \$params->{'key-files'},
892 )) {
893 usage(\*STDERR, 1);
894 };
895 if ($params->{'help'}) {
896 usage(\*STDOUT, 0);
897 };
898 if ($params->{'version'}) {
899 version(\*STDOUT);
900 exit(0);
901 };
902 usage(\*STDERR, 1) unless scalar @ARGV >= 1;
903
904 $CONFIG{'local-user'} = $params->{'local-user'} if defined $params->{'local-user'};
905 $CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
906 $CONFIG{'no-mail'} = $params->{'no-mail'} if defined $params->{'no-mail'};
907 $CONFIG{'mail'} = $params->{'mail'} if defined $params->{'mail'};
908 $CONFIG{'no-sign'} = $params->{'no-sign'} if defined $params->{'no-sign'};
909 push @{$CONFIG{'key-files'}}, @{$params->{'key-files'}} if defined $params->{'key-files'};
910
911 for my $keyid (@ARGV) {
912 $keyid =~ s/^0x//i;
913 if ($keyid =~ /^[A-F0-9]{32}$/i) {
914 info("Ignoring v3 fingerprint $keyid. v3 keys are obsolete.");
915 next;
916 };
917 if ($keyid !~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i) {
918 print STDERR "$keyid is not a keyid.\n";
919 usage(\*STDERR, 1);
920 };
921 push @KEYIDS, uc($keyid);
922 };
923
924 #################
925 # import own keys
926 #################
927 for my $keyid (@{$CONFIG{'keyid'}}) {
928 my $gpg = GnuPG::Interface->new();
929 $gpg->call( $CONFIG{'gpg'} );
930 $gpg->options->hash_init(
931 'homedir' => $GNUPGHOME,
932 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --fast-list-mode } ] );
933 $gpg->options->meta_interactive( 0 );
934 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
935 my $pid = $gpg->list_public_keys(handles => $handles, command_args => $keyid);
936 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
937 waitpid $pid, 0;
938
939 if ($stdout eq '') {
940 warn ("No data from gpg for list-key\n"); # There should be at least 'tru:' everywhere.
941 };
942 unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
943 info("Key $keyid not found in caff's home. Getting it from your normal GnuPGHome.");
944 my $key = export_key(undef, $keyid);
945 if (!defined $key || $key eq '') {
946 warn ("Did not get key $keyid from your normal GnuPGHome\n");
947 next;
948 };
949 my $result = import_key($GNUPGHOME, $key);
950 unless ($result) {
951 warn ("Could not import $keyid into caff's gnupghome.\n");
952 next;
953 };
954 }
955 }
956
957 ########################
958 # import keys from files
959 ########################
960 foreach my $keyfile (@{$CONFIG{'key-files'}}) {
961 my $gpg = GnuPG::Interface->new();
962 $gpg->call( $CONFIG{'gpg'} );
963 $gpg->options->hash_init('homedir' => $GNUPGHOME);
964 $gpg->options->meta_interactive( 0 );
965 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
966 my $pid = $gpg->import_keys(handles => $handles, command_args => $keyfile);
967 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
968 info ("Importing keys from $keyfile");
969 waitpid $pid, 0;
970 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
971 warn $stderr;
972 }
973 }
974
975 #############################
976 # receive keys from keyserver
977 #############################
978 my @keyids_ok;
979 if ($CONFIG{'no-download'}) {
980 @keyids_ok = @KEYIDS;
981 } else {
982 info ("fetching keys, this will take a while...");
983
984 my $gpg = GnuPG::Interface->new();
985 $gpg->call( $CONFIG{'gpg'} );
986 $gpg->options->hash_init(
987 'homedir' => $GNUPGHOME,
988 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always }, '--keyserver='.$CONFIG{'keyserver'} ] );
989 $gpg->options->meta_interactive( 0 );
990 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
991 my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
992 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
993 waitpid $pid, 0;
994
995 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
996 # [GNUPG:] NODATA 1
997 # [GNUPG:] NODATA 1
998 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
999 my %local_keyids = map { $_ => 1 } @KEYIDS;
1000 my $had_v3_keys = 0;
1001 for my $line (split /\n/, $status) {
1002 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
1003 my $imported_key = $1;
1004 my $whole_fpr = $imported_key;
1005 my $long_keyid = substr($imported_key, -16);
1006 my $short_keyid = substr($imported_key, -8);
1007 my $speced_key;
1008 for my $spec (($whole_fpr, $long_keyid, $short_keyid)) {
1009 $speced_key = $spec if $local_keyids{$spec};
1010 };
1011 unless ($speced_key) {
1012 notice ("Imported unexpected key; got: $imported_key\n");
1013 next;
1014 };
1015 debug ("Imported $imported_key for $speced_key");
1016 delete $local_keyids{$speced_key};
1017 unshift @keyids_ok, $imported_key;
1018 } elsif ($line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) /) {
1019 } elsif ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{32})/) {
1020 my $imported_key = $1;
1021 notice ("Imported key $1 is a version 3 key. Version 3 keys are obsolete, should not be used, and are not and will not be properly supported.");
1022 $had_v3_keys = 1;
1023 } else {
1024 notice ("got unknown reply from gpg: $line");
1025 }
1026 };
1027 if (scalar %local_keyids) {
1028 notice ("Import failed for: ". (join ' ', keys %local_keyids)."." . ($had_v3_keys ? " (Or maybe it's one of those ugly v3 keys?)" : ""));
1029 exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
1030 if (scalar keys %local_keyids == 1) {
1031 mywarn("Assuming ". (join ' ', keys %local_keyids)." is a fine keyid.");
1032 } else {
1033 mywarn("Assuming ". (join ' ', keys %local_keyids)." are fine keyids.");
1034 };
1035 push @keyids_ok, keys %local_keyids;
1036 }
1037 };
1038
1039 unless (@keyids_ok) {
1040 notice ("No keys to sign found");
1041 exit 0;
1042 }
1043
1044 ###########
1045 # sign keys
1046 ###########
1047 if ($CONFIG{'ask-sign'} && ! $CONFIG{'no-sign'}) {
1048 $CONFIG{'no-sign'} = ! ask("Continue with signing?", 1);
1049 }
1050
1051 unless ($CONFIG{'no-sign'}) {
1052 my @local_user;
1053 if ($CONFIG{'local-user'}) {
1054 if (ref($CONFIG{'local-user'})) {
1055 @local_user = @{$CONFIG{'local-user'}};
1056 } else {
1057 @local_user = split /\s*,\s*/, $CONFIG{'local-user'};
1058 };
1059 foreach (@local_user) {
1060 s/^0x//i;
1061 unless (/^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i) {
1062 print STDERR "Local-user $_ is not a keyid.\n";
1063 usage(\*STDERR, 1);
1064 };
1065 $_ = uc($_);
1066 };
1067 } else {
1068 @local_user = (undef);
1069 };
1070
1071 info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
1072 for my $keyid (@keyids_ok) {
1073 foreach my $local_user (@local_user) {
1074 my @command;
1075 push @command, $CONFIG{'gpg-sign'};
1076 push @command, '--local-user', $local_user if (defined $local_user);
1077 push @command, "--homedir=$GNUPGHOME";
1078 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
1079 push @command, '--no-auto-check-trustdb';
1080 push @command, '--trust-model=always';
1081 push @command, '--edit', $keyid;
1082 push @command, 'sign';
1083 push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
1084 print join(' ', @command),"\n";
1085 system (@command);
1086 };
1087 };
1088 };
1089
1090 ##################
1091 # export and prune
1092 ##################
1093 KEYS:
1094 for my $keyid (@keyids_ok) {
1095 # get key listing
1096 #################
1097 my $gpg = GnuPG::Interface->new();
1098 $gpg->call( $CONFIG{'gpg'} );
1099 $gpg->options->hash_init(
1100 'homedir' => $GNUPGHOME,
1101 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
1102 $gpg->options->meta_interactive( 0 );
1103 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1104 my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
1105 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
1106 waitpid $pid, 0;
1107 if ($stdout eq '') {
1108 warn ("No data from gpg for list-key $keyid\n");
1109 next;
1110 };
1111 my @publine = grep { /^pub/ } (split /\n/, $stdout);
1112 if (scalar @publine == 0) {
1113 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
1114 next;
1115 };
1116 my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
1117 if (scalar @publine > 0) {
1118 warn ("More than one key matched $keyid. Try to specify the long keyid or fingerprint\n");
1119 next;
1120 };
1121 unless (defined $longkeyid) {
1122 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
1123 next;
1124 };
1125 unless (defined $flags) {
1126 warn ("Didn't find flags in --list-key of key $keyid.\n");
1127 next;
1128 };
1129 my $can_encrypt = $flags =~ /E/;
1130
1131 # export the key
1132 ################
1133 my $asciikey = export_key($GNUPGHOME, $keyid);
1134 if ($asciikey eq '') {
1135 warn ("No data from gpg for export $keyid\n");
1136 next;
1137 };
1138
1139 my @UIDS;
1140 my $uid_number = 0;
1141 while (1) {
1142 my $this_uid_text = '';
1143 $uid_number++;
1144 debug("Doing key $keyid, uid $uid_number");
1145 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
1146
1147 # import into temporary gpghome
1148 ###############################
1149 my $result = import_key($tempdir, $asciikey);
1150 unless ($result) {
1151 warn ("Could not import $keyid into temporary gnupg.\n");
1152 next;
1153 };
1154
1155 # prune it
1156 ##########
1157 $gpg = GnuPG::Interface->new();
1158 $gpg->call( $CONFIG{'gpg-delsig'} );
1159 $gpg->options->hash_init(
1160 'homedir' => $tempdir,
1161 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --command-fd=0 --no-tty } ] );
1162 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1163 $pid = $gpg->wrap_call(
1164 commands => [ '--edit' ],
1165 command_args => [ $keyid ],
1166 handles => $handles );
1167
1168 debug("Starting edit session");
1169 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1170
1171 # delete other uids
1172 ###################
1173 my $number_of_subkeys = 0;
1174 my $i = 1;
1175 my $have_one = 0;
1176 my $is_uat = 0;
1177 my $delete_some = 0;
1178 debug("Parsing stdout output.");
1179 for my $line (split /\n/, $stdout) {
1180 debug("Checking line $line");
1181 my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
1182 if ($type eq 'sub') {
1183 $number_of_subkeys++;
1184 };
1185 next unless ($type eq 'uid' || $type eq 'uat');
1186 debug("line is interesting.");
1187 if ($uid_number != $i) {
1188 debug("mark for deletion.");
1189 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1190 $delete_some++;
1191 } else {
1192 debug("keep it.");
1193 $have_one = 1;
1194 $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
1195 $is_uat = $type eq 'uat';
1196 };
1197 $i++;
1198 };
1199 debug("Parsing stdout output done.");
1200 unless ($have_one) {
1201 debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
1202 info("key $keyid done.");
1203 last;
1204 };
1205
1206 my $prune_some_sigs_on_uid;
1207 my $prune_all_sigs_on_uid;
1208 if ($is_uat) {
1209 debug("handling attribute userid of key $keyid.");
1210 if ($uid_number == 1) {
1211 debug(" attribute userid is #1, unmarking #2 for deletion.");
1212 readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1213 $delete_some--;
1214 $prune_some_sigs_on_uid = 1;
1215 $prune_all_sigs_on_uid = 2;
1216 } else {
1217 debug("attribute userid is not #1, unmarking #1 for deletion.");
1218 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1219 $delete_some--;
1220 $prune_some_sigs_on_uid = 2;
1221 $prune_all_sigs_on_uid = 1;
1222 };
1223 } else {
1224 $prune_some_sigs_on_uid = 1;
1225 };
1226
1227 if ($delete_some) {
1228 debug("need to delete $delete_some uids.");
1229 readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
1230 readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1231 };
1232
1233 # delete subkeys
1234 ################
1235 if ($number_of_subkeys > 0) {
1236 for (my $i=1; $i<=$number_of_subkeys; $i++) {
1237 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1238 };
1239 readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
1240 readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1241 };
1242
1243 # delete signatures
1244 ###################
1245 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1246 my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
1247 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1248 if (defined $prune_all_sigs_on_uid) {
1249 readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1250 delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
1251 readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1252 };
1253
1254
1255 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
1256 waitpid $pid, 0;
1257
1258 my $asciikey = export_key($tempdir, $keyid);
1259 if ($asciikey eq '') {
1260 warn ("No data from gpg for export $keyid\n");
1261 next;
1262 };
1263
1264 if ($signed_by_me) {
1265 if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
1266 my $write = ask("Signature on $this_uid_text is old. Export?", 0, $params->{'export-old'}, $params->{'no-export-old'});
1267 next unless $write;
1268 };
1269 my $keydir = "$KEYSBASE/$DATE_STRING";
1270 -d $keydir || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
1271
1272 my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
1273 open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
1274 print KEY $asciikey;
1275 close KEY;
1276
1277 push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };
1278
1279 info("$longkeyid $uid_number $this_uid_text done.");
1280 } else {
1281 info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
1282 };
1283 };
1284
1285 if (scalar @UIDS == 0) {
1286 info("found no signed uids for $keyid");
1287 } else {
1288 next if $CONFIG{'no-mail'}; # do not send mail
1289
1290 my @attached;
1291 for my $uid (@UIDS) {
1292 trace("UID: $uid->{'text'}\n");
1293 if ($uid->{'is_uat'}) {
1294 my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
1295 push @attached, $uid if $attach;
1296 } elsif ($uid->{'text'} !~ /@/) {
1297 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
1298 push @attached, $uid if $attach;
1299 };
1300 };
1301
1302 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
1303 for my $uid (@UIDS) {
1304 if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1305 my $address = $uid->{'text'};
1306 $address =~ s/.*<(.*)>.*/$1/;
1307 if (ask("Mail signature for $uid->{'text'} to '$address'?", 1, $CONFIG{'mail'})) {
1308 my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
1309
1310 my $keydir = "$KEYSBASE/$DATE_STRING";
1311 my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
1312 open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
1313 print KEY $mail;
1314 close KEY;
1315 };
1316 };
1317 };
1318 };
1319
1320 };
1321
1322 ###########################
1323 # the default mail template
1324 ###########################
1325
1326 __DATA__
1327 Hi,
1328
1329 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}
1330 {foreach $uid (@uids) {
1331 $OUT .= "\t".$uid."\n";
1332 };}of your key {$key} signed by me.
1333
1334 If you have multiple user ids, I sent the signature for each user id
1335 separately to that user id's associated email address. You can import
1336 the signatures by running each through `gpg --import`.
1337
1338 Note that I did not upload your key to any keyservers. If you want this
1339 new signature to be available to others, please upload it yourself.
1340 With GnuPG this can be done using
1341 gpg --keyserver subkeys.pgp.net --send-key {$key}
1342
1343 If you have any questions, don't hesitate to ask.
1344
1345 Regards,
1346 {$owner}