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