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