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