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