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