]> git.sthu.org Git - pgp-tools.git/blob - caff/caff
7988badc534f64e5dd6a2c00a48b6198d1e27c78
[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 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, 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 Fcntl;
301 use IO::Select;
302 use Getopt::Long;
303 use GnuPG::Interface;
304
305 my %CONFIG;
306 my $REVISION = '$Rev$';
307 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
308 my $VERSION = "0.0.0.$REVISION_NUMER";
309
310
311
312 sub mywarn($) {
313 my ($line) = @_;
314 print "[WARN] $line\n";
315 };
316 sub notice($) {
317 my ($line) = @_;
318 print "[NOTICE] $line\n";
319 };
320 sub info($) {
321 my ($line) = @_;
322 print "[INFO] $line\n";
323 };
324 sub debug($) {
325 my ($line) = @_;
326 #print "[DEBUG] $line\n";
327 };
328 sub trace($) {
329 my ($line) = @_;
330 #print "[trace] $line\n";
331 };
332 sub trace2($) {
333 my ($line) = @_;
334 #print "[trace2] $line\n";
335 };
336
337
338 sub generate_config() {
339 notice("Error: \$LOGNAME is not set.\n") unless defined $ENV{'LOGNAME'};
340 my $gecos = defined $ENV{'LOGNAME'} ? (getpwnam($ENV{LOGNAME}))[6] : undef;
341 my $email;
342 my @keys;
343 # BSD does not have hostname -f, so we try without -f first
344 my $hostname = `hostname`;
345 $hostname = `hostname -f` unless $hostname =~ /\./;
346 chomp $hostname;
347 my ($Cgecos,$Cemail,$Ckeys) = ('','','');
348
349 if (defined $gecos) {
350 $gecos =~ s/,.*//;
351
352 my $gpg = GnuPG::Interface->new();
353 $gpg->call( 'gpg' );
354 $gpg->options->hash_init(
355 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
356 $gpg->options->meta_interactive( 0 );
357 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
358 my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $gecos ]);
359 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
360 waitpid $pid, 0;
361
362 if ($stdout eq '') {
363 warn ("No data from gpg for list-key\n"); # There should be at least 'tru:' everywhere.
364 };
365
366 @keys = ($stdout =~ /^pub:[^r:]*:(?:[^:]*:){2,2}([^:]+):/mg);
367 unless (scalar @keys) {
368 info("Error: No keys were found using \"gpg --list-public-keys '$gecos'\".");
369 @keys = qw{0123456789abcdef 89abcdef76543210};
370 $Ckeys = '#';
371 }
372 ($email) = ($stdout =~ /^uid:.*<(.+?@.+?)>.*:/m);
373 unless (defined $email) {
374 info("Error: No email address was found using \"gpg --list-public-keys '$gecos'\".");
375 $email = $ENV{'LOGNAME'}.'@'.$hostname;
376 $Cemail = '#';
377 }
378 } else {
379 $gecos = 'Unknown Caff User';
380 $email = $ENV{'LOGNAME'}.'@'.$hostname;
381 @keys = qw{0123456789abcdef 89abcdef76543210};
382 ($Cgecos,$Cemail,$Ckeys) = ('#','#','#');
383 };
384
385 my $template = <<EOT;
386 # .caffrc -- vim:ft=perl:
387 # This file is in perl(1) format - see caff(1) for details.
388
389 $Cgecos\$CONFIG{'owner'} = '$gecos';
390 $Cemail\$CONFIG{'email'} = '$email';
391 #\$CONFIG{'reply-to'} = 'foo\@bla.org';
392
393 # You can get your long keyid from
394 # gpg --with-colons --list-key <yourkeyid|name|emailaddress..>
395 #
396 # If you have a v4 key, it will simply be the last 16 digits of
397 # your fingerprint.
398 #
399 # Example:
400 # \$CONFIG{'keyid'} = [ qw{FEDCBA9876543210} ];
401 # or, if you have more than one key:
402 # \$CONFIG{'keyid'} = [ qw{0123456789ABCDEF 89ABCDEF76543210} ];
403 $Ckeys\$CONFIG{'keyid'} = [ qw{@keys} ];
404
405 # Select this/these keys to sign with
406 #\$CONFIG{'local-user'} = [ qw{@keys} ];
407
408 # Additionally encrypt messages for these keyids
409 #\$CONFIG{'also-encrypt-to'} = [ qw{@keys} ];
410
411 # Mail template to use for the encrypted part
412 #\$CONFIG{'mail-template'} = << 'EOM';
413 EOT
414
415 $template .= "#$_" foreach <DATA>;
416 $template .= "#EOM\n";
417 return $template;
418 };
419
420 sub check_executable($$) {
421 # (GnuPG::Interface gives lousy errors when the gpg binary isn't found,
422 # so we want to check manually.)
423 my ($purpose, $fn) = @_;
424 # Only check provided fnames with a slash in them.
425 return unless defined $fn;
426 if ($fn =~ m!/!) {
427 die ("$PROGRAM_NAME: $purpose executable '$fn' not found.\n") unless -x $fn;
428 } else {
429 for my $p (split(':', $ENV{PATH})) {
430 return if -x "$p/$fn";
431 };
432 die ("$PROGRAM_NAME: $purpose executable '$fn' not found on path.\n") unless -x $fn;
433 };
434 };
435
436 sub load_config() {
437 my $config = $ENV{'HOME'} . '/.caffrc';
438 unless (-f $config) {
439 print "No configfile $config present, I will use this template:\n";
440 my $template = generate_config();
441 print "$template\nPlease edit $config and run caff again.\n";
442 open F, ">$config" or die "$config: $!";
443 print F $template;
444 close F;
445 exit(1);
446 }
447 unless (scalar eval `cat $config`) {
448 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
449 };
450
451 $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
452 die ("$PROGRAM_NAME: owner is not defined in $config.\n") unless defined $CONFIG{'owner'};
453 die ("$PROGRAM_NAME: email is not defined in $config.\n") unless defined $CONFIG{'email'};
454 die ("$PROGRAM_NAME: keyid is not defined in $config.\n") unless defined $CONFIG{'keyid'};
455 die ("$PROGRAM_NAME: keyid is not an array ref in $config.\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
456 for my $keyid (@{$CONFIG{'keyid'}}) {
457 $keyid =~ /^[A-F0-9]{16}$/i or die ("$PROGRAM_NAME: key $keyid is not a long (16 digit) keyid in $config.\n");
458 };
459 @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
460 $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
461 $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
462 $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
463 $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
464 $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
465 check_executable("gpg", $CONFIG{'gpg'});
466 check_executable("gpg-sign", $CONFIG{'gpg-sign'});
467 check_executable("gpg-delsig", $CONFIG{'gpg-delsig'});
468 $CONFIG{'secret-keyring'} = ($ENV{'GNUPGHOME'} || "$ENV{'HOME'}/.gnupg") . '/secring.gpg'
469 unless defined $CONFIG{'secret-keyring'};
470 $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
471 $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
472 $CONFIG{'key-files'} = () unless defined $CONFIG{'key-files'};
473 $CONFIG{'mailer-send'} = [] unless defined $CONFIG{'mailer-send'};
474 die ("$PROGRAM_NAME: mailer-send is not an array ref in $config.\n") unless (ref $CONFIG{'mailer-send'} eq 'ARRAY');
475 unless (defined $CONFIG{'mail-template'}) {
476 $CONFIG{'mail-template'} .= $_ foreach <DATA>;
477 }
478 };
479
480 sub make_gpg_fds() {
481 my %fds = (
482 stdin => IO::Handle->new(),
483 stdout => IO::Handle->new(),
484 stderr => IO::Handle->new(),
485 status => IO::Handle->new() );
486 my $handles = GnuPG::Handles->new( %fds );
487 return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
488 };
489
490 sub readwrite_gpg($$$$$%) {
491 my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
492
493 trace("Entering readwrite_gpg.");
494
495 my ($first_line, undef) = split /\n/, $in;
496 debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
497
498 local $INPUT_RECORD_SEPARATOR = undef;
499 my $sout = IO::Select->new();
500 my $sin = IO::Select->new();
501 my $offset = 0;
502
503 trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
504
505 $inputfd->blocking(0);
506 $stdoutfd->blocking(0);
507 $statusfd->blocking(0) if defined $statusfd;
508 $stderrfd->blocking(0);
509 $sout->add($stdoutfd);
510 $sout->add($stderrfd);
511 $sout->add($statusfd) if defined $statusfd;
512 $sin->add($inputfd);
513
514 my ($stdout, $stderr, $status) = ("", "", "");
515 my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
516 trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
517
518 my $readwrote_stuff_this_time = 0;
519 my $do_not_wait_on_select = 0;
520 my ($readyr, $readyw, $written);
521 while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
522 if (defined $exitwhenstatusmatches) {
523 if ($status =~ /$exitwhenstatusmatches/m) {
524 trace("readwrite_gpg found match on $exitwhenstatusmatches");
525 if ($readwrote_stuff_this_time) {
526 trace("read/write some more\n");
527 $do_not_wait_on_select = 1;
528 } else {
529 trace("that's it in our while loop.\n");
530 last;
531 }
532 };
533 };
534
535 $readwrote_stuff_this_time = 0;
536 trace("select waiting for ".($sout->count())." fds.");
537 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
538 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
539 for my $wfd (@$readyw) {
540 $readwrote_stuff_this_time = 1;
541 if (length($in) != $offset) {
542 trace("writing to $wfd.");
543 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
544 $offset += $written;
545 };
546 if ($offset == length($in)) {
547 trace("writing to $wfd done.");
548 unless ($options{'nocloseinput'}) {
549 close $wfd;
550 trace("$wfd closed.");
551 };
552 $sin->remove($wfd);
553 $sin = undef;
554 }
555 }
556
557 next unless (defined(@$readyr)); # Wait some more.
558
559 for my $rfd (@$readyr) {
560 $readwrote_stuff_this_time = 1;
561 if ($rfd->eof) {
562 trace("reading from $rfd done.");
563 $sout->remove($rfd);
564 close($rfd);
565 next;
566 }
567 trace("reading from $rfd.");
568 if ($rfd == $stdoutfd) {
569 $stdout .= <$rfd>;
570 trace2("stdout is now $stdout\n================");
571 next;
572 }
573 if (defined $statusfd && $rfd == $statusfd) {
574 $status .= <$rfd>;
575 trace2("status is now $status\n================");
576 next;
577 }
578 if ($rfd == $stderrfd) {
579 $stderr .= <$rfd>;
580 trace2("stderr is now $stderr\n================");
581 next;
582 }
583 }
584 }
585 trace("readwrite_gpg done.");
586 return ($stdout, $stderr, $status);
587 };
588
589 sub ask($$;$$) {
590 my ($question, $default, $forceyes, $forceno) = @_;
591 my $answer;
592 my $yn = $default ? '[Y/n]' : '[y/N]';
593 while (1) {
594 print $question,' ',$yn, ' ';
595 if ($forceyes && $forceno) {
596 print "$default (from config/command line)\n";
597 return $default;
598 };
599 if ($forceyes) {
600 print "YES (from config/command line)\n";
601 return 1;
602 };
603 if ($forceno) {
604 print "NO (from config/command line)\n";
605 return 0;
606 };
607
608 $answer = <STDIN>;
609 if (!defined $answer) {
610 $OUTPUT_AUTOFLUSH = 1;
611 die "\n\n".
612 "End of STDIN reached. Are you using xargs? Caff wants to read from STDIN,\n".
613 "so you can't really use it with xargs. A patch against caff to read from\n".
614 "the terminal would be appreciated.\n".
615 "For now instead of cat keys | xargs caff do caff `cat keys`\n";
616 };
617 chomp $answer;
618 last if ((length $answer == 0) || ($answer =~ m/^[yYnN]$/) );
619 print "What about $yn is so hard to understand?\nAnswer with either 'n' or 'y' or just press enter for the default.\n";
620 sleep 1;
621 };
622 my $result = $default;
623 $result = 1 if $answer =~ /y/i;
624 $result = 0 if $answer =~ /n/i;
625 return $result;
626 };
627
628
629
630
631
632 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
633 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
634 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
635 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
636 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
637
638 load_config;
639 my $USER_AGENT = "caff $VERSION - http://pgp-tools.alioth.debian.org/";
640
641 my $KEYSBASE = $CONFIG{'caffhome'}.'/keys';
642 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
643
644 -d $KEYSBASE || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
645 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
646
647 my $NOW = time;
648 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
649 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
650
651
652 sub version($) {
653 my ($fd) = @_;
654 print $fd "caff $VERSION - (c) 2004, 2005, 2006 Peter Palfrader et al.\n";
655 };
656
657 sub usage($$) {
658 my ($fd, $exitcode) = @_;
659 version($fd);
660 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
661 print $fd "Consult the manual page for more information.\n";
662 exit $exitcode;
663 };
664
665 ######
666 # export key $keyid from $gnupghome
667 ######
668 sub export_key($$) {
669 my ($gnupghome, $keyid) = @_;
670
671 my $gpg = GnuPG::Interface->new();
672 $gpg->call( $CONFIG{'gpg'} );
673 if (defined $gnupghome) {
674 $gpg->options->hash_init(
675 'homedir' => $gnupghome,
676 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
677 'armor' => 1 );
678 } else {
679 $gpg->options->hash_init(
680 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
681 'armor' => 1 );
682 };
683 $gpg->options->meta_interactive( 0 );
684 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
685 my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
686 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
687 waitpid $pid, 0;
688
689 return $stdout;
690 };
691
692 ######
693 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
694 ######
695 sub import_key($$) {
696 my ($gnupghome, $asciikey) = @_;
697
698 my $gpg = GnuPG::Interface->new();
699 $gpg->call( $CONFIG{'gpg'} );
700 $gpg->options->hash_init(
701 'homedir' => $gnupghome,
702 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ] );
703 $gpg->options->meta_interactive( 0 );
704 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
705 my $pid = $gpg->import_keys(handles => $handles);
706 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
707 waitpid $pid, 0;
708
709 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
710 return undef;
711 };
712 return 1;
713 };
714
715
716 ######
717 # Send an email to $address. If $can_encrypt is true then the mail
718 # will be PGP/MIME encrypted to $longkeyid.
719 #
720 # $longkeyid, $uid, and @attached will be used in the email and the template.
721 ######
722 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
723 sub send_mail($$$@) {
724 my ($address, $can_encrypt, $key_id, @keys) = @_;
725
726 my $template = Text::Template->new(TYPE => 'STRING', SOURCE => $CONFIG{'mail-template'})
727 or die "Error creating template: $Text::Template::ERROR";
728
729 my @uids;
730 for my $key (@keys) {
731 push @uids, $key->{'text'};
732 };
733 my $message = $template->fill_in(HASH => { key => $key_id,
734 uids => \@uids,
735 owner => $CONFIG{'owner'}})
736 or die "Error filling template in: $Text::Template::ERROR";
737
738 my $message_entity = MIME::Entity->build(
739 Type => "text/plain",
740 Charset => "utf-8",
741 Disposition => 'inline',
742 Data => $message);
743
744 my @key_entities;
745 for my $key (@keys) {
746 $message_entity->attach(
747 Type => "application/pgp-keys",
748 Disposition => 'attachment',
749 Encoding => "7bit",
750 Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).'), signed by 0x'.$CONFIG{'keyid'}[0],
751 Data => $key->{'key'},
752 Filename => "0x$key_id.".$key->{'serial'}.".signed-by-0x".$CONFIG{'keyid'}[0].".asc");
753 };
754
755 if ($can_encrypt) {
756 my $message = $message_entity->stringify();
757
758 my $gpg = GnuPG::Interface->new();
759 $gpg->call( $CONFIG{'gpg'} );
760 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
761 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always } ],
762 'armor' => 1 );
763 $gpg->options->meta_interactive( 0 );
764 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
765 $gpg->options->push_recipients( $key_id );
766 if (defined $CONFIG{'also-encrypt-to'}) {
767 if (ref($CONFIG{'also-encrypt-to'})) {
768 $gpg->options->push_recipients($_)
769 foreach @{$CONFIG{'also-encrypt-to'}};
770 } else {
771 $gpg->options->push_recipients($CONFIG{'also-encrypt-to'});
772 }
773 }
774 my $pid = $gpg->encrypt(handles => $handles);
775 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
776 waitpid $pid, 0;
777 if ($stdout eq '') {
778 warn ("No data from gpg for list-key $key_id\n");
779 next;
780 };
781 $message = $stdout;
782
783 $message_entity = MIME::Entity->build(
784 Type => 'multipart/encrypted; protocol="application/pgp-encrypted"',
785 Encoding => '7bit');
786
787 $message_entity->attach(
788 Type => "application/pgp-encrypted",
789 Disposition => 'attachment',
790 Encoding => "7bit",
791 Data => "Version: 1\n");
792
793 $message_entity->attach(
794 Type => "application/octet-stream",
795 Filename => 'msg.asc',
796 Disposition => 'inline',
797 Encoding => "7bit",
798 Data => $message);
799 };
800
801 $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
802 $message_entity->head->add("To", $address);
803 $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
804 $message_entity->head->add("Reply-To", $CONFIG{'reply-to'}) if defined $CONFIG{'reply-to'};
805 $message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
806 $message_entity->head->add("User-Agent", $USER_AGENT);
807 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);
808 $message_entity->send(@{$CONFIG{'mailer-send'}});
809 $message_entity->stringify();
810 };
811
812 ######
813 # clean up a UID so that it can be used on the FS.
814 ######
815 sub sanitize_uid($) {
816 my ($uid) = @_;
817
818 my $good_uid = $uid;
819 $good_uid =~ tr#/:\\#_#;
820 trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
821 return $good_uid;
822 };
823
824 sub delete_signatures($$$$$$) {
825 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;
826
827 my $signed_by_me = 0;
828
829 my ($stdout, $stderr, $status) =
830 readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
831
832 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
833 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
834 my @sigline = grep { /^sig/ } (split /\n/, $stdout);
835 $stdout =~ s/\n/\\n/g;
836 notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
837 my $line = pop @sigline;
838 my $answer = "no";
839 if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
840 debug("[sigremoval] doing line $line.");
841 my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
842 if ($signer eq $longkeyid) {
843 debug("[sigremoval] selfsig ($signer).");
844 $answer = "no";
845 } elsif (grep { $signer eq $_ } @{$keyids}) {
846 debug("[sigremoval] signed by us ($signer).");
847 $answer = "no";
848 $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
849 } else {
850 debug("[sigremoval] not interested in that sig ($signer).");
851 $answer = "yes";
852 };
853 } else {
854 debug("[sigremoval] no sig line here, only got: ".$stdout);
855 };
856 ($stdout, $stderr, $status) =
857 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
858 };
859
860 return $signed_by_me;
861 };
862
863
864 ###################
865 # argument handling
866 ###################
867 my @KEYIDS;
868 my $params;
869
870 Getopt::Long::config('bundling');
871 if (!GetOptions (
872 '-h' => \$params->{'help'},
873 '--help' => \$params->{'help'},
874 '--version' => \$params->{'version'},
875 '-V' => \$params->{'version'},
876 '-u=s' => \$params->{'local-user'},
877 '--local-user=s' => \$params->{'local-user'},
878 '-e' => \$params->{'export-old'},
879 '--export-old' => \$params->{'export-old'},
880 '-E' => \$params->{'no-export-old'},
881 '--no-export-old' => \$params->{'no-export-old'},
882 '-m' => \$params->{'mail'},
883 '--mail' => \$params->{'mail'},
884 '-M' => \$params->{'no-mail'},
885 '--no-mail' => \$params->{'no-mail'},
886 '-R' => \$params->{'no-download'},
887 '--no-download' => \$params->{'no-download'},
888 '-S' => \$params->{'no-sign'},
889 '--no-sign' => \$params->{'no-sign'},
890 '--key-file=s@' => \$params->{'key-files'},
891 )) {
892 usage(\*STDERR, 1);
893 };
894 if ($params->{'help'}) {
895 usage(\*STDOUT, 0);
896 };
897 if ($params->{'version'}) {
898 version(\*STDOUT);
899 exit(0);
900 };
901 usage(\*STDERR, 1) unless scalar @ARGV >= 1;
902
903 $CONFIG{'local-user'} = $params->{'local-user'} if defined $params->{'local-user'};
904 $CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
905 $CONFIG{'no-mail'} = $params->{'no-mail'} if defined $params->{'no-mail'};
906 $CONFIG{'mail'} = $params->{'mail'} if defined $params->{'mail'};
907 $CONFIG{'no-sign'} = $params->{'no-sign'} if defined $params->{'no-sign'};
908 push @{$CONFIG{'key-files'}}, @{$params->{'key-files'}} if defined $params->{'key-files'};
909
910 for my $keyid (@ARGV) {
911 $keyid =~ s/^0x//i;
912 if ($keyid =~ /^[A-F0-9]{32}$/i) {
913 info("Ignoring v3 fingerprint $keyid. v3 keys are obsolete.");
914 next;
915 };
916 if ($keyid !~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i) {
917 print STDERR "$keyid is not a keyid.\n";
918 usage(\*STDERR, 1);
919 };
920 push @KEYIDS, uc($keyid);
921 };
922
923 #################
924 # import own keys
925 #################
926 for my $keyid (@{$CONFIG{'keyid'}}) {
927 my $gpg = GnuPG::Interface->new();
928 $gpg->call( $CONFIG{'gpg'} );
929 $gpg->options->hash_init(
930 'homedir' => $GNUPGHOME,
931 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --fast-list-mode } ] );
932 $gpg->options->meta_interactive( 0 );
933 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
934 my $pid = $gpg->list_public_keys(handles => $handles, command_args => $keyid);
935 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
936 waitpid $pid, 0;
937
938 if ($stdout eq '') {
939 warn ("No data from gpg for list-key\n"); # There should be at least 'tru:' everywhere.
940 };
941 unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
942 info("Key $keyid not found in caff's home. Getting it from your normal GnuPGHome.");
943 my $key = export_key(undef, $keyid);
944 if (!defined $key || $key eq '') {
945 warn ("Did not get key $keyid from your normal GnuPGHome\n");
946 next;
947 };
948 my $result = import_key($GNUPGHOME, $key);
949 unless ($result) {
950 warn ("Could not import $keyid into caff's gnupghome.\n");
951 next;
952 };
953 }
954 }
955
956 ########################
957 # import keys from files
958 ########################
959 foreach my $keyfile (@{$CONFIG{'key-files'}}) {
960 my $gpg = GnuPG::Interface->new();
961 $gpg->call( $CONFIG{'gpg'} );
962 $gpg->options->hash_init('homedir' => $GNUPGHOME);
963 $gpg->options->meta_interactive( 0 );
964 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
965 my $pid = $gpg->import_keys(handles => $handles, command_args => $keyfile);
966 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
967 info ("Importing keys from $keyfile");
968 waitpid $pid, 0;
969 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
970 warn $stderr;
971 }
972 }
973
974 #############################
975 # receive keys from keyserver
976 #############################
977 my @keyids_ok;
978 if ($CONFIG{'no-download'}) {
979 @keyids_ok = @KEYIDS;
980 } else {
981 info ("fetching keys, this will take a while...");
982
983 my $gpg = GnuPG::Interface->new();
984 $gpg->call( $CONFIG{'gpg'} );
985 $gpg->options->hash_init(
986 'homedir' => $GNUPGHOME,
987 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always }, '--keyserver='.$CONFIG{'keyserver'} ] );
988 $gpg->options->meta_interactive( 0 );
989 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
990 my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
991 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
992 waitpid $pid, 0;
993
994 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
995 # [GNUPG:] NODATA 1
996 # [GNUPG:] NODATA 1
997 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
998 my %local_keyids = map { $_ => 1 } @KEYIDS;
999 my $had_v3_keys = 0;
1000 for my $line (split /\n/, $status) {
1001 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
1002 my $imported_key = $1;
1003 my $whole_fpr = $imported_key;
1004 my $long_keyid = substr($imported_key, -16);
1005 my $short_keyid = substr($imported_key, -8);
1006 my $speced_key;
1007 for my $spec (($whole_fpr, $long_keyid, $short_keyid)) {
1008 $speced_key = $spec if $local_keyids{$spec};
1009 };
1010 unless ($speced_key) {
1011 notice ("Imported unexpected key; got: $imported_key\n");
1012 next;
1013 };
1014 debug ("Imported $imported_key for $speced_key");
1015 delete $local_keyids{$speced_key};
1016 unshift @keyids_ok, $imported_key;
1017 } elsif ($line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) /) {
1018 } elsif ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{32})/) {
1019 my $imported_key = $1;
1020 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.");
1021 $had_v3_keys = 1;
1022 } else {
1023 notice ("got unknown reply from gpg: $line");
1024 }
1025 };
1026 if (scalar %local_keyids) {
1027 notice ("Import failed for: ". (join ' ', keys %local_keyids)."." . ($had_v3_keys ? " (Or maybe it's one of those ugly v3 keys?)" : ""));
1028 exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
1029 if (scalar keys %local_keyids == 1) {
1030 mywarn("Assuming ". (join ' ', keys %local_keyids)." is a fine keyid.");
1031 } else {
1032 mywarn("Assuming ". (join ' ', keys %local_keyids)." are fine keyids.");
1033 };
1034 push @keyids_ok, keys %local_keyids;
1035 }
1036 };
1037
1038 unless (@keyids_ok) {
1039 notice ("No keys to sign found");
1040 exit 0;
1041 }
1042
1043 ###########
1044 # sign keys
1045 ###########
1046 if ($CONFIG{'ask-sign'} && ! $CONFIG{'no-sign'}) {
1047 $CONFIG{'no-sign'} = ! ask("Continue with signing?", 1);
1048 }
1049
1050 unless ($CONFIG{'no-sign'}) {
1051 my @local_user;
1052 if ($CONFIG{'local-user'}) {
1053 if (ref($CONFIG{'local-user'})) {
1054 @local_user = @{$CONFIG{'local-user'}};
1055 } else {
1056 @local_user = split /\s*,\s*/, $CONFIG{'local-user'};
1057 };
1058 foreach (@local_user) {
1059 s/^0x//i;
1060 unless (/^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i) {
1061 print STDERR "Local-user $_ is not a keyid.\n";
1062 usage(\*STDERR, 1);
1063 };
1064 $_ = uc($_);
1065 };
1066 } else {
1067 @local_user = (undef);
1068 };
1069
1070 info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
1071 for my $keyid (@keyids_ok) {
1072 foreach my $local_user (@local_user) {
1073 my @command;
1074 push @command, $CONFIG{'gpg-sign'};
1075 push @command, '--local-user', $local_user if (defined $local_user);
1076 push @command, "--homedir=$GNUPGHOME";
1077 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
1078 push @command, '--no-auto-check-trustdb';
1079 push @command, '--trust-model=always';
1080 push @command, '--edit', $keyid;
1081 push @command, 'sign';
1082 push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
1083 print join(' ', @command),"\n";
1084 system (@command);
1085 };
1086 };
1087 };
1088
1089 ##################
1090 # export and prune
1091 ##################
1092 KEYS:
1093 for my $keyid (@keyids_ok) {
1094 # get key listing
1095 #################
1096 my $gpg = GnuPG::Interface->new();
1097 $gpg->call( $CONFIG{'gpg'} );
1098 $gpg->options->hash_init(
1099 'homedir' => $GNUPGHOME,
1100 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode } ] );
1101 $gpg->options->meta_interactive( 0 );
1102 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1103 my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
1104 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
1105 waitpid $pid, 0;
1106 if ($stdout eq '') {
1107 warn ("No data from gpg for list-key $keyid\n");
1108 next;
1109 };
1110 my @publine = grep { /^pub/ } (split /\n/, $stdout);
1111 if (scalar @publine == 0) {
1112 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
1113 next;
1114 };
1115 my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
1116 if (scalar @publine > 0) {
1117 warn ("More than one key matched $keyid. Try to specify the long keyid or fingerprint\n");
1118 next;
1119 };
1120 unless (defined $longkeyid) {
1121 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
1122 next;
1123 };
1124 unless (defined $flags) {
1125 warn ("Didn't find flags in --list-key of key $keyid.\n");
1126 next;
1127 };
1128 my $can_encrypt = $flags =~ /E/;
1129
1130 # export the key
1131 ################
1132 my $asciikey = export_key($GNUPGHOME, $keyid);
1133 if ($asciikey eq '') {
1134 warn ("No data from gpg for export $keyid\n");
1135 next;
1136 };
1137
1138 my @UIDS;
1139 my $uid_number = 0;
1140 while (1) {
1141 my $this_uid_text = '';
1142 $uid_number++;
1143 debug("Doing key $keyid, uid $uid_number");
1144 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
1145
1146 # import into temporary gpghome
1147 ###############################
1148 my $result = import_key($tempdir, $asciikey);
1149 unless ($result) {
1150 warn ("Could not import $keyid into temporary gnupg.\n");
1151 next;
1152 };
1153
1154 # prune it
1155 ##########
1156 $gpg = GnuPG::Interface->new();
1157 $gpg->call( $CONFIG{'gpg-delsig'} );
1158 $gpg->options->hash_init(
1159 'homedir' => $tempdir,
1160 'extra_args' => [ qw{ --no-auto-check-trustdb --trust-model=always --with-colons --fixed-list-mode --command-fd=0 --no-tty } ] );
1161 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
1162 $pid = $gpg->wrap_call(
1163 commands => [ '--edit' ],
1164 command_args => [ $keyid ],
1165 handles => $handles );
1166
1167 debug("Starting edit session");
1168 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1169
1170 # delete other uids
1171 ###################
1172 my $number_of_subkeys = 0;
1173 my $i = 1;
1174 my $have_one = 0;
1175 my $is_uat = 0;
1176 my $delete_some = 0;
1177 debug("Parsing stdout output.");
1178 for my $line (split /\n/, $stdout) {
1179 debug("Checking line $line");
1180 my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
1181 if ($type eq 'sub') {
1182 $number_of_subkeys++;
1183 };
1184 next unless ($type eq 'uid' || $type eq 'uat');
1185 debug("line is interesting.");
1186 if ($uid_number != $i) {
1187 debug("mark for deletion.");
1188 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1189 $delete_some++;
1190 } else {
1191 debug("keep it.");
1192 $have_one = 1;
1193 $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
1194 $is_uat = $type eq 'uat';
1195 };
1196 $i++;
1197 };
1198 debug("Parsing stdout output done.");
1199 unless ($have_one) {
1200 debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
1201 info("key $keyid done.");
1202 last;
1203 };
1204
1205 my $prune_some_sigs_on_uid;
1206 my $prune_all_sigs_on_uid;
1207 if ($is_uat) {
1208 debug("handling attribute userid of key $keyid.");
1209 if ($uid_number == 1) {
1210 debug(" attribute userid is #1, unmarking #2 for deletion.");
1211 readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1212 $delete_some--;
1213 $prune_some_sigs_on_uid = 1;
1214 $prune_all_sigs_on_uid = 2;
1215 } else {
1216 debug("attribute userid is not #1, unmarking #1 for deletion.");
1217 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1218 $delete_some--;
1219 $prune_some_sigs_on_uid = 2;
1220 $prune_all_sigs_on_uid = 1;
1221 };
1222 } else {
1223 $prune_some_sigs_on_uid = 1;
1224 };
1225
1226 if ($delete_some) {
1227 debug("need to delete $delete_some uids.");
1228 readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
1229 readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1230 };
1231
1232 # delete subkeys
1233 ################
1234 if ($number_of_subkeys > 0) {
1235 for (my $i=1; $i<=$number_of_subkeys; $i++) {
1236 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1237 };
1238 readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
1239 readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
1240 };
1241
1242 # delete signatures
1243 ###################
1244 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1245 my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
1246 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1247 if (defined $prune_all_sigs_on_uid) {
1248 readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
1249 delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
1250 readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
1251 };
1252
1253
1254 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
1255 waitpid $pid, 0;
1256
1257 my $asciikey = export_key($tempdir, $keyid);
1258 if ($asciikey eq '') {
1259 warn ("No data from gpg for export $keyid\n");
1260 next;
1261 };
1262
1263 if ($signed_by_me) {
1264 if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
1265 my $write = ask("Signature on $this_uid_text is old. Export?", 0, $params->{'export-old'}, $params->{'no-export-old'});
1266 next unless $write;
1267 };
1268 my $keydir = "$KEYSBASE/$DATE_STRING";
1269 -d $keydir || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
1270
1271 my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
1272 open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
1273 print KEY $asciikey;
1274 close KEY;
1275
1276 push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };
1277
1278 info("$longkeyid $uid_number $this_uid_text done.");
1279 } else {
1280 info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
1281 };
1282 };
1283
1284 if (scalar @UIDS == 0) {
1285 info("found no signed uids for $keyid");
1286 } else {
1287 next if $CONFIG{'no-mail'}; # do not send mail
1288
1289 my @attached;
1290 for my $uid (@UIDS) {
1291 trace("UID: $uid->{'text'}\n");
1292 if ($uid->{'is_uat'}) {
1293 my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
1294 push @attached, $uid if $attach;
1295 } elsif ($uid->{'text'} !~ /@/) {
1296 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
1297 push @attached, $uid if $attach;
1298 };
1299 };
1300
1301 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
1302 for my $uid (@UIDS) {
1303 if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1304 my $address = $uid->{'text'};
1305 $address =~ s/.*<(.*)>.*/$1/;
1306 if (ask("Mail signature for $uid->{'text'} to '$address'?", 1, $CONFIG{'mail'})) {
1307 my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
1308
1309 my $keydir = "$KEYSBASE/$DATE_STRING";
1310 my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
1311 open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
1312 print KEY $mail;
1313 close KEY;
1314 };
1315 };
1316 };
1317 };
1318
1319 };
1320
1321 ###########################
1322 # the default mail template
1323 ###########################
1324
1325 __DATA__
1326 Hi,
1327
1328 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}
1329 {foreach $uid (@uids) {
1330 $OUT .= "\t".$uid."\n";
1331 };}of your key {$key} signed by me.
1332
1333 If you have multiple user ids, I sent the signature for each user id
1334 separately to that user id's associated email address. You can import
1335 the signatures by running each through `gpg --import`.
1336
1337 Note that I did not upload your key to any keyservers. If you want this
1338 new signature to be available to others, please upload it yourself.
1339 With GnuPG this can be done using
1340 gpg --keyserver subkeys.pgp.net --send-key {$key}
1341
1342 If you have any questions, don't hesitate to ask.
1343
1344 Regards,
1345 {$owner}