caff/caff

   1 #!/usr/bin/perl -w
   2
   3 # caff  --  CA - Fire and Forget
   4 # $Id$
   5 #
   6 # Copyright (c) 2004 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> [-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<-u> I<yourkeyid>
  59
  60 Select the key that is used for signing, in case you have more than one key.
  61
  62 =back
  63
  64 =head1 FILES
  65
  66 =over
  67
  68 =item $HOME/.caffrc  -  configuration file
  69
  70 =back
  71
  72 =head1 CONFIGURATION FILE OPTIONS
  73
  74 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
  75
  76 Example:
  77
  78         $CONFIG{'owner'}       = 'Peter Palfrader';
  79         $CONFIG{'email'}       = 'peter@palfrader.org';
  80
  81 =head2 Valid keys
  82
  83 =over
  84
  85 =item B<caffhome> [string]
  86
  87 Base directory for the files caff stores.  Default: B<$HOME/.caff/>.
  88
  89 =item B<owner> [string]
  90
  91 Your name.  B<REQUIRED>.
  92
  93 =item B<email> [string]
  94
  95 Your email address, used in From: lines.  B<REQUIRED>.
  96
  97 =item B<keyid> [list of keyids]
  98
  99 A list of your keys.  This is used to determine which signatures to keep
 100 in the pruning step.  If you select a key using B<-u> it has to be in
 101 this list.  B<REQUIRED>.
 102
 103 =item B<export-sig-age> [seconds]
 104
 105 Don't export UIDs by default, on which your latest signature is older
 106 than this age.  Default: B<24*60*60> (i.e. one day).
 107
 108 =item B<keyserver> [string]
 109
 110 Keyserver to download keys from.  Default: B<subkeys.pgp.net>.
 111
 112 =item B<gpg> [string]
 113
 114 Path to the GnuPG binary.  Default: B<gpg>.
 115
 116 =item B<gpg-sign> [string]
 117
 118 Path to the GnuPG binary which is used to sign keys.  Default: what
 119 B<gpg> is set to.
 120
 121 =item B<gpg-sdelsig> [string]
 122
 123 Path to the GnuPG binary which is used to split off signatures.  This is
 124 needed while the upstream GnuPG is not fixed  (there are 2 bugs in the
 125 Debian Bug Tracking System).  Default: what B<gpg> is set to.
 126
 127 =item B<secret-keyring> [string]
 128
 129 Path to your secret keyring.  Default: B<$HOME/.gnupg/secring.gpg>.
 130
 131 =back
 132
 133 =head1 AUTHOR
 134
 135 Peter Palfrader <peter@palfrader.org>
 136
 137 =cut
 138
 139 use strict;
 140 use IO::Handle;
 141 use English;
 142 use File::Path;
 143 use File::Temp qw{tempdir};
 144 use MIME::Entity;
 145 use Fcntl;
 146 use IO::Select;
 147 use GnuPG::Interface;
 148
 149 my %CONFIG;
 150 my $REVISION = '$Rev$';
 151 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
 152 my $VERSION = "0.0.0.$REVISION_NUMER";
 153
 154 sub load_config() {
 155         my $config = $ENV{'HOME'} . '/.caffrc';
 156         -f $config or die "No file $config present.  See caffrc(5).\n";
 157         unless (scalar eval `cat $config`) {
 158                 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
 159         };
 160
 161         $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
 162         die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
 163         die ("email is not defined.\n") unless defined $CONFIG{'email'};
 164         die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
 165         die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
 166         for my $keyid (@{$CONFIG{'keyid'}}) {
 167                 $keyid =~ /^[A-Fa-z0-9]{16}$/ or die ("key $keyid is not a long (16 digit) keyid.\n");
 168         };
 169         @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
 170         $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
 171         $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
 172         $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
 173         $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
 174         $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
 175         $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
 176 };
 177
 178 sub notice($) {
 179         my ($line) = @_;
 180         print "[NOTICE] $line\n";
 181 };
 182 sub info($) {
 183         my ($line) = @_;
 184         print "[INFO] $line\n";
 185 };
 186 sub debug($) {
 187         my ($line) = @_;
 188         #print "[DEBUG] $line\n";
 189 };
 190 sub trace($) {
 191         my ($line) = @_;
 192         #print "[trace] $line\n";
 193 };
 194 sub trace2($) {
 195         my ($line) = @_;
 196         #print "[trace2] $line\n";
 197 };
 198
 199 sub make_gpg_fds() {
 200         my %fds = (
 201                 stdin => IO::Handle->new(),
 202                 stdout => IO::Handle->new(),
 203                 stderr => IO::Handle->new(),
 204                 status => IO::Handle->new() );
 205         my $handles = GnuPG::Handles->new( %fds );
 206         return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
 207 };
 208
 209 sub readwrite_gpg($$$$$%) {
 210         my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
 211
 212         trace("Entering readwrite_gpg.");
 213
 214         my ($first_line, $dummy) = split /\n/, $in;
 215         debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
 216
 217         local $INPUT_RECORD_SEPARATOR = undef;
 218         my $sout = IO::Select->new();
 219         my $sin = IO::Select->new();
 220         my $offset = 0;
 221
 222         trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 223
 224         $inputfd->blocking(0);
 225         $stdoutfd->blocking(0);
 226         $statusfd->blocking(0) if defined $statusfd;
 227         $stderrfd->blocking(0);
 228         $sout->add($stdoutfd);
 229         $sout->add($stderrfd);
 230         $sout->add($statusfd) if defined $statusfd;
 231         $sin->add($inputfd);
 232
 233         my ($stdout, $stderr, $status) = ("", "", "");
 234         my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
 235         trace("doign stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
 236
 237         my ($readyr, $readyw, $written);
 238         while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 239                 if (defined $exitwhenstatusmatches) {
 240                         if ($status =~ /$exitwhenstatusmatches/m) {
 241                                 trace("readwrite_gpg found match on $exitwhenstatusmatches");
 242                                 last;
 243                         };
 244                 };
 245
 246                 trace("select waiting for ".($sout->count())." fds.");
 247                 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, 1);
 248                 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
 249                 for my $wfd (@$readyw) {
 250                         if (length($in) != $offset) {
 251                                 trace("writing to $wfd.");
 252                                 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 253                                 $offset += $written;
 254                         };
 255                         if ($offset == length($in)) {
 256                                 trace("writing to $wfd done.");
 257                                 unless ($options{'nocloseinput'}) {
 258                                         close $wfd;
 259                                         trace("$wfd closed.");
 260                                 };
 261                                 $sin->remove($wfd);
 262                                 $sin = undef;
 263                         }
 264                 }
 265
 266                 next unless (defined(@$readyr)); # Wait some more.
 267
 268                 for my $rfd (@$readyr) {
 269                         if ($rfd->eof) {
 270                                 trace("reading from $rfd done.");
 271                                 $sout->remove($rfd);
 272                                 close($rfd);
 273                                 next;
 274                         }
 275                         trace("reading from $rfd.");
 276                         if ($rfd == $stdoutfd) {
 277                                 $stdout .= <$rfd>;
 278                                 trace2("stdout is now $stdout\n================");
 279                                 next;
 280                         }
 281                         if (defined $statusfd && $rfd == $statusfd) {
 282                                 $status .= <$rfd>;
 283                                 trace2("status is now $status\n================");
 284                                 next;
 285                         }
 286                         if ($rfd == $stderrfd) {
 287                                 $stderr .= <$rfd>;
 288                                 trace2("stderr is now $stderr\n================");
 289                                 next;
 290                         }
 291                 }
 292         }
 293         trace("readwrite_gpg done.");
 294         return ($stdout, $stderr, $status);
 295 };
 296
 297 sub ask($$) {
 298         my ($question, $default) = @_;
 299         my $answer;
 300         while (1) {
 301                 print $question,' ',($default ? '[Y/n]' : '[y/N]'), ' ';
 302                 $answer = <STDIN>;
 303                 chomp $answer;
 304                 last if ((defined $answer) && (length $answer <= 1));
 305                 print "grrrrrr.\n";
 306                 sleep 1;
 307         };
 308         my $result = $default;
 309         $result = 1 if $answer =~ /y/i;
 310         $result = 0 if $answer =~ /n/i;
 311         return $result;
 312 };
 313
 314
 315
 316
 317
 318 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
 319 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
 320 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
 321 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
 322 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
 323
 324 load_config;
 325 my $USER_AGENT = "caff $VERSION - (c) 2004 Peter Palfrader";
 326
 327 my $KEYSBASE =  $CONFIG{'caffhome'}.'/keys';
 328 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
 329
 330 -d $KEYSBASE  || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
 331 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
 332
 333 my $NOW = time;
 334 my  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
 335 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
 336
 337
 338 sub usage() {
 339         print STDERR "caff $VERSION - (c) 2004 Peter Palfrader\n";
 340         print STDERR "Usage: $PROGRAM_NAME [-u <yourkeyid] <keyid> [<keyid> ...]\n";
 341         exit 1;
 342 };
 343
 344 sub export_key($$) {
 345         my ($gnupghome, $keyid) = @_;
 346
 347         my $gpg = GnuPG::Interface->new();
 348         $gpg->call( $CONFIG{'gpg'} );
 349         $gpg->options->hash_init(
 350                 'homedir' => $gnupghome,
 351                 'armor' => 1 );
 352         $gpg->options->meta_interactive( 0 );
 353         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 354         my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
 355         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 356         waitpid $pid, 0;
 357
 358         return $stdout;
 359 };
 360
 361 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 362 sub send_mail($$$@) {
 363         my ($address, $can_encrypt, $key_id, @keys) = @_;
 364
 365         my $message = "Hi,\n\n";
 366
 367         $message .= 'please find attached the user id'.(scalar @keys >= 2 ? 's' : '')."\n";
 368         for my $key (@keys) {
 369                 $message .= "\t".$key->{'text'}."\n";
 370         };
 371         $message .= qq{of your key $key_id signed by me.
 372
 373 Note that I did not upload your key to any keyservers. If you want this
 374 new signature to be available to others, please upload it yourself.
 375 With GnuPG this can be done using
 376         gpg --keyserver subkeys.pgp.net --send-key $key_id
 377
 378 If you have any questions, don't hesitate to ask.
 379
 380 Regards,
 381 $CONFIG{'owner'}
 382 };
 383         my $message_entity = MIME::Entity->build(
 384                 Type        => "text/plain",
 385                 Charset     => "utf-8",
 386                 Disposition => 'inline',
 387                 Data        => $message);
 388
 389         my @key_entities;
 390         for my $key (@keys) {
 391                 $message_entity->attach(
 392                         Type        => "application/pgp-keys",
 393                         Disposition => 'attachment',
 394                         Encoding    => "7bit",
 395                         Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
 396                         Data        => $key->{'key'},
 397                         Filename    => "0x$key_id.".$key->{'serial'}.".asc");
 398         };
 399
 400         if ($can_encrypt) {
 401                 my $message = $message_entity->stringify();
 402
 403                 my $gpg = GnuPG::Interface->new();
 404                 $gpg->call( $CONFIG{'gpg'} );
 405                 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
 406                         'extra_args' => '--always-trust',
 407                         'armor' => 1 );
 408                 $gpg->options->meta_interactive( 0 );
 409                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 410                 $gpg->options->push_recipients( $key_id );
 411                 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
 412                 my $pid = $gpg->encrypt(handles => $handles);
 413                 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 414                 waitpid $pid, 0;
 415                 if ($stdout eq '') {
 416                         warn ("No data from gpg for list-key $key_id\n");
 417                         next;
 418                 };
 419                 $message = $stdout;
 420
 421                 $message_entity = MIME::Entity->build(
 422                         Type        => 'multipart/encrypted; protocol="application/pgp-encrypted"');
 423
 424                 $message_entity->attach(
 425                         Type        => "application/pgp-encrypted",
 426                         Disposition => 'attachment',
 427                         Encoding    => "7bit",
 428                         Data        => "Version: 1\n");
 429
 430                 $message_entity->attach(
 431                         Type        => "application/octet-stream",
 432                         Filename    => 'msg.asc',
 433                         Disposition => 'inline',
 434                         Encoding    => "7bit",
 435                         Data        => $message);
 436         };
 437
 438         $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
 439         $message_entity->head->add("To", $address);
 440         $message_entity->head->add("From", $CONFIG{'owner'}.' <'.$CONFIG{'email'}.'>');
 441         $message_entity->head->add("User-Agent", $USER_AGENT);
 442         $message_entity->send();
 443         $message_entity->stringify();
 444 };
 445
 446 sub sanitize_uid($) {
 447         my ($uid) = @_;
 448
 449         my $good_uid = $uid;
 450         $good_uid =~ tr#/:\\#_#;
 451         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 452         return $good_uid;
 453 };
 454
 455 my $USER;
 456 my @KEYIDS;
 457
 458 usage() unless scalar @ARGV >= 1;
 459 if ($ARGV[0] eq '-u') {
 460         usage() unless scalar @ARGV >= 3;
 461         shift @ARGV;
 462         $USER = shift @ARGV;
 463         unless ($USER =~ /^[A-Za-z0-9]{8,8}([A-Za-z0-9]{8})?$/) {
 464                 print STDERR "-u $USER is not a keyid.\n";
 465                 usage();
 466         };
 467         $USER = uc($USER);
 468 };
 469 for my $keyid (@ARGV) {
 470         unless ($keyid =~ /^[A-Za-z0-9]{8}([A-Za-z0-9]{8})?$/) {
 471                 print STDERR "$keyid is not a keyid.\n";
 472                 usage();
 473         };
 474         push @KEYIDS, uc($keyid);
 475 };
 476
 477
 478 #############################
 479 # receive keys from keyserver
 480 #############################
 481 my $gpg = GnuPG::Interface->new();
 482 $gpg->call( $CONFIG{'gpg'} );
 483 $gpg->options->hash_init(
 484         'homedir' => $GNUPGHOME,
 485         'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 486 $gpg->options->meta_interactive( 0 );
 487 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 488 my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
 489 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 490 waitpid $pid, 0;
 491
 492 my @keyids_ok;
 493 my @keyids_failed;
 494 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 495 # [GNUPG:] NODATA 1
 496 # [GNUPG:] NODATA 1
 497 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 498 for my $line (split /\n/, $status) {
 499         if ($line =~ /^\[GNUPG:\] IMPORT_OK/) {
 500                 push @keyids_ok, shift @KEYIDS;
 501         } elsif ($line =~ /^\[GNUPG:\] NODATA/) {
 502                 push @keyids_failed, shift @KEYIDS;
 503         };
 504 }
 505 die ("Still keys in \@KEYIDS.  This should not happen.") if scalar @KEYIDS;
 506 notice ("Import failed for: ". (join ' ', @keyids_failed).".") if scalar @keyids_failed;
 507
 508 ###########
 509 # sign keys
 510 ###########
 511 info("Sign the following keys according to your policy...");
 512 for my $keyid (@keyids_ok) {
 513         my @command;
 514         push @command, $CONFIG{'gpg-sign'};
 515         push @command, '--local-user', $USER if (defined $USER);
 516         push @command, "--homedir=$GNUPGHOME";
 517         push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 518         push @command, '--sign-key', $keyid;
 519         print join(' ', @command),"\n";
 520         system (@command);
 521 };
 522
 523 ##################
 524 # export and prune
 525 ##################
 526 KEYS:
 527 for my $keyid (@keyids_ok) {
 528         # get key listing
 529         #################
 530         $gpg = GnuPG::Interface->new();
 531         $gpg->call( $CONFIG{'gpg'} );
 532         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 533         $gpg->options->meta_interactive( 0 );
 534         ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 535         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 536         $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 537         ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 538         waitpid $pid, 0;
 539         if ($stdout eq '') {
 540                 warn ("No data from gpg for list-key $keyid\n");
 541                 next;
 542         };
 543         my $keyinfo = $stdout;
 544         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 545         my ($dummy1, $dummy2, $dummy3, $dummy4, $longkeyid, $dummy6, $dummy7, $dummy8, $dummy9, $dummy10, $dummy11, $flags) = split /:/, pop @publine;
 546         my $can_encrypt = $flags =~ /E/;
 547         unless (defined $longkeyid) {
 548                 warn ("Didn't find public keyid in edit dialog of key $keyid.\n");
 549                 next;
 550         };
 551
 552         # export the key
 553         ################
 554         my $asciikey = export_key($GNUPGHOME, $keyid);
 555         if ($asciikey eq '') {
 556                 warn ("No data from gpg for export $keyid\n");
 557                 next;
 558         };
 559
 560         my @UIDS;
 561         my $uid_number = 0;
 562         while (1) {
 563                 my $this_uid_text = '';
 564                 $uid_number++;
 565                 info("Doing key $keyid, uid $uid_number");
 566
 567                 # import into temporary gpghome
 568                 ###############################
 569                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 570                 my $gpg = GnuPG::Interface->new();
 571                 $gpg->call( $CONFIG{'gpg'} );
 572                 $gpg->options->hash_init( 'homedir' => $tempdir );
 573                 $gpg->options->meta_interactive( 0 );
 574                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 575                 my $pid = $gpg->import_keys(handles => $handles);
 576                 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 577                 waitpid $pid, 0;
 578
 579                 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 580                         warn ("Could not import $keyid into temporary gnupg.\n");
 581                         next;
 582                 };
 583
 584                 # prune it
 585                 ##########
 586                 $gpg = GnuPG::Interface->new();
 587                 $gpg->call( $CONFIG{'gpg-delsig'} );
 588                 $gpg->options->hash_init(
 589                         'homedir' => $tempdir,
 590                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 591                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 592                 $pid = $gpg->wrap_call(
 593                         commands     => [ '--edit' ],
 594                         command_args => [ $keyid ],
 595                         handles      => $handles );
 596
 597                 debug("Starting edit session");
 598                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 599
 600                 # delete other uids
 601                 ###################
 602                 my $number_of_subkeys = 0;
 603                 my $i = 1;
 604                 my $have_one = 0;
 605                 my $is_uat = 0;
 606                 my $delete_some = 0;
 607                 debug("Parsing stdout output.");
 608                 for my $line (split /\n/, $stdout) {
 609                         debug("Checking line $line");
 610                         my ($type, $dummy2, $dummy3, $dummy4, $dummy5, $dummy6, $dummy7, $dummy8, $dummy9, $uidtext) = split /:/, $line;
 611                         if ($type eq 'sub') {
 612                                 $number_of_subkeys++;
 613                         };
 614                         next unless ($type eq 'uid' || $type eq 'uat');
 615                         debug("line is interesting.");
 616                         if ($uid_number != $i) {
 617                                 debug("mark for deletion.");
 618                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 619                                 $delete_some = 1;
 620                         } else {
 621                                 debug("keep it.");
 622                                 $have_one = 1;
 623                                 $this_uid_text = ($type eq 'uid') ? $uidtext : 'attribute';
 624                                 $is_uat = $type eq 'uat';
 625                         };
 626                         $i++;
 627                 };
 628                 debug("Parsing stdout output done.");
 629                 if ($is_uat) {
 630                         notice("Can't handle attribute userid of key $keyid.");
 631                         next;
 632                 };
 633                 unless ($have_one) {
 634                         info("key $keyid done.");
 635                         last;
 636                 };
 637                 if ($delete_some) {
 638                         debug("need to delete a few uids.");
 639                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 640                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 641                 };
 642
 643                 # delete subkeys
 644                 ################
 645                 if ($number_of_subkeys > 0) {
 646                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 647                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 648                         };
 649                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 650                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 651                 };
 652
 653                 # delete signatures
 654                 ###################
 655                 my $signed_by_me = 0;
 656                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 657                 ($stdout, $stderr, $status) =
 658                         readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 659
 660                 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 661                         # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 662                         my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 663                         my $line = pop @sigline;
 664                         my $answer = "no";
 665                         if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 666                                 my ($dummy1, $dummy2, $dummy3, $dummy4, $signer, $created, $dummy7, $dummy8, $dummy9) = split /:/, $line;
 667                                 if ($signer eq $longkeyid) {
 668                                         $answer = "no";
 669                                 } elsif (grep { $signer eq $_ } @{$CONFIG{'keyid'}}) {
 670                                         $answer = "no";
 671                                         $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 672                                 } else {
 673                                         $answer = "yes";
 674                                 };
 675                         };
 676                         ($stdout, $stderr, $status) =
 677                                 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 678                 };
 679                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
 680                 waitpid $pid, 0;
 681
 682                 my $asciikey = export_key($tempdir, $longkeyid);
 683                 if ($asciikey eq '') {
 684                         warn ("No data from gpg for export $longkeyid\n");
 685                         next;
 686                 };
 687
 688                 if ($signed_by_me) {
 689                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
 690                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0);
 691                                 next unless $write;
 692                         };
 693                         my $keydir = "$KEYSBASE/$DATE_STRING";
 694                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
 695
 696                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
 697                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile\n");
 698                         print KEY $asciikey;
 699                         close KEY;
 700
 701                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number };
 702
 703                         info("$longkeyid $uid_number $this_uid_text done.");
 704                 } else {
 705                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
 706                 };
 707         };
 708
 709         if (scalar @UIDS == 0) {
 710                 info("found no signed uids for $keyid");
 711         } else {
 712                 my @attached ;
 713                 for my $uid (@UIDS) {
 714                         trace("UID: $uid->{'text'}\n");
 715                         unless ($uid->{'text'} =~ /@/) {
 716                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
 717                                 push @attached, $uid if $attach;
 718                         };
 719                 };
 720
 721                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
 722                 for my $uid (@UIDS) {
 723                         if ($uid->{'text'} =~ /@/) {
 724                                 my $address = $uid->{'text'};
 725                                 $address =~ s/.*<(.*)>.*/$1/;
 726                                 my $send = ask("Send mail to '$address' for $uid->{'text'}?", 1);
 727                                 if ($send) {
 728                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 729
 730                                         my $keydir = "$KEYSBASE/$DATE_STRING";
 731                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
 732                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile\n");
 733                                         print KEY $mail;
 734                                         close KEY;
 735                                 };
 736                         };
 737                 };
 738         };
 739
 740 };
 741
 742
 743
 744
 745 ###############################################################3
 746 #### old fork gpg --edit
 747 =cut
 748                 my ($stdin_read, $stdin_write);
 749                 my ($stdout_read, $stdout_write);
 750                 my ($stderr_read, $stderr_write);
 751                 my ($status_read, $status_write);
 752                 pipe $stdin_read, $stdin_write;
 753                 pipe $stdout_read, $stdout_write;
 754                 pipe $stderr_read, $stderr_write;
 755                 pipe $status_read, $status_write;
 756
 757                 $pid = fork();
 758                 unless ($pid) { # child
 759                         close $stdin_write;
 760                         close $stdout_read;
 761                         close $stderr_read;
 762                         close $status_read;
 763
 764                         my @call;
 765                         push @call, $CONFIG{'gpg-delsig'};
 766                         push @call, "--homedir=$tempdir";
 767                         push @call, '--with-colons';
 768                         push @call, '--fixed-list-mode';
 769                         push @call, '--command-fd=0';
 770                         push @call, "--status-fd=".fileno($status_write);
 771                         push @call, "--no-tty";
 772                         push @call, "--edit";
 773                         push @call, $keyid;
 774
 775                         close STDIN;
 776                         close STDOUT;
 777                         close STDERR;
 778                         open (STDIN, "<&".fileno($stdin_read)) or die ("Cannot reopen stdin: $!\n");
 779                         open (STDOUT, ">&".fileno($stdout_write)) or die ("Cannot reopen stdout: $!\n");
 780                         open (STDERR, ">&".fileno($stderr_write)) or die ("Cannot reopen stderr: $!\n");
 781
 782                         fcntl $status_write, F_SETFD, 0;
 783
 784                         exec (@call);
 785                         exit;
 786                 };
 787                 close $stdin_read;
 788                 close $stdout_write;
 789                 close $stderr_write;
 790                 close $status_write;
 791
 792                 $inputfd = $stdin_write;
 793                 $stdoutfd = $stdout_read;
 794                 $stderrfd = $stderr_read;
 795                 $statusfd = $status_read;
 796 =cut