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