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