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-f0-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.
 289 If you have multiple user ids, I sent the signature for each user id
 290 separately to that user id's associated email address. You can import
 291 the signatures by running each through `gpg --import`.
 292
 293 If you want this new signature to be available to others, please upload
 294 it yourself. With GnuPG this can be done using
 295         gpg --keyserver subkeys.pgp.net --send-key {$key}
 296
 297 If you have any questions, don't hesitate to ask.
 298
 299 Regards,
 300 {$owner}
 301 EOM
 302 };
 303
 304 sub notice($) {
 305         my ($line) = @_;
 306         print "[NOTICE] $line\n";
 307 };
 308 sub info($) {
 309         my ($line) = @_;
 310         print "[INFO] $line\n";
 311 };
 312 sub debug($) {
 313         my ($line) = @_;
 314         #print "[DEBUG] $line\n";
 315 };
 316 sub trace($) {
 317         my ($line) = @_;
 318         #print "[trace] $line\n";
 319 };
 320 sub trace2($) {
 321         my ($line) = @_;
 322         #print "[trace2] $line\n";
 323 };
 324
 325 sub make_gpg_fds() {
 326         my %fds = (
 327                 stdin => IO::Handle->new(),
 328                 stdout => IO::Handle->new(),
 329                 stderr => IO::Handle->new(),
 330                 status => IO::Handle->new() );
 331         my $handles = GnuPG::Handles->new( %fds );
 332         return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
 333 };
 334
 335 sub readwrite_gpg($$$$$%) {
 336         my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd, %options) = @_;
 337
 338         trace("Entering readwrite_gpg.");
 339
 340         my ($first_line, undef) = split /\n/, $in;
 341         debug("readwrite_gpg sends ".(defined $first_line ? $first_line : "<nothing>"));
 342
 343         local $INPUT_RECORD_SEPARATOR = undef;
 344         my $sout = IO::Select->new();
 345         my $sin = IO::Select->new();
 346         my $offset = 0;
 347
 348         trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
 349
 350         $inputfd->blocking(0);
 351         $stdoutfd->blocking(0);
 352         $statusfd->blocking(0) if defined $statusfd;
 353         $stderrfd->blocking(0);
 354         $sout->add($stdoutfd);
 355         $sout->add($stderrfd);
 356         $sout->add($statusfd) if defined $statusfd;
 357         $sin->add($inputfd);
 358
 359         my ($stdout, $stderr, $status) = ("", "", "");
 360         my $exitwhenstatusmatches = $options{'exitwhenstatusmatches'};
 361         trace("doing stuff until we find $exitwhenstatusmatches") if defined $exitwhenstatusmatches;
 362
 363         my $readwrote_stuff_this_time = 0;
 364         my $do_not_wait_on_select = 0;
 365         my ($readyr, $readyw, $written);
 366         while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
 367                 if (defined $exitwhenstatusmatches) {
 368                         if ($status =~ /$exitwhenstatusmatches/m) {
 369                                 trace("readwrite_gpg found match on $exitwhenstatusmatches");
 370                                 if ($readwrote_stuff_this_time) {
 371                                         trace("read/write some more\n");
 372                                         $do_not_wait_on_select = 1;
 373                                 } else {
 374                                         trace("that's it in our while loop.\n");
 375                                         last;
 376                                 }
 377                         };
 378                 };
 379
 380                 $readwrote_stuff_this_time = 0;
 381                 trace("select waiting for ".($sout->count())." fds.");
 382                 ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, $do_not_wait_on_select ? 0 : 1);
 383                 trace("ready: write: ".(defined $readyw ? scalar @$readyw : 0 )."; read: ".(defined $readyr ? scalar @$readyr : 0));
 384                 for my $wfd (@$readyw) {
 385                         $readwrote_stuff_this_time = 1;
 386                         if (length($in) != $offset) {
 387                                 trace("writing to $wfd.");
 388                                 $written = $wfd->syswrite($in, length($in) - $offset, $offset);
 389                                 $offset += $written;
 390                         };
 391                         if ($offset == length($in)) {
 392                                 trace("writing to $wfd done.");
 393                                 unless ($options{'nocloseinput'}) {
 394                                         close $wfd;
 395                                         trace("$wfd closed.");
 396                                 };
 397                                 $sin->remove($wfd);
 398                                 $sin = undef;
 399                         }
 400                 }
 401
 402                 next unless (defined(@$readyr)); # Wait some more.
 403
 404                 for my $rfd (@$readyr) {
 405                         $readwrote_stuff_this_time = 1;
 406                         if ($rfd->eof) {
 407                                 trace("reading from $rfd done.");
 408                                 $sout->remove($rfd);
 409                                 close($rfd);
 410                                 next;
 411                         }
 412                         trace("reading from $rfd.");
 413                         if ($rfd == $stdoutfd) {
 414                                 $stdout .= <$rfd>;
 415                                 trace2("stdout is now $stdout\n================");
 416                                 next;
 417                         }
 418                         if (defined $statusfd && $rfd == $statusfd) {
 419                                 $status .= <$rfd>;
 420                                 trace2("status is now $status\n================");
 421                                 next;
 422                         }
 423                         if ($rfd == $stderrfd) {
 424                                 $stderr .= <$rfd>;
 425                                 trace2("stderr is now $stderr\n================");
 426                                 next;
 427                         }
 428                 }
 429         }
 430         trace("readwrite_gpg done.");
 431         return ($stdout, $stderr, $status);
 432 };
 433
 434 sub ask($$;$$) {
 435         my ($question, $default, $forceyes, $forceno) = @_;
 436         return $default if $forceyes and $forceno;
 437         return 1 if $forceyes;
 438         return 0 if $forceno;
 439         my $answer;
 440         while (1) {
 441                 print $question,' ',($default ? '[Y/n]' : '[y/N]'), ' ';
 442                 $answer = <STDIN>;
 443                 chomp $answer;
 444                 last if ((defined $answer) && (length $answer <= 1));
 445                 print "grrrrrr.\n";
 446                 sleep 1;
 447         };
 448         my $result = $default;
 449         $result = 1 if $answer =~ /y/i;
 450         $result = 0 if $answer =~ /n/i;
 451         return $result;
 452 };
 453
 454
 455
 456
 457
 458 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt';
 459 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay';
 460 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig';
 461 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)';
 462 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey';
 463
 464 load_config;
 465 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.";
 466
 467 my $KEYSBASE =  $CONFIG{'caffhome'}.'/keys';
 468 my $GNUPGHOME = $CONFIG{'caffhome'}.'/gnupghome';
 469
 470 -d $KEYSBASE  || mkpath($KEYSBASE , 0, 0700) or die ("Cannot create $KEYSBASE: $!\n");
 471 -d $GNUPGHOME || mkpath($GNUPGHOME, 0, 0700) or die ("Cannot create $GNUPGHOME: $!\n");
 472
 473 my $NOW = time;
 474 my  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($NOW);
 475 my $DATE_STRING = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
 476
 477
 478 sub version($) {
 479         my ($fd) = @_;
 480         print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al.\n";
 481 };
 482
 483 sub usage($$) {
 484         my ($fd, $exitcode) = @_;
 485         version($fd);
 486         print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...]\n";
 487         print $fd "Consult the manual page for more information.\n";
 488         exit $exitcode;
 489 };
 490
 491 ######
 492 # export key $keyid from $gnupghome
 493 ######
 494 sub export_key($$) {
 495         my ($gnupghome, $keyid) = @_;
 496
 497         my $gpg = GnuPG::Interface->new();
 498         $gpg->call( $CONFIG{'gpg'} );
 499         $gpg->options->hash_init(
 500                 'homedir' => $gnupghome,
 501                 'armor' => 1 );
 502         $gpg->options->meta_interactive( 0 );
 503         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 504         my $pid = $gpg->export_keys(handles => $handles, command_args => [ $keyid ]);
 505         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 506         waitpid $pid, 0;
 507
 508         return $stdout;
 509 };
 510
 511 ######
 512 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
 513 ######
 514 sub import_key($$) {
 515         my ($gnupghome, $asciikey) = @_;
 516
 517         my $gpg = GnuPG::Interface->new();
 518         $gpg->call( $CONFIG{'gpg'} );
 519         $gpg->options->hash_init( 'homedir' => $gnupghome );
 520         $gpg->options->meta_interactive( 0 );
 521         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 522         my $pid = $gpg->import_keys(handles => $handles);
 523         my ($stdout, $stderr, $status) = readwrite_gpg($asciikey, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 524         waitpid $pid, 0;
 525
 526         if ($status !~ /^\[GNUPG:\] IMPORT_OK/m) {
 527                 return undef;
 528         };
 529         return 1;
 530 };
 531
 532
 533 ######
 534 # Send an email to $address.  If $can_encrypt is true then the mail
 535 # will be PGP/MIME encrypted to $longkeyid.
 536 #
 537 # $longkeyid, $uid, and @attached will be used in the email and the template.
 538 ######
 539 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
 540 sub send_mail($$$@) {
 541         my ($address, $can_encrypt, $key_id, @keys) = @_;
 542
 543         my $template = Text::Template->new(TYPE => 'STRING', SOURCE => $CONFIG{'mail-template'})
 544             or die "Error creating template: $Text::Template::ERROR";
 545
 546         my @uids;
 547         for my $key (@keys) {
 548             push @uids, $key->{'text'};
 549         };
 550         my $message = $template->fill_in(HASH => { key => $key_id,
 551                                                    uids => \@uids,
 552                                                    owner => $CONFIG{'owner'}})
 553             or die "Error filling template in: $Text::Template::ERROR";
 554
 555         my $message_entity = MIME::Entity->build(
 556                 Type        => "text/plain",
 557                 Charset     => "utf-8",
 558                 Disposition => 'inline',
 559                 Data        => $message);
 560
 561         my @key_entities;
 562         for my $key (@keys) {
 563                 $message_entity->attach(
 564                         Type        => "application/pgp-keys",
 565                         Disposition => 'attachment',
 566                         Encoding    => "7bit",
 567                         Description => "PGP Key 0x$key_id, uid ".($key->{'text'}).' ('.($key->{'serial'}).')',
 568                         Data        => $key->{'key'},
 569                         Filename    => "0x$key_id.".$key->{'serial'}.".asc");
 570         };
 571
 572         if ($can_encrypt) {
 573                 my $message = $message_entity->stringify();
 574
 575                 my $gpg = GnuPG::Interface->new();
 576                 $gpg->call( $CONFIG{'gpg'} );
 577                 $gpg->options->hash_init( 'homedir' => $GNUPGHOME,
 578                         'extra_args' => '--always-trust',
 579                         'armor' => 1 );
 580                 $gpg->options->meta_interactive( 0 );
 581                 my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 582                 $gpg->options->push_recipients( $key_id );
 583                 $gpg->options->push_recipients( $CONFIG{'also-encrypt-to'} ) if defined $CONFIG{'also-encrypt-to'};
 584                 my $pid = $gpg->encrypt(handles => $handles);
 585                 my ($stdout, $stderr, $status) = readwrite_gpg($message, $inputfd, $stdoutfd, $stderrfd, $statusfd);
 586                 waitpid $pid, 0;
 587                 if ($stdout eq '') {
 588                         warn ("No data from gpg for list-key $key_id\n");
 589                         next;
 590                 };
 591                 $message = $stdout;
 592
 593                 $message_entity = MIME::Entity->build(
 594                         Type        => 'multipart/encrypted; protocol="application/pgp-encrypted"');
 595
 596                 $message_entity->attach(
 597                         Type        => "application/pgp-encrypted",
 598                         Disposition => 'attachment',
 599                         Encoding    => "7bit",
 600                         Data        => "Version: 1\n");
 601
 602                 $message_entity->attach(
 603                         Type        => "application/octet-stream",
 604                         Filename    => 'msg.asc',
 605                         Disposition => 'inline',
 606                         Encoding    => "7bit",
 607                         Data        => $message);
 608         };
 609
 610         $message_entity->head->add("Subject", "Your signed PGP key 0x$key_id");
 611         $message_entity->head->add("To", $address);
 612         $message_entity->head->add("From", '"'.$CONFIG{'owner'}.'" <'.$CONFIG{'email'}.'>');
 613         $message_entity->head->add("Bcc", $CONFIG{'bcc'}) if defined $CONFIG{'bcc'};
 614         $message_entity->head->add("User-Agent", $USER_AGENT);
 615         $message_entity->send();
 616         $message_entity->stringify();
 617 };
 618
 619 ######
 620 # clean up a UID so that it can be used on the FS.
 621 ######
 622 sub sanitize_uid($) {
 623         my ($uid) = @_;
 624
 625         my $good_uid = $uid;
 626         $good_uid =~ tr#/:\\#_#;
 627         trace2("[sanitize_uid] changed UID from $uid to $good_uid.\n") if $good_uid ne $uid;
 628         return $good_uid;
 629 };
 630
 631 sub delete_signatures($$$$$$) {
 632         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $keyids) =@_;
 633
 634         my $signed_by_me = 0;
 635
 636         my ($stdout, $stderr, $status) =
 637                 readwrite_gpg("delsig\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSIG_PROMPT, nocloseinput => 1);
 638
 639         while($status =~ /$KEYEDIT_DELSIG_PROMPT/m) {
 640                 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
 641                 my @sigline = grep { /^sig/ } (split /\n/, $stdout);
 642                 $stdout =~ s/\n/\\n/g;
 643                 notice("[sigremoval] why are there ".(scalar @sigline)." siglines in that part of the dialog!? got: $stdout") if scalar @sigline >= 2; # XXX
 644                 my $line = pop @sigline;
 645                 my $answer = "no";
 646                 if (defined $line) { # only if we found a sig here - we never remove revocation packets for instance
 647                         debug("[sigremoval] doing line $line.");
 648                         my (undef, undef, undef, undef, $signer, $created, undef, undef, undef) = split /:/, $line;
 649                         if ($signer eq $longkeyid) {
 650                                 debug("[sigremoval] selfsig ($signer).");
 651                                 $answer = "no";
 652                         } elsif (grep { $signer eq $_ } @{$keyids}) {
 653                                 debug("[sigremoval] signed by us ($signer).");
 654                                 $answer = "no";
 655                                 $signed_by_me = $signed_by_me > $created ? $signed_by_me : $created;
 656                         } else {
 657                                 debug("[sigremoval] not interested in that sig ($signer).");
 658                                 $answer = "yes";
 659                         };
 660                 } else {
 661                         debug("[sigremoval] no sig line here, only got: ".$stdout);
 662                 };
 663                 ($stdout, $stderr, $status) =
 664                         readwrite_gpg($answer."\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT, nocloseinput => 1);
 665         };
 666
 667         return $signed_by_me;
 668 };
 669
 670
 671
 672 my $USER;
 673 my @KEYIDS;
 674 my $params;
 675
 676 Getopt::Long::config('bundling');
 677 if (!GetOptions (
 678         '-h'              =>  \$params->{'help'},
 679         '--help'          =>  \$params->{'help'},
 680         '--version'       =>  \$params->{'version'},
 681         '-V'              =>  \$params->{'version'},
 682         '-u=s'            =>  \$params->{'local-user'},
 683         '--local-user=s'  =>  \$params->{'local-user'},
 684         '-e'              =>  \$params->{'export-old'},
 685         '--export-old'    =>  \$params->{'export-old'},
 686         '-E'              =>  \$params->{'no-export-old'},
 687         '--no-export-old' =>  \$params->{'no-export-old'},
 688         '-m'              =>  \$params->{'mail'},
 689         '--mail'          =>  \$params->{'mail'},
 690         '-M'              =>  \$params->{'no-mail'},
 691         '--no-mail'       =>  \$params->{'no-mail'},
 692         '-R'              =>  \$params->{'no-download'},
 693         '--no-download'   =>  \$params->{'no-download'},
 694         '-S'              =>  \$params->{'no-sign'},
 695         '--no-sign'       =>  \$params->{'no-sign'},
 696         )) {
 697         usage(\*STDERR, 1);
 698 };
 699 if ($params->{'help'}) {
 700         usage(\*STDOUT, 0);
 701 };
 702 if ($params->{'version'}) {
 703         version(\*STDOUT);
 704         exit(0);
 705 };
 706 usage(\*STDERR, 1) unless scalar @ARGV >= 1;
 707
 708
 709
 710 if ($params->{'local-user'}) {
 711         $USER = $params->{'local-user'};
 712         $USER =~ s/^0x//i;
 713         unless ($USER =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}|[A-Z0-9]{40})$/i) {
 714                 print STDERR "-u $USER is not a keyid.\n";
 715                 usage(\*STDERR, 1);
 716         };
 717         $USER = uc($USER);
 718 };
 719
 720 for my $keyid (@ARGV) {
 721         $keyid =~ s/^0x//i;
 722         unless ($keyid =~ /^([A-Z0-9]{8}|[A-Z0-9]{16}||[A-Z0-9]{40})$/i) {
 723                 print STDERR "$keyid is not a keyid.\n";
 724                 usage(\*STDERR, 1);
 725         };
 726         push @KEYIDS, uc($keyid);
 727 };
 728
 729 $CONFIG{'no-download'} = $params->{'no-download'} if defined $params->{'no-download'};
 730 $CONFIG{'no-mail'}     = $params->{'no-mail'}     if defined $params->{'no-mail'};
 731 $CONFIG{'mail'}        = $params->{'mail'}        if defined $params->{'mail'};
 732 $CONFIG{'no-sign'}     = $params->{'no-sign'}     if defined $params->{'no-sign'};
 733
 734
 735 #################
 736 # import own keys
 737 #################
 738         my $gpg = GnuPG::Interface->new();
 739         $gpg->call( $CONFIG{'gpg'} );
 740         $gpg->options->hash_init(
 741                 'homedir' => $GNUPGHOME,
 742                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 743         $gpg->options->meta_interactive( 0 );
 744         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 745         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 746         my $pid = $gpg->list_public_keys(handles => $handles, command_args => $CONFIG{'keyid'});
 747         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 748         waitpid $pid, 0;
 749         if ($stdout eq '') {
 750                 warn ("No data from gpg for list-key\n");
 751                 next;
 752         };
 753         foreach my $keyid (@{$CONFIG{'keyid'}}) {
 754                 unless ($stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m) {
 755                         info("Importing $keyid");
 756                         system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME";
 757                 }
 758         }
 759
 760 #############################
 761 # receive keys from keyserver
 762 #############################
 763 my @keyids_ok;
 764 if ($CONFIG{'no-download'}) {
 765         @keyids_ok = @KEYIDS;
 766 } else {
 767         info ("fetching keys, this will take a while...");
 768
 769         my $gpg = GnuPG::Interface->new();
 770         $gpg->call( $CONFIG{'gpg'} );
 771         $gpg->options->hash_init(
 772                 'homedir' => $GNUPGHOME,
 773                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 774         $gpg->options->meta_interactive( 0 );
 775         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 776         my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
 777         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 778         waitpid $pid, 0;
 779
 780 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 781 # [GNUPG:] NODATA 1
 782 # [GNUPG:] NODATA 1
 783 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 784         my %local_keyids = map { $_ => 1 } @KEYIDS;
 785         for my $line (split /\n/, $status) {
 786                 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
 787                         my $imported_key = $1;
 788                         my $whole_fpr = $imported_key;
 789                         my $long_keyid = substr($imported_key, -16);
 790                         my $short_keyid = substr($imported_key, -8);
 791                         my $speced_key;
 792                         for my $spec (($whole_fpr, $long_keyid, $short_keyid)) {
 793                                 $speced_key = $spec if $local_keyids{$spec};
 794                         };
 795                         unless ($speced_key) {
 796                             notice ("Imported unexpected key; got: $imported_key\n");
 797                             next;
 798                         };
 799                         debug ("Imported $imported_key for $speced_key");
 800                         delete $local_keyids{$speced_key};
 801                         unshift @keyids_ok, $imported_key;
 802                 } elsif ($line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) /) {
 803                 } else {
 804                         notice ("got unknown reply from gpg: $line");
 805                 }
 806         };
 807         if (scalar %local_keyids) {
 808                 notice ("Import failed for: ". (join ' ', keys %local_keyids).".");
 809                 exit 1 unless ask ("Some keys could not be imported - continue anyway?", 0);
 810         }
 811 };
 812
 813 unless (@keyids_ok) {
 814         notice ("No keys to sign found");
 815         exit 0;
 816 }
 817
 818 ###########
 819 # sign keys
 820 ###########
 821 unless ($CONFIG{'no-sign'}) {
 822         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
 823         for my $keyid (@keyids_ok) {
 824                 my @command;
 825                 push @command, $CONFIG{'gpg-sign'};
 826                 push @command, '--local-user', $USER if (defined $USER);
 827                 push @command, "--homedir=$GNUPGHOME";
 828                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 829                 push @command, '--edit', $keyid;
 830                 push @command, 'sign';
 831                 push @command, split ' ', $CONFIG{'gpg-sign-args'} || "";
 832                 print join(' ', @command),"\n";
 833                 system (@command);
 834         };
 835 };
 836
 837 ##################
 838 # export and prune
 839 ##################
 840 KEYS:
 841 for my $keyid (@keyids_ok) {
 842         # get key listing
 843         #################
 844         my $gpg = GnuPG::Interface->new();
 845         $gpg->call( $CONFIG{'gpg'} );
 846         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 847         $gpg->options->meta_interactive( 0 );
 848         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 849         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 850         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 851         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 852         waitpid $pid, 0;
 853         if ($stdout eq '') {
 854                 warn ("No data from gpg for list-key $keyid\n");
 855                 next;
 856         };
 857         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 858         if (scalar @publine == 0) {
 859                 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
 860                 next;
 861         };
 862         my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
 863         if (scalar @publine > 0) {
 864                 warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
 865                 next;
 866         };
 867         unless (defined $longkeyid) {
 868                 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
 869                 next;
 870         };
 871         unless (defined $flags) {
 872                 warn ("Didn't find flags in --list-key of key $keyid.\n");
 873                 next;
 874         };
 875         my $can_encrypt = $flags =~ /E/;
 876
 877         # export the key
 878         ################
 879         my $asciikey = export_key($GNUPGHOME, $keyid);
 880         if ($asciikey eq '') {
 881                 warn ("No data from gpg for export $keyid\n");
 882                 next;
 883         };
 884
 885         my @UIDS;
 886         my $uid_number = 0;
 887         while (1) {
 888                 my $this_uid_text = '';
 889                 $uid_number++;
 890                 debug("Doing key $keyid, uid $uid_number");
 891                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 892
 893                 # import into temporary gpghome
 894                 ###############################
 895                 my $result = import_key($tempdir, $asciikey);
 896                 unless ($result) {
 897                         warn ("Could not import $keyid into temporary gnupg.\n");
 898                         next;
 899                 };
 900
 901                 # prune it
 902                 ##########
 903                 $gpg = GnuPG::Interface->new();
 904                 $gpg->call( $CONFIG{'gpg-delsig'} );
 905                 $gpg->options->hash_init(
 906                         'homedir' => $tempdir,
 907                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 908                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 909                 $pid = $gpg->wrap_call(
 910                         commands     => [ '--edit' ],
 911                         command_args => [ $keyid ],
 912                         handles      => $handles );
 913
 914                 debug("Starting edit session");
 915                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 916
 917                 # delete other uids
 918                 ###################
 919                 my $number_of_subkeys = 0;
 920                 my $i = 1;
 921                 my $have_one = 0;
 922                 my $is_uat = 0;
 923                 my $delete_some = 0;
 924                 debug("Parsing stdout output.");
 925                 for my $line (split /\n/, $stdout) {
 926                         debug("Checking line $line");
 927                         my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
 928                         if ($type eq 'sub') {
 929                                 $number_of_subkeys++;
 930                         };
 931                         next unless ($type eq 'uid' || $type eq 'uat');
 932                         debug("line is interesting.");
 933                         if ($uid_number != $i) {
 934                                 debug("mark for deletion.");
 935                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 936                                 $delete_some++;
 937                         } else {
 938                                 debug("keep it.");
 939                                 $have_one = 1;
 940                                 $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
 941                                 $is_uat = $type eq 'uat';
 942                         };
 943                         $i++;
 944                 };
 945                 debug("Parsing stdout output done.");
 946                 unless ($have_one) {
 947                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
 948                         info("key $keyid done.");
 949                         last;
 950                 };
 951
 952                 my $prune_some_sigs_on_uid;
 953                 my $prune_all_sigs_on_uid;
 954                 if ($is_uat) {
 955                         debug("handling attribute userid of key $keyid.");
 956                         if ($uid_number == 1) {
 957                                 debug(" attribute userid is #1, unmarking #2 for deletion.");
 958                                 readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 959                                 $delete_some--;
 960                                 $prune_some_sigs_on_uid = 1;
 961                                 $prune_all_sigs_on_uid = 2;
 962                         } else {
 963                                 debug("attribute userid is not #1, unmarking #1 for deletion.");
 964                                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 965                                 $delete_some--;
 966                                 $prune_some_sigs_on_uid = 2;
 967                                 $prune_all_sigs_on_uid = 1;
 968                         };
 969                 } else {
 970                         $prune_some_sigs_on_uid = 1;
 971                 };
 972
 973                 if ($delete_some) {
 974                         debug("need to delete $delete_some uids.");
 975                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 976                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 977                 };
 978
 979                 # delete subkeys
 980                 ################
 981                 if ($number_of_subkeys > 0) {
 982                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 983                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 984                         };
 985                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 986                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 987                 };
 988
 989                 # delete signatures
 990                 ###################
 991                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
 992                 my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
 993                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
 994                 if (defined $prune_all_sigs_on_uid) {
 995                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
 996                         delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
 997                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
 998                 };
 999
1000
1001                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
1002                 waitpid $pid, 0;
1003
1004                 my $asciikey = export_key($tempdir, $keyid);
1005                 if ($asciikey eq '') {
1006                         warn ("No data from gpg for export $keyid\n");
1007                         next;
1008                 };
1009
1010                 if ($signed_by_me) {
1011                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
1012                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0, $params->{'export-old'}, $params->{'no-export-old'});
1013                                 next unless $write;
1014                         };
1015                         my $keydir = "$KEYSBASE/$DATE_STRING";
1016                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
1017
1018                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
1019                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
1020                         print KEY $asciikey;
1021                         close KEY;
1022
1023                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };
1024
1025                         info("$longkeyid $uid_number $this_uid_text done.");
1026                 } else {
1027                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
1028                 };
1029         };
1030
1031         if (scalar @UIDS == 0) {
1032                 info("found no signed uids for $keyid");
1033         } else {
1034                 next if $CONFIG{'no-mail'}; # do not send mail
1035
1036                 my @attached;
1037                 for my $uid (@UIDS) {
1038                         trace("UID: $uid->{'text'}\n");
1039                         if ($uid->{'is_uat'}) {
1040                                 my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
1041                                 push @attached, $uid if $attach;
1042                         } elsif ($uid->{'text'} !~ /@/) {
1043                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
1044                                 push @attached, $uid if $attach;
1045                         };
1046                 };
1047
1048                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
1049                 for my $uid (@UIDS) {
1050                         if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1051                                 my $address = $uid->{'text'};
1052                                 $address =~ s/.*<(.*)>.*/$1/;
1053                                 if (ask("Send mail to '$address' for $uid->{'text'}?", 1, $CONFIG{'mail'})) {
1054                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
1055
1056                                         my $keydir = "$KEYSBASE/$DATE_STRING";
1057                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
1058                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
1059                                         print KEY $mail;
1060                                         close KEY;
1061                                 };
1062                         };
1063                 };
1064         };
1065
1066 };