caff/caff

   1 #!/usr/bin/perl -w
   2
   3 # caff  --  CA - Fire and Forget
   4 # $Id$
   5 #
   6 # Copyright (c) 2004, 2005 Peter Palfrader <peter@palfrader.org>
   7 #
   8 # All rights reserved.
   9 #
  10 # Redistribution and use in source and binary forms, with or without
  11 # modification, are permitted provided that the following conditions
  12 # are met:
  13 # 1. Redistributions of source code must retain the above copyright
  14 #    notice, this list of conditions and the following disclaimer.
  15 # 2. Redistributions in binary form must reproduce the above copyright
  16 #    notice, this list of conditions and the following disclaimer in the
  17 #    documentation and/or other materials provided with the distribution.
  18 # 3. The name of the author may not be used to endorse or promote products
  19 #    derived from this software without specific prior written permission.
  20 #
  21 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
  22 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
  23 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
  24 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
  25 # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  26 # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  27 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  28 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  29 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  30 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  31
  32 =pod
  33
  34 =head1 NAME
  35
  36 caff -- CA - Fire and Forget
  37
  38 =head1 SYNOPSIS
  39
  40 =over
  41
  42 =item B<caff> [-mMR] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]
  43
  44 =back
  45
  46 =head1 DESCRIPTION
  47
  48 CA Fire and Forget is a script that helps you in keysigning.  It takes a list
  49 of keyids on the command line, fetches them from a keyserver and calls GnuPG so
  50 that you can sign it.  It then mails each key to all its email addresses - only
  51 including the one UID that we send to in each mail, pruned from all but self
  52 sigs and sigs done by you.
  53
  54 =head1 OPTIONS
  55
  56 =over
  57
  58 =item B<-m> B<-M>
  59
  60 Send/do not send mail after signing. Default is to ask the user for each uid.
  61
  62 =item B<-R>
  63
  64 Do not retrieve the key to be signed from a keyserver.
  65
  66 =item B<-u> I<yourkeyid>
  67
  68 Select the key that is used for signing, in case you have more than one key.
  69
  70 =back
  71
  72 =head1 FILES
  73
  74 =over
  75
  76 =item $HOME/.caffrc  -  configuration file
  77
  78 =back
  79
  80 =head1 CONFIGURATION FILE OPTIONS
  81
  82 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
  83
  84 Example:
  85
  86         $CONFIG{owner} = q{Peter Palfrader};
  87         $CONFIG{email} = q{peter@palfrader.org};
  88         $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
  89
  90 =head2 Valid keys
  91
  92 =over
  93
  94 =item B<caffhome> [string]
  95
  96 Base directory for the files caff stores.  Default: B<$HOME/.caff/>.
  97
  98 =item B<owner> [string]
  99
 100 Your name.  B<REQUIRED>.
 101
 102 =item B<email> [string]
 103
 104 Your email address, used in From: lines.  B<REQUIRED>.
 105
 106 =item B<keyid> [list of keyids]
 107
 108 A list of your keys.  This is used to determine which signatures to keep
 109 in the pruning step.  If you select a key using B<-u> it has to be in
 110 this list.  B<REQUIRED>.
 111
 112 =item B<export-sig-age> [seconds]
 113
 114 Don't export UIDs by default, on which your latest signature is older
 115 than this age.  Default: B<24*60*60> (i.e. one day).
 116
 117 =item B<keyserver> [string]
 118
 119 Keyserver to download keys from.  Default: B<subkeys.pgp.net>.
 120
 121 =item B<gpg> [string]
 122
 123 Path to the GnuPG binary.  Default: B<gpg>.
 124
 125 =item B<gpg-sign> [string]
 126
 127 Path to the GnuPG binary which is used to sign keys.  Default: what
 128 B<gpg> is set to.
 129
 130 =item B<gpg-delsig> [string]
 131
 132 Path to the GnuPG binary which is used to split off signatures.  This was
 133 needed while the upstream GnuPG was not fixed.  Default: what B<gpg>
 134 is set to.
 135
 136 =item B<secret-keyring> [string]
 137
 138 Path to your secret keyring.  Default: B<$HOME/.gnupg/secring.gpg>.
 139
 140 =item B<also-encrypt-to> [keyid]
 141
 142 An additional keyid to encrypt messages to. Default: none.
 143
 144 =item B<no-download> [boolean]
 145
 146 If true, then skip the step of fetching keys from the keyserver.
 147 Default: B<0>.
 148
 149 =item B<no-sign> [boolean]
 150
 151 If true, then skip the signing step. Default: B<0>.
 152
 153 =item B<mail-template> [string]
 154
 155 Email template which is used as the body text for the email sent out.
 156 instead of the default text if specified. The following perl variables
 157 can be used in the template:
 158
 159 =over
 160
 161 =item B<{owner}> [string]
 162
 163 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
 164
 165 =item B<{key}> [string]
 166
 167 The keyid of the key you signed.
 168
 169 =item B<{@uids}> [array]
 170
 171 The UIDs for which signatures are included in the mail.
 172
 173 =back
 174
 175 =back
 176
 177 =head1 AUTHOR
 178
 179 Peter Palfrader <peter@palfrader.org>
 180
 181 =head1 WEBSITE
 182
 183 http://pgp-tools.alioth.debian.org/
 184
 185 =cut
 186
 187 use strict;
 188 use IO::Handle;
 189 use English;
 190 use File::Path;
 191 use File::Temp qw{tempdir};
 192 use Text::Template;
 193 use MIME::Entity;
 194 use Fcntl;
 195 use IO::Select;
 196 use Getopt::Std;
 197 use GnuPG::Interface;
 198
 199 my %CONFIG;
 200 my $REVISION = '$Rev$';
 201 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
 202 my $VERSION = "0.0.0.$REVISION_NUMER";
 203
 204 sub load_config() {
 205         my $config = $ENV{'HOME'} . '/.caffrc';
 206         -f $config or die "No file $config present.  See caff(1).\n";
 207         unless (scalar eval `cat $config`) {
 208                 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
 209         };
 210
 211         $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
 212         die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
 213         die ("email is not defined.\n") unless defined $CONFIG{'email'};
 214         die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
 215         die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
 216         for my $keyid (@{$CONFIG{'keyid'}}) {
 217                 $keyid =~ /^[A-Fa-z0-9]{16}$/ or die ("key $keyid is not a long (16 digit) keyid.\n");
 218         };
 219         @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
 220         $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
 221         $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
 222         $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
 223         $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
 224         $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
 225         $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
 226         $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
 227         $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
 228         $CONFIG{'mail-template'} = <<'EOM' unless defined $CONFIG{'mail-template'};
 229 Hi,
 230
 231 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
 232 {foreach $uid (@uids) {
 233     $OUT .= "\t".$uid."\n";
 234 };} of your key {$key} signed by me.
 235
 236 Note that I did not upload your key to any keyservers. If you want this
 237 new signature to be available to others, please upload it yourself.
 238 With GnuPG this can be done using
 239         gpg --keyserver subkeys.pgp.net --send-key {$key}
 240
 241 If you have any questions, don't hesitate to ask.
 242
 243 Regards,
 244 {$owner}
 245 EOM
 246 };
 247
 248 sub notice($) {
 249         my ($line) = @_;
 250         print "[NOTICE] $line\n";
 251 };
 252 sub info($) {
 253         my ($line) = @_;
 254         print "[INFO] $line\n";
 255 };
 256 sub debug($) {
 257         my ($line) = @_;
 258         #print "[DEBUG] $line\n";
 259 };
 260 sub trace($) {
 261         my ($line) = @_;
 262         #print "[trace] $line\n";
 263 };
 264 sub trace2($) {
 265         my ($line) = @_;
 266         #print "[trace2] $line\n";
 267 };
 268
 269 sub make_gpg_fds() {
 270         my %fds = (
 271                 stdin => IO::Handle->new(),
 272                 stdout => IO::Handle->new(),
 273                 stderr => IO::Handle->new(),
 274                 status => IO::Handle->new() );
 275         my $handles = GnuPG::Handles->new( %fds );
 276         return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
 277 };
 278
 279 sub readwrite_gpg($$$$$%) {
 280         my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
 281
 282         trace("Entering readwrite_gpg.");
 283
 284         my ($first_line, undef) = split /\n/, $in;
 285         debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
 286
 287         local $INPUT_RECORD_SEPARATOR = undef;
 288         my $sout = IO::Select->new();
 289         my $sin = IO::Select->new();
 290         my $offset = 0;
 291
 292         trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 293
 294         $inputfd->blocking(0);
 295         $stdoutfd->blocking(0);
 296         $statusfd->blocking(0) if defined $statusfd;
 297         $stderrfd->blocking(0);
 298         $sout->add($stdoutfd);
 299         $sout->add($stderrfd);
 300         $sout->add($statusfd) if defined $statusfd;
 301         $sin->add($inputfd);
 302
 303         my ($stdout, $stderr, $status) = ("", "", "");
 304         my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
 305         trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
 306
 307         my $readwrote_stuff_this_time = 0;
 308         my $do_not_wait_on_select = 0;
 309         my ($readyr, $readyw, $written);
 310         while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 311                 if (defined $exitwhenstatusmatches) {
 312                         if ($status =~ /$exitwhenstatusmatches/m) {
 313                                 trace("readwrite_gpg found match on $exitwhenstatusmatches");
 314                                 if ($readwrote_stuff_this_time) {
 315                                         trace("read/write some more\n");
 316                                         $do_not_wait_on_select = 1;
 317                                 } else {
 318                                         trace("that's it in our while loop.\n");
 319                                         last;
 320                                 }
 321                         };
 322                 };
 323
 324                 $readwrote_stuff_this_time = 0;
 325                 trace("select waiting for ".($sout->count())." fds.");
 326                 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
 327                 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
 328                 for my $wfd (@$readyw) {
 329                         $readwrote_stuff_this_time = 1;
 330                         if (length($in) != $offset) {
 331                                 trace("writing to $wfd.");
 332                                 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 333                                 $offset += $written;
 334                         };
 335                         if ($offset == length($in)) {
 336                                 trace("writing to $wfd done.");
 337                                 unless ($options{'nocloseinput'}) {
 338                                         close $wfd;
 339                                         trace("$wfd closed.");
 340                                 };
 341                                 $sin->remove($wfd);
 342                                 $sin = undef;
 343                         }
 344                 }
 345
 346                 next unless (defined(@$readyr)); # Wait some more.
 347
 348                 for my $rfd (@$readyr) {
 349                         $readwrote_stuff_this_time = 1;
 350                         if ($rfd->eof) {
 351                                 trace("reading from $rfd done.");
 352                                 $sout->remove($rfd);
 353                                 close($rfd);
 354                                 next;
 355                         }
 356                         trace("reading from $rfd.");
 357                         if ($rfd == $stdoutfd) {
 358                                 $stdout .= <$rfd>;
 359                                 trace2("stdout is now $stdout\n================");
 360                                 next;
 361                         }
 362                         if (defined $statusfd && $rfd == $statusfd) {
 363                                 $status .= <$rfd>;
 364                                 trace2("status is now $status\n================");
 365                                 next;
 366                         }
 367                         if ($rfd == $stderrfd) {
 368                                 $stderr .= <$rfd>;
 369                                 trace2("stderr is now $stderr\n================");
 370                                 next;
 371                         }
 372                 }
 373         }
 374         trace("readwrite_gpg done.");
 375         return ($stdout, $stderr, $status);
 376 };
 377
 378 sub ask($$) {
 379         my ($question, $default) = @_;
 380         my $answer;
 381         while (1) {
 382                 print $question,' ',($default ? '[Y/n]' : '[y/N]'), ' ';
 383                 $answer = <STDIN>;
 384                 chomp $answer;
 385                 last if ((defined $answer) && (length $answer <= 1));
 386                 print "grrrrrr.\n";
 387                 sleep 1;
 388         };
 389         my $result = $default;
 390         $result = 1 if $answer =~ /y/i;
 391         $result = 0 if $answer =~ /n/i;
 392         return $result;
 393 };
 394
 395
 396
 397
 398
 399 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
 400 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
 401 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
 402 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
 403 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
 404
 405 load_config;
 406 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader";
 407
 408 my $KEYSBASE =  $CONFIG{'caffhome'}.'/keys';
 409 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
 410
 411 -d $KEYSBASE  || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
 412 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
 413
 414 my $NOW = time;
 415 my  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
 416 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
 417
 418
 419 sub usage() {
 420         print STDERR "caff $VERSION - (c) 2004, 2005 Peter Palfrader\n";
 421         print STDERR "Usage: $PROGRAM_NAME [-mMR] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
 422         exit 1;
 423 };
 424
 425 sub export_key($$) {
 426         my ($gnupghome, $keyid) = @_;
 427
 428         my $gpg = GnuPG::Interface->new();
 429         $gpg->call( $CONFIG{'gpg'} );
 430         $gpg->options->hash_init(
 431                 'homedir' => $gnupghome,
 432                 'armor' => 1 );
 433         $gpg->options->meta_interactive( 0 );
 434         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 435         my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
 436         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 437         waitpid $pid, 0;
 438
 439         return $stdout;
 440 };
 441
 442 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 443 sub send_mail($$$@) {
 444         my ($address, $can_encrypt, $key_id, @keys) = @_;
 445
 446         my $template = Text::Template->new(TYPE => 'STRING', SOURCE => $CONFIG{'mail-template'})
 447             or die "Error creating template: $Text::Template::ERROR";
 448
 449         my @uids;
 450         for my $key (@keys) {
 451             push @uids, $key->{'text'};
 452         };
 453         my $message = $template->fill_in(HASH => { key => $key_id,
 454                                                    uids => \@uids,
 455                                                    owner => $CONFIG{'owner'}})
 456             or die "Error filling template in: $Text::Template::ERROR";
 457
 458         my $message_entity = MIME::Entity->build(
 459                 Type        => "text/plain",
 460                 Charset     => "utf-8",
 461                 Disposition => 'inline',
 462                 Data        => $message);
 463
 464         my @key_entities;
 465         for my $key (@keys) {
 466                 $message_entity->attach(
 467                         Type        => "application/pgp-keys",
 468                         Disposition => 'attachment',
 469                         Encoding    => "7bit",
 470                         Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
 471                         Data        => $key->{'key'},
 472                         Filename    => "0x$key_id.".$key->{'serial'}.".asc");
 473         };
 474
 475         if ($can_encrypt) {
 476                 my $message = $message_entity->stringify();
 477
 478                 my $gpg = GnuPG::Interface->new();
 479                 $gpg->call( $CONFIG{'gpg'} );
 480                 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
 481                         'extra_args' => '--always-trust',
 482                         'armor' => 1 );
 483                 $gpg->options->meta_interactive( 0 );
 484                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 485                 $gpg->options->push_recipients( $key_id );
 486                 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
 487                 my $pid = $gpg->encrypt(handles => $handles);
 488                 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 489                 waitpid $pid, 0;
 490                 if ($stdout eq '') {
 491                         warn ("No data from gpg for list-key $key_id\n");
 492                         next;
 493                 };
 494                 $message = $stdout;
 495
 496                 $message_entity = MIME::Entity->build(
 497                         Type        => 'multipart/encrypted; protocol="application/pgp-encrypted"');
 498
 499                 $message_entity->attach(
 500                         Type        => "application/pgp-encrypted",
 501                         Disposition => 'attachment',
 502                         Encoding    => "7bit",
 503                         Data        => "Version: 1\n");
 504
 505                 $message_entity->attach(
 506                         Type        => "application/octet-stream",
 507                         Filename    => 'msg.asc',
 508                         Disposition => 'inline',
 509                         Encoding    => "7bit",
 510                         Data        => $message);
 511         };
 512
 513         $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
 514         $message_entity->head->add("To", $address);
 515         $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
 516         $message_entity->head->add("User-Agent", $USER_AGENT);
 517         $message_entity->send();
 518         $message_entity->stringify();
 519 };
 520
 521 sub sanitize_uid($) {
 522         my ($uid) = @_;
 523
 524         my $good_uid = $uid;
 525         $good_uid =~ tr#/:\\#_#;
 526         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 527         return $good_uid;
 528 };
 529
 530 my $USER;
 531 my @KEYIDS;
 532 my %opt;
 533
 534 getopts('mMRu:', \%opt);
 535
 536 usage() unless scalar @ARGV >= 1;
 537 if ($opt{u}) {
 538         $USER = $opt{u};
 539         $USER =~ s/^0x//i;
 540         unless ($USER =~ /^[A-Za-z0-9]{8,8}([A-Za-z0-9]{8})?$/) {
 541                 print STDERR "-u $USER is not a keyid.\n";
 542                 usage();
 543         };
 544         $USER = uc($USER);
 545 };
 546 for my $keyid (@ARGV) {
 547         $keyid =~ s/^0x//i;
 548         unless ($keyid =~ /^[A-Za-z0-9]{8}([A-Za-z0-9]{8}|[A-Za-z0-9]{32})?$/) {
 549                 print STDERR "$keyid is not a keyid.\n";
 550                 usage();
 551         };
 552         push @KEYIDS, uc($keyid);
 553 };
 554
 555
 556
 557 #################
 558 # import own keys
 559 #################
 560         my $gpg = GnuPG::Interface->new();
 561         $gpg->call( $CONFIG{'gpg'} );
 562         $gpg->options->hash_init(
 563                 'homedir' => $GNUPGHOME,
 564                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 565         $gpg->options->meta_interactive( 0 );
 566         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 567         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 568         my $pid = $gpg->list_public_keys(handles => $handles, command_args => $CONFIG{'keyid'});
 569         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 570         waitpid $pid, 0;
 571         if ($stdout eq '') {
 572                 warn ("No data from gpg for list-key\n");
 573                 next;
 574         };
 575         foreach my $keyid (@{$CONFIG{'keyid'}}) {
 576                 unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
 577                         info("Importing $keyid");
 578                         system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME";
 579                 }
 580         }
 581
 582 #############################
 583 # receive keys from keyserver
 584 #############################
 585 my @keyids_ok;
 586 my @keyids_failed;
 587 if ($CONFIG{'no-download'} or $opt{R}) {
 588         @keyids_ok = @KEYIDS;
 589 } else {
 590         my $gpg = GnuPG::Interface->new();
 591         $gpg->call( $CONFIG{'gpg'} );
 592         $gpg->options->hash_init(
 593                 'homedir' => $GNUPGHOME,
 594                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 595         $gpg->options->meta_interactive( 0 );
 596         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 597
 598         my @local_keyids = @KEYIDS;
 599         for my $keyid (@local_keyids) {
 600                 info ("fetching $keyid...");
 601                 my $pid = $gpg->recv_keys(handles => $handles, command_args => [ $keyid ]);
 602                 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 603                 waitpid $pid, 0;
 604
 605 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 606 # [GNUPG:] NODATA 1
 607 # [GNUPG:] NODATA 1
 608 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 609                 my $handled = 0;
 610                 for my $line (split /\n/, $status) {
 611                         if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
 612                                 my $imported_key = $1;
 613                                 if ($keyid ne $imported_key &&
 614                                     $keyid ne substr($imported_key, -16) &&
 615                                     $keyid ne substr($imported_key, -8)) {
 616                                     warn("Imported unexpected key.  expected: $keyid; got: $imported_key.\n");
 617                                     next;
 618                                 };
 619                                 push @keyids_ok, $keyid;
 620                                 shift @KEYIDS;
 621                                 $handled = 1;
 622                                 last;
 623                         } elsif ($line =~ /^\[GNUPG:\] NODATA/) {
 624                                 push @keyids_failed, $keyid;
 625                                 shift @KEYIDS;
 626                                 $handled = 1;
 627                                 last;
 628                         };
 629                 };
 630                 unless ($handled) {
 631                         notice ("Huh, what's up with $keyid?");
 632                         push @keyids_failed, $keyid;
 633                         shift @KEYIDS;
 634                 };
 635         };
 636         die ("Still keys in \@KEYIDS.  This should not happen.") if scalar @KEYIDS;
 637         notice ("Import failed for: ". (join ' ', @keyids_failed).".") if scalar @keyids_failed;
 638 };
 639
 640 ###########
 641 # sign keys
 642 ###########
 643 unless ($CONFIG{'no-sign'}) {
 644         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
 645         for my $keyid (@keyids_ok) {
 646                 my @command;
 647                 push @command, $CONFIG{'gpg-sign'};
 648                 push @command, '--local-user', $USER if (defined $USER);
 649                 push @command, "--homedir=$GNUPGHOME";
 650                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 651                 push @command, '--edit', $keyid;
 652                 push @command, 'sign';
 653                 print join(' ', @command),"\n";
 654                 system (@command);
 655         };
 656 };
 657
 658 ##################
 659 # export and prune
 660 ##################
 661 KEYS:
 662 for my $keyid (@keyids_ok) {
 663         # get key listing
 664         #################
 665         my $gpg = GnuPG::Interface->new();
 666         $gpg->call( $CONFIG{'gpg'} );
 667         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 668         $gpg->options->meta_interactive( 0 );
 669         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 670         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 671         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 672         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 673         waitpid $pid, 0;
 674         if ($stdout eq '') {
 675                 warn ("No data from gpg for list-key $keyid\n");
 676                 next;
 677         };
 678         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 679         if (scalar @publine == 0) {
 680                 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
 681                 next;
 682         };
 683         my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
 684         if (scalar @publine > 0) {
 685                 warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
 686                 next;
 687         };
 688         unless (defined $longkeyid) {
 689                 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
 690                 next;
 691         };
 692         unless (defined $flags) {
 693                 warn ("Didn't find flags in --list-key of key $keyid.\n");
 694                 next;
 695         };
 696         my $can_encrypt = $flags =~ /E/;
 697
 698         # export the key
 699         ################
 700         my $asciikey = export_key($GNUPGHOME, $keyid);
 701         if ($asciikey eq '') {
 702                 warn ("No data from gpg for export $keyid\n");
 703                 next;
 704         };
 705
 706         my @UIDS;
 707         my $uid_number = 0;
 708         while (1) {
 709                 my $this_uid_text = '';
 710                 $uid_number++;
 711                 debug("Doing key $keyid, uid $uid_number");
 712
 713                 # import into temporary gpghome
 714                 ###############################
 715                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 716                 my $gpg = GnuPG::Interface->new();
 717                 $gpg->call( $CONFIG{'gpg'} );
 718                 $gpg->options->hash_init( 'homedir' => $tempdir );
 719                 $gpg->options->meta_interactive( 0 );
 720                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 721                 my $pid = $gpg->import_keys(handles => $handles);
 722                 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 723                 waitpid $pid, 0;
 724
 725                 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 726                         warn ("Could not import $keyid into temporary gnupg.\n");
 727                         next;
 728                 };
 729
 730                 # prune it
 731                 ##########
 732                 $gpg = GnuPG::Interface->new();
 733                 $gpg->call( $CONFIG{'gpg-delsig'} );
 734                 $gpg->options->hash_init(
 735                         'homedir' => $tempdir,
 736                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 737                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 738                 $pid = $gpg->wrap_call(
 739                         commands     => [ '--edit' ],
 740                         command_args => [ $keyid ],
 741                         handles      => $handles );
 742
 743                 debug("Starting edit session");
 744                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 745
 746                 # delete other uids
 747                 ###################
 748                 my $number_of_subkeys = 0;
 749                 my $i = 1;
 750                 my $have_one = 0;
 751                 my $is_uat = 0;
 752                 my $delete_some = 0;
 753                 debug("Parsing stdout output.");
 754                 for my $line (split /\n/, $stdout) {
 755                         debug("Checking line $line");
 756                         my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
 757                         if ($type eq 'sub') {
 758                                 $number_of_subkeys++;
 759                         };
 760                         next unless ($type eq 'uid' || $type eq 'uat');
 761                         debug("line is interesting.");
 762                         if ($uid_number != $i) {
 763                                 debug("mark for deletion.");
 764                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 765                                 $delete_some = 1;
 766                         } else {
 767                                 debug("keep it.");
 768                                 $have_one = 1;
 769                                 $this_uid_text = ($type eq 'uid') ? $uidtext : 'attribute';
 770                                 $is_uat = $type eq 'uat';
 771                         };
 772                         $i++;
 773                 };
 774                 debug("Parsing stdout output done.");
 775                 if ($is_uat) {
 776                         notice("Can't handle attribute userid of key $keyid.");
 777                         next;
 778                 };
 779                 unless ($have_one) {
 780                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
 781                         info("key $keyid done.");
 782                         last;
 783                 };
 784                 if ($delete_some) {
 785                         debug("need to delete a few uids.");
 786                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 787                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 788                 };
 789
 790                 # delete subkeys
 791                 ################
 792                 if ($number_of_subkeys > 0) {
 793                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 794                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 795                         };
 796                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 797                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 798                 };
 799
 800                 # delete signatures
 801                 ###################
 802                 my $signed_by_me = 0;
 803                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 804                 ($stdout, $stderr, $status) =
 805                         readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 806
 807                 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 808                         # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 809                         my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 810                         $stdout =~ s/\n/\\n/g;
 811                         notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
 812                         my $line = pop @sigline;
 813                         my $answer = "no";
 814                         if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 815                                 debug("[sigremoval] doing line $line.");
 816                                 my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
 817                                 if ($signer eq $longkeyid) {
 818                                         debug("[sigremoval] selfsig ($signer).");
 819                                         $answer = "no";
 820                                 } elsif (grep { $signer eq $_ } @{$CONFIG{'keyid'}}) {
 821                                         debug("[sigremoval] signed by us ($signer).");
 822                                         $answer = "no";
 823                                         $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 824                                 } else {
 825                                         debug("[sigremoval] not interested in that sig ($signer).");
 826                                         $answer = "yes";
 827                                 };
 828                         } else {
 829                                 debug("[sigremoval] no sig line here, only got: ".$stdout);
 830                         };
 831                         ($stdout, $stderr, $status) =
 832                                 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 833                 };
 834                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
 835                 waitpid $pid, 0;
 836
 837                 my $asciikey = export_key($tempdir, $keyid);
 838                 if ($asciikey eq '') {
 839                         warn ("No data from gpg for export $keyid\n");
 840                         next;
 841                 };
 842
 843                 if ($signed_by_me) {
 844                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
 845                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0);
 846                                 next unless $write;
 847                         };
 848                         my $keydir = "$KEYSBASE/$DATE_STRING";
 849                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
 850
 851                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
 852                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
 853                         print KEY $asciikey;
 854                         close KEY;
 855
 856                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number };
 857
 858                         info("$longkeyid $uid_number $this_uid_text done.");
 859                 } else {
 860                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
 861                 };
 862         };
 863
 864         if (scalar @UIDS == 0) {
 865                 info("found no signed uids for $keyid");
 866         } else {
 867                 next if $opt{M}; # do not send mail
 868
 869                 my @attached;
 870                 for my $uid (@UIDS) {
 871                         trace("UID: $uid->{'text'}\n");
 872                         unless ($uid->{'text'} =~ /@/) {
 873                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
 874                                 push @attached, $uid if $attach;
 875                         };
 876                 };
 877
 878                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
 879                 for my $uid (@UIDS) {
 880                         if ($uid->{'text'} =~ /@/) {
 881                                 my $address = $uid->{'text'};
 882                                 $address =~ s/.*<(.*)>.*/$1/;
 883                                 if ($opt{m} or ask("Send mail to '$address' for $uid->{'text'}?", 1)) {
 884                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 885
 886                                         my $keydir = "$KEYSBASE/$DATE_STRING";
 887                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
 888                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
 889                                         print KEY $mail;
 890                                         close KEY;
 891                                 };
 892                         };
 893                 };
 894         };
 895
 896 };
 897
 898
 899
 900
 901 ###############################################################3
 902 #### old fork gpg --edit
 903 =cut
 904                 my ($stdin_read, $stdin_write);
 905                 my ($stdout_read, $stdout_write);
 906                 my ($stderr_read, $stderr_write);
 907                 my ($status_read, $status_write);
 908                 pipe $stdin_read, $stdin_write;
 909                 pipe $stdout_read, $stdout_write;
 910                 pipe $stderr_read, $stderr_write;
 911                 pipe $status_read, $status_write;
 912
 913                 $pid = fork();
 914                 unless ($pid) { # child
 915                         close $stdin_write;
 916                         close $stdout_read;
 917                         close $stderr_read;
 918                         close $status_read;
 919
 920                         my @call;
 921                         push @call, $CONFIG{'gpg-delsig'};
 922                         push @call, "--homedir=$tempdir";
 923                         push @call, '--with-colons';
 924                         push @call, '--fixed-list-mode';
 925                         push @call, '--command-fd=0';
 926                         push @call, "--status-fd=".fileno($status_write);
 927                         push @call, "--no-tty";
 928                         push @call, "--edit";
 929                         push @call, $keyid;
 930
 931                         close STDIN;
 932                         close STDOUT;
 933                         close STDERR;
 934                         open (STDIN, "<&".fileno($stdin_read)) or die ("Cannot reopen stdin: $!\n");
 935                         open (STDOUT, ">&".fileno($stdout_write)) or die ("Cannot reopen stdout: $!\n");
 936                         open (STDERR, ">&".fileno($stderr_write)) or die ("Cannot reopen stderr: $!\n");
 937
 938                         fcntl $status_write, F_SETFD, 0;
 939
 940                         exec (@call);
 941                         exit;
 942                 };
 943                 close $stdin_read;
 944                 close $stdout_write;
 945                 close $stderr_write;
 946                 close $status_write;
 947
 948                 $inputfd = $stdin_write;
 949                 $stdoutfd = $stdout_read;
 950                 $stderrfd = $stderr_read;
 951                 $statusfd = $status_read;
 952 =cut