caff/caff

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