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