]>
git.sthu.org Git - pgp-tools.git/blob - caff/caff
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> [-eEmMRS] [-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<-e>, B<--export-old>
61 Export old signatures. Default is to ask the user for each old signature.
63 =item B<-E>, B<--no-export-old>
65 Do not export old signatures. Default is to ask the user for each old
68 =item B<-m>, B<--mail>
70 Send mail after signing. Default is to ask the user for each uid.
72 =item B<-M>, B<--no-mail>
74 Do not send mail after signing. Default is to ask the user for each uid.
76 =item B<-R>, B<--no-download>
78 Do not retrieve the key to be signed from a keyserver.
80 =item B<-S>, B<--no-sign>
84 =item B<-u> I<yourkeyid>, B<--local-user> I<yourkeyid>
86 Select the key that is used for signing, in case you have more than one key.
94 =item $HOME/.caffrc - configuration file
98 =head1 CONFIGURATION FILE OPTIONS
100 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
104 $CONFIG{owner} = q{Peter Palfrader};
105 $CONFIG{email} = q{peter@palfrader.org};
106 $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
108 =head2 Required basic settings
112 =item B<owner> [string]
114 Your name. B<REQUIRED>.
116 =item B<email> [string]
118 Your email address, used in From: lines. B<REQUIRED>.
120 =item B<keyid> [list of keyids]
122 A list of your keys. This is used to determine which signatures to keep
123 in the pruning step. If you select a key using B<-u> it has to be in
124 this list. B<REQUIRED>.
126 =head2 General settings
128 =item B<caffhome> [string]
130 Base directory for the files caff stores. Default: B<$HOME/.caff/>.
132 =head2 GnuPG settings
134 =item B<gpg> [string]
136 Path to the GnuPG binary. Default: B<gpg>.
138 =item B<gpg-sign> [string]
140 Path to the GnuPG binary which is used to sign keys. Default: what
143 =item B<gpg-delsig> [string]
145 Path to the GnuPG binary which is used to split off signatures. This was
146 needed while the upstream GnuPG was not fixed. Default: what B<gpg>
149 =item B<secret-keyring> [string]
151 Path to your secret keyring. Default: B<$HOME/.gnupg/secring.gpg>.
153 =item B<also-encrypt-to> [keyid]
155 An additional keyid to encrypt messages to. Default: none.
157 =item B<gpg-sign-args> [string]
159 Additional arguments to pass to gpg. Default: none.
161 =head2 Keyserver settings
163 =item B<keyserver> [string]
165 Keyserver to download keys from. Default: B<subkeys.pgp.net>.
167 =item B<no-download> [boolean]
169 If true, then skip the step of fetching keys from the keyserver.
172 =head2 Signing settings
174 =item B<no-sign> [boolean]
176 If true, then skip the signing step. Default: B<0>.
178 =item B<ask-sign> [boolean]
180 If true, then pause before continuing to the signing step.
181 This is useful for offline signing. Default: B<0>.
183 =item B<export-sig-age> [seconds]
185 Don't export UIDs by default, on which your latest signature is older
186 than this age. Default: B<24*60*60> (i.e. one day).
190 =item B<mail> [boolean]
192 Do not prompt for sending mail, just do it. Default: B<0>.
194 =item B<no-mail> [boolean]
196 Do not prompt for sending mail. The messages are still written to
197 $CONFIG{caffhome}/keys/. Default: B<0>.
199 =item B<mail-template> [string]
201 Email template which is used as the body text for the email sent out
202 instead of the default text if specified. The following perl variables
203 can be used in the template:
207 =item B<{owner}> [string]
209 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
211 =item B<{key}> [string]
213 The keyid of the key you signed.
215 =item B<{@uids}> [array]
217 The UIDs for which signatures are included in the mail.
221 =item B<bcc> [string]
223 Address to send blind carbon copies to when sending mail.
232 =item Peter Palfrader <peter@palfrader.org>
234 =item Christoph Berg <cb@df7cb.de>
240 http://pgp-tools.alioth.debian.org/
248 use File
:: Temp
qw{ tempdir
};
254 use GnuPG
:: Interface
;
257 my $REVISION = ' $Rev $' ;
258 my ( $REVISION_NUMER ) = $REVISION =~ /(\d+)/ ;
259 my $VERSION = "0.0.0. $REVISION_NUMER " ;
262 my $config = $ENV { 'HOME' } . '/.caffrc' ;
263 - f
$config or die "No file $config present. See caff(1). \n " ;
264 unless ( scalar eval `cat $config ` ) {
265 die "Couldn't parse $config : $EVAL_ERROR \n " if $EVAL_ERROR ;
268 $CONFIG { 'caffhome' }= $ENV { 'HOME' }. '/.caff' unless defined $CONFIG { 'caffhome' };
269 die ( "owner is not defined. \n " ) unless defined $CONFIG { 'owner' };
270 die ( "email is not defined. \n " ) unless defined $CONFIG { 'email' };
271 die ( "keyid is not defined. \n " ) unless defined $CONFIG { 'keyid' };
272 die ( "keyid is not an array ref \n " ) unless ( ref $CONFIG { 'keyid' } eq 'ARRAY' );
273 for my $keyid ( @
{ $CONFIG { 'keyid' }}) {
274 $keyid =~ /^[A-F0-9]{16}$/i or die ( "key $keyid is not a long (16 digit) keyid. \n " );
276 @
{ $CONFIG { 'keyid' }} = map { uc } @
{ $CONFIG { 'keyid' }};
277 $CONFIG { 'export-sig-age' }= 24 * 60 * 60 unless defined $CONFIG { 'export-sig-age' };
278 $CONFIG { 'keyserver' } = 'subkeys.pgp.net' unless defined $CONFIG { 'keyserver' };
279 $CONFIG { 'gpg' } = 'gpg' unless defined $CONFIG { 'gpg' };
280 $CONFIG { 'gpg-sign' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-sign' };
281 $CONFIG { 'gpg-delsig' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-delsig' };
282 $CONFIG { 'secret-keyring' } = $ENV { 'HOME' }. '/.gnupg/secring.gpg' unless defined $CONFIG { 'secret-keyring' };
283 $CONFIG { 'no-download' } = 0 unless defined $CONFIG { 'no-download' };
284 $CONFIG { 'no-sign' } = 0 unless defined $CONFIG { 'no-sign' };
285 $CONFIG { 'mail-template' } = <<'EOM' unless defined $CONFIG {'mail-template'};
288 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
289 {foreach $uid ( @uids ) {
290 $OUT .= " \t ". $uid ." \n ";
291 };} of your key { $key } signed by me.
293 Note that I did not upload your key to any keyservers.
294 If you have multiple user ids, I sent the signature for each user id
295 separately to that user id's associated email address. You can import
296 the signatures by running each through `gpg --import`.
298 If you want this new signature to be available to others, please upload
299 it yourself. With GnuPG this can be done using
300 gpg --keyserver subkeys.pgp.net --send-key { $key }
302 If you have any questions, don't hesitate to ask.
311 print "[NOTICE] $line \n " ;
315 print "[INFO] $line \n " ;
319 #print "[DEBUG] $line\n";
323 #print "[trace] $line\n";
327 #print "[trace2] $line\n";
332 stdin
=> IO
:: Handle
-> new (),
333 stdout
=> IO
:: Handle
-> new (),
334 stderr
=> IO
:: Handle
-> new (),
335 status
=> IO
:: Handle
-> new () );
336 my $handles = GnuPG
:: Handles
-> new ( %fds );
337 return ( $fds { 'stdin' }, $fds { 'stdout' }, $fds { 'stderr' }, $fds { 'status' }, $handles );
340 sub readwrite_gpg
($$$$$%) {
341 my ( $in , $inputfd , $stdoutfd , $stderrfd , $statusfd , %options ) = @_ ;
343 trace
( "Entering readwrite_gpg." );
345 my ( $first_line , undef ) = split /\n/ , $in ;
346 debug
( "readwrite_gpg sends " .( defined $first_line ?
$first_line : "<nothing>" ));
348 local $INPUT_RECORD_SEPARATOR = undef ;
349 my $sout = IO
:: Select
-> new ();
350 my $sin = IO
:: Select
-> new ();
353 trace
( "input is $inputfd ; output is $stdoutfd ; err is $stderrfd ; status is " .( defined $statusfd ?
$statusfd : 'undef' ). "." );
355 $inputfd -> blocking ( 0 );
356 $stdoutfd -> blocking ( 0 );
357 $statusfd -> blocking ( 0 ) if defined $statusfd ;
358 $stderrfd -> blocking ( 0 );
359 $sout -> add ( $stdoutfd );
360 $sout -> add ( $stderrfd );
361 $sout -> add ( $statusfd ) if defined $statusfd ;
364 my ( $stdout , $stderr , $status ) = ( "" , "" , "" );
365 my $exitwhenstatusmatches = $options { 'exitwhenstatusmatches' };
366 trace
( "doing stuff until we find $exitwhenstatusmatches " ) if defined $exitwhenstatusmatches ;
368 my $readwrote_stuff_this_time = 0 ;
369 my $do_not_wait_on_select = 0 ;
370 my ( $readyr , $readyw , $written );
371 while ( $sout -> count () > 0 || ( defined ( $sin ) && ( $sin -> count () > 0 ))) {
372 if ( defined $exitwhenstatusmatches ) {
373 if ( $status =~ /$exitwhenstatusmatches/m ) {
374 trace
( "readwrite_gpg found match on $exitwhenstatusmatches " );
375 if ( $readwrote_stuff_this_time ) {
376 trace
( "read/write some more \n " );
377 $do_not_wait_on_select = 1 ;
379 trace
( "that's it in our while loop. \n " );
385 $readwrote_stuff_this_time = 0 ;
386 trace
( "select waiting for " .( $sout -> count ()). " fds." );
387 ( $readyr , $readyw , undef ) = IO
:: Select
:: select ( $sout , $sin , undef , $do_not_wait_on_select ?
0 : 1 );
388 trace
( "ready: write: " .( defined $readyw ?
scalar @
$readyw : 0 ). "; read: " .( defined $readyr ?
scalar @
$readyr : 0 ));
389 for my $wfd ( @
$readyw ) {
390 $readwrote_stuff_this_time = 1 ;
391 if ( length ( $in ) != $offset ) {
392 trace
( "writing to $wfd ." );
393 $written = $wfd -> syswrite ( $in , length ( $in ) - $offset , $offset );
396 if ( $offset == length ( $in )) {
397 trace
( "writing to $wfd done." );
398 unless ( $options { 'nocloseinput' }) {
400 trace
( " $wfd closed." );
407 next unless ( defined ( @
$readyr )); # Wait some more.
409 for my $rfd ( @
$readyr ) {
410 $readwrote_stuff_this_time = 1 ;
412 trace
( "reading from $rfd done." );
417 trace
( "reading from $rfd ." );
418 if ( $rfd == $stdoutfd ) {
420 trace2
( "stdout is now $stdout \n ================" );
423 if ( defined $statusfd && $rfd == $statusfd ) {
425 trace2
( "status is now $status \n ================" );
428 if ( $rfd == $stderrfd ) {
430 trace2
( "stderr is now $stderr \n ================" );
435 trace
( "readwrite_gpg done." );
436 return ( $stdout , $stderr , $status );
440 my ( $question , $default , $forceyes , $forceno ) = @_ ;
441 return $default if $forceyes and $forceno ;
442 return 1 if $forceyes ;
443 return 0 if $forceno ;
446 print $question , ' ' ,( $default ?
'[Y/n]' : '[y/N]' ), ' ' ;
449 last if (( defined $answer ) && ( length $answer <= 1 ));
453 my $result = $default ;
454 $result = 1 if $answer =~ /y/i ;
455 $result = 0 if $answer =~ /n/i ;
463 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt' ;
464 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay' ;
465 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig' ;
466 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)' ;
467 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey' ;
470 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al." ;
472 my $KEYSBASE = $CONFIG { 'caffhome' }. '/keys' ;
473 my $GNUPGHOME = $CONFIG { 'caffhome' }. '/gnupghome' ;
475 - d
$KEYSBASE || mkpath
( $KEYSBASE , 0 , 0700 ) or die ( "Cannot create $KEYSBASE : $! \n " );
476 - d
$GNUPGHOME || mkpath
( $GNUPGHOME , 0 , 0700 ) or die ( "Cannot create $GNUPGHOME : $! \n " );
479 my ( $sec , $min , $hour , $mday , $mon , $year , $wday , $yday , $isdst ) = localtime ( $NOW );
480 my $DATE_STRING = sprintf ( " %04d - %02d - %02d " , $year + 1900 , $mon + 1 , $mday );
485 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al. \n " ;
489 my ( $fd , $exitcode ) = @_ ;
491 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...] \n " ;
492 print $fd "Consult the manual page for more information. \n " ;
497 # export key $keyid from $gnupghome
500 my ( $gnupghome , $keyid ) = @_ ;
502 my $gpg = GnuPG
:: Interface
-> new ();
503 $gpg -> call ( $CONFIG { 'gpg' } );
504 $gpg -> options -> hash_init (
505 'homedir' => $gnupghome ,
506 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
508 $gpg -> options -> meta_interactive ( 0 );
509 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
510 my $pid = $gpg -> export_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
511 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
518 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
521 my ( $gnupghome , $asciikey ) = @_ ;
523 my $gpg = GnuPG
:: Interface
-> new ();
524 $gpg -> call ( $CONFIG { 'gpg' } );
525 $gpg -> options -> hash_init (
526 'homedir' => $gnupghome ,
527 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ] );
528 $gpg -> options -> meta_interactive ( 0 );
529 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
530 my $pid = $gpg -> import_keys ( handles
=> $handles );
531 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $asciikey , $inputfd , $stdoutfd , $stderrfd , $statusfd );
534 if ( $status !~ /^\[GNUPG:\] IMPORT_OK/m ) {
542 # Send an email to $address. If $can_encrypt is true then the mail
543 # will be PGP/MIME encrypted to $longkeyid.
545 # $longkeyid, $uid, and @attached will be used in the email and the template.
547 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
548 sub send_mail
($$$ @
) {
549 my ( $address , $can_encrypt , $key_id , @keys ) = @_ ;
551 my $template = Text
:: Template
-> new ( TYPE
=> 'STRING' , SOURCE
=> $CONFIG { 'mail-template' })
552 or die "Error creating template: $Text ::Template::ERROR" ;
555 for my $key ( @keys ) {
556 push @uids , $key ->{ 'text' };
558 my $message = $template -> fill_in ( HASH
=> { key
=> $key_id ,
560 owner
=> $CONFIG { 'owner' }})
561 or die "Error filling template in: $Text ::Template::ERROR" ;
563 my $message_entity = MIME
:: Entity
-> build (
564 Type
=> "text/plain" ,
566 Disposition
=> 'inline' ,
570 for my $key ( @keys ) {
571 $message_entity -> attach (
572 Type
=> "application/pgp-keys" ,
573 Disposition
=> 'attachment' ,
575 Description
=> "PGP Key 0x $key_id , uid " .( $key ->{ 'text' }). ' (' .( $key ->{ 'serial' }). ')' ,
576 Data
=> $key ->{ 'key' },
577 Filename
=> "0x $key_id ." . $key ->{ 'serial' }. ".asc" );
581 my $message = $message_entity -> stringify ();
583 my $gpg = GnuPG
:: Interface
-> new ();
584 $gpg -> call ( $CONFIG { 'gpg' } );
585 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME ,
586 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
588 $gpg -> options -> meta_interactive ( 0 );
589 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
590 $gpg -> options -> push_recipients ( $key_id );
591 $gpg -> options -> push_recipients ( $CONFIG { 'also-encrypt-to' } ) if defined $CONFIG { 'also-encrypt-to' };
592 my $pid = $gpg -> encrypt ( handles
=> $handles );
593 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $message , $inputfd , $stdoutfd , $stderrfd , $statusfd );
596 warn ( "No data from gpg for list-key $key_id \n " );
601 $message_entity = MIME
:: Entity
-> build (
602 Type
=> 'multipart/encrypted; protocol="application/pgp-encrypted"' );
604 $message_entity -> attach (
605 Type
=> "application/pgp-encrypted" ,
606 Disposition
=> 'attachment' ,
608 Data
=> "Version: 1 \n " );
610 $message_entity -> attach (
611 Type
=> "application/octet-stream" ,
612 Filename
=> 'msg.asc' ,
613 Disposition
=> 'inline' ,
618 $message_entity -> head -> add ( "Subject" , "Your signed PGP key 0x $key_id " );
619 $message_entity -> head -> add ( "To" , $address );
620 $message_entity -> head -> add ( "From" , '"' . $CONFIG { 'owner' }. '" <' . $CONFIG { 'email' }. '>' );
621 $message_entity -> head -> add ( "Bcc" , $CONFIG { 'bcc' }) if defined $CONFIG { 'bcc' };
622 $message_entity -> head -> add ( "User-Agent" , $USER_AGENT );
623 $message_entity -> send ();
624 $message_entity -> stringify ();
628 # clean up a UID so that it can be used on the FS.
630 sub sanitize_uid
($) {
634 $good_uid =~ tr
#/:\\#_#;
635 trace2
( "[sanitize_uid] changed UID from $uid to $good_uid . \n " ) if $good_uid ne $uid ;
639 sub delete_signatures
($$$$$$) {
640 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $keyids ) = @_ ;
642 my $signed_by_me = 0 ;
644 my ( $stdout , $stderr , $status ) =
645 readwrite_gpg
( "delsig \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSIG_PROMPT , nocloseinput
=> 1 );
647 while ( $status =~ /$KEYEDIT_DELSIG_PROMPT/m ) {
648 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
649 my @sigline = grep { /^sig/ } ( split /\n/ , $stdout );
650 $stdout =~ s/\n/\\n/g ;
651 notice
( "[sigremoval] why are there " .( scalar @sigline ). " siglines in that part of the dialog!? got: $stdout " ) if scalar @sigline >= 2 ; # XXX
652 my $line = pop @sigline ;
654 if ( defined $line ) { # only if we found a sig here - we never remove revocation packets for instance
655 debug
( "[sigremoval] doing line $line ." );
656 my ( undef , undef , undef , undef , $signer , $created , undef , undef , undef ) = split /:/ , $line ;
657 if ( $signer eq $longkeyid ) {
658 debug
( "[sigremoval] selfsig ( $signer )." );
660 } elsif ( grep { $signer eq $_ } @
{ $keyids }) {
661 debug
( "[sigremoval] signed by us ( $signer )." );
663 $signed_by_me = $signed_by_me > $created ?
$signed_by_me : $created ;
665 debug
( "[sigremoval] not interested in that sig ( $signer )." );
669 debug
( "[sigremoval] no sig line here, only got: " . $stdout );
671 ( $stdout , $stderr , $status ) =
672 readwrite_gpg
( $answer . " \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT , nocloseinput
=> 1 );
675 return $signed_by_me ;
684 Getopt
:: Long
:: config
( 'bundling' );
686 '-h' => \
$params ->{ 'help' },
687 '--help' => \
$params ->{ 'help' },
688 '--version' => \
$params ->{ 'version' },
689 '-V' => \
$params ->{ 'version' },
690 '-u=s' => \
$params ->{ 'local-user' },
691 '--local-user=s' => \
$params ->{ 'local-user' },
692 '-e' => \
$params ->{ 'export-old' },
693 '--export-old' => \
$params ->{ 'export-old' },
694 '-E' => \
$params ->{ 'no-export-old' },
695 '--no-export-old' => \
$params ->{ 'no-export-old' },
696 '-m' => \
$params ->{ 'mail' },
697 '--mail' => \
$params ->{ 'mail' },
698 '-M' => \
$params ->{ 'no-mail' },
699 '--no-mail' => \
$params ->{ 'no-mail' },
700 '-R' => \
$params ->{ 'no-download' },
701 '--no-download' => \
$params ->{ 'no-download' },
702 '-S' => \
$params ->{ 'no-sign' },
703 '--no-sign' => \
$params ->{ 'no-sign' },
707 if ( $params ->{ 'help' }) {
710 if ( $params ->{ 'version' }) {
714 usage
( \
* STDERR
, 1 ) unless scalar @ARGV >= 1 ;
718 if ( $params ->{ 'local-user' }) {
719 $USER = $params ->{ 'local-user' };
721 unless ( $USER =~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i ) {
722 print STDERR
"-u $USER is not a keyid. \n " ;
728 for my $keyid ( @ARGV ) {
730 unless ( $keyid =~ /^([A-F0-9]{8}|[A-F0-9]{16}||[A-F0-9]{40})$/i ) {
731 print STDERR
" $keyid is not a keyid. \n " ;
734 push @KEYIDS , uc ( $keyid );
737 $CONFIG { 'no-download' } = $params ->{ 'no-download' } if defined $params ->{ 'no-download' };
738 $CONFIG { 'no-mail' } = $params ->{ 'no-mail' } if defined $params ->{ 'no-mail' };
739 $CONFIG { 'mail' } = $params ->{ 'mail' } if defined $params ->{ 'mail' };
740 $CONFIG { 'no-sign' } = $params ->{ 'no-sign' } if defined $params ->{ 'no-sign' };
746 my $gpg = GnuPG
:: Interface
-> new ();
747 $gpg -> call ( $CONFIG { 'gpg' } );
748 $gpg -> options -> hash_init (
749 'homedir' => $GNUPGHOME ,
750 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
} ] );
751 $gpg -> options -> meta_interactive ( 0 );
752 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
753 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> $CONFIG { 'keyid' });
754 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
757 warn ( "No data from gpg for list-key \n " );
760 foreach my $keyid ( @
{ $CONFIG { 'keyid' }}) {
761 unless ( $stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m ) {
762 info
( "Importing $keyid " );
763 system "gpg --export $keyid | gpg --import --homedir $GNUPGHOME " ;
767 #############################
768 # receive keys from keyserver
769 #############################
771 if ( $CONFIG { 'no-download' }) {
772 @keyids_ok = @KEYIDS ;
774 info
( "fetching keys, this will take a while..." );
776 my $gpg = GnuPG
:: Interface
-> new ();
777 $gpg -> call ( $CONFIG { 'gpg' } );
778 $gpg -> options -> hash_init (
779 'homedir' => $GNUPGHOME ,
780 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
}, '--keyserver=' . $CONFIG { 'keyserver' } ] );
781 $gpg -> options -> meta_interactive ( 0 );
782 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
783 my $pid = $gpg -> recv_keys ( handles
=> $handles , command_args
=> [ @KEYIDS ]);
784 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
787 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
790 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
791 my %local_keyids = map { $_ => 1 } @KEYIDS ;
792 for my $line ( split /\n/ , $status ) {
793 if ( $line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/ ) {
794 my $imported_key = $1 ;
795 my $whole_fpr = $imported_key ;
796 my $long_keyid = substr ( $imported_key , - 16 );
797 my $short_keyid = substr ( $imported_key , - 8 );
799 for my $spec (( $whole_fpr , $long_keyid , $short_keyid )) {
800 $speced_key = $spec if $local_keyids { $spec };
802 unless ( $speced_key ) {
803 notice
( "Imported unexpected key; got: $imported_key \n " );
806 debug
( "Imported $imported_key for $speced_key " );
807 delete $local_keyids { $speced_key };
808 unshift @keyids_ok , $imported_key ;
809 } elsif ( $line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) / ) {
811 notice
( "got unknown reply from gpg: $line " );
814 if ( scalar %local_keyids ) {
815 notice
( "Import failed for: " . ( join ' ' , keys %local_keyids ). "." );
816 exit 1 unless ask
( "Some keys could not be imported - continue anyway?" , 0 );
820 unless ( @keyids_ok ) {
821 notice
( "No keys to sign found" );
828 if ( $CONFIG { 'ask-sign' } && ! $CONFIG { 'no-sign' }) {
829 $CONFIG { 'no-sign' } = ! ask
( "Continue with signing?" , 1 );
832 unless ( $CONFIG { 'no-sign' }) {
833 info
( "Sign the following keys according to your policy, then exit gpg with 'save' after signing each key" );
834 for my $keyid ( @keyids_ok ) {
836 push @command , $CONFIG { 'gpg-sign' };
837 push @command , '--local-user' , $USER if ( defined $USER );
838 push @command , "--homedir= $GNUPGHOME " ;
839 push @command , '--secret-keyring' , $CONFIG { 'secret-keyring' };
840 push @command , '--no-auto-check-trustdb' ;
841 push @command , '--trust-model=always' ;
842 push @command , '--edit' , $keyid ;
843 push @command , 'sign' ;
844 push @command , split ' ' , $CONFIG { 'gpg-sign-args' } || "" ;
845 print join ( ' ' , @command ), " \n " ;
854 for my $keyid ( @keyids_ok ) {
857 my $gpg = GnuPG
:: Interface
-> new ();
858 $gpg -> call ( $CONFIG { 'gpg' } );
859 $gpg -> options -> hash_init (
860 'homedir' => $GNUPGHOME ,
861 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
} ] );
862 $gpg -> options -> meta_interactive ( 0 );
863 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
864 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
865 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
868 warn ( "No data from gpg for list-key $keyid \n " );
871 my @publine = grep { /^pub/ } ( split /\n/ , $stdout );
872 if ( scalar @publine == 0 ) {
873 warn ( "No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME ). \n " );
876 my ( undef , undef , undef , undef , $longkeyid , undef , undef , undef , undef , undef , undef , $flags ) = split /:/ , pop @publine ;
877 if ( scalar @publine > 0 ) {
878 warn ( "More than one key matched $keyid . Try to specify the long keyid or fingerprint \n " );
881 unless ( defined $longkeyid ) {
882 warn ( "Didn't find public keyid in --list-key of key $keyid . \n " );
885 unless ( defined $flags ) {
886 warn ( "Didn't find flags in --list-key of key $keyid . \n " );
889 my $can_encrypt = $flags =~ /E/ ;
893 my $asciikey = export_key
( $GNUPGHOME , $keyid );
894 if ( $asciikey eq '' ) {
895 warn ( "No data from gpg for export $keyid \n " );
902 my $this_uid_text = '' ;
904 debug
( "Doing key $keyid , uid $uid_number " );
905 my $tempdir = tempdir
( "caff- $keyid -XXXXX" , DIR
=> '/tmp/' , CLEANUP
=> 1 );
907 # import into temporary gpghome
908 ###############################
909 my $result = import_key
( $tempdir , $asciikey );
911 warn ( "Could not import $keyid into temporary gnupg. \n " );
917 $gpg = GnuPG
:: Interface
-> new ();
918 $gpg -> call ( $CONFIG { 'gpg-delsig' } );
919 $gpg -> options -> hash_init (
920 'homedir' => $tempdir ,
921 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
-- command
- fd
= 0 -- no - tty
} ] );
922 ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
923 $pid = $gpg -> wrap_call (
924 commands
=> [ '--edit' ],
925 command_args
=> [ $keyid ],
926 handles
=> $handles );
928 debug
( "Starting edit session" );
929 ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
933 my $number_of_subkeys = 0 ;
938 debug
( "Parsing stdout output." );
939 for my $line ( split /\n/ , $stdout ) {
940 debug
( "Checking line $line " );
941 my ( $type , undef , undef , undef , undef , undef , undef , undef , undef , $uidtext ) = split /:/ , $line ;
942 if ( $type eq 'sub' ) {
943 $number_of_subkeys ++;
945 next unless ( $type eq 'uid' || $type eq 'uat' );
946 debug
( "line is interesting." );
947 if ( $uid_number != $i ) {
948 debug
( "mark for deletion." );
949 readwrite_gpg
( " $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
954 $this_uid_text = ( $type eq 'uid' ) ?
$uidtext : '[attribute]' ;
955 $is_uat = $type eq 'uat' ;
959 debug
( "Parsing stdout output done." );
961 debug
( "Uid " .( $uid_number - 1 ). " was the last, there is no $uid_number ." );
962 info
( "key $keyid done." );
966 my $prune_some_sigs_on_uid ;
967 my $prune_all_sigs_on_uid ;
969 debug
( "handling attribute userid of key $keyid ." );
970 if ( $uid_number == 1 ) {
971 debug
( " attribute userid is #1, unmarking #2 for deletion." );
972 readwrite_gpg
( "2 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
974 $prune_some_sigs_on_uid = 1 ;
975 $prune_all_sigs_on_uid = 2 ;
977 debug
( "attribute userid is not #1, unmarking #1 for deletion." );
978 readwrite_gpg
( "1 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
980 $prune_some_sigs_on_uid = 2 ;
981 $prune_all_sigs_on_uid = 1 ;
984 $prune_some_sigs_on_uid = 1 ;
988 debug
( "need to delete $delete_some uids." );
989 readwrite_gpg
( "deluid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELUID_PROMPT , nocloseinput
=> 1 );
990 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
995 if ( $number_of_subkeys > 0 ) {
996 for ( my $i = 1 ; $i <= $number_of_subkeys ; $i ++) {
997 readwrite_gpg
( "key $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
999 readwrite_gpg
( "delkey \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSUBKEY_PROMPT , nocloseinput
=> 1 );
1000 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1005 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1006 my $signed_by_me = delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $CONFIG { 'keyid' });
1007 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1008 if ( defined $prune_all_sigs_on_uid ) {
1009 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1010 delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , []);
1011 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1015 readwrite_gpg
( "save \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd );
1018 my $asciikey = export_key
( $tempdir , $keyid );
1019 if ( $asciikey eq '' ) {
1020 warn ( "No data from gpg for export $keyid \n " );
1024 if ( $signed_by_me ) {
1025 if ( $NOW - $signed_by_me > $CONFIG { 'export-sig-age' } ) {
1026 my $write = ask
( "Signature on $this_uid_text is old. Export?" , 0 , $params ->{ 'export-old' }, $params ->{ 'no-export-old' });
1029 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1030 - d
$keydir || mkpath
( $keydir , 0 , 0700 ) or die ( "Cannot create $keydir $! \n " );
1032 my $keyfile = " $keydir / $longkeyid .key. $uid_number ." . sanitize_uid
( $this_uid_text ). ".asc" ;
1033 open ( KEY
, "> $keyfile " ) or die ( "Cannot open $keyfile : $! \n " );
1034 print KEY
$asciikey ;
1037 push @UIDS , { text
=> $this_uid_text , key
=> $asciikey , serial
=> $uid_number , "is_uat" => $is_uat };
1039 info
( " $longkeyid $uid_number $this_uid_text done." );
1041 info
( " $longkeyid $uid_number $this_uid_text is not signed by me, not writing." );
1045 if ( scalar @UIDS == 0 ) {
1046 info
( "found no signed uids for $keyid " );
1048 next if $CONFIG { 'no-mail' }; # do not send mail
1051 for my $uid ( @UIDS ) {
1052 trace
( "UID: $uid ->{'text'} \n " );
1053 if ( $uid ->{ 'is_uat' }) {
1054 my $attach = ask
( "UID $uid ->{'text'} is an attribute UID, attach it to every email sent?" , 1 );
1055 push @attached , $uid if $attach ;
1056 } elsif ( $uid ->{ 'text' } !~ /@/ ) {
1057 my $attach = ask
( "UID $uid ->{'text'} is no email address, attach it to every email sent?" , 1 );
1058 push @attached , $uid if $attach ;
1062 notice
( "Key has no encryption capabilities, mail will be sent unencrypted" ) unless $can_encrypt ;
1063 for my $uid ( @UIDS ) {
1064 if (! $uid ->{ 'is_uat' } && ( $uid ->{ 'text' } =~ /@/ )) {
1065 my $address = $uid ->{ 'text' };
1066 $address =~ s/.*<(.*)>.*/$1/ ;
1067 if ( ask
( "Send mail to ' $address ' for $uid ->{'text'}?" , 1 , $CONFIG { 'mail' })) {
1068 my $mail = send_mail
( $address , $can_encrypt , $longkeyid , $uid , @attached );
1070 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1071 my $mailfile = " $keydir / $longkeyid .mail." . $uid ->{ 'serial' }. "." . sanitize_uid
( $uid ->{ 'text' });
1072 open ( KEY
, "> $mailfile " ) or die ( "Cannot open $mailfile : $! \n " );