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                             notice ("Imported unexpected key; got: $1$2$3$4. (This is normal for v3 keys.)\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|IMPORT_RES|IMPORTED) /) {
 791                 } else {
 792                         notice ("got unknown reply from gpg: $line");
 793                 }
 794         };
 795         if (scalar %local_keyids) {
 796                 notice ("Import failed for: ". (join ' ', keys %local_keyids).".");
 797                 exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
 798         }
 799 };
 800
 801 unless (@keyids_ok) {
 802         notice ("No keys to sign found");
 803         exit 0;
 804 }
 805
 806 ###########
 807 # sign keys
 808 ###########
 809 unless ($CONFIG{'no-sign'}) {
 810         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
 811         for my $keyid (@keyids_ok) {
 812                 my @command;
 813                 push @command, $CONFIG{'gpg-sign'};
 814                 push @command, '--local-user', $USER if (defined $USER);
 815                 push @command, "--homedir=$GNUPGHOME";
 816                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 817                 push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
 818                 push @command, '--edit', $keyid;
 819                 push @command, 'sign';
 820                 push @command, 'save';
 821                 print join(' ', @command),"\n";
 822                 system (@command);
 823         };
 824 };
 825
 826 ##################
 827 # export and prune
 828 ##################
 829 KEYS:
 830 for my $keyid (@keyids_ok) {
 831         # get key listing
 832         #################
 833         my $gpg = GnuPG::Interface->new();
 834         $gpg->call( $CONFIG{'gpg'} );
 835         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 836         $gpg->options->meta_interactive( 0 );
 837         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 838         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 839         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 840         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 841         waitpid $pid, 0;
 842         if ($stdout eq '') {
 843                 warn ("No data from gpg for list-key $keyid\n");
 844                 next;
 845         };
 846         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 847         if (scalar @publine == 0) {
 848                 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
 849                 next;
 850         };
 851         my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
 852         if (scalar @publine > 0) {
 853                 warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
 854                 next;
 855         };
 856         unless (defined $longkeyid) {
 857                 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
 858                 next;
 859         };
 860         unless (defined $flags) {
 861                 warn ("Didn't find flags in --list-key of key $keyid.\n");
 862                 next;
 863         };
 864         my $can_encrypt = $flags =~ /E/;
 865
 866         # export the key
 867         ################
 868         my $asciikey = export_key($GNUPGHOME, $keyid);
 869         if ($asciikey eq '') {
 870                 warn ("No data from gpg for export $keyid\n");
 871                 next;
 872         };
 873
 874         my @UIDS;
 875         my $uid_number = 0;
 876         while (1) {
 877                 my $this_uid_text = '';
 878                 $uid_number++;
 879                 debug("Doing key $keyid, uid $uid_number");
 880                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 881
 882                 # import into temporary gpghome
 883                 ###############################
 884                 my $result = import_key($tempdir, $asciikey);
 885                 unless ($result) {
 886                         warn ("Could not import $keyid into temporary gnupg.\n");
 887                         next;
 888                 };
 889
 890                 # prune it
 891                 ##########
 892                 $gpg = GnuPG::Interface->new();
 893                 $gpg->call( $CONFIG{'gpg-delsig'} );
 894                 $gpg->options->hash_init(
 895                         'homedir' => $tempdir,
 896                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 897                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 898                 $pid = $gpg->wrap_call(
 899                         commands     => [ '--edit' ],
 900                         command_args => [ $keyid ],
 901                         handles      => $handles );
 902
 903                 debug("Starting edit session");
 904                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 905
 906                 # delete other uids
 907                 ###################
 908                 my $number_of_subkeys = 0;
 909                 my $i = 1;
 910                 my $have_one = 0;
 911                 my $is_uat = 0;
 912                 my $delete_some = 0;
 913                 debug("Parsing stdout output.");
 914                 for my $line (split /\n/, $stdout) {
 915                         debug("Checking line $line");
 916                         my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
 917                         if ($type eq 'sub') {
 918                                 $number_of_subkeys++;
 919                         };
 920                         next unless ($type eq 'uid' || $type eq 'uat');
 921                         debug("line is interesting.");
 922                         if ($uid_number != $i) {
 923                                 debug("mark for deletion.");
 924                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 925                                 $delete_some++;
 926                         } else {
 927                                 debug("keep it.");
 928                                 $have_one = 1;
 929                                 $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
 930                                 $is_uat = $type eq 'uat';
 931                         };
 932                         $i++;
 933                 };
 934                 debug("Parsing stdout output done.");
 935                 unless ($have_one) {
 936                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
 937                         info("key $keyid done.");
 938                         last;
 939                 };
 940
 941                 my $prune_some_sigs_on_uid;
 942                 my $prune_all_sigs_on_uid;
 943                 if ($is_uat) {
 944                         debug("handling attribute userid of key $keyid.");
 945                         if ($uid_number == 1) {
 946                                 debug(" attribute userid is #1, unmarking #2 for deletion.");
 947                                 readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 948                                 $delete_some--;
 949                                 $prune_some_sigs_on_uid = 1;
 950                                 $prune_all_sigs_on_uid = 2;
 951                         } else {
 952                                 debug("attribute userid is not #1, unmarking #1 for deletion.");
 953                                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 954                                 $delete_some--;
 955                                 $prune_some_sigs_on_uid = 2;
 956                                 $prune_all_sigs_on_uid = 1;
 957                         };
 958                 } else {
 959                         $prune_some_sigs_on_uid = 1;
 960                 };
 961
 962                 if ($delete_some) {
 963                         debug("need to delete $delete_some uids.");
 964                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 965                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 966                 };
 967
 968                 # delete subkeys
 969                 ################
 970                 if ($number_of_subkeys > 0) {
 971                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 972                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 973                         };
 974                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 975                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 976                 };
 977
 978                 # delete signatures
 979                 ###################
 980                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
 981                 my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
 982                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
 983                 if (defined $prune_all_sigs_on_uid) {
 984                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
 985                         delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
 986                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
 987                 };
 988
 989
 990                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
 991                 waitpid $pid, 0;
 992
 993                 my $asciikey = export_key($tempdir, $keyid);
 994                 if ($asciikey eq '') {
 995                         warn ("No data from gpg for export $keyid\n");
 996                         next;
 997                 };
 998
 999                 if ($signed_by_me) {
1000                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
1001                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0, $params->{export}, $params->{'no-export'});
1002                                 next unless $write;
1003                         };
1004                         my $keydir = "$KEYSBASE/$DATE_STRING";
1005                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
1006
1007                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
1008                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
1009                         print KEY $asciikey;
1010                         close KEY;
1011
1012                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };
1013
1014                         info("$longkeyid $uid_number $this_uid_text done.");
1015                 } else {
1016                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
1017                 };
1018         };
1019
1020         if (scalar @UIDS == 0) {
1021                 info("found no signed uids for $keyid");
1022         } else {
1023                 next if $CONFIG{'no-mail'}; # do not send mail
1024
1025                 my @attached;
1026                 for my $uid (@UIDS) {
1027                         trace("UID: $uid->{'text'}\n");
1028                         if ($uid->{'is_uat'}) {
1029                                 my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
1030                                 push @attached, $uid if $attach;
1031                         } elsif ($uid->{'text'} !~ /@/) {
1032                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
1033                                 push @attached, $uid if $attach;
1034                         };
1035                 };
1036
1037                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
1038                 for my $uid (@UIDS) {
1039                         if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1040                                 my $address = $uid->{'text'};
1041                                 $address =~ s/.*<(.*)>.*/$1/;
1042                                 if (ask("Send mail to '$address' for $uid->{'text'}?", 1, $CONFIG{'mail'})) {
1043                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
1044
1045                                         my $keydir = "$KEYSBASE/$DATE_STRING";
1046                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
1047                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
1048                                         print KEY $mail;
1049                                         close KEY;
1050                                 };
1051                         };
1052                 };
1053         };
1054
1055 };