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 =back
 154
 155 =head1 AUTHOR
 156
 157 Peter Palfrader <peter@palfrader.org>
 158
 159 =head1 WEBSITE
 160
 161 http://pgp-tools.alioth.debian.org/
 162
 163 =cut
 164
 165 use strict;
 166 use IO::Handle;
 167 use English;
 168 use File::Path;
 169 use File::Temp qw{tempdir};
 170 use MIME::Entity;
 171 use Fcntl;
 172 use IO::Select;
 173 use Getopt::Std;
 174 use GnuPG::Interface;
 175
 176 my %CONFIG;
 177 my $REVISION = '$Rev$';
 178 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
 179 my $VERSION = "0.0.0.$REVISION_NUMER";
 180
 181 sub load_config() {
 182         my $config = $ENV{'HOME'} . '/.caffrc';
 183         -f $config or die "No file $config present.  See caff(1).\n";
 184         unless (scalar eval `cat $config`) {
 185                 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
 186         };
 187
 188         $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
 189         die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
 190         die ("email is not defined.\n") unless defined $CONFIG{'email'};
 191         die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
 192         die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
 193         for my $keyid (@{$CONFIG{'keyid'}}) {
 194                 $keyid =~ /^[A-Fa-z0-9]{16}$/ or die ("key $keyid is not a long (16 digit) keyid.\n");
 195         };
 196         @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
 197         $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
 198         $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
 199         $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
 200         $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
 201         $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
 202         $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
 203         $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
 204         $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
 205 };
 206
 207 sub notice($) {
 208         my ($line) = @_;
 209         print "[NOTICE] $line\n";
 210 };
 211 sub info($) {
 212         my ($line) = @_;
 213         print "[INFO] $line\n";
 214 };
 215 sub debug($) {
 216         my ($line) = @_;
 217         #print "[DEBUG] $line\n";
 218 };
 219 sub trace($) {
 220         my ($line) = @_;
 221         #print "[trace] $line\n";
 222 };
 223 sub trace2($) {
 224         my ($line) = @_;
 225         #print "[trace2] $line\n";
 226 };
 227
 228 sub make_gpg_fds() {
 229         my %fds = (
 230                 stdin => IO::Handle->new(),
 231                 stdout => IO::Handle->new(),
 232                 stderr => IO::Handle->new(),
 233                 status => IO::Handle->new() );
 234         my $handles = GnuPG::Handles->new( %fds );
 235         return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
 236 };
 237
 238 sub readwrite_gpg($$$$$%) {
 239         my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
 240
 241         trace("Entering readwrite_gpg.");
 242
 243         my ($first_line, undef) = split /\n/, $in;
 244         debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
 245
 246         local $INPUT_RECORD_SEPARATOR = undef;
 247         my $sout = IO::Select->new();
 248         my $sin = IO::Select->new();
 249         my $offset = 0;
 250
 251         trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 252
 253         $inputfd->blocking(0);
 254         $stdoutfd->blocking(0);
 255         $statusfd->blocking(0) if defined $statusfd;
 256         $stderrfd->blocking(0);
 257         $sout->add($stdoutfd);
 258         $sout->add($stderrfd);
 259         $sout->add($statusfd) if defined $statusfd;
 260         $sin->add($inputfd);
 261
 262         my ($stdout, $stderr, $status) = ("", "", "");
 263         my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
 264         trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
 265
 266         my $readwrote_stuff_this_time = 0;
 267         my $do_not_wait_on_select = 0;
 268         my ($readyr, $readyw, $written);
 269         while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 270                 if (defined $exitwhenstatusmatches) {
 271                         if ($status =~ /$exitwhenstatusmatches/m) {
 272                                 trace("readwrite_gpg found match on $exitwhenstatusmatches");
 273                                 if ($readwrote_stuff_this_time) {
 274                                         trace("read/write some more\n");
 275                                         $do_not_wait_on_select = 1;
 276                                 } else {
 277                                         trace("that's it in our while loop.\n");
 278                                         last;
 279                                 }
 280                         };
 281                 };
 282
 283                 $readwrote_stuff_this_time = 0;
 284                 trace("select waiting for ".($sout->count())." fds.");
 285                 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
 286                 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
 287                 for my $wfd (@$readyw) {
 288                         $readwrote_stuff_this_time = 1;
 289                         if (length($in) != $offset) {
 290                                 trace("writing to $wfd.");
 291                                 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 292                                 $offset += $written;
 293                         };
 294                         if ($offset == length($in)) {
 295                                 trace("writing to $wfd done.");
 296                                 unless ($options{'nocloseinput'}) {
 297                                         close $wfd;
 298                                         trace("$wfd closed.");
 299                                 };
 300                                 $sin->remove($wfd);
 301                                 $sin = undef;
 302                         }
 303                 }
 304
 305                 next unless (defined(@$readyr)); # Wait some more.
 306
 307                 for my $rfd (@$readyr) {
 308                         $readwrote_stuff_this_time = 1;
 309                         if ($rfd->eof) {
 310                                 trace("reading from $rfd done.");
 311                                 $sout->remove($rfd);
 312                                 close($rfd);
 313                                 next;
 314                         }
 315                         trace("reading from $rfd.");
 316                         if ($rfd == $stdoutfd) {
 317                                 $stdout .= <$rfd>;
 318                                 trace2("stdout is now $stdout\n================");
 319                                 next;
 320                         }
 321                         if (defined $statusfd && $rfd == $statusfd) {
 322                                 $status .= <$rfd>;
 323                                 trace2("status is now $status\n================");
 324                                 next;
 325                         }
 326                         if ($rfd == $stderrfd) {
 327                                 $stderr .= <$rfd>;
 328                                 trace2("stderr is now $stderr\n================");
 329                                 next;
 330                         }
 331                 }
 332         }
 333         trace("readwrite_gpg done.");
 334         return ($stdout, $stderr, $status);
 335 };
 336
 337 sub ask($$) {
 338         my ($question, $default) = @_;
 339         my $answer;
 340         while (1) {
 341                 print $question,' ',($default ? '[Y/n]' : '[y/N]'), ' ';
 342                 $answer = <STDIN>;
 343                 chomp $answer;
 344                 last if ((defined $answer) && (length $answer <= 1));
 345                 print "grrrrrr.\n";
 346                 sleep 1;
 347         };
 348         my $result = $default;
 349         $result = 1 if $answer =~ /y/i;
 350         $result = 0 if $answer =~ /n/i;
 351         return $result;
 352 };
 353
 354
 355
 356
 357
 358 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
 359 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
 360 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
 361 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
 362 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
 363
 364 load_config;
 365 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader";
 366
 367 my $KEYSBASE =  $CONFIG{'caffhome'}.'/keys';
 368 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
 369
 370 -d $KEYSBASE  || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
 371 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
 372
 373 my $NOW = time;
 374 my  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
 375 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
 376
 377
 378 sub usage() {
 379         print STDERR "caff $VERSION - (c) 2004, 2005 Peter Palfrader\n";
 380         print STDERR "Usage: $PROGRAM_NAME [-mMR] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
 381         exit 1;
 382 };
 383
 384 sub export_key($$) {
 385         my ($gnupghome, $keyid) = @_;
 386
 387         my $gpg = GnuPG::Interface->new();
 388         $gpg->call( $CONFIG{'gpg'} );
 389         $gpg->options->hash_init(
 390                 'homedir' => $gnupghome,
 391                 'armor' => 1 );
 392         $gpg->options->meta_interactive( 0 );
 393         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 394         my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
 395         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 396         waitpid $pid, 0;
 397
 398         return $stdout;
 399 };
 400
 401 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 402 sub send_mail($$$@) {
 403         my ($address, $can_encrypt, $key_id, @keys) = @_;
 404
 405         my $message = "Hi,\n\n";
 406
 407         $message .= 'please find attached the user id'.(scalar @keys >= 2 ? 's' : '')."\n";
 408         for my $key (@keys) {
 409                 $message .= "\t".$key->{'text'}."\n";
 410         };
 411         $message .= qq{of your key $key_id signed by me.
 412
 413 Note that I did not upload your key to any keyservers. If you want this
 414 new signature to be available to others, please upload it yourself.
 415 With GnuPG this can be done using
 416         gpg --keyserver subkeys.pgp.net --send-key $key_id
 417
 418 If you have any questions, don't hesitate to ask.
 419
 420 Regards,
 421 $CONFIG{'owner'}
 422 };
 423         my $message_entity = MIME::Entity->build(
 424                 Type        => "text/plain",
 425                 Charset     => "utf-8",
 426                 Disposition => 'inline',
 427                 Data        => $message);
 428
 429         my @key_entities;
 430         for my $key (@keys) {
 431                 $message_entity->attach(
 432                         Type        => "application/pgp-keys",
 433                         Disposition => 'attachment',
 434                         Encoding    => "7bit",
 435                         Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
 436                         Data        => $key->{'key'},
 437                         Filename    => "0x$key_id.".$key->{'serial'}.".asc");
 438         };
 439
 440         if ($can_encrypt) {
 441                 my $message = $message_entity->stringify();
 442
 443                 my $gpg = GnuPG::Interface->new();
 444                 $gpg->call( $CONFIG{'gpg'} );
 445                 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
 446                         'extra_args' => '--always-trust',
 447                         'armor' => 1 );
 448                 $gpg->options->meta_interactive( 0 );
 449                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 450                 $gpg->options->push_recipients( $key_id );
 451                 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
 452                 my $pid = $gpg->encrypt(handles => $handles);
 453                 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 454                 waitpid $pid, 0;
 455                 if ($stdout eq '') {
 456                         warn ("No data from gpg for list-key $key_id\n");
 457                         next;
 458                 };
 459                 $message = $stdout;
 460
 461                 $message_entity = MIME::Entity->build(
 462                         Type        => 'multipart/encrypted; protocol="application/pgp-encrypted"');
 463
 464                 $message_entity->attach(
 465                         Type        => "application/pgp-encrypted",
 466                         Disposition => 'attachment',
 467                         Encoding    => "7bit",
 468                         Data        => "Version: 1\n");
 469
 470                 $message_entity->attach(
 471                         Type        => "application/octet-stream",
 472                         Filename    => 'msg.asc',
 473                         Disposition => 'inline',
 474                         Encoding    => "7bit",
 475                         Data        => $message);
 476         };
 477
 478         $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
 479         $message_entity->head->add("To", $address);
 480         $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
 481         $message_entity->head->add("User-Agent", $USER_AGENT);
 482         $message_entity->send();
 483         $message_entity->stringify();
 484 };
 485
 486 sub sanitize_uid($) {
 487         my ($uid) = @_;
 488
 489         my $good_uid = $uid;
 490         $good_uid =~ tr#/:\\#_#;
 491         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 492         return $good_uid;
 493 };
 494
 495 my $USER;
 496 my @KEYIDS;
 497 my %opt;
 498
 499 getopts('mMRu:', \%opt);
 500
 501 usage() unless scalar @ARGV >= 1;
 502 if ($opt{u}) {
 503         $USER = $opt{u};
 504         $USER =~ s/^0x//i;
 505         unless ($USER =~ /^[A-Za-z0-9]{8,8}([A-Za-z0-9]{8})?$/) {
 506                 print STDERR "-u $USER is not a keyid.\n";
 507                 usage();
 508         };
 509         $USER = uc($USER);
 510 };
 511 for my $keyid (@ARGV) {
 512         $keyid =~ s/^0x//i;
 513         unless ($keyid =~ /^[A-Za-z0-9]{8}([A-Za-z0-9]{8}|[A-Za-z0-9]{32})?$/) {
 514                 print STDERR "$keyid is not a keyid.\n";
 515                 usage();
 516         };
 517         push @KEYIDS, uc($keyid);
 518 };
 519
 520
 521
 522 #################
 523 # import own keys
 524 #################
 525         my $gpg = GnuPG::Interface->new();
 526         $gpg->call( $CONFIG{'gpg'} );
 527         $gpg->options->hash_init(
 528                 'homedir' => $GNUPGHOME,
 529                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 530         $gpg->options->meta_interactive( 0 );
 531         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 532         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 533         my $pid = $gpg->list_public_keys(handles => $handles, command_args => $CONFIG{'keyid'});
 534         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 535         waitpid $pid, 0;
 536         if ($stdout eq '') {
 537                 warn ("No data from gpg for list-key\n");
 538                 next;
 539         };
 540         foreach my $keyid (@{$CONFIG{'keyid'}}) {
 541                 unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
 542                         info("Importing $keyid");
 543                         system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME";
 544                 }
 545         }
 546
 547 #############################
 548 # receive keys from keyserver
 549 #############################
 550 my @keyids_ok;
 551 my @keyids_failed;
 552 if ($CONFIG{'no-download'} or $opt{R}) {
 553         @keyids_ok = @KEYIDS;
 554 } else {
 555         my $gpg = GnuPG::Interface->new();
 556         $gpg->call( $CONFIG{'gpg'} );
 557         $gpg->options->hash_init(
 558                 'homedir' => $GNUPGHOME,
 559                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 560         $gpg->options->meta_interactive( 0 );
 561         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 562
 563         my @local_keyids = @KEYIDS;
 564         for my $keyid (@local_keyids) {
 565                 info ("fetching $keyid...");
 566                 my $pid = $gpg->recv_keys(handles => $handles, command_args => [ $keyid ]);
 567                 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 568                 waitpid $pid, 0;
 569
 570 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 571 # [GNUPG:] NODATA 1
 572 # [GNUPG:] NODATA 1
 573 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 574                 my $handled = 0;
 575                 for my $line (split /\n/, $status) {
 576                         if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
 577                                 my $imported_key = $1;
 578                                 if ($keyid ne $imported_key &&
 579                                     $keyid ne substr($imported_key, -16) &&
 580                                     $keyid ne substr($imported_key, -8)) {
 581                                     warn("Imported unexpected key.  expected: $keyid; got: $imported_key.\n");
 582                                     next;
 583                                 };
 584                                 push @keyids_ok, $keyid;
 585                                 shift @KEYIDS;
 586                                 $handled = 1;
 587                                 last;
 588                         } elsif ($line =~ /^\[GNUPG:\] NODATA/) {
 589                                 push @keyids_failed, $keyid;
 590                                 shift @KEYIDS;
 591                                 $handled = 1;
 592                                 last;
 593                         };
 594                 };
 595                 unless ($handled) {
 596                         notice ("Huh, what's up with $keyid?");
 597                         push @keyids_failed, $keyid;
 598                         shift @KEYIDS;
 599                 };
 600         };
 601         die ("Still keys in \@KEYIDS.  This should not happen.") if scalar @KEYIDS;
 602         notice ("Import failed for: ". (join ' ', @keyids_failed).".") if scalar @keyids_failed;
 603 };
 604
 605 ###########
 606 # sign keys
 607 ###########
 608 unless ($CONFIG{'no-sign'}) {
 609         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
 610         for my $keyid (@keyids_ok) {
 611                 my @command;
 612                 push @command, $CONFIG{'gpg-sign'};
 613                 push @command, '--local-user', $USER if (defined $USER);
 614                 push @command, "--homedir=$GNUPGHOME";
 615                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 616                 push @command, '--edit', $keyid;
 617                 push @command, 'sign';
 618                 print join(' ', @command),"\n";
 619                 system (@command);
 620         };
 621 };
 622
 623 ##################
 624 # export and prune
 625 ##################
 626 KEYS:
 627 for my $keyid (@keyids_ok) {
 628         # get key listing
 629         #################
 630         my $gpg = GnuPG::Interface->new();
 631         $gpg->call( $CONFIG{'gpg'} );
 632         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 633         $gpg->options->meta_interactive( 0 );
 634         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 635         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 636         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 637         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 638         waitpid $pid, 0;
 639         if ($stdout eq '') {
 640                 warn ("No data from gpg for list-key $keyid\n");
 641                 next;
 642         };
 643         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 644         my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
 645         if (scalar @publine > 0) {
 646                 warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
 647                 next;
 648         };
 649         unless (defined $longkeyid) {
 650                 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
 651                 next;
 652         };
 653         unless (defined $flags) {
 654                 warn ("Didn't find flags in --list-key of key $keyid.\n");
 655                 next;
 656         };
 657         my $can_encrypt = $flags =~ /E/;
 658
 659         # export the key
 660         ################
 661         my $asciikey = export_key($GNUPGHOME, $keyid);
 662         if ($asciikey eq '') {
 663                 warn ("No data from gpg for export $keyid\n");
 664                 next;
 665         };
 666
 667         my @UIDS;
 668         my $uid_number = 0;
 669         while (1) {
 670                 my $this_uid_text = '';
 671                 $uid_number++;
 672                 debug("Doing key $keyid, uid $uid_number");
 673
 674                 # import into temporary gpghome
 675                 ###############################
 676                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 677                 my $gpg = GnuPG::Interface->new();
 678                 $gpg->call( $CONFIG{'gpg'} );
 679                 $gpg->options->hash_init( 'homedir' => $tempdir );
 680                 $gpg->options->meta_interactive( 0 );
 681                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 682                 my $pid = $gpg->import_keys(handles => $handles);
 683                 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 684                 waitpid $pid, 0;
 685
 686                 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 687                         warn ("Could not import $keyid into temporary gnupg.\n");
 688                         next;
 689                 };
 690
 691                 # prune it
 692                 ##########
 693                 $gpg = GnuPG::Interface->new();
 694                 $gpg->call( $CONFIG{'gpg-delsig'} );
 695                 $gpg->options->hash_init(
 696                         'homedir' => $tempdir,
 697                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 698                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 699                 $pid = $gpg->wrap_call(
 700                         commands     => [ '--edit' ],
 701                         command_args => [ $keyid ],
 702                         handles      => $handles );
 703
 704                 debug("Starting edit session");
 705                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 706
 707                 # delete other uids
 708                 ###################
 709                 my $number_of_subkeys = 0;
 710                 my $i = 1;
 711                 my $have_one = 0;
 712                 my $is_uat = 0;
 713                 my $delete_some = 0;
 714                 debug("Parsing stdout output.");
 715                 for my $line (split /\n/, $stdout) {
 716                         debug("Checking line $line");
 717                         my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
 718                         if ($type eq 'sub') {
 719                                 $number_of_subkeys++;
 720                         };
 721                         next unless ($type eq 'uid' || $type eq 'uat');
 722                         debug("line is interesting.");
 723                         if ($uid_number != $i) {
 724                                 debug("mark for deletion.");
 725                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 726                                 $delete_some = 1;
 727                         } else {
 728                                 debug("keep it.");
 729                                 $have_one = 1;
 730                                 $this_uid_text = ($type eq 'uid') ? $uidtext : 'attribute';
 731                                 $is_uat = $type eq 'uat';
 732                         };
 733                         $i++;
 734                 };
 735                 debug("Parsing stdout output done.");
 736                 if ($is_uat) {
 737                         notice("Can't handle attribute userid of key $keyid.");
 738                         next;
 739                 };
 740                 unless ($have_one) {
 741                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
 742                         info("key $keyid done.");
 743                         last;
 744                 };
 745                 if ($delete_some) {
 746                         debug("need to delete a few uids.");
 747                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 748                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 749                 };
 750
 751                 # delete subkeys
 752                 ################
 753                 if ($number_of_subkeys > 0) {
 754                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 755                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 756                         };
 757                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 758                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 759                 };
 760
 761                 # delete signatures
 762                 ###################
 763                 my $signed_by_me = 0;
 764                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 765                 ($stdout, $stderr, $status) =
 766                         readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 767
 768                 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 769                         # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 770                         my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 771                         $stdout =~ s/\n/\\n/g;
 772                         notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
 773                         my $line = pop @sigline;
 774                         my $answer = "no";
 775                         if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 776                                 debug("[sigremoval] doing line $line.");
 777                                 my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
 778                                 if ($signer eq $longkeyid) {
 779                                         debug("[sigremoval] selfsig ($signer).");
 780                                         $answer = "no";
 781                                 } elsif (grep { $signer eq $_ } @{$CONFIG{'keyid'}}) {
 782                                         debug("[sigremoval] signed by us ($signer).");
 783                                         $answer = "no";
 784                                         $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 785                                 } else {
 786                                         debug("[sigremoval] not interested in that sig ($signer).");
 787                                         $answer = "yes";
 788                                 };
 789                         } else {
 790                                 debug("[sigremoval] no sig line here, only got: ".$stdout);
 791                         };
 792                         ($stdout, $stderr, $status) =
 793                                 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 794                 };
 795                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
 796                 waitpid $pid, 0;
 797
 798                 my $asciikey = export_key($tempdir, $keyid);
 799                 if ($asciikey eq '') {
 800                         warn ("No data from gpg for export $keyid\n");
 801                         next;
 802                 };
 803
 804                 if ($signed_by_me) {
 805                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
 806                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0);
 807                                 next unless $write;
 808                         };
 809                         my $keydir = "$KEYSBASE/$DATE_STRING";
 810                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
 811
 812                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
 813                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile\n");
 814                         print KEY $asciikey;
 815                         close KEY;
 816
 817                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number };
 818
 819                         info("$longkeyid $uid_number $this_uid_text done.");
 820                 } else {
 821                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
 822                 };
 823         };
 824
 825         if (scalar @UIDS == 0) {
 826                 info("found no signed uids for $keyid");
 827         } else {
 828                 next if $opt{M}; # do not send mail
 829
 830                 my @attached;
 831                 for my $uid (@UIDS) {
 832                         trace("UID: $uid->{'text'}\n");
 833                         unless ($uid->{'text'} =~ /@/) {
 834                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
 835                                 push @attached, $uid if $attach;
 836                         };
 837                 };
 838
 839                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
 840                 for my $uid (@UIDS) {
 841                         if ($uid->{'text'} =~ /@/) {
 842                                 my $address = $uid->{'text'};
 843                                 $address =~ s/.*<(.*)>.*/$1/;
 844                                 if ($opt{m} or ask("Send mail to '$address' for $uid->{'text'}?", 1)) {
 845                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 846
 847                                         my $keydir = "$KEYSBASE/$DATE_STRING";
 848                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
 849                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile\n");
 850                                         print KEY $mail;
 851                                         close KEY;
 852                                 };
 853                         };
 854                 };
 855         };
 856
 857 };
 858
 859
 860
 861
 862 ###############################################################3
 863 #### old fork gpg --edit
 864 =cut
 865                 my ($stdin_read, $stdin_write);
 866                 my ($stdout_read, $stdout_write);
 867                 my ($stderr_read, $stderr_write);
 868                 my ($status_read, $status_write);
 869                 pipe $stdin_read, $stdin_write;
 870                 pipe $stdout_read, $stdout_write;
 871                 pipe $stderr_read, $stderr_write;
 872                 pipe $status_read, $status_write;
 873
 874                 $pid = fork();
 875                 unless ($pid) { # child
 876                         close $stdin_write;
 877                         close $stdout_read;
 878                         close $stderr_read;
 879                         close $status_read;
 880
 881                         my @call;
 882                         push @call, $CONFIG{'gpg-delsig'};
 883                         push @call, "--homedir=$tempdir";
 884                         push @call, '--with-colons';
 885                         push @call, '--fixed-list-mode';
 886                         push @call, '--command-fd=0';
 887                         push @call, "--status-fd=".fileno($status_write);
 888                         push @call, "--no-tty";
 889                         push @call, "--edit";
 890                         push @call, $keyid;
 891
 892                         close STDIN;
 893                         close STDOUT;
 894                         close STDERR;
 895                         open (STDIN, "<&".fileno($stdin_read)) or die ("Cannot reopen stdin: $!\n");
 896                         open (STDOUT, ">&".fileno($stdout_write)) or die ("Cannot reopen stdout: $!\n");
 897                         open (STDERR, ">&".fileno($stderr_write)) or die ("Cannot reopen stderr: $!\n");
 898
 899                         fcntl $status_write, F_SETFD, 0;
 900
 901                         exec (@call);
 902                         exit;
 903                 };
 904                 close $stdin_read;
 905                 close $stdout_write;
 906                 close $stderr_write;
 907                 close $status_write;
 908
 909                 $inputfd = $stdin_write;
 910                 $stdoutfd = $stdout_read;
 911                 $stderrfd = $stderr_read;
 912                 $statusfd = $status_read;
 913 =cut