]>
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
100 =item $HOME/.caff/keys/yyyy-mm-dd/ - processed keys
102 =item $HOME/.caff/gnupghome/ - caff's working dir for gpg
104 =item $HOME/.caff/gnupghome/gpg.conf - gpg configuration
106 useful options include use-agent, default-cert-level, etc.
110 =head1 CONFIGURATION FILE OPTIONS
112 The configuration file is a perl script that sets values in the hash B<%CONFIG>.
113 The file is generated when it does not exist.
117 $CONFIG{owner} = q{Peter Palfrader};
118 $CONFIG{email} = q{peter@palfrader.org};
119 $CONFIG{keyid} = [ qw{DE7AAF6E94C09C7F 62AF4031C82E0039} ];
121 =head2 Required basic settings
125 =item B<owner> [string]
127 Your name. B<REQUIRED>.
129 =item B<email> [string]
131 Your email address, used in From: lines. B<REQUIRED>.
133 =item B<keyid> [list of keyids]
135 A list of your keys. This is used to determine which signatures to keep
136 in the pruning step. If you select a key using B<-u> it has to be in
137 this list. B<REQUIRED>.
139 =head2 General settings
141 =item B<caffhome> [string]
143 Base directory for the files caff stores. Default: B<$HOME/.caff/>.
145 =head2 GnuPG settings
147 =item B<gpg> [string]
149 Path to the GnuPG binary. Default: B<gpg>.
151 =item B<gpg-sign> [string]
153 Path to the GnuPG binary which is used to sign keys. Default: what
156 =item B<gpg-delsig> [string]
158 Path to the GnuPG binary which is used to split off signatures. This was
159 needed while the upstream GnuPG was not fixed. Default: what B<gpg>
162 =item B<secret-keyring> [string]
164 Path to your secret keyring. Default: B<$HOME/.gnupg/secring.gpg>.
166 =item B<also-encrypt-to> [keyid]
168 An additional keyid to encrypt messages to. Default: none.
170 =item B<gpg-sign-args> [string]
172 Additional arguments to pass to gpg. Default: none.
174 =head2 Keyserver settings
176 =item B<keyserver> [string]
178 Keyserver to download keys from. Default: B<subkeys.pgp.net>.
180 =item B<no-download> [boolean]
182 If true, then skip the step of fetching keys from the keyserver.
185 =item B<key-files> [list of files]
187 A list of files containing keys to be imported.
189 =head2 Signing settings
191 =item B<no-sign> [boolean]
193 If true, then skip the signing step. Default: B<0>.
195 =item B<ask-sign> [boolean]
197 If true, then pause before continuing to the signing step.
198 This is useful for offline signing. Default: B<0>.
200 =item B<export-sig-age> [seconds]
202 Don't export UIDs by default, on which your latest signature is older
203 than this age. Default: B<24*60*60> (i.e. one day).
207 =item B<mail> [boolean]
209 Do not prompt for sending mail, just do it. Default: B<0>.
211 =item B<no-mail> [boolean]
213 Do not prompt for sending mail. The messages are still written to
214 $CONFIG{caffhome}/keys/. Default: B<0>.
216 =item B<mail-template> [string]
218 Email template which is used as the body text for the email sent out
219 instead of the default text if specified. The following perl variables
220 can be used in the template:
224 =item B<{owner}> [string]
226 Your name as specified in the L<B<owner>|/item_owner__5bstring_5d> setting.
228 =item B<{key}> [string]
230 The keyid of the key you signed.
232 =item B<{@uids}> [array]
234 The UIDs for which signatures are included in the mail.
238 =item B<reply-to> [string]
240 Add a Reply-To: header to messages sent. Default: none.
242 =item B<bcc> [string]
244 Address to send blind carbon copies to when sending mail.
253 =item Peter Palfrader <peter@palfrader.org>
255 =item Christoph Berg <cb@df7cb.de>
261 http://pgp-tools.alioth.debian.org/
265 gpg(1), pgp-clean(1), /usr/share/doc/signing-party/examples/caffrc.sample.
273 use File
:: Temp
qw{ tempdir
};
279 use GnuPG
:: Interface
;
282 my $REVISION = ' $Rev $' ;
283 my ( $REVISION_NUMER ) = $REVISION =~ /(\d+)/ ;
284 my $VERSION = "0.0.0. $REVISION_NUMER " ;
286 sub generate_config
() {
287 die "Error: \ $LOGNAME is not set. \n " unless $ENV { LOGNAME
};
288 my $gecos = ( getpwnam ( $ENV { LOGNAME
}))[ 6 ];
291 my $gpg = GnuPG
:: Interface
-> new ();
293 $gpg -> options -> hash_init (
294 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
} ] );
295 $gpg -> options -> meta_interactive ( 0 );
296 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
297 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> [ $gecos ]);
298 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
302 warn ( "No data from gpg for list-key \n " ); # There should be at least 'tru:' everywhere.
306 unless ( @keys = ( $stdout =~ /^pub:[^r:]*:(?:[^:]*:){2,2}([^:]+):/mg )) {
307 die "Error: No keys were found using \" gpg --list-public-keys ' $gecos ' \" . \n " ;
309 unless ( $stdout =~ /^uid:.*<(.+@.+)>.*:/m ) {
310 die "Error: No email address was found using \" gpg --list-public-keys ' $gecos ' \" . \n " ;
315 # .caffrc -- vim:syntax=perl:
316 # This file is in perl(1) format - see caff(1) for details.
318 \ $CONFIG {'owner'} = ' $gecos ';
319 \ $CONFIG {'email'} = ' $email ';
321 # you can get your long keyid from
322 # gpg --with-colons --list-key <yourkeyid|name|emailaddress..>
324 # if you have a v4 key, it will simply be the last 16 digits of
327 \ $CONFIG {'keyid'} = [ qw{ @keys } ];
332 my $config = $ENV { 'HOME' } . '/.caffrc' ;
333 unless (- f
$config ) {
334 print "No configfile $config present, I will use this template: \n " ;
335 my $template = generate_config
();
336 print " $template \n Please edit $config and run caff again. \n " ;
337 open F
, "> $config " or die " $config : $!" ;
342 unless ( scalar eval `cat $config ` ) {
343 die "Couldn't parse $config : $EVAL_ERROR \n " if $EVAL_ERROR ;
346 $CONFIG { 'caffhome' }= $ENV { 'HOME' }. '/.caff' unless defined $CONFIG { 'caffhome' };
347 die ( "owner is not defined. \n " ) unless defined $CONFIG { 'owner' };
348 die ( "email is not defined. \n " ) unless defined $CONFIG { 'email' };
349 die ( "keyid is not defined. \n " ) unless defined $CONFIG { 'keyid' };
350 die ( "keyid is not an array ref \n " ) unless ( ref $CONFIG { 'keyid' } eq 'ARRAY' );
351 for my $keyid ( @
{ $CONFIG { 'keyid' }}) {
352 $keyid =~ /^[A-F0-9]{16}$/i or die ( "key $keyid is not a long (16 digit) keyid. \n " );
354 @
{ $CONFIG { 'keyid' }} = map { uc } @
{ $CONFIG { 'keyid' }};
355 $CONFIG { 'export-sig-age' }= 24 * 60 * 60 unless defined $CONFIG { 'export-sig-age' };
356 $CONFIG { 'keyserver' } = 'subkeys.pgp.net' unless defined $CONFIG { 'keyserver' };
357 $CONFIG { 'gpg' } = 'gpg' unless defined $CONFIG { 'gpg' };
358 $CONFIG { 'gpg-sign' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-sign' };
359 $CONFIG { 'gpg-delsig' } = $CONFIG { 'gpg' } unless defined $CONFIG { 'gpg-delsig' };
360 $CONFIG { 'secret-keyring' } = $ENV { 'HOME' }. '/.gnupg/secring.gpg' unless defined $CONFIG { 'secret-keyring' };
361 $CONFIG { 'no-download' } = 0 unless defined $CONFIG { 'no-download' };
362 $CONFIG { 'no-sign' } = 0 unless defined $CONFIG { 'no-sign' };
363 $CONFIG { 'key-files' } = () unless defined $CONFIG { 'key-files' };
364 $CONFIG { 'mail-template' } = <<'EOM' unless defined $CONFIG {'mail-template'};
367 please find attached the user id{(scalar @uids >= 2 ? 's' : '')}.
368 {foreach $uid ( @uids ) {
369 $OUT .= " \t ". $uid ." \n ";
370 };} of your key { $key } signed by me.
372 Note that I did not upload your key to any keyservers.
373 If you have multiple user ids, I sent the signature for each user id
374 separately to that user id's associated email address. You can import
375 the signatures by running each through `gpg --import`.
377 If you want this new signature to be available to others, please upload
378 it yourself. With GnuPG this can be done using
379 gpg --keyserver subkeys.pgp.net --send-key { $key }
381 If you have any questions, don't hesitate to ask.
390 print "[NOTICE] $line \n " ;
394 print "[INFO] $line \n " ;
398 #print "[DEBUG] $line\n";
402 #print "[trace] $line\n";
406 #print "[trace2] $line\n";
411 stdin
=> IO
:: Handle
-> new (),
412 stdout
=> IO
:: Handle
-> new (),
413 stderr
=> IO
:: Handle
-> new (),
414 status
=> IO
:: Handle
-> new () );
415 my $handles = GnuPG
:: Handles
-> new ( %fds );
416 return ( $fds { 'stdin' }, $fds { 'stdout' }, $fds { 'stderr' }, $fds { 'status' }, $handles );
419 sub readwrite_gpg
($$$$$%) {
420 my ( $in , $inputfd , $stdoutfd , $stderrfd , $statusfd , %options ) = @_ ;
422 trace
( "Entering readwrite_gpg." );
424 my ( $first_line , undef ) = split /\n/ , $in ;
425 debug
( "readwrite_gpg sends " .( defined $first_line ?
$first_line : "<nothing>" ));
427 local $INPUT_RECORD_SEPARATOR = undef ;
428 my $sout = IO
:: Select
-> new ();
429 my $sin = IO
:: Select
-> new ();
432 trace
( "input is $inputfd ; output is $stdoutfd ; err is $stderrfd ; status is " .( defined $statusfd ?
$statusfd : 'undef' ). "." );
434 $inputfd -> blocking ( 0 );
435 $stdoutfd -> blocking ( 0 );
436 $statusfd -> blocking ( 0 ) if defined $statusfd ;
437 $stderrfd -> blocking ( 0 );
438 $sout -> add ( $stdoutfd );
439 $sout -> add ( $stderrfd );
440 $sout -> add ( $statusfd ) if defined $statusfd ;
443 my ( $stdout , $stderr , $status ) = ( "" , "" , "" );
444 my $exitwhenstatusmatches = $options { 'exitwhenstatusmatches' };
445 trace
( "doing stuff until we find $exitwhenstatusmatches " ) if defined $exitwhenstatusmatches ;
447 my $readwrote_stuff_this_time = 0 ;
448 my $do_not_wait_on_select = 0 ;
449 my ( $readyr , $readyw , $written );
450 while ( $sout -> count () > 0 || ( defined ( $sin ) && ( $sin -> count () > 0 ))) {
451 if ( defined $exitwhenstatusmatches ) {
452 if ( $status =~ /$exitwhenstatusmatches/m ) {
453 trace
( "readwrite_gpg found match on $exitwhenstatusmatches " );
454 if ( $readwrote_stuff_this_time ) {
455 trace
( "read/write some more \n " );
456 $do_not_wait_on_select = 1 ;
458 trace
( "that's it in our while loop. \n " );
464 $readwrote_stuff_this_time = 0 ;
465 trace
( "select waiting for " .( $sout -> count ()). " fds." );
466 ( $readyr , $readyw , undef ) = IO
:: Select
:: select ( $sout , $sin , undef , $do_not_wait_on_select ?
0 : 1 );
467 trace
( "ready: write: " .( defined $readyw ?
scalar @
$readyw : 0 ). "; read: " .( defined $readyr ?
scalar @
$readyr : 0 ));
468 for my $wfd ( @
$readyw ) {
469 $readwrote_stuff_this_time = 1 ;
470 if ( length ( $in ) != $offset ) {
471 trace
( "writing to $wfd ." );
472 $written = $wfd -> syswrite ( $in , length ( $in ) - $offset , $offset );
475 if ( $offset == length ( $in )) {
476 trace
( "writing to $wfd done." );
477 unless ( $options { 'nocloseinput' }) {
479 trace
( " $wfd closed." );
486 next unless ( defined ( @
$readyr )); # Wait some more.
488 for my $rfd ( @
$readyr ) {
489 $readwrote_stuff_this_time = 1 ;
491 trace
( "reading from $rfd done." );
496 trace
( "reading from $rfd ." );
497 if ( $rfd == $stdoutfd ) {
499 trace2
( "stdout is now $stdout \n ================" );
502 if ( defined $statusfd && $rfd == $statusfd ) {
504 trace2
( "status is now $status \n ================" );
507 if ( $rfd == $stderrfd ) {
509 trace2
( "stderr is now $stderr \n ================" );
514 trace
( "readwrite_gpg done." );
515 return ( $stdout , $stderr , $status );
519 my ( $question , $default , $forceyes , $forceno ) = @_ ;
521 my $yn = $default ?
'[Y/n]' : '[y/N]' ;
523 print $question , ' ' , $yn , ' ' ;
524 if ( $forceyes && $forceno ) {
525 print " $default (from config/command line) \n " ;
529 print "YES (from config/command line) \n " ;
533 print "NO (from config/command line) \n " ;
538 if (! defined $answer ) {
539 $OUTPUT_AUTOFLUSH = 1 ;
541 "End of STDIN reached. Are you using xargs? Caff wants to read from STDIN, \n " .
542 "so you can't really use it with xargs. A patch against caff to read from \n " .
543 "the terminal would be appreciated. \n " .
544 "For now instead of cat keys | xargs caff do caff `cat keys` \n " ;
547 last if (( length $answer == 0 ) || ( $answer =~ m/^[yYnN]$/ ) );
548 print "What about $yn is so hard to understand? \n Answer with either 'n' or 'y' or just press enter for the default. \n " ;
551 my $result = $default ;
552 $result = 1 if $answer =~ /y/i ;
553 $result = 0 if $answer =~ /n/i ;
561 my $KEYEDIT_PROMPT = '^\[GNUPG:\] GET_LINE keyedit.prompt' ;
562 my $KEYEDIT_DELUID_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.uid.okay' ;
563 my $KEYEDIT_DELSIG_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.delsig' ;
564 my $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT = '^\[GNUPG:\] (GET_BOOL keyedit.delsig|GET_LINE keyedit.prompt)' ;
565 my $KEYEDIT_DELSUBKEY_PROMPT = '^\[GNUPG:\] GET_BOOL keyedit.remove.subkey' ;
568 my $USER_AGENT = "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al." ;
570 my $KEYSBASE = $CONFIG { 'caffhome' }. '/keys' ;
571 my $GNUPGHOME = $CONFIG { 'caffhome' }. '/gnupghome' ;
573 - d
$KEYSBASE || mkpath
( $KEYSBASE , 0 , 0700 ) or die ( "Cannot create $KEYSBASE : $! \n " );
574 - d
$GNUPGHOME || mkpath
( $GNUPGHOME , 0 , 0700 ) or die ( "Cannot create $GNUPGHOME : $! \n " );
577 my ( $sec , $min , $hour , $mday , $mon , $year , $wday , $yday , $isdst ) = localtime ( $NOW );
578 my $DATE_STRING = sprintf ( " %04d - %02d - %02d " , $year + 1900 , $mon + 1 , $mday );
583 print $fd "caff $VERSION - (c) 2004, 2005 Peter Palfrader et al. \n " ;
587 my ( $fd , $exitcode ) = @_ ;
589 print $fd "Usage: $PROGRAM_NAME [-eEmMRS] [-u <yourkeyid>] <keyid> [<keyid> ...] \n " ;
590 print $fd "Consult the manual page for more information. \n " ;
595 # export key $keyid from $gnupghome
598 my ( $gnupghome , $keyid ) = @_ ;
600 my $gpg = GnuPG
:: Interface
-> new ();
601 $gpg -> call ( $CONFIG { 'gpg' } );
602 if ( defined $gnupghome ) {
603 $gpg -> options -> hash_init (
604 'homedir' => $gnupghome ,
605 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
608 $gpg -> options -> hash_init (
609 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
612 $gpg -> options -> meta_interactive ( 0 );
613 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
614 my $pid = $gpg -> export_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
615 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
622 # import a key from the scalar $asciikey into a gpg homedirectory in $tempdir
625 my ( $gnupghome , $asciikey ) = @_ ;
627 my $gpg = GnuPG
:: Interface
-> new ();
628 $gpg -> call ( $CONFIG { 'gpg' } );
629 $gpg -> options -> hash_init (
630 'homedir' => $gnupghome ,
631 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ] );
632 $gpg -> options -> meta_interactive ( 0 );
633 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
634 my $pid = $gpg -> import_keys ( handles
=> $handles );
635 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $asciikey , $inputfd , $stdoutfd , $stderrfd , $statusfd );
638 if ( $status !~ /^\[GNUPG:\] IMPORT_OK/m ) {
646 # Send an email to $address. If $can_encrypt is true then the mail
647 # will be PGP/MIME encrypted to $longkeyid.
649 # $longkeyid, $uid, and @attached will be used in the email and the template.
651 #send_mail($address, $can_encrypt, $longkeyid, $uid, @attached);
652 sub send_mail
($$$ @
) {
653 my ( $address , $can_encrypt , $key_id , @keys ) = @_ ;
655 my $template = Text
:: Template
-> new ( TYPE
=> 'STRING' , SOURCE
=> $CONFIG { 'mail-template' })
656 or die "Error creating template: $Text ::Template::ERROR" ;
659 for my $key ( @keys ) {
660 push @uids , $key ->{ 'text' };
662 my $message = $template -> fill_in ( HASH
=> { key
=> $key_id ,
664 owner
=> $CONFIG { 'owner' }})
665 or die "Error filling template in: $Text ::Template::ERROR" ;
667 my $message_entity = MIME
:: Entity
-> build (
668 Type
=> "text/plain" ,
670 Disposition
=> 'inline' ,
674 for my $key ( @keys ) {
675 $message_entity -> attach (
676 Type
=> "application/pgp-keys" ,
677 Disposition
=> 'attachment' ,
679 Description
=> "PGP Key 0x $key_id , uid " .( $key ->{ 'text' }). ' (' .( $key ->{ 'serial' }). '), signed by 0x' . $CONFIG { 'keyid' }[ 0 ],
680 Data
=> $key ->{ 'key' },
681 Filename
=> "0x $key_id ." . $key ->{ 'serial' }. ".signed-by-0x" . $CONFIG { 'keyid' }[ 0 ]. ".asc" );
685 my $message = $message_entity -> stringify ();
687 my $gpg = GnuPG
:: Interface
-> new ();
688 $gpg -> call ( $CONFIG { 'gpg' } );
689 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME ,
690 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
} ],
692 $gpg -> options -> meta_interactive ( 0 );
693 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
694 $gpg -> options -> push_recipients ( $key_id );
695 $gpg -> options -> push_recipients ( $CONFIG { 'also-encrypt-to' } ) if defined $CONFIG { 'also-encrypt-to' };
696 my $pid = $gpg -> encrypt ( handles
=> $handles );
697 my ( $stdout , $stderr , $status ) = readwrite_gpg
( $message , $inputfd , $stdoutfd , $stderrfd , $statusfd );
700 warn ( "No data from gpg for list-key $key_id \n " );
705 $message_entity = MIME
:: Entity
-> build (
706 Type
=> 'multipart/encrypted; protocol="application/pgp-encrypted"' );
708 $message_entity -> attach (
709 Type
=> "application/pgp-encrypted" ,
710 Disposition
=> 'attachment' ,
712 Data
=> "Version: 1 \n " );
714 $message_entity -> attach (
715 Type
=> "application/octet-stream" ,
716 Filename
=> 'msg.asc' ,
717 Disposition
=> 'inline' ,
722 $message_entity -> head -> add ( "Subject" , "Your signed PGP key 0x $key_id " );
723 $message_entity -> head -> add ( "To" , $address );
724 $message_entity -> head -> add ( "From" , '"' . $CONFIG { 'owner' }. '" <' . $CONFIG { 'email' }. '>' );
725 $message_entity -> head -> add ( "Reply-To" , $CONFIG { 'reply-to' }) if defined $CONFIG { 'reply-to' };
726 $message_entity -> head -> add ( "Bcc" , $CONFIG { 'bcc' }) if defined $CONFIG { 'bcc' };
727 $message_entity -> head -> add ( "User-Agent" , $USER_AGENT );
728 $message_entity -> send ();
729 $message_entity -> stringify ();
733 # clean up a UID so that it can be used on the FS.
735 sub sanitize_uid
($) {
739 $good_uid =~ tr
#/:\\#_#;
740 trace2
( "[sanitize_uid] changed UID from $uid to $good_uid . \n " ) if $good_uid ne $uid ;
744 sub delete_signatures
($$$$$$) {
745 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $keyids ) = @_ ;
747 my $signed_by_me = 0 ;
749 my ( $stdout , $stderr , $status ) =
750 readwrite_gpg
( "delsig \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSIG_PROMPT , nocloseinput
=> 1 );
752 while ( $status =~ /$KEYEDIT_DELSIG_PROMPT/m ) {
753 # sig:?::17:EA2199412477CAF8:1058095214:::::13x:
754 my @sigline = grep { /^sig/ } ( split /\n/ , $stdout );
755 $stdout =~ s/\n/\\n/g ;
756 notice
( "[sigremoval] why are there " .( scalar @sigline ). " siglines in that part of the dialog!? got: $stdout " ) if scalar @sigline >= 2 ; # XXX
757 my $line = pop @sigline ;
759 if ( defined $line ) { # only if we found a sig here - we never remove revocation packets for instance
760 debug
( "[sigremoval] doing line $line ." );
761 my ( undef , undef , undef , undef , $signer , $created , undef , undef , undef ) = split /:/ , $line ;
762 if ( $signer eq $longkeyid ) {
763 debug
( "[sigremoval] selfsig ( $signer )." );
765 } elsif ( grep { $signer eq $_ } @
{ $keyids }) {
766 debug
( "[sigremoval] signed by us ( $signer )." );
768 $signed_by_me = $signed_by_me > $created ?
$signed_by_me : $created ;
770 debug
( "[sigremoval] not interested in that sig ( $signer )." );
774 debug
( "[sigremoval] no sig line here, only got: " . $stdout );
776 ( $stdout , $stderr , $status ) =
777 readwrite_gpg
( $answer . " \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_KEYEDIT_OR_DELSIG_PROMPT , nocloseinput
=> 1 );
780 return $signed_by_me ;
789 Getopt
:: Long
:: config
( 'bundling' );
791 '-h' => \
$params ->{ 'help' },
792 '--help' => \
$params ->{ 'help' },
793 '--version' => \
$params ->{ 'version' },
794 '-V' => \
$params ->{ 'version' },
795 '-u=s' => \
$params ->{ 'local-user' },
796 '--local-user=s' => \
$params ->{ 'local-user' },
797 '-e' => \
$params ->{ 'export-old' },
798 '--export-old' => \
$params ->{ 'export-old' },
799 '-E' => \
$params ->{ 'no-export-old' },
800 '--no-export-old' => \
$params ->{ 'no-export-old' },
801 '-m' => \
$params ->{ 'mail' },
802 '--mail' => \
$params ->{ 'mail' },
803 '-M' => \
$params ->{ 'no-mail' },
804 '--no-mail' => \
$params ->{ 'no-mail' },
805 '-R' => \
$params ->{ 'no-download' },
806 '--no-download' => \
$params ->{ 'no-download' },
807 '-S' => \
$params ->{ 'no-sign' },
808 '--no-sign' => \
$params ->{ 'no-sign' },
809 '--key-file=s@' => \
$params ->{ 'key-files' },
813 if ( $params ->{ 'help' }) {
816 if ( $params ->{ 'version' }) {
820 usage
( \
* STDERR
, 1 ) unless scalar @ARGV >= 1 ;
824 if ( $params ->{ 'local-user' }) {
825 $USER = $params ->{ 'local-user' };
827 unless ( $USER =~ /^([A-F0-9]{8}|[A-F0-9]{16}|[A-F0-9]{40})$/i ) {
828 print STDERR
"-u $USER is not a keyid. \n " ;
834 for my $keyid ( @ARGV ) {
836 unless ( $keyid =~ /^([A-F0-9]{8}|[A-F0-9]{16}||[A-F0-9]{40})$/i ) {
837 if ( $keyid =~ /^[A-F0-9]{32}$/ ) {
838 info
( "Ignoring v3 fingerprint $keyid . v3 keys are obsolete." );
841 print STDERR
" $keyid is not a keyid. \n " ;
844 push @KEYIDS , uc ( $keyid );
847 $CONFIG { 'no-download' } = $params ->{ 'no-download' } if defined $params ->{ 'no-download' };
848 $CONFIG { 'no-mail' } = $params ->{ 'no-mail' } if defined $params ->{ 'no-mail' };
849 $CONFIG { 'mail' } = $params ->{ 'mail' } if defined $params ->{ 'mail' };
850 $CONFIG { 'no-sign' } = $params ->{ 'no-sign' } if defined $params ->{ 'no-sign' };
851 push @
{ $CONFIG { 'key-files' }}, @
{ $params ->{ 'key-files' }} if defined $params ->{ 'key-files' };
857 for my $keyid ( @
{ $CONFIG { 'keyid' }}) {
858 my $gpg = GnuPG
:: Interface
-> new ();
859 $gpg -> call ( $CONFIG { 'gpg' } );
860 $gpg -> options -> hash_init (
861 'homedir' => $GNUPGHOME ,
862 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
-- fast
- list
- mode
} ] );
863 $gpg -> options -> meta_interactive ( 0 );
864 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
865 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> $keyid );
866 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
870 warn ( "No data from gpg for list-key \n " ); # There should be at least 'tru:' everywhere.
872 unless ( $stdout =~ /^pub:(?:[^:]*:){3,3}$keyid:/m ) {
873 info
( "Key $keyid not found in caff's home. Getting it from your normal GnuPGHome." );
874 my $key = export_key
( undef , $keyid );
875 if (! defined $key || $key eq '' ) {
876 warn ( "Did not get key $keyid from your normal GnuPGHome \n " );
879 my $result = import_key
( $GNUPGHOME , $key );
881 warn ( "Could not import $keyid into caff's gnupghome. \n " );
887 ########################
888 # import keys from files
889 ########################
890 foreach my $keyfile ( @
{ $CONFIG { 'key-files' }}) {
891 my $gpg = GnuPG
:: Interface
-> new ();
892 $gpg -> call ( $CONFIG { 'gpg' } );
893 $gpg -> options -> hash_init ( 'homedir' => $GNUPGHOME );
894 $gpg -> options -> meta_interactive ( 0 );
895 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
896 my $pid = $gpg -> import_keys ( handles
=> $handles , command_args
=> $keyfile );
897 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
898 info
( "Importing keys from $keyfile " );
900 if ( $status !~ /^\[GNUPG:\] IMPORT_OK/m ) {
905 #############################
906 # receive keys from keyserver
907 #############################
909 if ( $CONFIG { 'no-download' }) {
910 @keyids_ok = @KEYIDS ;
912 info
( "fetching keys, this will take a while..." );
914 my $gpg = GnuPG
:: Interface
-> new ();
915 $gpg -> call ( $CONFIG { 'gpg' } );
916 $gpg -> options -> hash_init (
917 'homedir' => $GNUPGHOME ,
918 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
}, '--keyserver=' . $CONFIG { 'keyserver' } ] );
919 $gpg -> options -> meta_interactive ( 0 );
920 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
921 my $pid = $gpg -> recv_keys ( handles
=> $handles , command_args
=> [ @KEYIDS ]);
922 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
925 # [GNUPG:] IMPORT_OK 0 5B00C96D5D54AEE1206BAF84DE7AAF6E94C09C7F
928 # [GNUPG:] IMPORT_OK 0 25FC1614B8F87B52FF2F99B962AF4031C82E0039
929 my %local_keyids = map { $_ => 1 } @KEYIDS ;
931 for my $line ( split /\n/ , $status ) {
932 if ( $line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{40})/ ) {
933 my $imported_key = $1 ;
934 my $whole_fpr = $imported_key ;
935 my $long_keyid = substr ( $imported_key , - 16 );
936 my $short_keyid = substr ( $imported_key , - 8 );
938 for my $spec (( $whole_fpr , $long_keyid , $short_keyid )) {
939 $speced_key = $spec if $local_keyids { $spec };
941 unless ( $speced_key ) {
942 notice
( "Imported unexpected key; got: $imported_key \n " );
945 debug
( "Imported $imported_key for $speced_key " );
946 delete $local_keyids { $speced_key };
947 unshift @keyids_ok , $imported_key ;
948 } elsif ( $line =~ /^\[GNUPG:\] (NODATA|IMPORT_RES|IMPORTED) / ) {
949 } elsif ( $line =~ /^\[GNUPG:\] IMPORT_OK \d+ ([0-9A-F]{32})/ ) {
950 my $imported_key = $1 ;
951 notice
( "Imported key $1 is a version 3 key. Version 3 keys are obsolete, should not be used, and are not and will not be properly supported." );
954 notice
( "got unknown reply from gpg: $line " );
957 if ( scalar %local_keyids ) {
958 notice
( "Import failed for: " . ( join ' ' , keys %local_keyids ). "." . ( $had_v3_keys ?
" (Or maybe it's one of those ugly v3 keys?)" : "" ));
959 exit 1 unless ask
( "Some keys could not be imported - continue anyway?" , 0 );
963 unless ( @keyids_ok ) {
964 notice
( "No keys to sign found" );
971 if ( $CONFIG { 'ask-sign' } && ! $CONFIG { 'no-sign' }) {
972 $CONFIG { 'no-sign' } = ! ask
( "Continue with signing?" , 1 );
975 unless ( $CONFIG { 'no-sign' }) {
976 info
( "Sign the following keys according to your policy, then exit gpg with 'save' after signing each key" );
977 for my $keyid ( @keyids_ok ) {
979 push @command , $CONFIG { 'gpg-sign' };
980 push @command , '--local-user' , $USER if ( defined $USER );
981 push @command , "--homedir= $GNUPGHOME " ;
982 push @command , '--secret-keyring' , $CONFIG { 'secret-keyring' };
983 push @command , '--no-auto-check-trustdb' ;
984 push @command , '--trust-model=always' ;
985 push @command , '--edit' , $keyid ;
986 push @command , 'sign' ;
987 push @command , split ' ' , $CONFIG { 'gpg-sign-args' } || "" ;
988 print join ( ' ' , @command ), " \n " ;
997 for my $keyid ( @keyids_ok ) {
1000 my $gpg = GnuPG
:: Interface
-> new ();
1001 $gpg -> call ( $CONFIG { 'gpg' } );
1002 $gpg -> options -> hash_init (
1003 'homedir' => $GNUPGHOME ,
1004 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
} ] );
1005 $gpg -> options -> meta_interactive ( 0 );
1006 my ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
1007 my $pid = $gpg -> list_public_keys ( handles
=> $handles , command_args
=> [ $keyid ]);
1008 my ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd );
1010 if ( $stdout eq '' ) {
1011 warn ( "No data from gpg for list-key $keyid \n " );
1014 my @publine = grep { /^pub/ } ( split /\n/ , $stdout );
1015 if ( scalar @publine == 0 ) {
1016 warn ( "No public keys found with list-key $keyid (note that caff uses its own keyring in $GNUPGHOME ). \n " );
1019 my ( undef , undef , undef , undef , $longkeyid , undef , undef , undef , undef , undef , undef , $flags ) = split /:/ , pop @publine ;
1020 if ( scalar @publine > 0 ) {
1021 warn ( "More than one key matched $keyid . Try to specify the long keyid or fingerprint \n " );
1024 unless ( defined $longkeyid ) {
1025 warn ( "Didn't find public keyid in --list-key of key $keyid . \n " );
1028 unless ( defined $flags ) {
1029 warn ( "Didn't find flags in --list-key of key $keyid . \n " );
1032 my $can_encrypt = $flags =~ /E/ ;
1036 my $asciikey = export_key
( $GNUPGHOME , $keyid );
1037 if ( $asciikey eq '' ) {
1038 warn ( "No data from gpg for export $keyid \n " );
1045 my $this_uid_text = '' ;
1047 debug
( "Doing key $keyid , uid $uid_number " );
1048 my $tempdir = tempdir
( "caff- $keyid -XXXXX" , DIR
=> '/tmp/' , CLEANUP
=> 1 );
1050 # import into temporary gpghome
1051 ###############################
1052 my $result = import_key
( $tempdir , $asciikey );
1054 warn ( "Could not import $keyid into temporary gnupg. \n " );
1060 $gpg = GnuPG
:: Interface
-> new ();
1061 $gpg -> call ( $CONFIG { 'gpg-delsig' } );
1062 $gpg -> options -> hash_init (
1063 'homedir' => $tempdir ,
1064 'extra_args' => [ qw{ -- no - auto
- check
- trustdb
-- trust
- model
= always
-- with
- colons
-- fixed
- list
- mode
-- command
- fd
= 0 -- no - tty
} ] );
1065 ( $inputfd , $stdoutfd , $stderrfd , $statusfd , $handles ) = make_gpg_fds
();
1066 $pid = $gpg -> wrap_call (
1067 commands
=> [ '--edit' ],
1068 command_args
=> [ $keyid ],
1069 handles
=> $handles );
1071 debug
( "Starting edit session" );
1072 ( $stdout , $stderr , $status ) = readwrite_gpg
( '' , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1076 my $number_of_subkeys = 0 ;
1080 my $delete_some = 0 ;
1081 debug
( "Parsing stdout output." );
1082 for my $line ( split /\n/ , $stdout ) {
1083 debug
( "Checking line $line " );
1084 my ( $type , undef , undef , undef , undef , undef , undef , undef , undef , $uidtext ) = split /:/ , $line ;
1085 if ( $type eq 'sub' ) {
1086 $number_of_subkeys ++;
1088 next unless ( $type eq 'uid' || $type eq 'uat' );
1089 debug
( "line is interesting." );
1090 if ( $uid_number != $i ) {
1091 debug
( "mark for deletion." );
1092 readwrite_gpg
( " $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1097 $this_uid_text = ( $type eq 'uid' ) ?
$uidtext : '[attribute]' ;
1098 $is_uat = $type eq 'uat' ;
1102 debug
( "Parsing stdout output done." );
1103 unless ( $have_one ) {
1104 debug
( "Uid " .( $uid_number - 1 ). " was the last, there is no $uid_number ." );
1105 info
( "key $keyid done." );
1109 my $prune_some_sigs_on_uid ;
1110 my $prune_all_sigs_on_uid ;
1112 debug
( "handling attribute userid of key $keyid ." );
1113 if ( $uid_number == 1 ) {
1114 debug
( " attribute userid is #1, unmarking #2 for deletion." );
1115 readwrite_gpg
( "2 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1117 $prune_some_sigs_on_uid = 1 ;
1118 $prune_all_sigs_on_uid = 2 ;
1120 debug
( "attribute userid is not #1, unmarking #1 for deletion." );
1121 readwrite_gpg
( "1 \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1123 $prune_some_sigs_on_uid = 2 ;
1124 $prune_all_sigs_on_uid = 1 ;
1127 $prune_some_sigs_on_uid = 1 ;
1131 debug
( "need to delete $delete_some uids." );
1132 readwrite_gpg
( "deluid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELUID_PROMPT , nocloseinput
=> 1 );
1133 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1138 if ( $number_of_subkeys > 0 ) {
1139 for ( my $i = 1 ; $i <= $number_of_subkeys ; $i ++) {
1140 readwrite_gpg
( "key $i \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1142 readwrite_gpg
( "delkey \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_DELSUBKEY_PROMPT , nocloseinput
=> 1 );
1143 readwrite_gpg
( "yes \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 );
1148 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1149 my $signed_by_me = delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , $CONFIG { 'keyid' });
1150 readwrite_gpg
( " $prune_some_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1151 if ( defined $prune_all_sigs_on_uid ) {
1152 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # mark uid for delsig
1153 delete_signatures
( $inputfd , $stdoutfd , $stderrfd , $statusfd , $longkeyid , []);
1154 readwrite_gpg
( " $prune_all_sigs_on_uid \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd , exitwhenstatusmatches
=> $KEYEDIT_PROMPT , nocloseinput
=> 1 ); # unmark uid from delsig
1158 readwrite_gpg
( "save \n " , $inputfd , $stdoutfd , $stderrfd , $statusfd );
1161 my $asciikey = export_key
( $tempdir , $keyid );
1162 if ( $asciikey eq '' ) {
1163 warn ( "No data from gpg for export $keyid \n " );
1167 if ( $signed_by_me ) {
1168 if ( $NOW - $signed_by_me > $CONFIG { 'export-sig-age' } ) {
1169 my $write = ask
( "Signature on $this_uid_text is old. Export?" , 0 , $params ->{ 'export-old' }, $params ->{ 'no-export-old' });
1172 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1173 - d
$keydir || mkpath
( $keydir , 0 , 0700 ) or die ( "Cannot create $keydir $! \n " );
1175 my $keyfile = " $keydir / $longkeyid .key. $uid_number ." . sanitize_uid
( $this_uid_text ). ".asc" ;
1176 open ( KEY
, "> $keyfile " ) or die ( "Cannot open $keyfile : $! \n " );
1177 print KEY
$asciikey ;
1180 push @UIDS , { text
=> $this_uid_text , key
=> $asciikey , serial
=> $uid_number , "is_uat" => $is_uat };
1182 info
( " $longkeyid $uid_number $this_uid_text done." );
1184 info
( " $longkeyid $uid_number $this_uid_text is not signed by me, not writing." );
1188 if ( scalar @UIDS == 0 ) {
1189 info
( "found no signed uids for $keyid " );
1191 next if $CONFIG { 'no-mail' }; # do not send mail
1194 for my $uid ( @UIDS ) {
1195 trace
( "UID: $uid ->{'text'} \n " );
1196 if ( $uid ->{ 'is_uat' }) {
1197 my $attach = ask
( "UID $uid ->{'text'} is an attribute UID, attach it to every email sent?" , 1 );
1198 push @attached , $uid if $attach ;
1199 } elsif ( $uid ->{ 'text' } !~ /@/ ) {
1200 my $attach = ask
( "UID $uid ->{'text'} is no email address, attach it to every email sent?" , 1 );
1201 push @attached , $uid if $attach ;
1205 notice
( "Key has no encryption capabilities, mail will be sent unencrypted" ) unless $can_encrypt ;
1206 for my $uid ( @UIDS ) {
1207 if (! $uid ->{ 'is_uat' } && ( $uid ->{ 'text' } =~ /@/ )) {
1208 my $address = $uid ->{ 'text' };
1209 $address =~ s/.*<(.*)>.*/$1/ ;
1210 if ( ask
( "Mail signature for $uid ->{'text'} to ' $address '?" , 1 , $CONFIG { 'mail' })) {
1211 my $mail = send_mail
( $address , $can_encrypt , $longkeyid , $uid , @attached );
1213 my $keydir = " $KEYSBASE / $DATE_STRING " ;
1214 my $mailfile = " $keydir / $longkeyid .mail." . $uid ->{ 'serial' }. "." . sanitize_uid
( $uid ->{ 'text' });
1215 open ( KEY
, "> $mailfile " ) or die ( "Cannot open $mailfile : $! \n " );