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