]>
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.
88 =item B<--key-file> I<file>
90 Import keys from file. Can be supplied more than once.
98 =item $HOME/.caffrc - configuration file
102 =head1 CONFIGURATION FILE OPTIONS
104 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
108 $CONFIG{owner} = q{Peter Palfrader};
109 $CONFIG{email} = q{peter@palfrader.org};
110 $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
112 =head2 Required basic settings
116 =item B<owner> [string]
118 Your name. B<REQUIRED>.
120 =item B<email> [string]
122 Your email address, used in From: lines. B<REQUIRED>.
124 =item B<keyid> [list of keyids]
126 A list of your keys. This is used to determine which signatures to keep
127 in the pruning step. If you select a key using B<-u> it has to be in
128 this list. B<REQUIRED>.
130 =head2 General settings
132 =item B<caffhome> [string]
134 Base directory for the files caff stores. Default: B<$HOME/.caff/>.
136 =head2 GnuPG settings
138 =item B<gpg> [string]
140 Path to the GnuPG binary. Default: B<gpg>.
142 =item B<gpg-sign> [string]
144 Path to the GnuPG binary which is used to sign keys. Default: what
147 =item B<gpg-delsig> [string]
149 Path to the GnuPG binary which is used to split off signatures. This was
150 needed while the upstream GnuPG was not fixed. Default: what B<gpg>
153 =item B<secret-keyring> [string]
155 Path to your secret keyring. Default: B<$HOME/.gnupg/secring.gpg>.
157 =item B<also-encrypt-to> [keyid]
159 An additional keyid to encrypt messages to. Default: none.
161 =item B<gpg-sign-args> [string]
163 Additional arguments to pass to gpg. Default: none.
165 =head2 Keyserver settings
167 =item B<keyserver> [string]
169 Keyserver to download keys from. Default: B<subkeys.pgp.net>.
171 =item B<no-download> [boolean]
173 If true, then skip the step of fetching keys from the keyserver.
176 =item B<key-files> [list of files]
178 A list of files containing keys to be imported.
180 =head2 Signing settings
182 =item B<no-sign> [boolean]
184 If true, then skip the signing step. Default: B<0>.
186 =item B<ask-sign> [boolean]
188 If true, then pause before continuing to the signing step.
189 This is useful for offline signing. Default: B<0>.
191 =item B<export-sig-age> [seconds]
193 Don't export UIDs by default, on which your latest signature is older
194 than this age. Default: B<24*60*60> (i.e. one day).
198 =item B<mail> [boolean]
200 Do not prompt for sending mail, just do it. Default: B<0>.
202 =item B<no-mail> [boolean]
204 Do not prompt for sending mail. The messages are still written to
205 $CONFIG{caffhome}/keys/. Default: B<0>.
207 =item B<mail-template> [string]
209 Email template which is used as the body text for the email sent out
210 instead of the default text if specified. The following perl variables
211 can be used in the template:
215 =item B<{owner}> [string]
217 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
219 =item B<{key}> [string]
221 The keyid of the key you signed.
223 =item B<{@uids}> [array]
225 The UIDs for which signatures are included in the mail.
229 =item B<bcc> [string]
231 Address to send blind carbon copies to when sending mail.
240 =item Peter Palfrader <peter@palfrader.org>
242 =item Christoph Berg <cb@df7cb.de>
248 http://pgp-tools.alioth.debian.org/
256 use File
:: Temp
qw{ tempdir
};
262 use GnuPG
:: Interface
;
265 my $REVISION = ' $Rev $' ;
266 my ( $REVISION_NUMER ) = $REVISION =~ /(\d+)/ ;
267 my $VERSION = "0.0.0. $REVISION_NUMER " ;
270 my $config = $ENV { 'HOME' } . '/.caffrc' ;
271 - f
$config or die "No file $config present. See caff(1). \n " ;
272 unless ( scalar eval `cat $config ` ) {
273 die "Couldn't parse $config : $EVAL_ERROR \n " if $EVAL_ERROR ;
276 $CONFIG { 'caffhome' }= $ENV { 'HOME' }. '/.caff' unless defined $CONFIG { 'caffhome' };
277 die ( "owner is not defined. \n " ) unless defined $CONFIG { 'owner' };
278 die ( "email is not defined. \n " ) unless defined $CONFIG { 'email' };
279 die ( "keyid is not defined. \n " ) unless defined $CONFIG { 'keyid' };
280 die ( "keyid is not an array ref \n " ) unless ( ref $CONFIG { 'keyid' } eq 'ARRAY' );
281 for my $keyid ( @
{ $CONFIG { 'keyid' }}) {
282 $keyid =~ /^[A-F0-9]{16}$/i or die ( "key $keyid is not a long (16 digit) keyid. \n " );
284 @
{ $CONFIG { 'keyid' }} = map { uc } @
{ $CONFIG { 'keyid' }};
285 $CONFIG { 'export-sig-age' }= 24 * 60 * 60 unless defined $CONFIG { 'export-sig-age' };
286 $CONFIG { 'keyserver' } = 'subkeys.pgp.net' unless defined $CONFIG { 'keyserver' };
287 $CONFIG { 'gpg' } = 'gpg' unless defined $CONFIG { 'gpg' };
288 $CONFIG { 'gpg-sign' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-sign' };
289 $CONFIG { 'gpg-delsig' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-delsig' };
290 $CONFIG { 'secret-keyring' } = $ENV { 'HOME' }. '/.gnupg/secring.gpg' unless defined $CONFIG { 'secret-keyring' };
291 $CONFIG { 'no-download' } = 0 unless defined $CONFIG { 'no-download' };
292 $CONFIG { 'no-sign' } = 0 unless defined $CONFIG { 'no-sign' };
293 $CONFIG { 'key-files' } = () unless defined $CONFIG { 'key-files' };
294 $CONFIG { 'mail-template' } = <<'EOM' unless defined $CONFIG {'mail-template'};
297 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
298 {foreach $uid ( @uids ) {
299 $OUT .= " \t ". $uid ." \n ";
300 };} of your key { $key } signed by me.
302 Note that I did not upload your key to any keyservers.
303 If you have multiple user ids, I sent the signature for each user id
304 separately to that user id's associated email address. You can import
305 the signatures by running each through `gpg --import`.
307 If you want this new signature to be available to others, please upload
308 it yourself. With GnuPG this can be done using
309 gpg --keyserver subkeys.pgp.net --send-key { $key }
311 If you have any questions, don't hesitate to ask.
320 print "[NOTICE] $line \n " ;
324 print "[INFO] $line \n " ;
328 #print "[DEBUG] $line\n";
332 #print "[trace] $line\n";
336 #print "[trace2] $line\n";
341 stdin
=> IO
:: Handle
-> new (),
342 stdout
=> IO
:: Handle
-> new (),
343 stderr
=> IO
:: Handle
-> new (),
344 status
=> IO
:: Handle
-> new () );
345 my $handles = GnuPG
:: Handles
-> new ( %fds );
346 return ( $fds { 'stdin' }, $fds { 'stdout' }, $fds { 'stderr' }, $fds { 'status' }, $handles );
349 sub readwrite_gpg
($$$$$%) {
350 my ( $in , $inputfd , $stdoutfd , $stderrfd , $statusfd , %options ) = @_ ;
352 trace
( "Entering readwrite_gpg." );
354 my ( $first_line , undef ) = split /\n/ , $in ;
355 debug
( "readwrite_gpg sends " .( defined $first_line ?
$first_line : "<nothing>" ));
357 local $INPUT_RECORD_SEPARATOR = undef ;
358 my $sout = IO
:: Select
-> new ();
359 my $sin = IO
:: Select
-> new ();
362 trace
( "input is $inputfd ; output is $stdoutfd ; err is $stderrfd ; status is " .( defined $statusfd ?
$statusfd : 'undef' ). "." );
364 $inputfd -> blocking ( 0 );
365 $stdoutfd -> blocking ( 0 );
366 $statusfd -> blocking ( 0 ) if defined $statusfd ;
367 $stderrfd -> blocking ( 0 );
368 $sout -> add ( $stdoutfd );
369 $sout -> add ( $stderrfd );
370 $sout -> add ( $statusfd ) if defined $statusfd ;
373 my ( $stdout , $stderr , $status ) = ( "" , "" , "" );
374 my $exitwhenstatusmatches = $options { 'exitwhenstatusmatches' };
375 trace
( "doing stuff until we find $exitwhenstatusmatches " ) if defined $exitwhenstatusmatches ;
377 my $readwrote_stuff_this_time = 0 ;
378 my $do_not_wait_on_select = 0 ;
379 my ( $readyr , $readyw , $written );
380 while ( $sout -> count () > 0 || ( defined ( $sin ) && ( $sin -> count () > 0 ))) {
381 if ( defined $exitwhenstatusmatches ) {
382 if ( $status =~ /$exitwhenstatusmatches/m ) {
383 trace
( "readwrite_gpg found match on $exitwhenstatusmatches " );
384 if ( $readwrote_stuff_this_time ) {
385 trace
( "read/write some more \n " );
386 $do_not_wait_on_select = 1 ;
388 trace
( "that's it in our while loop. \n " );
394 $readwrote_stuff_this_time = 0 ;
395 trace
( "select waiting for " .( $sout -> count ()). " fds." );
396 ( $readyr , $readyw , undef ) = IO
:: Select
:: select ( $sout , $sin , undef , $do_not_wait_on_select ?
0 : 1 );
397 trace
( "ready: write: " .( defined $readyw ?
scalar @
$readyw : 0 ). "; read: " .( defined $readyr ?
scalar @
$readyr : 0 ));
398 for my $wfd ( @
$readyw ) {
399 $readwrote_stuff_this_time = 1 ;
400 if ( length ( $in ) != $offset ) {
401 trace
( "writing to $wfd ." );
402 $written = $wfd -> syswrite ( $in , length ( $in ) - $offset , $offset );
405 if ( $offset == length ( $in )) {
406 trace
( "writing to $wfd done." );
407 unless ( $options { 'nocloseinput' }) {
409 trace
( " $wfd closed." );
416 next unless ( defined ( @
$readyr )); # Wait some more.
418 for my $rfd ( @
$readyr ) {
419 $readwrote_stuff_this_time = 1 ;
421 trace
( "reading from $rfd done." );
426 trace
( "reading from $rfd ." );
427 if ( $rfd == $stdoutfd ) {
429 trace2
( "stdout is now $stdout \n ================" );
432 if ( defined $statusfd && $rfd == $statusfd ) {
434 trace2
( "status is now $status \n ================" );
437 if ( $rfd == $stderrfd ) {
439 trace2
( "stderr is now $stderr \n ================" );
444 trace
( "readwrite_gpg done." );
445 return ( $stdout , $stderr , $status );
449 my ( $question , $default , $forceyes , $forceno ) = @_ ;
451 my $yn = $default ?
'[Y/n]' : '[y/N]' ;
453 print $question , ' ' , $yn , ' ' ;
454 if ( $forceyes && $forceno ) {
455 print " $default (from config/command line) \n " ;
459 print "YES (from config/command line) \n " ;
463 print "NO (from config/command line) \n " ;
468 if (! defined $answer ) {
469 $OUTPUT_AUTOFLUSH = 1 ;
471 "End of STDIN reached. Are you using xargs? Caff wants to read from STDIN, \n " .
472 "so you can't really use it with xargs. A patch against caff to read from \n " .
473 "the terminal would be appreciated. \n " .
474 "For now instead of cat keys | xargs caff do caff `cat keys` \n " ;
477 last if (( length $answer == 0 ) || ( $answer =~ m/^[yYnN]$/ ) );
478 print "What about $yn is so hard to understand? \n Answer with either 'n' or 'y' or just press enter for the default. \n " ;
481 my $result = $default ;
482 $result = 1 if $answer =~ /y/i ;
483 $result = 0 if $answer =~ /n/i ;
491 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt' ;
492 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay' ;
493 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig' ;
494 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)' ;
495 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey' ;
498 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al." ;
500 my $KEYSBASE = $CONFIG { 'caffhome' }. '/keys' ;
501 my $GNUPGHOME = $CONFIG { 'caffhome' }. '/gnupghome' ;
503 - d
$KEYSBASE || mkpath
( $KEYSBASE , 0 , 0700 ) or die ( "Cannot create $KEYSBASE : $! \n " );
504 - d
$GNUPGHOME || mkpath
( $GNUPGHOME , 0 , 0700 ) or die ( "Cannot create $GNUPGHOME : $! \n " );
507 my ( $sec , $min , $hour , $mday , $mon , $year , $wday , $yday , $isdst ) = localtime ( $NOW );
508 my $DATE_STRING = sprintf ( " %04d - %02d - %02d " , $year + 1900 , $mon + 1 , $mday );
513 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al. \n " ;
517 my ( $fd , $exitcode ) = @_ ;
519 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...] \n " ;
520 print $fd "Consult the manual page for more information. \n " ;
525 # export key $keyid from $gnupghome
528 my ( $gnupghome , $keyid ) = @_ ;
530 my $gpg = GnuPG
:: Interface
-> new ();
531 $gpg -> call ( $CONFIG { 'gpg' } );
532 if ( defined $gnupghome ) {
533 $gpg -> options -> hash_init (
534 'homedir' => $gnupghome ,
535 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
538 $gpg -> options -> hash_init (
539 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
542 $gpg -> options -> meta_interactive ( 0 );
543 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
544 my $pid = $gpg -> export_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
545 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
552 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
555 my ( $gnupghome , $asciikey ) = @_ ;
557 my $gpg = GnuPG
:: Interface
-> new ();
558 $gpg -> call ( $CONFIG { 'gpg' } );
559 $gpg -> options -> hash_init (
560 'homedir' => $gnupghome ,
561 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ] );
562 $gpg -> options -> meta_interactive ( 0 );
563 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
564 my $pid = $gpg -> import_keys ( handles
=> $handles );
565 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $asciikey , $inputfd , $stdoutfd , $stderrfd , $statusfd );
568 if ( $status !~ /^\[GNUPG:\] IMPORT_OK/m ) {
576 # Send an email to $address. If $can_encrypt is true then the mail
577 # will be PGP/MIME encrypted to $longkeyid.
579 # $longkeyid, $uid, and @attached will be used in the email and the template.
581 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
582 sub send_mail
($$$ @
) {
583 my ( $address , $can_encrypt , $key_id , @keys ) = @_ ;
585 my $template = Text
:: Template
-> new ( TYPE
=> 'STRING' , SOURCE
=> $CONFIG { 'mail-template' })
586 or die "Error creating template: $Text ::Template::ERROR" ;
589 for my $key ( @keys ) {
590 push @uids , $key ->{ 'text' };
592 my $message = $template -> fill_in ( HASH
=> { key
=> $key_id ,
594 owner
=> $CONFIG { 'owner' }})
595 or die "Error filling template in: $Text ::Template::ERROR" ;
597 my $message_entity = MIME
:: Entity
-> build (
598 Type
=> "text/plain" ,
600 Disposition
=> 'inline' ,
604 for my $key ( @keys ) {
605 $message_entity -> attach (
606 Type
=> "application/pgp-keys" ,
607 Disposition
=> 'attachment' ,
609 Description
=> "PGP Key 0x $key_id , uid " .( $key ->{ 'text' }). ' (' .( $key ->{ 'serial' }). '), signed by 0x' . $CONFIG { 'keyid' }[ 0 ],
610 Data
=> $key ->{ 'key' },
611 Filename
=> "0x $key_id ." . $key ->{ 'serial' }. ".signed-by-0x" . $CONFIG { 'keyid' }[ 0 ]. ".asc" );
615 my $message = $message_entity -> stringify ();
617 my $gpg = GnuPG
:: Interface
-> new ();
618 $gpg -> call ( $CONFIG { 'gpg' } );
619 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME ,
620 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
622 $gpg -> options -> meta_interactive ( 0 );
623 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
624 $gpg -> options -> push_recipients ( $key_id );
625 $gpg -> options -> push_recipients ( $CONFIG { 'also-encrypt-to' } ) if defined $CONFIG { 'also-encrypt-to' };
626 my $pid = $gpg -> encrypt ( handles
=> $handles );
627 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $message , $inputfd , $stdoutfd , $stderrfd , $statusfd );
630 warn ( "No data from gpg for list-key $key_id \n " );
635 $message_entity = MIME
:: Entity
-> build (
636 Type
=> 'multipart/encrypted; protocol="application/pgp-encrypted"' );
638 $message_entity -> attach (
639 Type
=> "application/pgp-encrypted" ,
640 Disposition
=> 'attachment' ,
642 Data
=> "Version: 1 \n " );
644 $message_entity -> attach (
645 Type
=> "application/octet-stream" ,
646 Filename
=> 'msg.asc' ,
647 Disposition
=> 'inline' ,
652 $message_entity -> head -> add ( "Subject" , "Your signed PGP key 0x $key_id " );
653 $message_entity -> head -> add ( "To" , $address );
654 $message_entity -> head -> add ( "From" , '"' . $CONFIG { 'owner' }. '" <' . $CONFIG { 'email' }. '>' );
655 $message_entity -> head -> add ( "Bcc" , $CONFIG { 'bcc' }) if defined $CONFIG { 'bcc' };
656 $message_entity -> head -> add ( "User-Agent" , $USER_AGENT );
657 $message_entity -> send ();
658 $message_entity -> stringify ();
662 # clean up a UID so that it can be used on the FS.
664 sub sanitize_uid
($) {
668 $good_uid =~ tr
#/:\\#_#;
669 trace2
( "[sanitize_uid] changed UID from $uid to $good_uid . \n " ) if $good_uid ne $uid ;
673 sub delete_signatures
($$$$$$) {
674 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $keyids ) = @_ ;
676 my $signed_by_me = 0 ;
678 my ( $stdout , $stderr , $status ) =
679 readwrite_gpg
( "delsig \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSIG_PROMPT , nocloseinput
=> 1 );
681 while ( $status =~ /$KEYEDIT_DELSIG_PROMPT/m ) {
682 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
683 my @sigline = grep { /^sig/ } ( split /\n/ , $stdout );
684 $stdout =~ s/\n/\\n/g ;
685 notice
( "[sigremoval] why are there " .( scalar @sigline ). " siglines in that part of the dialog!? got: $stdout " ) if scalar @sigline >= 2 ; # XXX
686 my $line = pop @sigline ;
688 if ( defined $line ) { # only if we found a sig here - we never remove revocation packets for instance
689 debug
( "[sigremoval] doing line $line ." );
690 my ( undef , undef , undef , undef , $signer , $created , undef , undef , undef ) = split /:/ , $line ;
691 if ( $signer eq $longkeyid ) {
692 debug
( "[sigremoval] selfsig ( $signer )." );
694 } elsif ( grep { $signer eq $_ } @
{ $keyids }) {
695 debug
( "[sigremoval] signed by us ( $signer )." );
697 $signed_by_me = $signed_by_me > $created ?
$signed_by_me : $created ;
699 debug
( "[sigremoval] not interested in that sig ( $signer )." );
703 debug
( "[sigremoval] no sig line here, only got: " . $stdout );
705 ( $stdout , $stderr , $status ) =
706 readwrite_gpg
( $answer . " \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT , nocloseinput
=> 1 );
709 return $signed_by_me ;
718 Getopt
:: Long
:: config
( 'bundling' );
720 '-h' => \
$params ->{ 'help' },
721 '--help' => \
$params ->{ 'help' },
722 '--version' => \
$params ->{ 'version' },
723 '-V' => \
$params ->{ 'version' },
724 '-u=s' => \
$params ->{ 'local-user' },
725 '--local-user=s' => \
$params ->{ 'local-user' },
726 '-e' => \
$params ->{ 'export-old' },
727 '--export-old' => \
$params ->{ 'export-old' },
728 '-E' => \
$params ->{ 'no-export-old' },
729 '--no-export-old' => \
$params ->{ 'no-export-old' },
730 '-m' => \
$params ->{ 'mail' },
731 '--mail' => \
$params ->{ 'mail' },
732 '-M' => \
$params ->{ 'no-mail' },
733 '--no-mail' => \
$params ->{ 'no-mail' },
734 '-R' => \
$params ->{ 'no-download' },
735 '--no-download' => \
$params ->{ 'no-download' },
736 '-S' => \
$params ->{ 'no-sign' },
737 '--no-sign' => \
$params ->{ 'no-sign' },
738 '--key-file=s@' => \
$params ->{ 'key-files' },
742 if ( $params ->{ 'help' }) {
745 if ( $params ->{ 'version' }) {
749 usage
( \
* STDERR
, 1 ) unless scalar @ARGV >= 1 ;
753 if ( $params ->{ 'local-user' }) {
754 $USER = $params ->{ 'local-user' };
756 unless ( $USER =~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i ) {
757 print STDERR
"-u $USER is not a keyid. \n " ;
763 for my $keyid ( @ARGV ) {
765 unless ( $keyid =~ /^([A-F0-9]{8}|[A-F0-9]{16}||[A-F0-9]{40})$/i ) {
766 if ( $keyid =~ /^[A-F0-9]{32}$/ ) {
767 info
( "Ignoring v3 fingerprint $keyid . v3 keys are obsolete." );
770 print STDERR
" $keyid is not a keyid. \n " ;
773 push @KEYIDS , uc ( $keyid );
776 $CONFIG { 'no-download' } = $params ->{ 'no-download' } if defined $params ->{ 'no-download' };
777 $CONFIG { 'no-mail' } = $params ->{ 'no-mail' } if defined $params ->{ 'no-mail' };
778 $CONFIG { 'mail' } = $params ->{ 'mail' } if defined $params ->{ 'mail' };
779 $CONFIG { 'no-sign' } = $params ->{ 'no-sign' } if defined $params ->{ 'no-sign' };
780 push @
{ $CONFIG { 'key-files' }}, @
{ $params ->{ 'key-files' }} if defined $params ->{ 'key-files' };
786 for my $keyid ( @
{ $CONFIG { 'keyid' }}) {
787 my $gpg = GnuPG
:: Interface
-> new ();
788 $gpg -> call ( $CONFIG { 'gpg' } );
789 $gpg -> options -> hash_init (
790 'homedir' => $GNUPGHOME ,
791 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
-- fast
- list
- mode
} ] );
792 $gpg -> options -> meta_interactive ( 0 );
793 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
794 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> $keyid );
795 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
799 warn ( "No data from gpg for list-key \n " ); # There should be at least 'tru:' everywhere.
801 unless ( $stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m ) {
802 info
( "Key $keyid not found in caff's home. Getting it from your normal GnuPGHome." );
803 my $key = export_key
( undef , $keyid );
804 if (! defined $key || $key eq '' ) {
805 warn ( "Did not get key $keyid from your normal GnuPGHome \n " );
808 my $result = import_key
( $GNUPGHOME , $key );
810 warn ( "Could not import $keyid into caff's gnupghome. \n " );
816 ########################
817 # import keys from files
818 ########################
819 foreach my $keyfile ( @
{ $CONFIG { 'key-files' }}) {
820 my $gpg = GnuPG
:: Interface
-> new ();
821 $gpg -> call ( $CONFIG { 'gpg' } );
822 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME );
823 $gpg -> options -> meta_interactive ( 0 );
824 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
825 my $pid = $gpg -> import_keys ( handles
=> $handles , command_args
=> $keyfile );
826 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
827 info
( "Importing keys from $keyfile " );
829 if ( $status !~ /^\[GNUPG:\] IMPORT_OK/m ) {
834 #############################
835 # receive keys from keyserver
836 #############################
838 if ( $CONFIG { 'no-download' }) {
839 @keyids_ok = @KEYIDS ;
841 info
( "fetching keys, this will take a while..." );
843 my $gpg = GnuPG
:: Interface
-> new ();
844 $gpg -> call ( $CONFIG { 'gpg' } );
845 $gpg -> options -> hash_init (
846 'homedir' => $GNUPGHOME ,
847 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
}, '--keyserver=' . $CONFIG { 'keyserver' } ] );
848 $gpg -> options -> meta_interactive ( 0 );
849 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
850 my $pid = $gpg -> recv_keys ( handles
=> $handles , command_args
=> [ @KEYIDS ]);
851 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
854 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
857 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
858 my %local_keyids = map { $_ => 1 } @KEYIDS ;
859 for my $line ( split /\n/ , $status ) {
860 if ( $line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/ ) {
861 my $imported_key = $1 ;
862 my $whole_fpr = $imported_key ;
863 my $long_keyid = substr ( $imported_key , - 16 );
864 my $short_keyid = substr ( $imported_key , - 8 );
866 for my $spec (( $whole_fpr , $long_keyid , $short_keyid )) {
867 $speced_key = $spec if $local_keyids { $spec };
869 unless ( $speced_key ) {
870 notice
( "Imported unexpected key; got: $imported_key \n " );
873 debug
( "Imported $imported_key for $speced_key " );
874 delete $local_keyids { $speced_key };
875 unshift @keyids_ok , $imported_key ;
876 } elsif ( $line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) / ) {
878 notice
( "got unknown reply from gpg: $line " );
881 if ( scalar %local_keyids ) {
882 notice
( "Import failed for: " . ( join ' ' , keys %local_keyids ). "." );
883 exit 1 unless ask
( "Some keys could not be imported - continue anyway?" , 0 );
887 unless ( @keyids_ok ) {
888 notice
( "No keys to sign found" );
895 if ( $CONFIG { 'ask-sign' } && ! $CONFIG { 'no-sign' }) {
896 $CONFIG { 'no-sign' } = ! ask
( "Continue with signing?" , 1 );
899 unless ( $CONFIG { 'no-sign' }) {
900 info
( "Sign the following keys according to your policy, then exit gpg with 'save' after signing each key" );
901 for my $keyid ( @keyids_ok ) {
903 push @command , $CONFIG { 'gpg-sign' };
904 push @command , '--local-user' , $USER if ( defined $USER );
905 push @command , "--homedir= $GNUPGHOME " ;
906 push @command , '--secret-keyring' , $CONFIG { 'secret-keyring' };
907 push @command , '--no-auto-check-trustdb' ;
908 push @command , '--trust-model=always' ;
909 push @command , '--edit' , $keyid ;
910 push @command , 'sign' ;
911 push @command , split ' ' , $CONFIG { 'gpg-sign-args' } || "" ;
912 print join ( ' ' , @command ), " \n " ;
921 for my $keyid ( @keyids_ok ) {
924 my $gpg = GnuPG
:: Interface
-> new ();
925 $gpg -> call ( $CONFIG { 'gpg' } );
926 $gpg -> options -> hash_init (
927 'homedir' => $GNUPGHOME ,
928 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
} ] );
929 $gpg -> options -> meta_interactive ( 0 );
930 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
931 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
932 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
935 warn ( "No data from gpg for list-key $keyid \n " );
938 my @publine = grep { /^pub/ } ( split /\n/ , $stdout );
939 if ( scalar @publine == 0 ) {
940 warn ( "No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME ). \n " );
943 my ( undef , undef , undef , undef , $longkeyid , undef , undef , undef , undef , undef , undef , $flags ) = split /:/ , pop @publine ;
944 if ( scalar @publine > 0 ) {
945 warn ( "More than one key matched $keyid . Try to specify the long keyid or fingerprint \n " );
948 unless ( defined $longkeyid ) {
949 warn ( "Didn't find public keyid in --list-key of key $keyid . \n " );
952 unless ( defined $flags ) {
953 warn ( "Didn't find flags in --list-key of key $keyid . \n " );
956 my $can_encrypt = $flags =~ /E/ ;
960 my $asciikey = export_key
( $GNUPGHOME , $keyid );
961 if ( $asciikey eq '' ) {
962 warn ( "No data from gpg for export $keyid \n " );
969 my $this_uid_text = '' ;
971 debug
( "Doing key $keyid , uid $uid_number " );
972 my $tempdir = tempdir
( "caff- $keyid -XXXXX" , DIR
=> '/tmp/' , CLEANUP
=> 1 );
974 # import into temporary gpghome
975 ###############################
976 my $result = import_key
( $tempdir , $asciikey );
978 warn ( "Could not import $keyid into temporary gnupg. \n " );
984 $gpg = GnuPG
:: Interface
-> new ();
985 $gpg -> call ( $CONFIG { 'gpg-delsig' } );
986 $gpg -> options -> hash_init (
987 'homedir' => $tempdir ,
988 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
-- command
- fd
= 0 -- no - tty
} ] );
989 ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
990 $pid = $gpg -> wrap_call (
991 commands
=> [ '--edit' ],
992 command_args
=> [ $keyid ],
993 handles
=> $handles );
995 debug
( "Starting edit session" );
996 ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1000 my $number_of_subkeys = 0 ;
1004 my $delete_some = 0 ;
1005 debug
( "Parsing stdout output." );
1006 for my $line ( split /\n/ , $stdout ) {
1007 debug
( "Checking line $line " );
1008 my ( $type , undef , undef , undef , undef , undef , undef , undef , undef , $uidtext ) = split /:/ , $line ;
1009 if ( $type eq 'sub' ) {
1010 $number_of_subkeys ++;
1012 next unless ( $type eq 'uid' || $type eq 'uat' );
1013 debug
( "line is interesting." );
1014 if ( $uid_number != $i ) {
1015 debug
( "mark for deletion." );
1016 readwrite_gpg
( " $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1021 $this_uid_text = ( $type eq 'uid' ) ?
$uidtext : '[attribute]' ;
1022 $is_uat = $type eq 'uat' ;
1026 debug
( "Parsing stdout output done." );
1027 unless ( $have_one ) {
1028 debug
( "Uid " .( $uid_number - 1 ). " was the last, there is no $uid_number ." );
1029 info
( "key $keyid done." );
1033 my $prune_some_sigs_on_uid ;
1034 my $prune_all_sigs_on_uid ;
1036 debug
( "handling attribute userid of key $keyid ." );
1037 if ( $uid_number == 1 ) {
1038 debug
( " attribute userid is #1, unmarking #2 for deletion." );
1039 readwrite_gpg
( "2 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1041 $prune_some_sigs_on_uid = 1 ;
1042 $prune_all_sigs_on_uid = 2 ;
1044 debug
( "attribute userid is not #1, unmarking #1 for deletion." );
1045 readwrite_gpg
( "1 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1047 $prune_some_sigs_on_uid = 2 ;
1048 $prune_all_sigs_on_uid = 1 ;
1051 $prune_some_sigs_on_uid = 1 ;
1055 debug
( "need to delete $delete_some uids." );
1056 readwrite_gpg
( "deluid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELUID_PROMPT , nocloseinput
=> 1 );
1057 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1062 if ( $number_of_subkeys > 0 ) {
1063 for ( my $i = 1 ; $i <= $number_of_subkeys ; $i ++) {
1064 readwrite_gpg
( "key $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1066 readwrite_gpg
( "delkey \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSUBKEY_PROMPT , nocloseinput
=> 1 );
1067 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1072 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1073 my $signed_by_me = delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $CONFIG { 'keyid' });
1074 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1075 if ( defined $prune_all_sigs_on_uid ) {
1076 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1077 delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , []);
1078 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1082 readwrite_gpg
( "save \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd );
1085 my $asciikey = export_key
( $tempdir , $keyid );
1086 if ( $asciikey eq '' ) {
1087 warn ( "No data from gpg for export $keyid \n " );
1091 if ( $signed_by_me ) {
1092 if ( $NOW - $signed_by_me > $CONFIG { 'export-sig-age' } ) {
1093 my $write = ask
( "Signature on $this_uid_text is old. Export?" , 0 , $params ->{ 'export-old' }, $params ->{ 'no-export-old' });
1096 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1097 - d
$keydir || mkpath
( $keydir , 0 , 0700 ) or die ( "Cannot create $keydir $! \n " );
1099 my $keyfile = " $keydir / $longkeyid .key. $uid_number ." . sanitize_uid
( $this_uid_text ). ".asc" ;
1100 open ( KEY
, "> $keyfile " ) or die ( "Cannot open $keyfile : $! \n " );
1101 print KEY
$asciikey ;
1104 push @UIDS , { text
=> $this_uid_text , key
=> $asciikey , serial
=> $uid_number , "is_uat" => $is_uat };
1106 info
( " $longkeyid $uid_number $this_uid_text done." );
1108 info
( " $longkeyid $uid_number $this_uid_text is not signed by me, not writing." );
1112 if ( scalar @UIDS == 0 ) {
1113 info
( "found no signed uids for $keyid " );
1115 next if $CONFIG { 'no-mail' }; # do not send mail
1118 for my $uid ( @UIDS ) {
1119 trace
( "UID: $uid ->{'text'} \n " );
1120 if ( $uid ->{ 'is_uat' }) {
1121 my $attach = ask
( "UID $uid ->{'text'} is an attribute UID, attach it to every email sent?" , 1 );
1122 push @attached , $uid if $attach ;
1123 } elsif ( $uid ->{ 'text' } !~ /@/ ) {
1124 my $attach = ask
( "UID $uid ->{'text'} is no email address, attach it to every email sent?" , 1 );
1125 push @attached , $uid if $attach ;
1129 notice
( "Key has no encryption capabilities, mail will be sent unencrypted" ) unless $can_encrypt ;
1130 for my $uid ( @UIDS ) {
1131 if (! $uid ->{ 'is_uat' } && ( $uid ->{ 'text' } =~ /@/ )) {
1132 my $address = $uid ->{ 'text' };
1133 $address =~ s/.*<(.*)>.*/$1/ ;
1134 if ( ask
( "Mail signature for $uid ->{'text'} to ' $address '?" , 1 , $CONFIG { 'mail' })) {
1135 my $mail = send_mail
( $address , $can_encrypt , $longkeyid , $uid , @attached );
1137 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1138 my $mailfile = " $keydir / $longkeyid .mail." . $uid ->{ 'serial' }. "." . sanitize_uid
( $uid ->{ 'text' });
1139 open ( KEY
, "> $mailfile " ) or die ( "Cannot open $mailfile : $! \n " );