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 =~ tr#/:\\#_#;
 450         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 451         return $good_uid;
 452 };
 453
 454 my $USER;
 455 my @KEYIDS;
 456
 457 usage() unless scalar @ARGV >= 1;
 458 if ($ARGV[0] eq '-u') {
 459         usage() unless scalar @ARGV >= 3;
 460         shift @ARGV;
 461         $USER = shift @ARGV;
 462         unless ($USER =~ /^[A-Za-z0-9]{8,8}([A-Za-z0-9]{8})?$/) {
 463                 print STDERR "-u $USER is not a keyid.\n";
 464                 usage();
 465         };
 466         $USER = uc($USER);
 467 };
 468 for my $keyid (@ARGV) {
 469         unless ($keyid =~ /^[A-Za-z0-9]{8}([A-Za-z0-9]{8})?$/) {
 470                 print STDERR "$keyid is not a keyid.\n";
 471                 usage();
 472         };
 473         push @KEYIDS, uc($keyid);
 474 };
 475
 476
 477 #############################
 478 # receive keys from keyserver
 479 #############################
 480 my $gpg = GnuPG::Interface->new();
 481 $gpg->call( $CONFIG{'gpg'} );
 482 $gpg->options->hash_init(
 483         'homedir' => $GNUPGHOME,
 484         'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 485 $gpg->options->meta_interactive( 0 );
 486 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 487 my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
 488 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 489 waitpid $pid, 0;
 490
 491 my @keyids_ok;
 492 my @keyids_failed;
 493 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 494 # [GNUPG:] NODATA 1
 495 # [GNUPG:] NODATA 1
 496 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 497 for my $line (split /\n/, $status) {
 498         if ($line =~ /^\[GNUPG:\] IMPORT_OK/) {
 499                 push @keyids_ok, shift @KEYIDS;
 500         } elsif ($line =~ /^\[GNUPG:\] NODATA/) {
 501                 push @keyids_failed, shift @KEYIDS;
 502         };
 503 }
 504 die ("Still keys in \@KEYIDS.  This should not happen.") if scalar @KEYIDS;
 505 notice ("Import failed for: ". (join ' ', @keyids_failed).".") if scalar @keyids_failed;
 506
 507 ###########
 508 # sign keys
 509 ###########
 510 info("Sign the following keys according to your policy...");
 511 for my $keyid (@keyids_ok) {
 512         my @command;
 513         push @command, $CONFIG{'gpg-sign'};
 514         push @command, '--local-user', $USER if (defined $USER);
 515         push @command, "--homedir=$GNUPGHOME";
 516         push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 517         push @command, '--sign-key', $keyid;
 518         print join(' ', @command),"\n";
 519         system (@command);
 520 };
 521
 522 ##################
 523 # export and prune
 524 ##################
 525 KEYS:
 526 for my $keyid (@keyids_ok) {
 527         # get key listing
 528         #################
 529         $gpg = GnuPG::Interface->new();
 530         $gpg->call( $CONFIG{'gpg'} );
 531         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 532         $gpg->options->meta_interactive( 0 );
 533         ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 534         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 535         $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 536         ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 537         waitpid $pid, 0;
 538         if ($stdout eq '') {
 539                 warn ("No data from gpg for list-key $keyid\n");
 540                 next;
 541         };
 542         my $keyinfo = $stdout;
 543         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 544         my ($dummy1, $dummy2, $dummy3, $dummy4, $longkeyid, $dummy6, $dummy7, $dummy8, $dummy9, $dummy10, $dummy11, $flags) = split /:/, pop @publine;
 545         my $can_encrypt = $flags =~ /E/;
 546         unless (defined $longkeyid) {
 547                 warn ("Didn't find public keyid in edit dialog of key $keyid.\n");
 548                 next;
 549         };
 550
 551         # export the key
 552         ################
 553         my $asciikey = export_key($GNUPGHOME, $keyid);
 554         if ($asciikey eq '') {
 555                 warn ("No data from gpg for export $keyid\n");
 556                 next;
 557         };
 558
 559         my @UIDS;
 560         my $uid_number = 0;
 561         while (1) {
 562                 my $this_uid_text = '';
 563                 $uid_number++;
 564                 info("Doing key $keyid, uid $uid_number");
 565
 566                 # import into temporary gpghome
 567                 ###############################
 568                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 569                 my $gpg = GnuPG::Interface->new();
 570                 $gpg->call( $CONFIG{'gpg'} );
 571                 $gpg->options->hash_init( 'homedir' => $tempdir );
 572                 $gpg->options->meta_interactive( 0 );
 573                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 574                 my $pid = $gpg->import_keys(handles => $handles);
 575                 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 576                 waitpid $pid, 0;
 577
 578                 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 579                         warn ("Could not import $keyid into temporary gnupg.\n");
 580                         next;
 581                 };
 582
 583                 # prune it
 584                 ##########
 585                 $gpg = GnuPG::Interface->new();
 586                 $gpg->call( $CONFIG{'gpg-delsig'} );
 587                 $gpg->options->hash_init(
 588                         'homedir' => $tempdir,
 589                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 590                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 591                 $pid = $gpg->wrap_call(
 592                         commands     => [ '--edit' ],
 593                         command_args => [ $keyid ],
 594                         handles      => $handles );
 595
 596                 debug("Starting edit session");
 597                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 598
 599                 # delete other uids
 600                 ###################
 601                 my $number_of_subkeys = 0;
 602                 my $i = 1;
 603                 my $have_one = 0;
 604                 my $is_uat = 0;
 605                 my $delete_some = 0;
 606                 debug("Parsing stdout output.");
 607                 for my $line (split /\n/, $stdout) {
 608                         debug("Checking line $line");
 609                         my ($type, $dummy2, $dummy3, $dummy4, $dummy5, $dummy6, $dummy7, $dummy8, $dummy9, $uidtext) = split /:/, $line;
 610                         if ($type eq 'sub') {
 611                                 $number_of_subkeys++;
 612                         };
 613                         next unless ($type eq 'uid' || $type eq 'uat');
 614                         debug("line is interesting.");
 615                         if ($uid_number != $i) {
 616                                 debug("mark for deletion.");
 617                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 618                                 $delete_some = 1;
 619                         } else {
 620                                 debug("keep it.");
 621                                 $have_one = 1;
 622                                 $this_uid_text = ($type eq 'uid') ? $uidtext : 'attribute';
 623                                 $is_uat = $type eq 'uat';
 624                         };
 625                         $i++;
 626                 };
 627                 debug("Parsing stdout output done.");
 628                 if ($is_uat) {
 629                         notice("Can't handle attribute userid of key $keyid.");
 630                         next;
 631                 };
 632                 unless ($have_one) {
 633                         info("key $keyid done.");
 634                         last;
 635                 };
 636                 if ($delete_some) {
 637                         debug("need to delete a few uids.");
 638                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 639                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 640                 };
 641
 642                 # delete subkeys
 643                 ################
 644                 if ($number_of_subkeys > 0) {
 645                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 646                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 647                         };
 648                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 649                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 650                 };
 651
 652                 # delete signatures
 653                 ###################
 654                 my $signed_by_me = 0;
 655                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 656                 ($stdout, $stderr, $status) =
 657                         readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 658
 659                 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 660                         # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 661                         my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 662                         my $line = pop @sigline;
 663                         my $answer = "no";
 664                         if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 665                                 my ($dummy1, $dummy2, $dummy3, $dummy4, $signer, $created, $dummy7, $dummy8, $dummy9) = split /:/, $line;
 666                                 if ($signer eq $longkeyid) {
 667                                         $answer = "no";
 668                                 } elsif (grep { $signer eq $_ } @{$CONFIG{'keyid'}}) {
 669                                         $answer = "no";
 670                                         $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 671                                 } else {
 672                                         $answer = "yes";
 673                                 };
 674                         };
 675                         ($stdout, $stderr, $status) =
 676                                 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 677                 };
 678                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
 679                 waitpid $pid, 0;
 680
 681                 my $asciikey = export_key($tempdir, $longkeyid);
 682                 if ($asciikey eq '') {
 683                         warn ("No data from gpg for export $longkeyid\n");
 684                         next;
 685                 };
 686
 687                 if ($signed_by_me) {
 688                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
 689                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0);
 690                                 next unless $write;
 691                         };
 692                         my $keydir = "$KEYSBASE/$DATE_STRING";
 693                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
 694
 695                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
 696                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile\n");
 697                         print KEY $asciikey;
 698                         close KEY;
 699
 700                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number };
 701
 702                         info("$longkeyid $uid_number $this_uid_text done.");
 703                 } else {
 704                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
 705                 };
 706         };
 707
 708         if (scalar @UIDS == 0) {
 709                 info("found no signed uids for $keyid");
 710         } else {
 711                 my @attached ;
 712                 for my $uid (@UIDS) {
 713                         trace("UID: $uid->{'text'}\n");
 714                         unless ($uid->{'text'} =~ /@/) {
 715                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
 716                                 push @attached, $uid;
 717                         };
 718                 };
 719
 720                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
 721                 for my $uid (@UIDS) {
 722                         if ($uid->{'text'} =~ /@/) {
 723                                 my $address = $uid->{'text'};
 724                                 $address =~ s/.*<(.*)>.*/$1/;
 725                                 my $send = ask("Send mail to '$address' for $uid->{'text'}?", 1);
 726                                 if ($send) {
 727                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 728
 729                                         my $keydir = "$KEYSBASE/$DATE_STRING";
 730                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
 731                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile\n");
 732                                         print KEY $mail;
 733                                         close KEY;
 734                                 };
 735                         };
 736                 };
 737         };
 738
 739 };
 740
 741
 742
 743
 744 ###############################################################3
 745 #### old fork gpg --edit
 746 =cut
 747                 my ($stdin_read, $stdin_write);
 748                 my ($stdout_read, $stdout_write);
 749                 my ($stderr_read, $stderr_write);
 750                 my ($status_read, $status_write);
 751                 pipe $stdin_read, $stdin_write;
 752                 pipe $stdout_read, $stdout_write;
 753                 pipe $stderr_read, $stderr_write;
 754                 pipe $status_read, $status_write;
 755
 756                 $pid = fork();
 757                 unless ($pid) { # child
 758                         close $stdin_write;
 759                         close $stdout_read;
 760                         close $stderr_read;
 761                         close $status_read;
 762
 763                         my @call;
 764                         push @call, $CONFIG{'gpg-delsig'};
 765                         push @call, "--homedir=$tempdir";
 766                         push @call, '--with-colons';
 767                         push @call, '--fixed-list-mode';
 768                         push @call, '--command-fd=0';
 769                         push @call, "--status-fd=".fileno($status_write);
 770                         push @call, "--no-tty";
 771                         push @call, "--edit";
 772                         push @call, $keyid;
 773
 774                         close STDIN;
 775                         close STDOUT;
 776                         close STDERR;
 777                         open (STDIN, "<&".fileno($stdin_read)) or die ("Cannot reopen stdin: $!\n");
 778                         open (STDOUT, ">&".fileno($stdout_write)) or die ("Cannot reopen stdout: $!\n");
 779                         open (STDERR, ">&".fileno($stderr_write)) or die ("Cannot reopen stderr: $!\n");
 780
 781                         fcntl $status_write, F_SETFD, 0;
 782
 783                         exec (@call);
 784                         exit;
 785                 };
 786                 close $stdin_read;
 787                 close $stdout_write;
 788                 close $stderr_write;
 789                 close $status_write;
 790
 791                 $inputfd = $stdin_write;
 792                 $stdoutfd = $stdout_read;
 793                 $stderrfd = $stderr_read;
 794                 $statusfd = $status_read;
 795 =cut