caff/caff

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