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