caff/caff

   1 #!/usr/bin/perl -w
   2
   3 # caff  --  CA - Fire and Forget
   4 # $Id$
   5 #
   6 # Copyright (c) 2004, 2005 Peter Palfrader <peter@palfrader.org>
   7 #
   8 # All rights reserved.
   9 #
  10 # Redistribution and use in source and binary forms, with or without
  11 # modification, are permitted provided that the following conditions
  12 # are met:
  13 # 1. Redistributions of source code must retain the above copyright
  14 #    notice, this list of conditions and the following disclaimer.
  15 # 2. Redistributions in binary form must reproduce the above copyright
  16 #    notice, this list of conditions and the following disclaimer in the
  17 #    documentation and/or other materials provided with the distribution.
  18 # 3. The name of the author may not be used to endorse or promote products
  19 #    derived from this software without specific prior written permission.
  20 #
  21 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
  22 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
  23 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
  24 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
  25 # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  26 # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  27 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  28 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  29 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  30 # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  31
  32 =pod
  33
  34 =head1 NAME
  35
  36 caff -- CA - Fire and Forget
  37
  38 =head1 SYNOPSIS
  39
  40 =over
  41
  42 =item B<caff> [-mMR] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]
  43
  44 =back
  45
  46 =head1 DESCRIPTION
  47
  48 CA Fire and Forget is a script that helps you in keysigning.  It takes a list
  49 of keyids on the command line, fetches them from a keyserver and calls GnuPG so
  50 that you can sign it.  It then mails each key to all its email addresses - only
  51 including the one UID that we send to in each mail, pruned from all but self
  52 sigs and sigs done by you.
  53
  54 =head1 OPTIONS
  55
  56 =over
  57
  58 =item B<-m> B<-M>
  59
  60 Send/do not send mail after signing. Default is to ask the user for each uid.
  61
  62 =item B<-R>
  63
  64 Do not retrieve the key to be signed from a keyserver.
  65
  66 =item B<-u> I<yourkeyid>
  67
  68 Select the key that is used for signing, in case you have more than one key.
  69
  70 =back
  71
  72 =head1 FILES
  73
  74 =over
  75
  76 =item $HOME/.caffrc  -  configuration file
  77
  78 =back
  79
  80 =head1 CONFIGURATION FILE OPTIONS
  81
  82 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
  83
  84 Example:
  85
  86         $CONFIG{owner} = q{Peter Palfrader};
  87         $CONFIG{email} = q{peter@palfrader.org};
  88         $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
  89
  90 =head2 Valid keys
  91
  92 =over
  93
  94 =item B<caffhome> [string]
  95
  96 Base directory for the files caff stores.  Default: B<$HOME/.caff/>.
  97
  98 =item B<owner> [string]
  99
 100 Your name.  B<REQUIRED>.
 101
 102 =item B<email> [string]
 103
 104 Your email address, used in From: lines.  B<REQUIRED>.
 105
 106 =item B<keyid> [list of keyids]
 107
 108 A list of your keys.  This is used to determine which signatures to keep
 109 in the pruning step.  If you select a key using B<-u> it has to be in
 110 this list.  B<REQUIRED>.
 111
 112 =item B<export-sig-age> [seconds]
 113
 114 Don't export UIDs by default, on which your latest signature is older
 115 than this age.  Default: B<24*60*60> (i.e. one day).
 116
 117 =item B<keyserver> [string]
 118
 119 Keyserver to download keys from.  Default: B<subkeys.pgp.net>.
 120
 121 =item B<gpg> [string]
 122
 123 Path to the GnuPG binary.  Default: B<gpg>.
 124
 125 =item B<gpg-sign> [string]
 126
 127 Path to the GnuPG binary which is used to sign keys.  Default: what
 128 B<gpg> is set to.
 129
 130 =item B<gpg-delsig> [string]
 131
 132 Path to the GnuPG binary which is used to split off signatures.  This was
 133 needed while the upstream GnuPG was not fixed.  Default: what B<gpg>
 134 is set to.
 135
 136 =item B<secret-keyring> [string]
 137
 138 Path to your secret keyring.  Default: B<$HOME/.gnupg/secring.gpg>.
 139
 140 =item B<also-encrypt-to> [keyid]
 141
 142 An additional keyid to encrypt messages to. Default: none.
 143
 144 =item B<no-download> [boolean]
 145
 146 If true, then skip the step of fetching keys from the keyserver.
 147 Default: B<0>.
 148
 149 =item B<no-sign> [boolean]
 150
 151 If true, then skip the signing step. Default: B<0>.
 152
 153 =back
 154
 155 =head1 AUTHOR
 156
 157 Peter Palfrader <peter@palfrader.org>
 158
 159 =head1 WEBSITE
 160
 161 http://pgp-tools.alioth.debian.org/
 162
 163 =cut
 164
 165 use strict;
 166 use IO::Handle;
 167 use English;
 168 use File::Path;
 169 use File::Temp qw{tempdir};
 170 use MIME::Entity;
 171 use Fcntl;
 172 use IO::Select;
 173 use Getopt::Std;
 174 use GnuPG::Interface;
 175
 176 my %CONFIG;
 177 my $REVISION = '$Rev$';
 178 my ($REVISION_NUMER) = $REVISION =~ /(\d+)/;
 179 my $VERSION = "0.0.0.$REVISION_NUMER";
 180
 181 sub load_config() {
 182         my $config = $ENV{'HOME'} . '/.caffrc';
 183         -f $config or die "No file $config present.  See caff(1).\n";
 184         unless (scalar eval `cat $config`) {
 185                 die "Couldn't parse $config: $EVAL_ERROR\n" if $EVAL_ERROR;
 186         };
 187
 188         $CONFIG{'caffhome'}=$ENV{'HOME'}.'/.caff' unless defined $CONFIG{'caffhome'};
 189         die ("owner is not defined.\n") unless defined $CONFIG{'owner'};
 190         die ("email is not defined.\n") unless defined $CONFIG{'email'};
 191         die ("keyid is not defined.\n") unless defined $CONFIG{'keyid'};
 192         die ("keyid is not an array ref\n") unless (ref $CONFIG{'keyid'} eq 'ARRAY');
 193         for my $keyid (@{$CONFIG{'keyid'}}) {
 194                 $keyid =~ /^[A-Fa-z0-9]{16}$/ or die ("key $keyid is not a long (16 digit) keyid.\n");
 195         };
 196         @{$CONFIG{'keyid'}} = map { uc } @{$CONFIG{'keyid'}};
 197         $CONFIG{'export-sig-age'}= 24*60*60 unless defined $CONFIG{'export-sig-age'};
 198         $CONFIG{'keyserver'} = 'subkeys.pgp.net' unless defined $CONFIG{'keyserver'};
 199         $CONFIG{'gpg'} = 'gpg' unless defined $CONFIG{'gpg'};
 200         $CONFIG{'gpg-sign'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-sign'};
 201         $CONFIG{'gpg-delsig'} = $CONFIG{'gpg'} unless defined $CONFIG{'gpg-delsig'};
 202         $CONFIG{'secret-keyring'} = $ENV{'HOME'}.'/.gnupg/secring.gpg' unless defined $CONFIG{'secret-keyring'};
 203         $CONFIG{'no-download'} = 0 unless defined $CONFIG{'no-download'};
 204         $CONFIG{'no-sign'} = 0 unless defined $CONFIG{'no-sign'};
 205 };
 206
 207 sub notice($) {
 208         my ($line) = @_;
 209         print "[NOTICE] $line\n";
 210 };
 211 sub info($) {
 212         my ($line) = @_;
 213         print "[INFO] $line\n";
 214 };
 215 sub debug($) {
 216         my ($line) = @_;
 217         #print "[DEBUG] $line\n";
 218 };
 219 sub trace($) {
 220         my ($line) = @_;
 221         #print "[trace] $line\n";
 222 };
 223 sub trace2($) {
 224         my ($line) = @_;
 225         #print "[trace2] $line\n";
 226 };
 227
 228 sub make_gpg_fds() {
 229         my %fds = (
 230                 stdin => IO::Handle->new(),
 231                 stdout => IO::Handle->new(),
 232                 stderr => IO::Handle->new(),
 233                 status => IO::Handle->new() );
 234         my $handles = GnuPG::Handles->new( %fds );
 235         return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
 236 };
 237
 238 sub readwrite_gpg($$$$$%) {
 239         my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
 240
 241         trace("Entering readwrite_gpg.");
 242
 243         my ($first_line, undef) = split /\n/, $in;
 244         debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
 245
 246         local $INPUT_RECORD_SEPARATOR = undef;
 247         my $sout = IO::Select->new();
 248         my $sin = IO::Select->new();
 249         my $offset = 0;
 250
 251         trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 252
 253         $inputfd->blocking(0);
 254         $stdoutfd->blocking(0);
 255         $statusfd->blocking(0) if defined $statusfd;
 256         $stderrfd->blocking(0);
 257         $sout->add($stdoutfd);
 258         $sout->add($stderrfd);
 259         $sout->add($statusfd) if defined $statusfd;
 260         $sin->add($inputfd);
 261
 262         my ($stdout, $stderr, $status) = ("", "", "");
 263         my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
 264         trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
 265
 266         my $readwrote_stuff_this_time = 0;
 267         my $do_not_wait_on_select = 0;
 268         my ($readyr, $readyw, $written);
 269         while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 270                 if (defined $exitwhenstatusmatches) {
 271                         if ($status =~ /$exitwhenstatusmatches/m) {
 272                                 trace("readwrite_gpg found match on $exitwhenstatusmatches");
 273                                 if ($readwrote_stuff_this_time) {
 274                                         trace("read/write some more\n");
 275                                         $do_not_wait_on_select = 1;
 276                                 } else {
 277                                         trace("that's it in our while loop.\n");
 278                                         last;
 279                                 }
 280                         };
 281                 };
 282
 283                 $readwrote_stuff_this_time = 0;
 284                 trace("select waiting for ".($sout->count())." fds.");
 285                 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
 286                 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
 287                 for my $wfd (@$readyw) {
 288                         $readwrote_stuff_this_time = 1;
 289                         if (length($in) != $offset) {
 290                                 trace("writing to $wfd.");
 291                                 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 292                                 $offset += $written;
 293                         };
 294                         if ($offset == length($in)) {
 295                                 trace("writing to $wfd done.");
 296                                 unless ($options{'nocloseinput'}) {
 297                                         close $wfd;
 298                                         trace("$wfd closed.");
 299                                 };
 300                                 $sin->remove($wfd);
 301                                 $sin = undef;
 302                         }
 303                 }
 304
 305                 next unless (defined(@$readyr)); # Wait some more.
 306
 307                 for my $rfd (@$readyr) {
 308                         $readwrote_stuff_this_time = 1;
 309                         if ($rfd->eof) {
 310                                 trace("reading from $rfd done.");
 311                                 $sout->remove($rfd);
 312                                 close($rfd);
 313                                 next;
 314                         }
 315                         trace("reading from $rfd.");
 316                         if ($rfd == $stdoutfd) {
 317                                 $stdout .= <$rfd>;
 318                                 trace2("stdout is now $stdout\n================");
 319                                 next;
 320                         }
 321                         if (defined $statusfd && $rfd == $statusfd) {
 322                                 $status .= <$rfd>;
 323                                 trace2("status is now $status\n================");
 324                                 next;
 325                         }
 326                         if ($rfd == $stderrfd) {
 327                                 $stderr .= <$rfd>;
 328                                 trace2("stderr is now $stderr\n================");
 329                                 next;
 330                         }
 331                 }
 332         }
 333         trace("readwrite_gpg done.");
 334         return ($stdout, $stderr, $status);
 335 };
 336
 337 sub ask($$) {
 338         my ($question, $default) = @_;
 339         my $answer;
 340         while (1) {
 341                 print $question,' ',($default ? '[Y/n]' : '[y/N]'), ' ';
 342                 $answer = <STDIN>;
 343                 chomp $answer;
 344                 last if ((defined $answer) && (length $answer <= 1));
 345                 print "grrrrrr.\n";
 346                 sleep 1;
 347         };
 348         my $result = $default;
 349         $result = 1 if $answer =~ /y/i;
 350         $result = 0 if $answer =~ /n/i;
 351         return $result;
 352 };
 353
 354
 355
 356
 357
 358 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
 359 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
 360 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
 361 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
 362 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
 363
 364 load_config;
 365 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader";
 366
 367 my $KEYSBASE =  $CONFIG{'caffhome'}.'/keys';
 368 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
 369
 370 -d $KEYSBASE  || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
 371 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
 372
 373 my $NOW = time;
 374 my  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
 375 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
 376
 377
 378 sub usage() {
 379         print STDERR "caff $VERSION - (c) 2004, 2005 Peter Palfrader\n";
 380         print STDERR "Usage: $PROGRAM_NAME [-mMR] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
 381         exit 1;
 382 };
 383
 384 sub export_key($$) {
 385         my ($gnupghome, $keyid) = @_;
 386
 387         my $gpg = GnuPG::Interface->new();
 388         $gpg->call( $CONFIG{'gpg'} );
 389         $gpg->options->hash_init(
 390                 'homedir' => $gnupghome,
 391                 'armor' => 1 );
 392         $gpg->options->meta_interactive( 0 );
 393         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 394         my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
 395         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 396         waitpid $pid, 0;
 397
 398         return $stdout;
 399 };
 400
 401 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 402 sub send_mail($$$@) {
 403         my ($address, $can_encrypt, $key_id, @keys) = @_;
 404
 405         my $message = "Hi,\n\n";
 406
 407         $message .= 'please find attached the user id'.(scalar @keys >= 2 ? 's' : '')."\n";
 408         for my $key (@keys) {
 409                 $message .= "\t".$key->{'text'}."\n";
 410         };
 411         $message .= qq{of your key $key_id signed by me.
 412
 413 Note that I did not upload your key to any keyservers. If you want this
 414 new signature to be available to others, please upload it yourself.
 415 With GnuPG this can be done using
 416         gpg --keyserver subkeys.pgp.net --send-key $key_id
 417
 418 If you have any questions, don't hesitate to ask.
 419
 420 Regards,
 421 $CONFIG{'owner'}
 422 };
 423         my $message_entity = MIME::Entity->build(
 424                 Type        => "text/plain",
 425                 Charset     => "utf-8",
 426                 Disposition => 'inline',
 427                 Data        => $message);
 428
 429         my @key_entities;
 430         for my $key (@keys) {
 431                 $message_entity->attach(
 432                         Type        => "application/pgp-keys",
 433                         Disposition => 'attachment',
 434                         Encoding    => "7bit",
 435                         Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
 436                         Data        => $key->{'key'},
 437                         Filename    => "0x$key_id.".$key->{'serial'}.".asc");
 438         };
 439
 440         if ($can_encrypt) {
 441                 my $message = $message_entity->stringify();
 442
 443                 my $gpg = GnuPG::Interface->new();
 444                 $gpg->call( $CONFIG{'gpg'} );
 445                 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
 446                         'extra_args' => '--always-trust',
 447                         'armor' => 1 );
 448                 $gpg->options->meta_interactive( 0 );
 449                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 450                 $gpg->options->push_recipients( $key_id );
 451                 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
 452                 my $pid = $gpg->encrypt(handles => $handles);
 453                 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 454                 waitpid $pid, 0;
 455                 if ($stdout eq '') {
 456                         warn ("No data from gpg for list-key $key_id\n");
 457                         next;
 458                 };
 459                 $message = $stdout;
 460
 461                 $message_entity = MIME::Entity->build(
 462                         Type        => 'multipart/encrypted; protocol="application/pgp-encrypted"');
 463
 464                 $message_entity->attach(
 465                         Type        => "application/pgp-encrypted",
 466                         Disposition => 'attachment',
 467                         Encoding    => "7bit",
 468                         Data        => "Version: 1\n");
 469
 470                 $message_entity->attach(
 471                         Type        => "application/octet-stream",
 472                         Filename    => 'msg.asc',
 473                         Disposition => 'inline',
 474                         Encoding    => "7bit",
 475                         Data        => $message);
 476         };
 477
 478         $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
 479         $message_entity->head->add("To", $address);
 480         $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
 481         $message_entity->head->add("User-Agent", $USER_AGENT);
 482         $message_entity->send();
 483         $message_entity->stringify();
 484 };
 485
 486 sub sanitize_uid($) {
 487         my ($uid) = @_;
 488
 489         my $good_uid = $uid;
 490         $good_uid =~ tr#/:\\#_#;
 491         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 492         return $good_uid;
 493 };
 494
 495 my $USER;
 496 my @KEYIDS;
 497 my %opt;
 498
 499 getopts('mMRu:', \%opt);
 500
 501 usage() unless scalar @ARGV >= 1;
 502 if ($opt{u}) {
 503         $USER = $opt{u};
 504         $USER =~ s/^0x//i;
 505         unless ($USER =~ /^[A-Za-z0-9]{8,8}([A-Za-z0-9]{8})?$/) {
 506                 print STDERR "-u $USER is not a keyid.\n";
 507                 usage();
 508         };
 509         $USER = uc($USER);
 510 };
 511 for my $keyid (@ARGV) {
 512         $keyid =~ s/^0x//i;
 513         unless ($keyid =~ /^[A-Za-z0-9]{8}([A-Za-z0-9]{8}|[A-Za-z0-9]{32})?$/) {
 514                 print STDERR "$keyid is not a keyid.\n";
 515                 usage();
 516         };
 517         push @KEYIDS, uc($keyid);
 518 };
 519
 520
 521
 522 #################
 523 # import own keys
 524 #################
 525         my $gpg = GnuPG::Interface->new();
 526         $gpg->call( $CONFIG{'gpg'} );
 527         $gpg->options->hash_init(
 528                 'homedir' => $GNUPGHOME,
 529                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 530         $gpg->options->meta_interactive( 0 );
 531         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 532         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 533         my $pid = $gpg->list_public_keys(handles => $handles, command_args => $CONFIG{'keyid'});
 534         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 535         waitpid $pid, 0;
 536         if ($stdout eq '') {
 537                 warn ("No data from gpg for list-key\n");
 538                 next;
 539         };
 540         foreach my $keyid (@{$CONFIG{'keyid'}}) {
 541                 unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
 542                         info("Importing $keyid");
 543                         system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME";
 544                 }
 545         }
 546
 547 #############################
 548 # receive keys from keyserver
 549 #############################
 550 my @keyids_ok;
 551 my @keyids_failed;
 552 if ($CONFIG{'no-download'} or $opt{R}) {
 553         @keyids_ok = @KEYIDS;
 554 } else {
 555         my $gpg = GnuPG::Interface->new();
 556         $gpg->call( $CONFIG{'gpg'} );
 557         $gpg->options->hash_init(
 558                 'homedir' => $GNUPGHOME,
 559                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 560         $gpg->options->meta_interactive( 0 );
 561         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 562
 563         my @local_keyids = @KEYIDS;
 564         for my $keyid (@local_keyids) {
 565                 info ("fetching $keyid...");
 566                 my $pid = $gpg->recv_keys(handles => $handles, command_args => [ $keyid ]);
 567                 my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 568                 waitpid $pid, 0;
 569
 570 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 571 # [GNUPG:] NODATA 1
 572 # [GNUPG:] NODATA 1
 573 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 574                 my $handled = 0;
 575                 for my $line (split /\n/, $status) {
 576                         if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
 577                                 my $imported_key = $1;
 578                                 if ($keyid ne $imported_key &&
 579                                     $keyid ne substr($imported_key, -16) &&
 580                                     $keyid ne substr($imported_key, -8)) {
 581                                     warn("Imported unexpected key.  expected: $keyid; got: $imported_key.\n");
 582                                     next;
 583                                 };
 584                                 push @keyids_ok, $keyid;
 585                                 shift @KEYIDS;
 586                                 $handled = 1;
 587                                 last;
 588                         } elsif ($line =~ /^\[GNUPG:\] NODATA/) {
 589                                 push @keyids_failed, $keyid;
 590                                 shift @KEYIDS;
 591                                 $handled = 1;
 592                                 last;
 593                         };
 594                 };
 595                 unless ($handled) {
 596                         notice ("Huh, what's up with $keyid?");
 597                         push @keyids_failed, $keyid;
 598                         shift @KEYIDS;
 599                 };
 600         };
 601         die ("Still keys in \@KEYIDS.  This should not happen.") if scalar @KEYIDS;
 602         notice ("Import failed for: ". (join ' ', @keyids_failed).".") if scalar @keyids_failed;
 603 };
 604
 605 ###########
 606 # sign keys
 607 ###########
 608 unless ($CONFIG{'no-sign'}) {
 609         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
 610         for my $keyid (@keyids_ok) {
 611                 my @command;
 612                 push @command, $CONFIG{'gpg-sign'};
 613                 push @command, '--local-user', $USER if (defined $USER);
 614                 push @command, "--homedir=$GNUPGHOME";
 615                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 616                 push @command, '--edit', $keyid;
 617                 push @command, 'sign';
 618                 print join(' ', @command),"\n";
 619                 system (@command);
 620         };
 621 };
 622
 623 ##################
 624 # export and prune
 625 ##################
 626 KEYS:
 627 for my $keyid (@keyids_ok) {
 628         # get key listing
 629         #################
 630         my $gpg = GnuPG::Interface->new();
 631         $gpg->call( $CONFIG{'gpg'} );
 632         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 633         $gpg->options->meta_interactive( 0 );
 634         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 635         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 636         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 637         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 638         waitpid $pid, 0;
 639         if ($stdout eq '') {
 640                 warn ("No data from gpg for list-key $keyid\n");
 641                 next;
 642         };
 643         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 644         if (scalar @publine == 0) {
 645                 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
 646                 next;
 647         };
 648         my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
 649         if (scalar @publine > 0) {
 650                 warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
 651                 next;
 652         };
 653         unless (defined $longkeyid) {
 654                 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
 655                 next;
 656         };
 657         unless (defined $flags) {
 658                 warn ("Didn't find flags in --list-key of key $keyid.\n");
 659                 next;
 660         };
 661         my $can_encrypt = $flags =~ /E/;
 662
 663         # export the key
 664         ################
 665         my $asciikey = export_key($GNUPGHOME, $keyid);
 666         if ($asciikey eq '') {
 667                 warn ("No data from gpg for export $keyid\n");
 668                 next;
 669         };
 670
 671         my @UIDS;
 672         my $uid_number = 0;
 673         while (1) {
 674                 my $this_uid_text = '';
 675                 $uid_number++;
 676                 debug("Doing key $keyid, uid $uid_number");
 677
 678                 # import into temporary gpghome
 679                 ###############################
 680                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 681                 my $gpg = GnuPG::Interface->new();
 682                 $gpg->call( $CONFIG{'gpg'} );
 683                 $gpg->options->hash_init( 'homedir' => $tempdir );
 684                 $gpg->options->meta_interactive( 0 );
 685                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 686                 my $pid = $gpg->import_keys(handles => $handles);
 687                 my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 688                 waitpid $pid, 0;
 689
 690                 if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 691                         warn ("Could not import $keyid into temporary gnupg.\n");
 692                         next;
 693                 };
 694
 695                 # prune it
 696                 ##########
 697                 $gpg = GnuPG::Interface->new();
 698                 $gpg->call( $CONFIG{'gpg-delsig'} );
 699                 $gpg->options->hash_init(
 700                         'homedir' => $tempdir,
 701                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 702                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 703                 $pid = $gpg->wrap_call(
 704                         commands     => [ '--edit' ],
 705                         command_args => [ $keyid ],
 706                         handles      => $handles );
 707
 708                 debug("Starting edit session");
 709                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 710
 711                 # delete other uids
 712                 ###################
 713                 my $number_of_subkeys = 0;
 714                 my $i = 1;
 715                 my $have_one = 0;
 716                 my $is_uat = 0;
 717                 my $delete_some = 0;
 718                 debug("Parsing stdout output.");
 719                 for my $line (split /\n/, $stdout) {
 720                         debug("Checking line $line");
 721                         my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
 722                         if ($type eq 'sub') {
 723                                 $number_of_subkeys++;
 724                         };
 725                         next unless ($type eq 'uid' || $type eq 'uat');
 726                         debug("line is interesting.");
 727                         if ($uid_number != $i) {
 728                                 debug("mark for deletion.");
 729                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 730                                 $delete_some = 1;
 731                         } else {
 732                                 debug("keep it.");
 733                                 $have_one = 1;
 734                                 $this_uid_text = ($type eq 'uid') ? $uidtext : 'attribute';
 735                                 $is_uat = $type eq 'uat';
 736                         };
 737                         $i++;
 738                 };
 739                 debug("Parsing stdout output done.");
 740                 if ($is_uat) {
 741                         notice("Can't handle attribute userid of key $keyid.");
 742                         next;
 743                 };
 744                 unless ($have_one) {
 745                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
 746                         info("key $keyid done.");
 747                         last;
 748                 };
 749                 if ($delete_some) {
 750                         debug("need to delete a few uids.");
 751                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 752                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 753                 };
 754
 755                 # delete subkeys
 756                 ################
 757                 if ($number_of_subkeys > 0) {
 758                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 759                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 760                         };
 761                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 762                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 763                 };
 764
 765                 # delete signatures
 766                 ###################
 767                 my $signed_by_me = 0;
 768                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 769                 ($stdout, $stderr, $status) =
 770                         readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 771
 772                 while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 773                         # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 774                         my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 775                         $stdout =~ s/\n/\\n/g;
 776                         notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
 777                         my $line = pop @sigline;
 778                         my $answer = "no";
 779                         if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 780                                 debug("[sigremoval] doing line $line.");
 781                                 my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
 782                                 if ($signer eq $longkeyid) {
 783                                         debug("[sigremoval] selfsig ($signer).");
 784                                         $answer = "no";
 785                                 } elsif (grep { $signer eq $_ } @{$CONFIG{'keyid'}}) {
 786                                         debug("[sigremoval] signed by us ($signer).");
 787                                         $answer = "no";
 788                                         $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 789                                 } else {
 790                                         debug("[sigremoval] not interested in that sig ($signer).");
 791                                         $answer = "yes";
 792                                 };
 793                         } else {
 794                                 debug("[sigremoval] no sig line here, only got: ".$stdout);
 795                         };
 796                         ($stdout, $stderr, $status) =
 797                                 readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 798                 };
 799                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
 800                 waitpid $pid, 0;
 801
 802                 my $asciikey = export_key($tempdir, $keyid);
 803                 if ($asciikey eq '') {
 804                         warn ("No data from gpg for export $keyid\n");
 805                         next;
 806                 };
 807
 808                 if ($signed_by_me) {
 809                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
 810                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0);
 811                                 next unless $write;
 812                         };
 813                         my $keydir = "$KEYSBASE/$DATE_STRING";
 814                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
 815
 816                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
 817                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile\n");
 818                         print KEY $asciikey;
 819                         close KEY;
 820
 821                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number };
 822
 823                         info("$longkeyid $uid_number $this_uid_text done.");
 824                 } else {
 825                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
 826                 };
 827         };
 828
 829         if (scalar @UIDS == 0) {
 830                 info("found no signed uids for $keyid");
 831         } else {
 832                 next if $opt{M}; # do not send mail
 833
 834                 my @attached;
 835                 for my $uid (@UIDS) {
 836                         trace("UID: $uid->{'text'}\n");
 837                         unless ($uid->{'text'} =~ /@/) {
 838                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
 839                                 push @attached, $uid if $attach;
 840                         };
 841                 };
 842
 843                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
 844                 for my $uid (@UIDS) {
 845                         if ($uid->{'text'} =~ /@/) {
 846                                 my $address = $uid->{'text'};
 847                                 $address =~ s/.*<(.*)>.*/$1/;
 848                                 if ($opt{m} or ask("Send mail to '$address' for $uid->{'text'}?", 1)) {
 849                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 850
 851                                         my $keydir = "$KEYSBASE/$DATE_STRING";
 852                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
 853                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile\n");
 854                                         print KEY $mail;
 855                                         close KEY;
 856                                 };
 857                         };
 858                 };
 859         };
 860
 861 };
 862
 863
 864
 865
 866 ###############################################################3
 867 #### old fork gpg --edit
 868 =cut
 869                 my ($stdin_read, $stdin_write);
 870                 my ($stdout_read, $stdout_write);
 871                 my ($stderr_read, $stderr_write);
 872                 my ($status_read, $status_write);
 873                 pipe $stdin_read, $stdin_write;
 874                 pipe $stdout_read, $stdout_write;
 875                 pipe $stderr_read, $stderr_write;
 876                 pipe $status_read, $status_write;
 877
 878                 $pid = fork();
 879                 unless ($pid) { # child
 880                         close $stdin_write;
 881                         close $stdout_read;
 882                         close $stderr_read;
 883                         close $status_read;
 884
 885                         my @call;
 886                         push @call, $CONFIG{'gpg-delsig'};
 887                         push @call, "--homedir=$tempdir";
 888                         push @call, '--with-colons';
 889                         push @call, '--fixed-list-mode';
 890                         push @call, '--command-fd=0';
 891                         push @call, "--status-fd=".fileno($status_write);
 892                         push @call, "--no-tty";
 893                         push @call, "--edit";
 894                         push @call, $keyid;
 895
 896                         close STDIN;
 897                         close STDOUT;
 898                         close STDERR;
 899                         open (STDIN, "<&".fileno($stdin_read)) or die ("Cannot reopen stdin: $!\n");
 900                         open (STDOUT, ">&".fileno($stdout_write)) or die ("Cannot reopen stdout: $!\n");
 901                         open (STDERR, ">&".fileno($stderr_write)) or die ("Cannot reopen stderr: $!\n");
 902
 903                         fcntl $status_write, F_SETFD, 0;
 904
 905                         exec (@call);
 906                         exit;
 907                 };
 908                 close $stdin_read;
 909                 close $stdout_write;
 910                 close $stderr_write;
 911                 close $status_write;
 912
 913                 $inputfd = $stdin_write;
 914                 $stdoutfd = $stdout_read;
 915                 $stderrfd = $stderr_read;
 916                 $statusfd = $status_read;
 917 =cut