caff/caff

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