]> git.sthu.org Git - pgp-tools.git/blob - caff/caff
short options are evil too. descript that v3 keys should be avoided
[pgp-tools.git] / caff / caff
1 #!/usr/bin/perl -w
2
3 # caff -- CA - Fire and Forget
4 # $Id$
5 #
6 # Copyright (c) 2004, 2005 Peter Palfrader <peter@palfrader.org>
7 # Copyright (c) 2005 Christoph Berg <cb@df7cb.de>
8 #
9 # All rights reserved.
10 #
11 # Redistribution and use in source and binary forms, with or without
12 # modification, are permitted provided that the following conditions
13 # are met:
14 # 1. Redistributions of source code must retain the above copyright
15 # notice, this list of conditions and the following disclaimer.
16 # 2. Redistributions in binary form must reproduce the above copyright
17 # notice, this list of conditions and the following disclaimer in the
18 # documentation and/or other materials provided with the distribution.
19 # 3. The name of the author may not be used to endorse or promote products
20 # derived from this software without specific prior written permission.
21 #
22 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
23 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
24 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
25 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
26 # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
27 # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
31 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33 =pod
34
35 =head1 NAME
36
37 caff -- CA - Fire and Forget
38
39 =head1 SYNOPSIS
40
41 =over
42
43 =item B<caff> [-eEmMRS] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]
44
45 =back
46
47 =head1 DESCRIPTION
48
49 CA Fire and Forget is a script that helps you in keysigning. It takes a list
50 of keyids on the command line, fetches them from a keyserver and calls GnuPG so
51 that you can sign it. It then mails each key to all its email addresses - only
52 including the one UID that we send to in each mail, pruned from all but self
53 sigs and sigs done by you.
54
55 =head1 OPTIONS
56
57 =over
58
59 =item B<-e>, B<--export-old>
60
61 Export old signatures. Default is to ask the user for each old signature.
62
63 =item B<-E>, B<--no-export-old>
64
65 Do not export old signatures. Default is to ask the user for each old
66 signature.
67
68 =item B<-m>, B<--mail>
69
70 Send mail after signing. Default is to ask the user for each uid.
71
72 =item B<-M>, B<--no-mail>
73
74 Do not send mail after signing. Default is to ask the user for each uid.
75
76 =item B<-R>, B<--no-download>
77
78 Do not retrieve the key to be signed from a keyserver.
79
80 =item B<-S>, B<--no-sign>
81
82 Do not sign the keys.
83
84 =item B<-u> I<yourkeyid>, B<--local-user> I<yourkeyid>
85
86 Select the key that is used for signing, in case you have more than one key.
87
88 =back
89
90 =head1 FILES
91
92 =over
93
94 =item $HOME/.caffrc - configuration file
95
96 =back
97
98 =head1 CONFIGURATION FILE OPTIONS
99
100 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
101
102 Example:
103
104 $CONFIG{owner} = q{Peter Palfrader};
105 $CONFIG{email} = q{peter@palfrader.org};
106 $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
107
108 =head2 Required basic settings
109
110 =over
111
112 =item B<owner> [string]
113
114 Your name. B<REQUIRED>.
115
116 =item B<email> [string]
117
118 Your email address, used in From: lines. B<REQUIRED>.
119
120 =item B<keyid> [list of keyids]
121
122 A list of your keys. This is used to determine which signatures to keep
123 in the pruning step. If you select a key using B<-u> it has to be in
124 this list. B<REQUIRED>.
125
126 =head2 General settings
127
128 =item B<caffhome> [string]
129
130 Base directory for the files caff stores. Default: B<$HOME/.caff/>.
131
132 =head2 GnuPG settings
133
134 =item B<gpg> [string]
135
136 Path to the GnuPG binary. Default: B<gpg>.
137
138 =item B<gpg-sign> [string]
139
140 Path to the GnuPG binary which is used to sign keys. Default: what
141 B<gpg> is set to.
142
143 =item B<gpg-delsig> [string]
144
145 Path to the GnuPG binary which is used to split off signatures. This was
146 needed while the upstream GnuPG was not fixed. Default: what B<gpg>
147 is set to.
148
149 =item B<secret-keyring> [string]
150
151 Path to your secret keyring. Default: B<$HOME/.gnupg/secring.gpg>.
152
153 =item B<also-encrypt-to> [keyid]
154
155 An additional keyid to encrypt messages to. Default: none.
156
157 =item B<gpg-sign-args> [string]
158
159 Additional arguments to pass to gpg. Default: none.
160
161 =head2 Keyserver settings
162
163 =item B<keyserver> [string]
164
165 Keyserver to download keys from. Default: B<subkeys.pgp.net>.
166
167 =item B<no-download> [boolean]
168
169 If true, then skip the step of fetching keys from the keyserver.
170 Default: B<0>.
171
172 =head2 Signing settings
173
174 =item B<no-sign> [boolean]
175
176 If true, then skip the signing step. Default: B<0>.
177
178 =item B<export-sig-age> [seconds]
179
180 Don't export UIDs by default, on which your latest signature is older
181 than this age. Default: B<24*60*60> (i.e. one day).
182
183 =head2 Mail settings
184
185 =item B<mail> [boolean]
186
187 Do not prompt for sending mail, just do it. Default: B<0>.
188
189 =item B<no-mail> [boolean]
190
191 Do not prompt for sending mail. The messages are still written to
192 $CONFIG{caffhome}/keys/. Default: B<0>.
193
194 =item B<mail-template> [string]
195
196 Email template which is used as the body text for the email sent out
197 instead of the default text if specified. The following perl variables
198 can be used in the template:
199
200 =over
201
202 =item B<{owner}> [string]
203
204 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
205
206 =item B<{key}> [string]
207
208 The keyid of the key you signed.
209
210 =item B<{@uids}> [array]
211
212 The UIDs for which signatures are included in the mail.
213
214 =back
215
216 =item B<bcc> [string]
217
218 Address to send blind carbon copies to when sending mail.
219 Default: none.
220
221 =back
222
223 =head1 AUTHORS
224
225 =over
226
227 =item Peter Palfrader <peter@palfrader.org>
228
229 =item Christoph Berg <cb@df7cb.de>
230
231 =back
232
233 =head1 WEBSITE
234
235 http://pgp-tools.alioth.debian.org/
236
237 =cut
238
239 use strict;
240 use IO::Handle;
241 use English;
242 use File::Path;
243 use File::Temp qw{tempdir};
244 use Text::Template;
245 use MIME::Entity;
246 use Fcntl;
247 use IO::Select;
248 use Getopt::Long;
249 use GnuPG::Interface;
250
251 my %CONFIG;
252 my $REVISION = '$Rev$';
253 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
254 my $VERSION = "0.0.0.$REVISION_NUMER";
255
256 sub load_config() {
257 my $config = $ENV{'HOME'} . '/.caffrc';
258 -f $config or die "No file $config present. See caff(1).\n";
259 unless (scalar eval `cat $config`) {
260 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
261 };
262
263 $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
264 die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
265 die ("email is not defined.\n") unless defined $CONFIG{'email'};
266 die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
267 die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
268 for my $keyid (@{$CONFIG{'keyid'}}) {
269 $keyid =~ /^[A-Fa-z0-9]{16}$/ or die ("key $keyid is not a long (16 digit) keyid.\n");
270 };
271 @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
272 $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
273 $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
274 $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
275 $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
276 $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
277 $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
278 $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
279 $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
280 $CONFIG{'mail-template'} = <<'EOM' unless defined $CONFIG{'mail-template'};
281 Hi,
282
283 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
284 {foreach $uid (@uids) {
285 $OUT .= "\t".$uid."\n";
286 };} of your key {$key} signed by me.
287
288 Note that I did not upload your key to any keyservers. If you want this
289 new signature to be available to others, please upload it yourself.
290 With GnuPG this can be done using
291 gpg --keyserver subkeys.pgp.net --send-key {$key}
292
293 If you have any questions, don't hesitate to ask.
294
295 Regards,
296 {$owner}
297 EOM
298 };
299
300 sub notice($) {
301 my ($line) = @_;
302 print "[NOTICE] $line\n";
303 };
304 sub info($) {
305 my ($line) = @_;
306 print "[INFO] $line\n";
307 };
308 sub debug($) {
309 my ($line) = @_;
310 #print "[DEBUG] $line\n";
311 };
312 sub trace($) {
313 my ($line) = @_;
314 #print "[trace] $line\n";
315 };
316 sub trace2($) {
317 my ($line) = @_;
318 #print "[trace2] $line\n";
319 };
320
321 sub make_gpg_fds() {
322 my %fds = (
323 stdin => IO::Handle->new(),
324 stdout => IO::Handle->new(),
325 stderr => IO::Handle->new(),
326 status => IO::Handle->new() );
327 my $handles = GnuPG::Handles->new( %fds );
328 return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
329 };
330
331 sub readwrite_gpg($$$$$%) {
332 my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
333
334 trace("Entering readwrite_gpg.");
335
336 my ($first_line, undef) = split /\n/, $in;
337 debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
338
339 local $INPUT_RECORD_SEPARATOR = undef;
340 my $sout = IO::Select->new();
341 my $sin = IO::Select->new();
342 my $offset = 0;
343
344 trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
345
346 $inputfd->blocking(0);
347 $stdoutfd->blocking(0);
348 $statusfd->blocking(0) if defined $statusfd;
349 $stderrfd->blocking(0);
350 $sout->add($stdoutfd);
351 $sout->add($stderrfd);
352 $sout->add($statusfd) if defined $statusfd;
353 $sin->add($inputfd);
354
355 my ($stdout, $stderr, $status) = ("", "", "");
356 my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
357 trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
358
359 my $readwrote_stuff_this_time = 0;
360 my $do_not_wait_on_select = 0;
361 my ($readyr, $readyw, $written);
362 while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
363 if (defined $exitwhenstatusmatches) {
364 if ($status =~ /$exitwhenstatusmatches/m) {
365 trace("readwrite_gpg found match on $exitwhenstatusmatches");
366 if ($readwrote_stuff_this_time) {
367 trace("read/write some more\n");
368 $do_not_wait_on_select = 1;
369 } else {
370 trace("that's it in our while loop.\n");
371 last;
372 }
373 };
374 };
375
376 $readwrote_stuff_this_time = 0;
377 trace("select waiting for ".($sout->count())." fds.");
378 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
379 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
380 for my $wfd (@$readyw) {
381 $readwrote_stuff_this_time = 1;
382 if (length($in) != $offset) {
383 trace("writing to $wfd.");
384 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
385 $offset += $written;
386 };
387 if ($offset == length($in)) {
388 trace("writing to $wfd done.");
389 unless ($options{'nocloseinput'}) {
390 close $wfd;
391 trace("$wfd closed.");
392 };
393 $sin->remove($wfd);
394 $sin = undef;
395 }
396 }
397
398 next unless (defined(@$readyr)); # Wait some more.
399
400 for my $rfd (@$readyr) {
401 $readwrote_stuff_this_time = 1;
402 if ($rfd->eof) {
403 trace("reading from $rfd done.");
404 $sout->remove($rfd);
405 close($rfd);
406 next;
407 }
408 trace("reading from $rfd.");
409 if ($rfd == $stdoutfd) {
410 $stdout .= <$rfd>;
411 trace2("stdout is now $stdout\n================");
412 next;
413 }
414 if (defined $statusfd && $rfd == $statusfd) {
415 $status .= <$rfd>;
416 trace2("status is now $status\n================");
417 next;
418 }
419 if ($rfd == $stderrfd) {
420 $stderr .= <$rfd>;
421 trace2("stderr is now $stderr\n================");
422 next;
423 }
424 }
425 }
426 trace("readwrite_gpg done.");
427 return ($stdout, $stderr, $status);
428 };
429
430 sub ask($$;$$) {
431 my ($question, $default, $forceyes, $forceno) = @_;
432 return $default if $forceyes and $forceno;
433 return 1 if $forceyes;
434 return 0 if $forceno;
435 my $answer;
436 while (1) {
437 print $question,' ',($default ? '[Y/n]' : '[y/N]'), ' ';
438 $answer = <STDIN>;
439 chomp $answer;
440 last if ((defined $answer) && (length $answer <= 1));
441 print "grrrrrr.\n";
442 sleep 1;
443 };
444 my $result = $default;
445 $result = 1 if $answer =~ /y/i;
446 $result = 0 if $answer =~ /n/i;
447 return $result;
448 };
449
450
451
452
453
454 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
455 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
456 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
457 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
458 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
459
460 load_config;
461 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.";
462
463 my $KEYSBASE = $CONFIG{'caffhome'}.'/keys';
464 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
465
466 -d $KEYSBASE || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
467 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
468
469 my $NOW = time;
470 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
471 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
472
473
474 sub version($) {
475 my ($fd) = @_;
476 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.\n";
477 };
478
479 sub usage($$) {
480 my ($fd, $exitcode) = @_;
481 version($fd);
482 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
483 print $fd "Consult the manual page for more information.\n";
484 exit $exitcode;
485 };
486
487 ######
488 # export key $keyid from $gnupghome
489 ######
490 sub export_key($$) {
491 my ($gnupghome, $keyid) = @_;
492
493 my $gpg = GnuPG::Interface->new();
494 $gpg->call( $CONFIG{'gpg'} );
495 $gpg->options->hash_init(
496 'homedir' => $gnupghome,
497 'armor' => 1 );
498 $gpg->options->meta_interactive( 0 );
499 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
500 my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
501 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
502 waitpid $pid, 0;
503
504 return $stdout;
505 };
506
507 ######
508 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
509 ######
510 sub import_key($$) {
511 my ($gnupghome, $asciikey) = @_;
512
513 my $gpg = GnuPG::Interface->new();
514 $gpg->call( $CONFIG{'gpg'} );
515 $gpg->options->hash_init( 'homedir' => $gnupghome );
516 $gpg->options->meta_interactive( 0 );
517 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
518 my $pid = $gpg->import_keys(handles => $handles);
519 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
520 waitpid $pid, 0;
521
522 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
523 return undef;
524 };
525 return 1;
526 };
527
528
529 ######
530 # Send an email to $address. If $can_encrypt is true then the mail
531 # will be PGP/MIME encrypted to $longkeyid.
532 #
533 # $longkeyid, $uid, and @attached will be used in the email and the template.
534 ######
535 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
536 sub send_mail($$$@) {
537 my ($address, $can_encrypt, $key_id, @keys) = @_;
538
539 my $template = Text::Template->new(TYPE => 'STRING', SOURCE => $CONFIG{'mail-template'})
540 or die "Error creating template: $Text::Template::ERROR";
541
542 my @uids;
543 for my $key (@keys) {
544 push @uids, $key->{'text'};
545 };
546 my $message = $template->fill_in(HASH => { key => $key_id,
547 uids => \@uids,
548 owner => $CONFIG{'owner'}})
549 or die "Error filling template in: $Text::Template::ERROR";
550
551 my $message_entity = MIME::Entity->build(
552 Type => "text/plain",
553 Charset => "utf-8",
554 Disposition => 'inline',
555 Data => $message);
556
557 my @key_entities;
558 for my $key (@keys) {
559 $message_entity->attach(
560 Type => "application/pgp-keys",
561 Disposition => 'attachment',
562 Encoding => "7bit",
563 Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
564 Data => $key->{'key'},
565 Filename => "0x$key_id.".$key->{'serial'}.".asc");
566 };
567
568 if ($can_encrypt) {
569 my $message = $message_entity->stringify();
570
571 my $gpg = GnuPG::Interface->new();
572 $gpg->call( $CONFIG{'gpg'} );
573 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
574 'extra_args' => '--always-trust',
575 'armor' => 1 );
576 $gpg->options->meta_interactive( 0 );
577 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
578 $gpg->options->push_recipients( $key_id );
579 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
580 my $pid = $gpg->encrypt(handles => $handles);
581 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
582 waitpid $pid, 0;
583 if ($stdout eq '') {
584 warn ("No data from gpg for list-key $key_id\n");
585 next;
586 };
587 $message = $stdout;
588
589 $message_entity = MIME::Entity->build(
590 Type => 'multipart/encrypted; protocol="application/pgp-encrypted"');
591
592 $message_entity->attach(
593 Type => "application/pgp-encrypted",
594 Disposition => 'attachment',
595 Encoding => "7bit",
596 Data => "Version: 1\n");
597
598 $message_entity->attach(
599 Type => "application/octet-stream",
600 Filename => 'msg.asc',
601 Disposition => 'inline',
602 Encoding => "7bit",
603 Data => $message);
604 };
605
606 $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
607 $message_entity->head->add("To", $address);
608 $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
609 $message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
610 $message_entity->head->add("User-Agent", $USER_AGENT);
611 $message_entity->send();
612 $message_entity->stringify();
613 };
614
615 ######
616 # clean up a UID so that it can be used on the FS.
617 ######
618 sub sanitize_uid($) {
619 my ($uid) = @_;
620
621 my $good_uid = $uid;
622 $good_uid =~ tr#/:\\#_#;
623 trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
624 return $good_uid;
625 };
626
627 sub delete_signatures($$$$$$) {
628 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;
629
630 my $signed_by_me = 0;
631
632 my ($stdout, $stderr, $status) =
633 readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
634
635 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
636 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
637 my @sigline = grep { /^sig/ } (split /\n/, $stdout);
638 $stdout =~ s/\n/\\n/g;
639 notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
640 my $line = pop @sigline;
641 my $answer = "no";
642 if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
643 debug("[sigremoval] doing line $line.");
644 my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
645 if ($signer eq $longkeyid) {
646 debug("[sigremoval] selfsig ($signer).");
647 $answer = "no";
648 } elsif (grep { $signer eq $_ } @{$keyids}) {
649 debug("[sigremoval] signed by us ($signer).");
650 $answer = "no";
651 $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
652 } else {
653 debug("[sigremoval] not interested in that sig ($signer).");
654 $answer = "yes";
655 };
656 } else {
657 debug("[sigremoval] no sig line here, only got: ".$stdout);
658 };
659 ($stdout, $stderr, $status) =
660 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
661 };
662
663 return $signed_by_me;
664 };
665
666
667
668 my $USER;
669 my @KEYIDS;
670 my $params;
671
672 Getopt::Long::config('bundling');
673 if (!GetOptions (
674 '-h' => \$params->{'help'},
675 '--help' => \$params->{'help'},
676 '--version' => \$params->{'version'},
677 '-V' => \$params->{'version'},
678 '-u=s' => \$params->{'local-user'},
679 '--local-user=s' => \$params->{'local-user'},
680 '-e' => \$params->{'export-old'},
681 '--export-old' => \$params->{'export-old'},
682 '-E' => \$params->{'no-export-old'},
683 '--no-export-old' => \$params->{'no-export-old'},
684 '-m' => \$params->{'mail'},
685 '--mail' => \$params->{'mail'},
686 '-M' => \$params->{'no-mail'},
687 '--no-mail' => \$params->{'no-mail'},
688 '-R' => \$params->{'no-download'},
689 '--no-download' => \$params->{'no-download'},
690 '-S' => \$params->{'no-sign'},
691 '--no-sign' => \$params->{'no-sign'},
692 )) {
693 usage(\*STDERR, 1);
694 };
695 if ($params->{'help'}) {
696 usage(\*STDOUT, 0);
697 };
698 if ($params->{'version'}) {
699 version(\*STDOUT);
700 exit(0);
701 };
702 usage(\*STDERR, 1) unless scalar @ARGV >= 1;
703
704
705
706 if ($params->{'local-user'}) {
707 $USER = $params->{'local-user'};
708 $USER =~ s/^0x//i;
709 unless ($USER =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}|[A-Z0-9]{40})$/i) {
710 print STDERR "-u $USER is not a keyid.\n";
711 usage(\*STDERR, 1);
712 };
713 $USER = uc($USER);
714 };
715
716 for my $keyid (@ARGV) {
717 $keyid =~ s/^0x//i;
718 unless ($keyid =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}||[A-Z0-9]{40})$/i) {
719 print STDERR "$keyid is not a keyid.\n";
720 usage(\*STDERR, 1);
721 };
722 push @KEYIDS, uc($keyid);
723 };
724
725 $CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
726 $CONFIG{'no-mail'} = $params->{'no-mail'} if defined $params->{'no-mail'};
727 $CONFIG{'mail'} = $params->{'mail'} if defined $params->{'mail'};
728 $CONFIG{'no-sign'} = $params->{'no-sign'} if defined $params->{'no-sign'};
729
730
731 #################
732 # import own keys
733 #################
734 my $gpg = GnuPG::Interface->new();
735 $gpg->call( $CONFIG{'gpg'} );
736 $gpg->options->hash_init(
737 'homedir' => $GNUPGHOME,
738 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
739 $gpg->options->meta_interactive( 0 );
740 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
741 $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
742 my $pid = $gpg->list_public_keys(handles => $handles, command_args => $CONFIG{'keyid'});
743 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
744 waitpid $pid, 0;
745 if ($stdout eq '') {
746 warn ("No data from gpg for list-key\n");
747 next;
748 };
749 foreach my $keyid (@{$CONFIG{'keyid'}}) {
750 unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
751 info("Importing $keyid");
752 system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME";
753 }
754 }
755
756 #############################
757 # receive keys from keyserver
758 #############################
759 my @keyids_ok;
760 if ($CONFIG{'no-download'}) {
761 @keyids_ok = @KEYIDS;
762 } else {
763 info ("fetching keys, this will take a while...");
764
765 my $gpg = GnuPG::Interface->new();
766 $gpg->call( $CONFIG{'gpg'} );
767 $gpg->options->hash_init(
768 'homedir' => $GNUPGHOME,
769 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
770 $gpg->options->meta_interactive( 0 );
771 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
772 my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
773 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
774 waitpid $pid, 0;
775
776 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
777 # [GNUPG:] NODATA 1
778 # [GNUPG:] NODATA 1
779 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
780 my %local_keyids = map { $_ => 1 } @KEYIDS;
781 for my $line (split /\n/, $status) {
782 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
783 my $imported_key = $1;
784 my $whole_fpr = $imported_key;
785 my $long_keyid = substr($imported_key, -16);
786 my $short_keyid = substr($imported_key, -8);
787 my $speced_key;
788 for my $spec (($whole_fpr, $long_keyid, $short_keyid)) {
789 $speced_key = $spec if $local_keyids{$spec};
790 };
791 unless ($speced_key) {
792 notice ("Imported unexpected key; got: $imported_key\n");
793 next;
794 };
795 debug ("Imported $imported_key for $speced_key");
796 delete $local_keyids{$speced_key};
797 unshift @keyids_ok, $imported_key;
798 } elsif ($line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) /) {
799 } else {
800 notice ("got unknown reply from gpg: $line");
801 }
802 };
803 if (scalar %local_keyids) {
804 notice ("Import failed for: ". (join ' ', keys %local_keyids).".");
805 exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
806 }
807 };
808
809 unless (@keyids_ok) {
810 notice ("No keys to sign found");
811 exit 0;
812 }
813
814 ###########
815 # sign keys
816 ###########
817 unless ($CONFIG{'no-sign'}) {
818 info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
819 for my $keyid (@keyids_ok) {
820 my @command;
821 push @command, $CONFIG{'gpg-sign'};
822 push @command, '--local-user', $USER if (defined $USER);
823 push @command, "--homedir=$GNUPGHOME";
824 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
825 push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
826 push @command, '--edit', $keyid;
827 push @command, 'sign';
828 push @command, 'save';
829 print join(' ', @command),"\n";
830 system (@command);
831 };
832 };
833
834 ##################
835 # export and prune
836 ##################
837 KEYS:
838 for my $keyid (@keyids_ok) {
839 # get key listing
840 #################
841 my $gpg = GnuPG::Interface->new();
842 $gpg->call( $CONFIG{'gpg'} );
843 $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
844 $gpg->options->meta_interactive( 0 );
845 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
846 $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
847 my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
848 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
849 waitpid $pid, 0;
850 if ($stdout eq '') {
851 warn ("No data from gpg for list-key $keyid\n");
852 next;
853 };
854 my @publine = grep { /^pub/ } (split /\n/, $stdout);
855 if (scalar @publine == 0) {
856 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
857 next;
858 };
859 my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
860 if (scalar @publine > 0) {
861 warn ("More than one key matched $keyid. Try to specify the long keyid or fingerprint\n");
862 next;
863 };
864 unless (defined $longkeyid) {
865 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
866 next;
867 };
868 unless (defined $flags) {
869 warn ("Didn't find flags in --list-key of key $keyid.\n");
870 next;
871 };
872 my $can_encrypt = $flags =~ /E/;
873
874 # export the key
875 ################
876 my $asciikey = export_key($GNUPGHOME, $keyid);
877 if ($asciikey eq '') {
878 warn ("No data from gpg for export $keyid\n");
879 next;
880 };
881
882 my @UIDS;
883 my $uid_number = 0;
884 while (1) {
885 my $this_uid_text = '';
886 $uid_number++;
887 debug("Doing key $keyid, uid $uid_number");
888 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
889
890 # import into temporary gpghome
891 ###############################
892 my $result = import_key($tempdir, $asciikey);
893 unless ($result) {
894 warn ("Could not import $keyid into temporary gnupg.\n");
895 next;
896 };
897
898 # prune it
899 ##########
900 $gpg = GnuPG::Interface->new();
901 $gpg->call( $CONFIG{'gpg-delsig'} );
902 $gpg->options->hash_init(
903 'homedir' => $tempdir,
904 'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
905 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
906 $pid = $gpg->wrap_call(
907 commands => [ '--edit' ],
908 command_args => [ $keyid ],
909 handles => $handles );
910
911 debug("Starting edit session");
912 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
913
914 # delete other uids
915 ###################
916 my $number_of_subkeys = 0;
917 my $i = 1;
918 my $have_one = 0;
919 my $is_uat = 0;
920 my $delete_some = 0;
921 debug("Parsing stdout output.");
922 for my $line (split /\n/, $stdout) {
923 debug("Checking line $line");
924 my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
925 if ($type eq 'sub') {
926 $number_of_subkeys++;
927 };
928 next unless ($type eq 'uid' || $type eq 'uat');
929 debug("line is interesting.");
930 if ($uid_number != $i) {
931 debug("mark for deletion.");
932 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
933 $delete_some++;
934 } else {
935 debug("keep it.");
936 $have_one = 1;
937 $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
938 $is_uat = $type eq 'uat';
939 };
940 $i++;
941 };
942 debug("Parsing stdout output done.");
943 unless ($have_one) {
944 debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
945 info("key $keyid done.");
946 last;
947 };
948
949 my $prune_some_sigs_on_uid;
950 my $prune_all_sigs_on_uid;
951 if ($is_uat) {
952 debug("handling attribute userid of key $keyid.");
953 if ($uid_number == 1) {
954 debug(" attribute userid is #1, unmarking #2 for deletion.");
955 readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
956 $delete_some--;
957 $prune_some_sigs_on_uid = 1;
958 $prune_all_sigs_on_uid = 2;
959 } else {
960 debug("attribute userid is not #1, unmarking #1 for deletion.");
961 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
962 $delete_some--;
963 $prune_some_sigs_on_uid = 2;
964 $prune_all_sigs_on_uid = 1;
965 };
966 } else {
967 $prune_some_sigs_on_uid = 1;
968 };
969
970 if ($delete_some) {
971 debug("need to delete $delete_some uids.");
972 readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
973 readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
974 };
975
976 # delete subkeys
977 ################
978 if ($number_of_subkeys > 0) {
979 for (my $i=1; $i<=$number_of_subkeys; $i++) {
980 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
981 };
982 readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
983 readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
984 };
985
986 # delete signatures
987 ###################
988 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
989 my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
990 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
991 if (defined $prune_all_sigs_on_uid) {
992 readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
993 delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
994 readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
995 };
996
997
998 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
999 waitpid $pid, 0;
1000
1001 my $asciikey = export_key($tempdir, $keyid);
1002 if ($asciikey eq '') {
1003 warn ("No data from gpg for export $keyid\n");
1004 next;
1005 };
1006
1007 if ($signed_by_me) {
1008 if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
1009 my $write = ask("Signature on $this_uid_text is old. Export?", 0, $params->{'export-old'}, $params->{'no-export-old'});
1010 next unless $write;
1011 };
1012 my $keydir = "$KEYSBASE/$DATE_STRING";
1013 -d $keydir || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
1014
1015 my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
1016 open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
1017 print KEY $asciikey;
1018 close KEY;
1019
1020 push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };
1021
1022 info("$longkeyid $uid_number $this_uid_text done.");
1023 } else {
1024 info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
1025 };
1026 };
1027
1028 if (scalar @UIDS == 0) {
1029 info("found no signed uids for $keyid");
1030 } else {
1031 next if $CONFIG{'no-mail'}; # do not send mail
1032
1033 my @attached;
1034 for my $uid (@UIDS) {
1035 trace("UID: $uid->{'text'}\n");
1036 if ($uid->{'is_uat'}) {
1037 my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
1038 push @attached, $uid if $attach;
1039 } elsif ($uid->{'text'} !~ /@/) {
1040 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
1041 push @attached, $uid if $attach;
1042 };
1043 };
1044
1045 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
1046 for my $uid (@UIDS) {
1047 if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1048 my $address = $uid->{'text'};
1049 $address =~ s/.*<(.*)>.*/$1/;
1050 if (ask("Send mail to '$address' for $uid->{'text'}?", 1, $CONFIG{'mail'})) {
1051 my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
1052
1053 my $keydir = "$KEYSBASE/$DATE_STRING";
1054 my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
1055 open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
1056 print KEY $mail;
1057 close KEY;
1058 };
1059 };
1060 };
1061 };
1062
1063 };