]>
git.sthu.org Git - pgp-tools.git/blob - caff/caff
35739f0cb8d6eaa62066f0252b8a01dd9e6e2f1a
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 ) = @_ ;
443 print $question , ' ' ,( $default ?
'[Y/n]' : '[y/N]' ), ' ' ;
444 if ( $forceyes && $forceno ) {
445 print " $default (from config/command line) \n " ;
449 print "YES (from config/command line) \n " ;
453 print "NO (from config/command line) \n " ;
459 last if (( defined $answer ) && ( length $answer <= 1 ));
460 print "Error reading from STDIN (are you using caff with xargs?). \n " ;
463 my $result = $default ;
464 $result = 1 if $answer =~ /y/i ;
465 $result = 0 if $answer =~ /n/i ;
473 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt' ;
474 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay' ;
475 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig' ;
476 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)' ;
477 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey' ;
480 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al." ;
482 my $KEYSBASE = $CONFIG { 'caffhome' }. '/keys' ;
483 my $GNUPGHOME = $CONFIG { 'caffhome' }. '/gnupghome' ;
485 - d
$KEYSBASE || mkpath
( $KEYSBASE , 0 , 0700 ) or die ( "Cannot create $KEYSBASE : $! \n " );
486 - d
$GNUPGHOME || mkpath
( $GNUPGHOME , 0 , 0700 ) or die ( "Cannot create $GNUPGHOME : $! \n " );
489 my ( $sec , $min , $hour , $mday , $mon , $year , $wday , $yday , $isdst ) = localtime ( $NOW );
490 my $DATE_STRING = sprintf ( " %04d - %02d - %02d " , $year + 1900 , $mon + 1 , $mday );
495 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al. \n " ;
499 my ( $fd , $exitcode ) = @_ ;
501 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...] \n " ;
502 print $fd "Consult the manual page for more information. \n " ;
507 # export key $keyid from $gnupghome
510 my ( $gnupghome , $keyid ) = @_ ;
512 my $gpg = GnuPG
:: Interface
-> new ();
513 $gpg -> call ( $CONFIG { 'gpg' } );
514 if ( defined $gnupghome ) {
515 $gpg -> options -> hash_init (
516 'homedir' => $gnupghome ,
517 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
520 $gpg -> options -> hash_init (
521 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
524 $gpg -> options -> meta_interactive ( 0 );
525 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
526 my $pid = $gpg -> export_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
527 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
534 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
537 my ( $gnupghome , $asciikey ) = @_ ;
539 my $gpg = GnuPG
:: Interface
-> new ();
540 $gpg -> call ( $CONFIG { 'gpg' } );
541 $gpg -> options -> hash_init (
542 'homedir' => $gnupghome ,
543 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ] );
544 $gpg -> options -> meta_interactive ( 0 );
545 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
546 my $pid = $gpg -> import_keys ( handles
=> $handles );
547 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $asciikey , $inputfd , $stdoutfd , $stderrfd , $statusfd );
550 if ( $status !~ /^\[GNUPG:\] IMPORT_OK/m ) {
558 # Send an email to $address. If $can_encrypt is true then the mail
559 # will be PGP/MIME encrypted to $longkeyid.
561 # $longkeyid, $uid, and @attached will be used in the email and the template.
563 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
564 sub send_mail
($$$ @
) {
565 my ( $address , $can_encrypt , $key_id , @keys ) = @_ ;
567 my $template = Text
:: Template
-> new ( TYPE
=> 'STRING' , SOURCE
=> $CONFIG { 'mail-template' })
568 or die "Error creating template: $Text ::Template::ERROR" ;
571 for my $key ( @keys ) {
572 push @uids , $key ->{ 'text' };
574 my $message = $template -> fill_in ( HASH
=> { key
=> $key_id ,
576 owner
=> $CONFIG { 'owner' }})
577 or die "Error filling template in: $Text ::Template::ERROR" ;
579 my $message_entity = MIME
:: Entity
-> build (
580 Type
=> "text/plain" ,
582 Disposition
=> 'inline' ,
586 for my $key ( @keys ) {
587 $message_entity -> attach (
588 Type
=> "application/pgp-keys" ,
589 Disposition
=> 'attachment' ,
591 Description
=> "PGP Key 0x $key_id , uid " .( $key ->{ 'text' }). ' (' .( $key ->{ 'serial' }). '), signed by 0x' . $CONFIG { 'keyid' }[ 0 ],
592 Data
=> $key ->{ 'key' },
593 Filename
=> "0x $key_id ." . $key ->{ 'serial' }. ".signed-by-0x" . $CONFIG { 'keyid' }[ 0 ]. ".asc" );
597 my $message = $message_entity -> stringify ();
599 my $gpg = GnuPG
:: Interface
-> new ();
600 $gpg -> call ( $CONFIG { 'gpg' } );
601 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME ,
602 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
604 $gpg -> options -> meta_interactive ( 0 );
605 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
606 $gpg -> options -> push_recipients ( $key_id );
607 $gpg -> options -> push_recipients ( $CONFIG { 'also-encrypt-to' } ) if defined $CONFIG { 'also-encrypt-to' };
608 my $pid = $gpg -> encrypt ( handles
=> $handles );
609 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $message , $inputfd , $stdoutfd , $stderrfd , $statusfd );
612 warn ( "No data from gpg for list-key $key_id \n " );
617 $message_entity = MIME
:: Entity
-> build (
618 Type
=> 'multipart/encrypted; protocol="application/pgp-encrypted"' );
620 $message_entity -> attach (
621 Type
=> "application/pgp-encrypted" ,
622 Disposition
=> 'attachment' ,
624 Data
=> "Version: 1 \n " );
626 $message_entity -> attach (
627 Type
=> "application/octet-stream" ,
628 Filename
=> 'msg.asc' ,
629 Disposition
=> 'inline' ,
634 $message_entity -> head -> add ( "Subject" , "Your signed PGP key 0x $key_id " );
635 $message_entity -> head -> add ( "To" , $address );
636 $message_entity -> head -> add ( "From" , '"' . $CONFIG { 'owner' }. '" <' . $CONFIG { 'email' }. '>' );
637 $message_entity -> head -> add ( "Bcc" , $CONFIG { 'bcc' }) if defined $CONFIG { 'bcc' };
638 $message_entity -> head -> add ( "User-Agent" , $USER_AGENT );
639 $message_entity -> send ();
640 $message_entity -> stringify ();
644 # clean up a UID so that it can be used on the FS.
646 sub sanitize_uid
($) {
650 $good_uid =~ tr
#/:\\#_#;
651 trace2
( "[sanitize_uid] changed UID from $uid to $good_uid . \n " ) if $good_uid ne $uid ;
655 sub delete_signatures
($$$$$$) {
656 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $keyids ) = @_ ;
658 my $signed_by_me = 0 ;
660 my ( $stdout , $stderr , $status ) =
661 readwrite_gpg
( "delsig \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSIG_PROMPT , nocloseinput
=> 1 );
663 while ( $status =~ /$KEYEDIT_DELSIG_PROMPT/m ) {
664 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
665 my @sigline = grep { /^sig/ } ( split /\n/ , $stdout );
666 $stdout =~ s/\n/\\n/g ;
667 notice
( "[sigremoval] why are there " .( scalar @sigline ). " siglines in that part of the dialog!? got: $stdout " ) if scalar @sigline >= 2 ; # XXX
668 my $line = pop @sigline ;
670 if ( defined $line ) { # only if we found a sig here - we never remove revocation packets for instance
671 debug
( "[sigremoval] doing line $line ." );
672 my ( undef , undef , undef , undef , $signer , $created , undef , undef , undef ) = split /:/ , $line ;
673 if ( $signer eq $longkeyid ) {
674 debug
( "[sigremoval] selfsig ( $signer )." );
676 } elsif ( grep { $signer eq $_ } @
{ $keyids }) {
677 debug
( "[sigremoval] signed by us ( $signer )." );
679 $signed_by_me = $signed_by_me > $created ?
$signed_by_me : $created ;
681 debug
( "[sigremoval] not interested in that sig ( $signer )." );
685 debug
( "[sigremoval] no sig line here, only got: " . $stdout );
687 ( $stdout , $stderr , $status ) =
688 readwrite_gpg
( $answer . " \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT , nocloseinput
=> 1 );
691 return $signed_by_me ;
700 Getopt
:: Long
:: config
( 'bundling' );
702 '-h' => \
$params ->{ 'help' },
703 '--help' => \
$params ->{ 'help' },
704 '--version' => \
$params ->{ 'version' },
705 '-V' => \
$params ->{ 'version' },
706 '-u=s' => \
$params ->{ 'local-user' },
707 '--local-user=s' => \
$params ->{ 'local-user' },
708 '-e' => \
$params ->{ 'export-old' },
709 '--export-old' => \
$params ->{ 'export-old' },
710 '-E' => \
$params ->{ 'no-export-old' },
711 '--no-export-old' => \
$params ->{ 'no-export-old' },
712 '-m' => \
$params ->{ 'mail' },
713 '--mail' => \
$params ->{ 'mail' },
714 '-M' => \
$params ->{ 'no-mail' },
715 '--no-mail' => \
$params ->{ 'no-mail' },
716 '-R' => \
$params ->{ 'no-download' },
717 '--no-download' => \
$params ->{ 'no-download' },
718 '-S' => \
$params ->{ 'no-sign' },
719 '--no-sign' => \
$params ->{ 'no-sign' },
723 if ( $params ->{ 'help' }) {
726 if ( $params ->{ 'version' }) {
730 usage
( \
* STDERR
, 1 ) unless scalar @ARGV >= 1 ;
734 if ( $params ->{ 'local-user' }) {
735 $USER = $params ->{ 'local-user' };
737 unless ( $USER =~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i ) {
738 print STDERR
"-u $USER is not a keyid. \n " ;
744 for my $keyid ( @ARGV ) {
746 unless ( $keyid =~ /^([A-F0-9]{8}|[A-F0-9]{16}||[A-F0-9]{40})$/i ) {
747 if ( $keyid =~ /^[A-F0-9]{32}$/ ) {
748 info
( "Ignoring v3 fingerprint $keyid . v3 keys are obsolete." );
751 print STDERR
" $keyid is not a keyid. \n " ;
754 push @KEYIDS , uc ( $keyid );
757 $CONFIG { 'no-download' } = $params ->{ 'no-download' } if defined $params ->{ 'no-download' };
758 $CONFIG { 'no-mail' } = $params ->{ 'no-mail' } if defined $params ->{ 'no-mail' };
759 $CONFIG { 'mail' } = $params ->{ 'mail' } if defined $params ->{ 'mail' };
760 $CONFIG { 'no-sign' } = $params ->{ 'no-sign' } if defined $params ->{ 'no-sign' };
766 for my $keyid ( @
{ $CONFIG { 'keyid' }}) {
767 my $gpg = GnuPG
:: Interface
-> new ();
768 $gpg -> call ( $CONFIG { 'gpg' } );
769 $gpg -> options -> hash_init (
770 'homedir' => $GNUPGHOME ,
771 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
-- fast
- list
- mode
} ] );
772 $gpg -> options -> meta_interactive ( 0 );
773 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
774 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> $keyid );
775 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
779 warn ( "No data from gpg for list-key \n " ); # There should be at least 'tru:' everywhere.
781 unless ( $stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m ) {
782 info
( "Key $keyid not found in caff's home. Getting it from your normal GnuPGHome." );
783 my $key = export_key
( undef , $keyid );
784 if (! defined $key || $key eq '' ) {
785 warn ( "Did not get key $keyid from your normal GnuPGHome \n " );
788 my $result = import_key
( $GNUPGHOME , $key );
790 warn ( "Could not import $keyid into caff's gnupghome. \n " );
796 #############################
797 # receive keys from keyserver
798 #############################
800 if ( $CONFIG { 'no-download' }) {
801 @keyids_ok = @KEYIDS ;
803 info
( "fetching keys, this will take a while..." );
805 my $gpg = GnuPG
:: Interface
-> new ();
806 $gpg -> call ( $CONFIG { 'gpg' } );
807 $gpg -> options -> hash_init (
808 'homedir' => $GNUPGHOME ,
809 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
}, '--keyserver=' . $CONFIG { 'keyserver' } ] );
810 $gpg -> options -> meta_interactive ( 0 );
811 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
812 my $pid = $gpg -> recv_keys ( handles
=> $handles , command_args
=> [ @KEYIDS ]);
813 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
816 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
819 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
820 my %local_keyids = map { $_ => 1 } @KEYIDS ;
821 for my $line ( split /\n/ , $status ) {
822 if ( $line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/ ) {
823 my $imported_key = $1 ;
824 my $whole_fpr = $imported_key ;
825 my $long_keyid = substr ( $imported_key , - 16 );
826 my $short_keyid = substr ( $imported_key , - 8 );
828 for my $spec (( $whole_fpr , $long_keyid , $short_keyid )) {
829 $speced_key = $spec if $local_keyids { $spec };
831 unless ( $speced_key ) {
832 notice
( "Imported unexpected key; got: $imported_key \n " );
835 debug
( "Imported $imported_key for $speced_key " );
836 delete $local_keyids { $speced_key };
837 unshift @keyids_ok , $imported_key ;
838 } elsif ( $line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) / ) {
840 notice
( "got unknown reply from gpg: $line " );
843 if ( scalar %local_keyids ) {
844 notice
( "Import failed for: " . ( join ' ' , keys %local_keyids ). "." );
845 exit 1 unless ask
( "Some keys could not be imported - continue anyway?" , 0 );
849 unless ( @keyids_ok ) {
850 notice
( "No keys to sign found" );
857 if ( $CONFIG { 'ask-sign' } && ! $CONFIG { 'no-sign' }) {
858 $CONFIG { 'no-sign' } = ! ask
( "Continue with signing?" , 1 );
861 unless ( $CONFIG { 'no-sign' }) {
862 info
( "Sign the following keys according to your policy, then exit gpg with 'save' after signing each key" );
863 for my $keyid ( @keyids_ok ) {
865 push @command , $CONFIG { 'gpg-sign' };
866 push @command , '--local-user' , $USER if ( defined $USER );
867 push @command , "--homedir= $GNUPGHOME " ;
868 push @command , '--secret-keyring' , $CONFIG { 'secret-keyring' };
869 push @command , '--no-auto-check-trustdb' ;
870 push @command , '--trust-model=always' ;
871 push @command , '--edit' , $keyid ;
872 push @command , 'sign' ;
873 push @command , split ' ' , $CONFIG { 'gpg-sign-args' } || "" ;
874 print join ( ' ' , @command ), " \n " ;
883 for my $keyid ( @keyids_ok ) {
886 my $gpg = GnuPG
:: Interface
-> new ();
887 $gpg -> call ( $CONFIG { 'gpg' } );
888 $gpg -> options -> hash_init (
889 'homedir' => $GNUPGHOME ,
890 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
} ] );
891 $gpg -> options -> meta_interactive ( 0 );
892 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
893 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
894 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
897 warn ( "No data from gpg for list-key $keyid \n " );
900 my @publine = grep { /^pub/ } ( split /\n/ , $stdout );
901 if ( scalar @publine == 0 ) {
902 warn ( "No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME ). \n " );
905 my ( undef , undef , undef , undef , $longkeyid , undef , undef , undef , undef , undef , undef , $flags ) = split /:/ , pop @publine ;
906 if ( scalar @publine > 0 ) {
907 warn ( "More than one key matched $keyid . Try to specify the long keyid or fingerprint \n " );
910 unless ( defined $longkeyid ) {
911 warn ( "Didn't find public keyid in --list-key of key $keyid . \n " );
914 unless ( defined $flags ) {
915 warn ( "Didn't find flags in --list-key of key $keyid . \n " );
918 my $can_encrypt = $flags =~ /E/ ;
922 my $asciikey = export_key
( $GNUPGHOME , $keyid );
923 if ( $asciikey eq '' ) {
924 warn ( "No data from gpg for export $keyid \n " );
931 my $this_uid_text = '' ;
933 debug
( "Doing key $keyid , uid $uid_number " );
934 my $tempdir = tempdir
( "caff- $keyid -XXXXX" , DIR
=> '/tmp/' , CLEANUP
=> 1 );
936 # import into temporary gpghome
937 ###############################
938 my $result = import_key
( $tempdir , $asciikey );
940 warn ( "Could not import $keyid into temporary gnupg. \n " );
946 $gpg = GnuPG
:: Interface
-> new ();
947 $gpg -> call ( $CONFIG { 'gpg-delsig' } );
948 $gpg -> options -> hash_init (
949 'homedir' => $tempdir ,
950 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
-- command
- fd
= 0 -- no - tty
} ] );
951 ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
952 $pid = $gpg -> wrap_call (
953 commands
=> [ '--edit' ],
954 command_args
=> [ $keyid ],
955 handles
=> $handles );
957 debug
( "Starting edit session" );
958 ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
962 my $number_of_subkeys = 0 ;
967 debug
( "Parsing stdout output." );
968 for my $line ( split /\n/ , $stdout ) {
969 debug
( "Checking line $line " );
970 my ( $type , undef , undef , undef , undef , undef , undef , undef , undef , $uidtext ) = split /:/ , $line ;
971 if ( $type eq 'sub' ) {
972 $number_of_subkeys ++;
974 next unless ( $type eq 'uid' || $type eq 'uat' );
975 debug
( "line is interesting." );
976 if ( $uid_number != $i ) {
977 debug
( "mark for deletion." );
978 readwrite_gpg
( " $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
983 $this_uid_text = ( $type eq 'uid' ) ?
$uidtext : '[attribute]' ;
984 $is_uat = $type eq 'uat' ;
988 debug
( "Parsing stdout output done." );
990 debug
( "Uid " .( $uid_number - 1 ). " was the last, there is no $uid_number ." );
991 info
( "key $keyid done." );
995 my $prune_some_sigs_on_uid ;
996 my $prune_all_sigs_on_uid ;
998 debug
( "handling attribute userid of key $keyid ." );
999 if ( $uid_number == 1 ) {
1000 debug
( " attribute userid is #1, unmarking #2 for deletion." );
1001 readwrite_gpg
( "2 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1003 $prune_some_sigs_on_uid = 1 ;
1004 $prune_all_sigs_on_uid = 2 ;
1006 debug
( "attribute userid is not #1, unmarking #1 for deletion." );
1007 readwrite_gpg
( "1 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1009 $prune_some_sigs_on_uid = 2 ;
1010 $prune_all_sigs_on_uid = 1 ;
1013 $prune_some_sigs_on_uid = 1 ;
1017 debug
( "need to delete $delete_some uids." );
1018 readwrite_gpg
( "deluid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELUID_PROMPT , nocloseinput
=> 1 );
1019 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1024 if ( $number_of_subkeys > 0 ) {
1025 for ( my $i = 1 ; $i <= $number_of_subkeys ; $i ++) {
1026 readwrite_gpg
( "key $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1028 readwrite_gpg
( "delkey \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSUBKEY_PROMPT , nocloseinput
=> 1 );
1029 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1034 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1035 my $signed_by_me = delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $CONFIG { 'keyid' });
1036 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1037 if ( defined $prune_all_sigs_on_uid ) {
1038 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1039 delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , []);
1040 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1044 readwrite_gpg
( "save \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd );
1047 my $asciikey = export_key
( $tempdir , $keyid );
1048 if ( $asciikey eq '' ) {
1049 warn ( "No data from gpg for export $keyid \n " );
1053 if ( $signed_by_me ) {
1054 if ( $NOW - $signed_by_me > $CONFIG { 'export-sig-age' } ) {
1055 my $write = ask
( "Signature on $this_uid_text is old. Export?" , 0 , $params ->{ 'export-old' }, $params ->{ 'no-export-old' });
1058 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1059 - d
$keydir || mkpath
( $keydir , 0 , 0700 ) or die ( "Cannot create $keydir $! \n " );
1061 my $keyfile = " $keydir / $longkeyid .key. $uid_number ." . sanitize_uid
( $this_uid_text ). ".asc" ;
1062 open ( KEY
, "> $keyfile " ) or die ( "Cannot open $keyfile : $! \n " );
1063 print KEY
$asciikey ;
1066 push @UIDS , { text
=> $this_uid_text , key
=> $asciikey , serial
=> $uid_number , "is_uat" => $is_uat };
1068 info
( " $longkeyid $uid_number $this_uid_text done." );
1070 info
( " $longkeyid $uid_number $this_uid_text is not signed by me, not writing." );
1074 if ( scalar @UIDS == 0 ) {
1075 info
( "found no signed uids for $keyid " );
1077 next if $CONFIG { 'no-mail' }; # do not send mail
1080 for my $uid ( @UIDS ) {
1081 trace
( "UID: $uid ->{'text'} \n " );
1082 if ( $uid ->{ 'is_uat' }) {
1083 my $attach = ask
( "UID $uid ->{'text'} is an attribute UID, attach it to every email sent?" , 1 );
1084 push @attached , $uid if $attach ;
1085 } elsif ( $uid ->{ 'text' } !~ /@/ ) {
1086 my $attach = ask
( "UID $uid ->{'text'} is no email address, attach it to every email sent?" , 1 );
1087 push @attached , $uid if $attach ;
1091 notice
( "Key has no encryption capabilities, mail will be sent unencrypted" ) unless $can_encrypt ;
1092 for my $uid ( @UIDS ) {
1093 if (! $uid ->{ 'is_uat' } && ( $uid ->{ 'text' } =~ /@/ )) {
1094 my $address = $uid ->{ 'text' };
1095 $address =~ s/.*<(.*)>.*/$1/ ;
1096 if ( ask
( "Mail signature for $uid ->{'text'} to ' $address '?" , 1 , $CONFIG { 'mail' })) {
1097 my $mail = send_mail
( $address , $can_encrypt , $longkeyid , $uid , @attached );
1099 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1100 my $mailfile = " $keydir / $longkeyid .mail." . $uid ->{ 'serial' }. "." . sanitize_uid
( $uid ->{ 'text' });
1101 open ( KEY
, "> $mailfile " ) or die ( "Cannot open $mailfile : $! \n " );