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