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