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