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