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, $dummy) = 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})?$/) {
 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/) {
 577                                 push @keyids_ok, shift @KEYIDS;
 578                                 $handled = 1;
 579                                 last;
 580                         } elsif ($line =~ /^\[GNUPG:\] NODATA/) {
 581                                 push @keyids_failed, shift @KEYIDS;
 582                                 $handled = 1;
 583                                 last;
 584                         };
 585                 };
 586                 unless ($handled) {
 587                         notice ("Huh, what's up with $keyid?");
 588                         push @keyids_failed, shift @KEYIDS;
 589                 };
 590         };
 591         die ("Still keys in \@KEYIDS.  This should not happen.") if scalar @KEYIDS;
 592         notice ("Import failed for: ". (join ' ', @keyids_failed).".") if scalar @keyids_failed;
 593 };
 594
 595 ###########
 596 # sign keys
 597 ###########
 598 unless ($CONFIG{'no-sign'}) {
 599         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
 600         for my $keyid (@keyids_ok) {
 601                 my @command;
 602                 push @command, $CONFIG{'gpg-sign'};
 603                 push @command, '--local-user', $USER if (defined $USER);
 604                 push @command, "--homedir=$GNUPGHOME";
 605                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 606                 push @command, '--edit', $keyid;
 607                 push @command, 'sign';
 608                 print join(' ', @command),"\n";
 609                 system (@command);
 610         };
 611 };
 612
 613 ##################
 614 # export and prune
 615 ##################
 616 KEYS:
 617 for my $keyid (@keyids_ok) {
 618         # get key listing
 619         #################
 620         my $gpg = GnuPG::Interface->new();
 621         $gpg->call( $CONFIG{'gpg'} );
 622         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 623         $gpg->options->meta_interactive( 0 );
 624         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 625         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 626         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 627         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 628         waitpid $pid, 0;
 629         if ($stdout eq '') {
 630                 warn ("No data from gpg for list-key $keyid\n");
 631                 next;
 632         };
 633         my $keyinfo = $stdout;
 634         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 635         my ($dummy1, $dummy2, $dummy3, $dummy4, $longkeyid, $dummy6, $dummy7, $dummy8, $dummy9, $dummy10, $dummy11, $flags) = split /:/, pop @publine;
 636         my $can_encrypt = $flags =~ /E/;
 637         unless (defined $longkeyid) {
 638                 warn ("Didn't find public keyid in edit dialog of key $keyid.\n");
 639                 next;
 640         };
 641
 642         # export the key
 643         ################
 644         my $asciikey = export_key($GNUPGHOME, $keyid);
 645         if ($asciikey eq '') {
 646                 warn ("No data from gpg for export $keyid\n");
 647                 next;
 648         };
 649
 650         my @UIDS;
 651         my $uid_number = 0;
 652         while (1) {
 653                 my $this_uid_text = '';
 654                 $uid_number++;
 655                 debug("Doing key $keyid, uid $uid_number");
 656
 657                 # import into temporary gpghome
 658                 ###############################
 659                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 660                 my $gpg = GnuPG::Interface->new();
 661                 $gpg->call( $CONFIG{'gpg'} );
 662                 $gpg->options->hash_init( 'homedir' => $tempdir );
 663                 $gpg->options->meta_interactive( 0 );
 664                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 665                 my $pid = $gpg->import_keys(handles => $handles);
 666                 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 667                 waitpid $pid, 0;
 668
 669                 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 670                         warn ("Could not import $keyid into temporary gnupg.\n");
 671                         next;
 672                 };
 673
 674                 # prune it
 675                 ##########
 676                 $gpg = GnuPG::Interface->new();
 677                 $gpg->call( $CONFIG{'gpg-delsig'} );
 678                 $gpg->options->hash_init(
 679                         'homedir' => $tempdir,
 680                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 681                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 682                 $pid = $gpg->wrap_call(
 683                         commands     => [ '--edit' ],
 684                         command_args => [ $keyid ],
 685                         handles      => $handles );
 686
 687                 debug("Starting edit session");
 688                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 689
 690                 # delete other uids
 691                 ###################
 692                 my $number_of_subkeys = 0;
 693                 my $i = 1;
 694                 my $have_one = 0;
 695                 my $is_uat = 0;
 696                 my $delete_some = 0;
 697                 debug("Parsing stdout output.");
 698                 for my $line (split /\n/, $stdout) {
 699                         debug("Checking line $line");
 700                         my ($type, $dummy2, $dummy3, $dummy4, $dummy5, $dummy6, $dummy7, $dummy8, $dummy9, $uidtext) = split /:/, $line;
 701                         if ($type eq 'sub') {
 702                                 $number_of_subkeys++;
 703                         };
 704                         next unless ($type eq 'uid' || $type eq 'uat');
 705                         debug("line is interesting.");
 706                         if ($uid_number != $i) {
 707                                 debug("mark for deletion.");
 708                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 709                                 $delete_some = 1;
 710                         } else {
 711                                 debug("keep it.");
 712                                 $have_one = 1;
 713                                 $this_uid_text = ($type eq 'uid') ? $uidtext : 'attribute';
 714                                 $is_uat = $type eq 'uat';
 715                         };
 716                         $i++;
 717                 };
 718                 debug("Parsing stdout output done.");
 719                 if ($is_uat) {
 720                         notice("Can't handle attribute userid of key $keyid.");
 721                         next;
 722                 };
 723                 unless ($have_one) {
 724                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
 725                         info("key $keyid done.");
 726                         last;
 727                 };
 728                 if ($delete_some) {
 729                         debug("need to delete a few uids.");
 730                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 731                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 732                 };
 733
 734                 # delete subkeys
 735                 ################
 736                 if ($number_of_subkeys > 0) {
 737                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 738                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 739                         };
 740                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 741                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 742                 };
 743
 744                 # delete signatures
 745                 ###################
 746                 my $signed_by_me = 0;
 747                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 748                 ($stdout, $stderr, $status) =
 749                         readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 750
 751                 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 752                         # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 753                         my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 754                         $stdout =~ s/\n/\\n/g;
 755                         notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
 756                         my $line = pop @sigline;
 757                         my $answer = "no";
 758                         if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 759                                 debug("[sigremoval] doing line $line.");
 760                                 my ($dummy1, $dummy2, $dummy3, $dummy4, $signer, $created, $dummy7, $dummy8, $dummy9) = split /:/, $line;
 761                                 if ($signer eq $longkeyid) {
 762                                         debug("[sigremoval] selfsig ($signer).");
 763                                         $answer = "no";
 764                                 } elsif (grep { $signer eq $_ } @{$CONFIG{'keyid'}}) {
 765                                         debug("[sigremoval] signed by us ($signer).");
 766                                         $answer = "no";
 767                                         $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 768                                 } else {
 769                                         debug("[sigremoval] not interested in that sig ($signer).");
 770                                         $answer = "yes";
 771                                 };
 772                         } else {
 773                                 debug("[sigremoval] no sig line here, only got: ".$stdout);
 774                         };
 775                         ($stdout, $stderr, $status) =
 776                                 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 777                 };
 778                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
 779                 waitpid $pid, 0;
 780
 781                 my $asciikey = export_key($tempdir, $longkeyid);
 782                 if ($asciikey eq '') {
 783                         warn ("No data from gpg for export $longkeyid\n");
 784                         next;
 785                 };
 786
 787                 if ($signed_by_me) {
 788                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
 789                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0);
 790                                 next unless $write;
 791                         };
 792                         my $keydir = "$KEYSBASE/$DATE_STRING";
 793                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
 794
 795                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
 796                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile\n");
 797                         print KEY $asciikey;
 798                         close KEY;
 799
 800                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number };
 801
 802                         info("$longkeyid $uid_number $this_uid_text done.");
 803                 } else {
 804                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
 805                 };
 806         };
 807
 808         if (scalar @UIDS == 0) {
 809                 info("found no signed uids for $keyid");
 810         } else {
 811                 next if $opt{M}; # do not send mail
 812
 813                 my @attached;
 814                 for my $uid (@UIDS) {
 815                         trace("UID: $uid->{'text'}\n");
 816                         unless ($uid->{'text'} =~ /@/) {
 817                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
 818                                 push @attached, $uid if $attach;
 819                         };
 820                 };
 821
 822                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
 823                 for my $uid (@UIDS) {
 824                         if ($uid->{'text'} =~ /@/) {
 825                                 my $address = $uid->{'text'};
 826                                 $address =~ s/.*<(.*)>.*/$1/;
 827                                 if ($opt{m} or ask("Send mail to '$address' for $uid->{'text'}?", 1)) {
 828                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 829
 830                                         my $keydir = "$KEYSBASE/$DATE_STRING";
 831                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
 832                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile\n");
 833                                         print KEY $mail;
 834                                         close KEY;
 835                                 };
 836                         };
 837                 };
 838         };
 839
 840 };
 841
 842
 843
 844
 845 ###############################################################3
 846 #### old fork gpg --edit
 847 =cut
 848                 my ($stdin_read, $stdin_write);
 849                 my ($stdout_read, $stdout_write);
 850                 my ($stderr_read, $stderr_write);
 851                 my ($status_read, $status_write);
 852                 pipe $stdin_read, $stdin_write;
 853                 pipe $stdout_read, $stdout_write;
 854                 pipe $stderr_read, $stderr_write;
 855                 pipe $status_read, $status_write;
 856
 857                 $pid = fork();
 858                 unless ($pid) { # child
 859                         close $stdin_write;
 860                         close $stdout_read;
 861                         close $stderr_read;
 862                         close $status_read;
 863
 864                         my @call;
 865                         push @call, $CONFIG{'gpg-delsig'};
 866                         push @call, "--homedir=$tempdir";
 867                         push @call, '--with-colons';
 868                         push @call, '--fixed-list-mode';
 869                         push @call, '--command-fd=0';
 870                         push @call, "--status-fd=".fileno($status_write);
 871                         push @call, "--no-tty";
 872                         push @call, "--edit";
 873                         push @call, $keyid;
 874
 875                         close STDIN;
 876                         close STDOUT;
 877                         close STDERR;
 878                         open (STDIN, "<&".fileno($stdin_read)) or die ("Cannot reopen stdin: $!\n");
 879                         open (STDOUT, ">&".fileno($stdout_write)) or die ("Cannot reopen stdout: $!\n");
 880                         open (STDERR, ">&".fileno($stderr_write)) or die ("Cannot reopen stderr: $!\n");
 881
 882                         fcntl $status_write, F_SETFD, 0;
 883
 884                         exec (@call);
 885                         exit;
 886                 };
 887                 close $stdin_read;
 888                 close $stdout_write;
 889                 close $stderr_write;
 890                 close $status_write;
 891
 892                 $inputfd = $stdin_write;
 893                 $stdoutfd = $stdout_read;
 894                 $stderrfd = $stderr_read;
 895                 $statusfd = $status_read;
 896 =cut