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