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