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