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-Z0-9]{8}|[A-Z0-9]{16}|[A-Z0-9]{32}|[A-Z0-9]{40})$/i) {
 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-Z0-9]{8}|[A-Z0-9]{16}|[A-Z0-9]{32}|[A-Z0-9]{40})$/i) {
 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 if ($CONFIG{'no-download'}) {
 734         @keyids_ok = @KEYIDS;
 735 } else {
 736         my $gpg = GnuPG::Interface->new();
 737         $gpg->call( $CONFIG{'gpg'} );
 738         $gpg->options->hash_init(
 739                 'homedir' => $GNUPGHOME,
 740                 'extra_args' => '--keyserver='.$CONFIG{'keyserver'} );
 741         $gpg->options->meta_interactive( 0 );
 742         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 743
 744         my %local_keyids = map { $_ => 1 } @KEYIDS;
 745         info ("fetching keys, this will take a while...");
 746         my $pid = $gpg->recv_keys(handles => $handles, command_args => [ @KEYIDS ]);
 747         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 748         waitpid $pid, 0;
 749
 750 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
 751 # [GNUPG:] NODATA 1
 752 # [GNUPG:] NODATA 1
 753 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
 754         for my $line (split /\n/, $status) {
 755                 if ($line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/) {
 756                         my $imported_key = $1;
 757                         if (not exists $local_keyids{$imported_key}) {
 758                             warn("Imported unexpected key; got: $imported_key.\n");
 759                             next;
 760                         };
 761                         info ("Imported $imported_key");
 762                         delete $local_keyids{$imported_key};
 763                         unshift @keyids_ok, $imported_key;
 764                 }
 765         };
 766         notice ("Import failed for: ". (join ' ', keys %local_keyids).".") if scalar %local_keyids;
 767 };
 768
 769 ###########
 770 # sign keys
 771 ###########
 772 unless ($CONFIG{'no-sign'}) {
 773         info("Sign the following keys according to your policy, then exit gpg with 'save' after signing each key");
 774         for my $keyid (@keyids_ok) {
 775                 my @command;
 776                 push @command, $CONFIG{'gpg-sign'};
 777                 push @command, '--local-user', $USER if (defined $USER);
 778                 push @command, "--homedir=$GNUPGHOME";
 779                 push @command, '--secret-keyring', $CONFIG{'secret-keyring'};
 780                 push @command, '--edit', $keyid;
 781                 push @command, 'sign';
 782                 print join(' ', @command),"\n";
 783                 system (@command);
 784         };
 785 };
 786
 787 ##################
 788 # export and prune
 789 ##################
 790 KEYS:
 791 for my $keyid (@keyids_ok) {
 792         # get key listing
 793         #################
 794         my $gpg = GnuPG::Interface->new();
 795         $gpg->call( $CONFIG{'gpg'} );
 796         $gpg->options->hash_init( 'homedir' => $GNUPGHOME );
 797         $gpg->options->meta_interactive( 0 );
 798         my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 799         $gpg->options->hash_init( 'extra_args' => [ '--with-colons', '--fixed-list-mode' ] );
 800         my $pid = $gpg->list_public_keys(handles => $handles, command_args => [ $keyid ]);
 801         my ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd);
 802         waitpid $pid, 0;
 803         if ($stdout eq '') {
 804                 warn ("No data from gpg for list-key $keyid\n");
 805                 next;
 806         };
 807         my @publine = grep { /^pub/ } (split /\n/, $stdout);
 808         if (scalar @publine == 0) {
 809                 warn ("No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME).\n");
 810                 next;
 811         };
 812         my (undef, undef, undef, undef, $longkeyid, undef, undef, undef, undef, undef, undef, $flags) = split /:/, pop @publine;
 813         if (scalar @publine > 0) {
 814                 warn ("More than one key matched $keyid.  Try to specify the long keyid or fingerprint\n");
 815                 next;
 816         };
 817         unless (defined $longkeyid) {
 818                 warn ("Didn't find public keyid in --list-key of key $keyid.\n");
 819                 next;
 820         };
 821         unless (defined $flags) {
 822                 warn ("Didn't find flags in --list-key of key $keyid.\n");
 823                 next;
 824         };
 825         my $can_encrypt = $flags =~ /E/;
 826
 827         # export the key
 828         ################
 829         my $asciikey = export_key($GNUPGHOME, $keyid);
 830         if ($asciikey eq '') {
 831                 warn ("No data from gpg for export $keyid\n");
 832                 next;
 833         };
 834
 835         my @UIDS;
 836         my $uid_number = 0;
 837         while (1) {
 838                 my $this_uid_text = '';
 839                 $uid_number++;
 840                 debug("Doing key $keyid, uid $uid_number");
 841                 my $tempdir = tempdir( "caff-$keyid-XXXXX", DIR => '/tmp/', CLEANUP => 1);
 842
 843                 # import into temporary gpghome
 844                 ###############################
 845                 my $result = import_key($tempdir, $asciikey);
 846                 unless ($result) {
 847                         warn ("Could not import $keyid into temporary gnupg.\n");
 848                         next;
 849                 };
 850
 851                 # prune it
 852                 ##########
 853                 $gpg = GnuPG::Interface->new();
 854                 $gpg->call( $CONFIG{'gpg-delsig'} );
 855                 $gpg->options->hash_init(
 856                         'homedir' => $tempdir,
 857                         'extra_args' => [ '--with-colons', '--fixed-list-mode', '--command-fd=0', '--no-tty' ] );
 858                 ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = make_gpg_fds();
 859                 $pid = $gpg->wrap_call(
 860                         commands     => [ '--edit' ],
 861                         command_args => [ $keyid ],
 862                         handles      => $handles );
 863
 864                 debug("Starting edit session");
 865                 ($stdout, $stderr, $status) = readwrite_gpg('', $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 866
 867                 # delete other uids
 868                 ###################
 869                 my $number_of_subkeys = 0;
 870                 my $i = 1;
 871                 my $have_one = 0;
 872                 my $is_uat = 0;
 873                 my $delete_some = 0;
 874                 debug("Parsing stdout output.");
 875                 for my $line (split /\n/, $stdout) {
 876                         debug("Checking line $line");
 877                         my ($type, undef, undef, undef, undef, undef, undef, undef, undef, $uidtext) = split /:/, $line;
 878                         if ($type eq 'sub') {
 879                                 $number_of_subkeys++;
 880                         };
 881                         next unless ($type eq 'uid' || $type eq 'uat');
 882                         debug("line is interesting.");
 883                         if ($uid_number != $i) {
 884                                 debug("mark for deletion.");
 885                                 readwrite_gpg("$i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 886                                 $delete_some++;
 887                         } else {
 888                                 debug("keep it.");
 889                                 $have_one = 1;
 890                                 $this_uid_text = ($type eq 'uid') ? $uidtext : '[attribute]';
 891                                 $is_uat = $type eq 'uat';
 892                         };
 893                         $i++;
 894                 };
 895                 debug("Parsing stdout output done.");
 896                 unless ($have_one) {
 897                         debug("Uid ".($uid_number-1)." was the last, there is no $uid_number.");
 898                         info("key $keyid done.");
 899                         last;
 900                 };
 901
 902                 my $prune_some_sigs_on_uid;
 903                 my $prune_all_sigs_on_uid;
 904                 if ($is_uat) {
 905                         debug("handling attribute userid of key $keyid.");
 906                         if ($uid_number == 1) {
 907                                 debug(" attribute userid is #1, unmarking #2 for deletion.");
 908                                 readwrite_gpg("2\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 909                                 $delete_some--;
 910                                 $prune_some_sigs_on_uid = 1;
 911                                 $prune_all_sigs_on_uid = 2;
 912                         } else {
 913                                 debug("attribute userid is not #1, unmarking #1 for deletion.");
 914                                 readwrite_gpg("1\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 915                                 $delete_some--;
 916                                 $prune_some_sigs_on_uid = 2;
 917                                 $prune_all_sigs_on_uid = 1;
 918                         };
 919                 } else {
 920                         $prune_some_sigs_on_uid = 1;
 921                 };
 922
 923                 if ($delete_some) {
 924                         debug("need to delete $delete_some uids.");
 925                         readwrite_gpg("deluid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELUID_PROMPT, nocloseinput => 1);
 926                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 927                 };
 928
 929                 # delete subkeys
 930                 ################
 931                 if ($number_of_subkeys > 0) {
 932                         for (my $i=1; $i<=$number_of_subkeys; $i++) {
 933                                 readwrite_gpg("key $i\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 934                         };
 935                         readwrite_gpg("delkey\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_DELSUBKEY_PROMPT, nocloseinput => 1);
 936                         readwrite_gpg("yes\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1);
 937                 };
 938
 939                 # delete signatures
 940                 ###################
 941                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
 942                 my $signed_by_me = delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, $CONFIG{'keyid'});
 943                 readwrite_gpg("$prune_some_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
 944                 if (defined $prune_all_sigs_on_uid) {
 945                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # mark uid for delsig
 946                         delete_signatures($inputfd, $stdoutfd, $stderrfd, $statusfd, $longkeyid, []);
 947                         readwrite_gpg("$prune_all_sigs_on_uid\n", $inputfd, $stdoutfd, $stderrfd, $statusfd, exitwhenstatusmatches => $KEYEDIT_PROMPT, nocloseinput => 1); # unmark uid from delsig
 948                 };
 949
 950
 951                 readwrite_gpg("save\n", $inputfd, $stdoutfd, $stderrfd, $statusfd);
 952                 waitpid $pid, 0;
 953
 954                 my $asciikey = export_key($tempdir, $keyid);
 955                 if ($asciikey eq '') {
 956                         warn ("No data from gpg for export $keyid\n");
 957                         next;
 958                 };
 959
 960                 if ($signed_by_me) {
 961                         if ($NOW - $signed_by_me > $CONFIG{'export-sig-age'} ) {
 962                                 my $write = ask("Signature on $this_uid_text is old.  Export?", 0);
 963                                 next unless $write;
 964                         };
 965                         my $keydir = "$KEYSBASE/$DATE_STRING";
 966                         -d $keydir  || mkpath($keydir , 0, 0700) or die ("Cannot create $keydir $!\n");
 967
 968                         my $keyfile = "$keydir/$longkeyid.key.$uid_number.".sanitize_uid($this_uid_text).".asc";
 969                         open (KEY, ">$keyfile") or die ("Cannot open $keyfile: $!\n");
 970                         print KEY $asciikey;
 971                         close KEY;
 972
 973                         push @UIDS, { text => $this_uid_text, key => $asciikey, serial => $uid_number, "is_uat" => $is_uat };
 974
 975                         info("$longkeyid $uid_number $this_uid_text done.");
 976                 } else {
 977                         info("$longkeyid $uid_number $this_uid_text is not signed by me, not writing.");
 978                 };
 979         };
 980
 981         if (scalar @UIDS == 0) {
 982                 info("found no signed uids for $keyid");
 983         } else {
 984                 next if $CONFIG{'no-mail'}; # do not send mail
 985
 986                 my @attached;
 987                 for my $uid (@UIDS) {
 988                         trace("UID: $uid->{'text'}\n");
 989                         if ($uid->{'is_uat'}) {
 990                                 my $attach = ask("UID $uid->{'text'} is an attribute UID, attach it to every email sent?", 1);
 991                                 push @attached, $uid if $attach;
 992                         } elsif ($uid->{'text'} !~ /@/) {
 993                                 my $attach = ask("UID $uid->{'text'} is no email address, attach it to every email sent?", 1);
 994                                 push @attached, $uid if $attach;
 995                         };
 996                 };
 997
 998                 notice("Key has no encryption capabilities, mail will be sent unencrypted") unless $can_encrypt;
 999                 for my $uid (@UIDS) {
1000                         if (!$uid->{'is_uat'} && ($uid->{'text'} =~ /@/)) {
1001                                 my $address = $uid->{'text'};
1002                                 $address =~ s/.*<(.*)>.*/$1/;
1003                                 if ($CONFIG{'mail'} or ask("Send mail to '$address' for $uid->{'text'}?", 1)) {
1004                                         my $mail = send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
1005
1006                                         my $keydir = "$KEYSBASE/$DATE_STRING";
1007                                         my $mailfile = "$keydir/$longkeyid.mail.".$uid->{'serial'}.".".sanitize_uid($uid->{'text'});
1008                                         open (KEY, ">$mailfile") or die ("Cannot open $mailfile: $!\n");
1009                                         print KEY $mail;
1010                                         close KEY;
1011                                 };
1012                         };
1013                 };
1014         };
1015
1016 };