caff/caff

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