]>
git.sthu.org Git - pgp-tools.git/blob - caff/caff
cd8a4ca4d189cf07e86533d18b21828beb895a62
3 # caff -- CA - Fire and Forget
6 # Copyright (c) 2004, 2005 Peter Palfrader <peter@palfrader.org>
7 # Copyright (c) 2005 Christoph Berg <cb@df7cb.de>
11 # Redistribution and use in source and binary forms, with or without
12 # modification, are permitted provided that the following conditions
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.
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.
37 caff -- CA - Fire and Forget
43 =item B<caff> [-mMR] [-u I<yourkeyid>] I<keyid> [I<keyid> ..]
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.
59 =item B<-m>, B<--mail>
61 Send mail after signing. Default is to ask the user for each uid.
63 =item B<-M>, B<--no-mail>
65 Do not send mail after signing. Default is to ask the user for each uid.
67 =item B<-R>, B<--no-download>
69 Do not retrieve the key to be signed from a keyserver.
71 =item B<-u> I<yourkeyid>, B<--local-user> I<yourkeyid>
73 Select the key that is used for signing, in case you have more than one key.
81 =item $HOME/.caffrc - configuration file
85 =head1 CONFIGURATION FILE OPTIONS
87 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
91 $CONFIG{owner} = q{Peter Palfrader};
92 $CONFIG{email} = q{peter@palfrader.org};
93 $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
95 =head2 Required basic settings
99 =item B<owner> [string]
101 Your name. B<REQUIRED>.
103 =item B<email> [string]
105 Your email address, used in From: lines. B<REQUIRED>.
107 =item B<keyid> [list of keyids]
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>.
113 =head2 General settings
115 =item B<caffhome> [string]
117 Base directory for the files caff stores. Default: B<$HOME/.caff/>.
119 =head2 GnuPG settings
121 =item B<gpg> [string]
123 Path to the GnuPG binary. Default: B<gpg>.
125 =item B<gpg-sign> [string]
127 Path to the GnuPG binary which is used to sign keys. Default: what
130 =item B<gpg-delsig> [string]
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>
136 =item B<secret-keyring> [string]
138 Path to your secret keyring. Default: B<$HOME/.gnupg/secring.gpg>.
140 =item B<also-encrypt-to> [keyid]
142 An additional keyid to encrypt messages to. Default: none.
144 =head2 Keyserver settings
146 =item B<keyserver> [string]
148 Keyserver to download keys from. Default: B<subkeys.pgp.net>.
150 =item B<no-download> [boolean]
152 If true, then skip the step of fetching keys from the keyserver.
155 =head2 Signing settings
157 =item B<no-sign> [boolean]
159 If true, then skip the signing step. Default: B<0>.
161 =item B<export-sig-age> [seconds]
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).
168 =item B<mail> [boolean]
170 Do not prompt for sending mail, just do it. Default: B<0>.
172 =item B<no-mail> [boolean]
174 Do not prompt for sending mail. The messages are still written to
175 $CONFIG{caffhome}/keys/. Default: B<0>.
177 =item B<mail-template> [string]
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:
185 =item B<{owner}> [string]
187 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
189 =item B<{key}> [string]
191 The keyid of the key you signed.
193 =item B<{@uids}> [array]
195 The UIDs for which signatures are included in the mail.
199 =item B<bcc> [string]
201 Address to send blind carbon copies to when sending mail.
210 =item Peter Palfrader <peter@palfrader.org>
212 =item Christoph Berg <cb@df7cb.de>
218 http://pgp-tools.alioth.debian.org/
226 use File
:: Temp
qw{ tempdir
};
232 use GnuPG
:: Interface
;
235 my $REVISION = ' $Rev $' ;
236 my ( $REVISION_NUMER ) = $REVISION =~ /(\d+)/ ;
237 my $VERSION = "0.0.0. $REVISION_NUMER " ;
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 ;
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 " );
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'};
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.
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 }
276 If you have any questions, don't hesitate to ask.
285 print "[NOTICE] $line \n " ;
289 print "[INFO] $line \n " ;
293 #print "[DEBUG] $line\n";
297 #print "[trace] $line\n";
301 #print "[trace2] $line\n";
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 );
314 sub readwrite_gpg
($$$$$%) {
315 my ( $in , $inputfd , $stdoutfd , $stderrfd , $statusfd , %options ) = @_ ;
317 trace
( "Entering readwrite_gpg." );
319 my ( $first_line , undef ) = split /\n/ , $in ;
320 debug
( "readwrite_gpg sends " .( defined $first_line ?
$first_line : "<nothing>" ));
322 local $INPUT_RECORD_SEPARATOR = undef ;
323 my $sout = IO
:: Select
-> new ();
324 my $sin = IO
:: Select
-> new ();
327 trace
( "input is $inputfd ; output is $stdoutfd ; err is $stderrfd ; status is " .( defined $statusfd ?
$statusfd : 'undef' ). "." );
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 ;
338 my ( $stdout , $stderr , $status ) = ( "" , "" , "" );
339 my $exitwhenstatusmatches = $options { 'exitwhenstatusmatches' };
340 trace
( "doing stuff until we find $exitwhenstatusmatches " ) if defined $exitwhenstatusmatches ;
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 ;
353 trace
( "that's it in our while loop. \n " );
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 );
370 if ( $offset == length ( $in )) {
371 trace
( "writing to $wfd done." );
372 unless ( $options { 'nocloseinput' }) {
374 trace
( " $wfd closed." );
381 next unless ( defined ( @
$readyr )); # Wait some more.
383 for my $rfd ( @
$readyr ) {
384 $readwrote_stuff_this_time = 1 ;
386 trace
( "reading from $rfd done." );
391 trace
( "reading from $rfd ." );
392 if ( $rfd == $stdoutfd ) {
394 trace2
( "stdout is now $stdout \n ================" );
397 if ( defined $statusfd && $rfd == $statusfd ) {
399 trace2
( "status is now $status \n ================" );
402 if ( $rfd == $stderrfd ) {
404 trace2
( "stderr is now $stderr \n ================" );
409 trace
( "readwrite_gpg done." );
410 return ( $stdout , $stderr , $status );
414 my ( $question , $default ) = @_ ;
417 print $question , ' ' ,( $default ?
'[Y/n]' : '[y/N]' ), ' ' ;
420 last if (( defined $answer ) && ( length $answer <= 1 ));
424 my $result = $default ;
425 $result = 1 if $answer =~ /y/i ;
426 $result = 0 if $answer =~ /n/i ;
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' ;
441 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al." ;
443 my $KEYSBASE = $CONFIG { 'caffhome' }. '/keys' ;
444 my $GNUPGHOME = $CONFIG { 'caffhome' }. '/gnupghome' ;
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 " );
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 );
456 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al. \n " ;
460 my ( $fd , $exitcode ) = @_ ;
462 print $fd "Usage: $PROGRAM_NAME [-mMR] [-u <yourkeyid>] <keyid> [<keyid> ...] \n " ;
463 print $fd "Consult the manual page for more information. \n " ;
468 # export key $keyid from $gnupghome
471 my ( $gnupghome , $keyid ) = @_ ;
473 my $gpg = GnuPG
:: Interface
-> new ();
474 $gpg -> call ( $CONFIG { 'gpg' } );
475 $gpg -> options -> hash_init (
476 'homedir' => $gnupghome ,
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 );
488 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
491 my ( $gnupghome , $asciikey ) = @_ ;
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 );
502 if ( $status !~ /^\[GNUPG:\] IMPORT_OK/m ) {
510 # Send an email to $address. If $can_encrypt is true then the mail
511 # will be PGP/MIME encrypted to $longkeyid.
513 # $longkeyid, $uid, and @attached will be used in the email and the template.
515 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
516 sub send_mail
($$$ @
) {
517 my ( $address , $can_encrypt , $key_id , @keys ) = @_ ;
519 my $template = Text
:: Template
-> new ( TYPE
=> 'STRING' , SOURCE
=> $CONFIG { 'mail-template' })
520 or die "Error creating template: $Text ::Template::ERROR" ;
523 for my $key ( @keys ) {
524 push @uids , $key ->{ 'text' };
526 my $message = $template -> fill_in ( HASH
=> { key
=> $key_id ,
528 owner
=> $CONFIG { 'owner' }})
529 or die "Error filling template in: $Text ::Template::ERROR" ;
531 my $message_entity = MIME
:: Entity
-> build (
532 Type
=> "text/plain" ,
534 Disposition
=> 'inline' ,
538 for my $key ( @keys ) {
539 $message_entity -> attach (
540 Type
=> "application/pgp-keys" ,
541 Disposition
=> 'attachment' ,
543 Description
=> "PGP Key 0x $key_id , uid " .( $key ->{ 'text' }). ' (' .( $key ->{ 'serial' }). ')' ,
544 Data
=> $key ->{ 'key' },
545 Filename
=> "0x $key_id ." . $key ->{ 'serial' }. ".asc" );
549 my $message = $message_entity -> stringify ();
551 my $gpg = GnuPG
:: Interface
-> new ();
552 $gpg -> call ( $CONFIG { 'gpg' } );
553 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME ,
554 'extra_args' => '--always-trust' ,
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 );
564 warn ( "No data from gpg for list-key $key_id \n " );
569 $message_entity = MIME
:: Entity
-> build (
570 Type
=> 'multipart/encrypted; protocol="application/pgp-encrypted"' );
572 $message_entity -> attach (
573 Type
=> "application/pgp-encrypted" ,
574 Disposition
=> 'attachment' ,
576 Data
=> "Version: 1 \n " );
578 $message_entity -> attach (
579 Type
=> "application/octet-stream" ,
580 Filename
=> 'msg.asc' ,
581 Disposition
=> 'inline' ,
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 ();
596 # clean up a UID so that it can be used on the FS.
598 sub sanitize_uid
($) {
602 $good_uid =~ tr
#/:\\#_#;
603 trace2
( "[sanitize_uid] changed UID from $uid to $good_uid . \n " ) if $good_uid ne $uid ;
607 sub delete_signatures
($$$$$$) {
608 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $keyids ) = @_ ;
610 my $signed_by_me = 0 ;
612 my ( $stdout , $stderr , $status ) =
613 readwrite_gpg
( "delsig \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSIG_PROMPT , nocloseinput
=> 1 );
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 ;
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 )." );
628 } elsif ( grep { $signer eq $_ } @
{ $keyids }) {
629 debug
( "[sigremoval] signed by us ( $signer )." );
631 $signed_by_me = $signed_by_me > $created ?
$signed_by_me : $created ;
633 debug
( "[sigremoval] not interested in that sig ( $signer )." );
637 debug
( "[sigremoval] no sig line here, only got: " . $stdout );
639 ( $stdout , $stderr , $status ) =
640 readwrite_gpg
( $answer . " \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT , nocloseinput
=> 1 );
643 return $signed_by_me ;
652 Getopt
:: Long
:: config
( 'bundling' );
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' },
669 if ( $params ->{ 'help' }) {
672 if ( $params ->{ 'version' }) {
676 usage
( \
* STDERR
, 1 ) unless scalar @ARGV >= 1 ;
680 if ( $params ->{ 'local-user' }) {
681 $USER = $params ->{ 'local-user' };
683 unless ( $USER =~ /^[A-Za-z0-9]{8,8}([A-Za-z0-9]{8})?$/ ) {
684 print STDERR
"-u $USER is not a keyid. \n " ;
690 for my $keyid ( @ARGV ) {
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 " ;
696 push @KEYIDS , uc ( $keyid );
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' };
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 );
719 warn ( "No data from gpg for list-key \n " );
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 " ;
729 #############################
730 # receive keys from keyserver
731 #############################
734 if ( $CONFIG { 'no-download' }) {
735 @keyids_ok = @KEYIDS ;
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
();
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 );
752 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
755 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
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 " );
766 push @keyids_ok , $keyid ;
770 } elsif ( $line =~ /^\[GNUPG:\] NODATA/ ) {
771 push @keyids_failed , $keyid ;
778 notice
( "Huh, what's up with $keyid ?" );
779 push @keyids_failed , $keyid ;
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 ;
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 ) {
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 " ;
809 for my $keyid ( @keyids_ok ) {
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 );
822 warn ( "No data from gpg for list-key $keyid \n " );
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 " );
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 " );
835 unless ( defined $longkeyid ) {
836 warn ( "Didn't find public keyid in --list-key of key $keyid . \n " );
839 unless ( defined $flags ) {
840 warn ( "Didn't find flags in --list-key of key $keyid . \n " );
843 my $can_encrypt = $flags =~ /E/ ;
847 my $asciikey = export_key
( $GNUPGHOME , $keyid );
848 if ( $asciikey eq '' ) {
849 warn ( "No data from gpg for export $keyid \n " );
856 my $this_uid_text = '' ;
858 debug
( "Doing key $keyid , uid $uid_number " );
859 my $tempdir = tempdir
( "caff- $keyid -XXXXX" , DIR
=> '/tmp/' , CLEANUP
=> 1 );
861 # import into temporary gpghome
862 ###############################
863 my $result = import_key
( $tempdir , $asciikey );
865 warn ( "Could not import $keyid into temporary gnupg. \n " );
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 );
882 debug
( "Starting edit session" );
883 ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
887 my $number_of_subkeys = 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 ++;
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 );
908 $this_uid_text = ( $type eq 'uid' ) ?
$uidtext : '[attribute]' ;
909 $is_uat = $type eq 'uat' ;
913 debug
( "Parsing stdout output done." );
915 debug
( "Uid " .( $uid_number - 1 ). " was the last, there is no $uid_number ." );
916 info
( "key $keyid done." );
920 my $prune_some_sigs_on_uid ;
921 my $prune_all_sigs_on_uid ;
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 );
928 $prune_some_sigs_on_uid = 1 ;
929 $prune_all_sigs_on_uid = 2 ;
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 );
934 $prune_some_sigs_on_uid = 2 ;
935 $prune_all_sigs_on_uid = 1 ;
938 $prune_some_sigs_on_uid = 1 ;
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 );
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 );
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 );
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
969 readwrite_gpg
( "save \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd );
972 my $asciikey = export_key
( $tempdir , $keyid );
973 if ( $asciikey eq '' ) {
974 warn ( "No data from gpg for export $keyid \n " );
979 if ( $NOW - $signed_by_me > $CONFIG { 'export-sig-age' } ) {
980 my $write = ask
( "Signature on $this_uid_text is old. Export?" , 0 );
983 my $keydir = " $KEYSBASE / $DATE_STRING " ;
984 - d
$keydir || mkpath
( $keydir , 0 , 0700 ) or die ( "Cannot create $keydir $! \n " );
986 my $keyfile = " $keydir / $longkeyid .key. $uid_number ." . sanitize_uid
( $this_uid_text ). ".asc" ;
987 open ( KEY
, "> $keyfile " ) or die ( "Cannot open $keyfile : $! \n " );
991 push @UIDS , { text
=> $this_uid_text , key
=> $asciikey , serial
=> $uid_number , "is_uat" => $is_uat };
993 info
( " $longkeyid $uid_number $this_uid_text done." );
995 info
( " $longkeyid $uid_number $this_uid_text is not signed by me, not writing." );
999 if ( scalar @UIDS == 0 ) {
1000 info
( "found no signed uids for $keyid " );
1002 next if $CONFIG { 'no-mail' }; # do not send mail
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 ;
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 );
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 " );