#!/usr/bin/perl # $Id: robotca,v 1.12 2004/03/05 16:43:02 kyle Exp $ # # ROBOT CA -- Automatic PGP key signer. # # Copyright (C) 2004 Kyle Hasselbacher # # This program is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by the # Free Software Foundation; either version 2 of the License, or (at your # option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General # Public License for more details. # # You should have received a copy of the GNU General Public License along # with this program; if not, write to the Free Software Foundation, Inc., # 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # # # This script accepts a PGP public key block (ASCII armored) as input. # It uses GnuPG to get the ID on the key, and get an email address from # that. It signs the key and emails the signed key to the email address. # # The basic steps: # 1. Get key info # 2. Import the key(s) # 3. Sign key(s) # 4. Export the signed key(s) # 5. Delete the key from my ring. # # Some notes # # Internally, the user's "key ID" is always the textual key ID, not a # numeric one. I couldn't see a way to get a key fingerprint from just a # key block, so I did this. # # Given a key with many IDs, we loop over them, signing each individually. # After each signing, we delete the key from the keyring. The thing is, we # delete it AS EVERY ID on it, so only one of the deletions "works", and # the others give error messages. I see them in my procmail log file. # # I haven't tried things like international characters. The worst I've # thrown at it is things like quotation marks. # # # STEP ONE: Get the key info. # # Here's what GnuPG gives me: # # kyle@firebee ~ $ gpg --with-colons < gpg/fake/exported.asc # pub:-:1024:17:5E22EB0801A381C8:2002-11-08:2002-11-22::-:Kyle Hasselbacher (TEST ONLY) : # sub:-:1024:16:FC4488380FAF5440:2002-11-08:2002-11-22::: [expires: 2002-11-22] # # If there's an ID with silly characters in it, they're escaped with # a \xHH notattion where HH are hex digits. # # Object::Model (TEST\ONLY) -> Object\x3a\x3aModel (TEST\x5cONLY) # # pub:-:1024:17:CE60C0CD21A1F6FF:2002-11-08:2002-11-22::-:Object\x3a\x3aModel (TEST\x5cONLY) : # sub:-:1024:16:63FD1486F8F830B8:2002-11-08:2002-11-22::: [expires: 2002-11-22] # # Note that GnuPG's escapes don't work for the shell, so we have to decode # them and then escape differently when we pass arguments. # # STEP TWO: import the key # # kyle@firebee ~ $ gpg --import < gpg/fake/exported.asc # gpg: key 01A381C8: public key "Kyle Hasselbacher (TEST ONLY) " imported # gpg: Total number processed: 1 # gpg: imported: 1 # # STEP THREE: sign the key # # gpg --sign-key 5E22EB0801A381C8 # gpg --sign-key "=Kyle Hasselbacher (TEST ONLY) " # # STEP FOUR: export the signed key # gpg -a --export "=Kyle Hasselbacher (TEST ONLY) " # # STEP FIVE: delete the key # gpg --batch --yes --delete-key "=Kyle Hasselbacher (TEST ONLY) " # Don't need --yes if you specify key by fingerprint (good idea) # # # CONCERNS ( + = done, - = still a concern ) # - I need to check errors and failures on everything. # + Look up shell meta characters--what must escape in ""? -- "`$\ # + get the same uid twice? perish! # + Make some logs # + Check if they sent me a key I already signed. # + If I abort after importing the key, I still have to delete it! # + Check if I signed a key for that address recently. # + Check if they sent a key with an ID much like mine. # + Check the format of the key input # - Drop emails from mailer daemon (with procmail?) # - Consider a queue system for when I get overloaded. # + Maybe have a total "scratch" keyring created for each request. # - How to deal with icky MIME encoding? Just disallow it! # - Config options galore # -- digest history file or not # -- log transactions or not # - Consider using -T (taint) # - Might be nice to respond with diagnostics once in a while # + Do I need to lock every time? What if I try to operate on duplicate keys # concurently? -- scratch home takes care of this. # + What if I get an expired key? # + config option for the answer to "how much you checked?" # + Encrypt the response email. # - Do not sign sign-only keys. ("unusable public key" when enrcrypting) # + Use --ask-cert-expire (make a config option) # + Config option to sign only keys that have no comment or real name. # + Use --cert-policty-url (make a config option) # - Use --cert-notation ? # + Fix the Open3 deadlock - SIGALRM, temp files, select() # + Handle key deletion better; don't delete the same key repeatedly. # + Keys with expiration dates trip up the signature expiration code. # - UTF8 in key IDs still has a problem? # use strict; use warnings; use vars qw( %history ); use Config::IniFiles; use Data::Dumper; use Digest::SHA1; use Expect; use Fcntl qw(:DEFAULT :flock); use File::Copy; use File::Path; use Getopt::Mixed; use IO::File; use IO::Dir; #use IPC::Open3; use Mail::Send; my $home = $ENV{'HOME'} || $ENV{'LOGDIR'} || (getpwuid($<))[7]; my $config_ini = "$home/robotca.ini"; # If umask is 0177 (for instance), the directory I create later # can't be accessed. umask( 0077 ); # # COMMAND LINE OPTIONS # -i --ini Select another INI file section for variables # -f --config Select another INI file # -d --debug Set debugging (e.g., -d 1) # use vars qw( $opt_f $opt_i $opt_d ); Getopt::Mixed::getOptions( join(' ', qw( f=s config>f d=i debug>d i=s ini>i ) ) ); $config_ini = $opt_f if ( defined( $opt_f ) ); # # EXAMPLE INI FILE # # [robotca] # gpgbin=/usr/bin/gpg # DEBUG=0 # logfile=/home/robotca/log # myaddr=robotca@toehold.com # mykey=894C42F0CF87046D7DA46CA06A55980B975361E0 # histfile=/home/robotca/history # passphrase=XXX # sign_freq=60 # # EXPLANATIONS # gpgbin -- where your GnuPG lives # logfile -- where to log messages (omit for no logging) # myaddr -- The email address of the robot. Used to avoid loops. # mykey -- The key fingerprint of the robot's key. Used to export the # robot's key in the response. Leave blank for no export. # histfile -- Where to store signing history. NOT created if it's not there. # passphrase -- The passphrase for the robot's key. MUST HAVE # sign_freq -- How often (in seconds) it will sign a key for the same person. # (defaults to 24 hours) # expectlog -- Another debug flag, this tells whether to show what the # Expect module is doing during a key signing. # url -- Home page for the RCA (sent in the response email). # operator -- the email address of the operator (also in the response email). # mailop -- flag for whether to Bcc the operator with responses (for debugging) # sigclass -- how to answer the "how carefully have you verified" question. # (must be 0, 1, 2, or 3). I consider 3 a bad idea for this app. # cert_expire -- How long the signature lasts in days (can append [wmy] for # weeks, months, or years). 0 = does not expire # cert_url -- Passed in on signing as --cert-policty-url. This defaults to # the 'url' parameter if it's not given explicitly. # sign_email_only -- flag that when set makes the robot sign only IDs that # do not contain a real name or comment. ONLY email. # my %config; my $defsec = 'robotca'; $defsec = $opt_i if ( defined( $opt_i ) ); tie %config, 'Config::IniFiles', ( -file => $config_ini, -default => $defsec ); my $DEBUG = $config{ $defsec }{ 'DEBUG' }; my $gpg_bin = $config{ $defsec }{ 'gpgbin' }; my $log_file = $config{ $defsec }{ 'logfile' }; my $my_addr = $config{ $defsec }{ 'myaddr' }; my $hist_file = $config{ $defsec }{ 'histfile' }; # Try to make sure we have a working gpg. if ( ! -x $gpg_bin ) { if ( -x '/usr/bin/gpg' ) { $gpg_bin = '/usr/bin/gpg'; } else { $gpg_bin = 'gpg'; } } $DEBUG = $opt_d if ( defined( $opt_d ) ); if ( $DEBUG ) { print "\$DEBUG = $DEBUG\n"; # print "\$gpg_bin = $gpg_bin\n"; # print "\$log_file = $log_file\n"; # print "\$hist_file = $hist_file\n"; # print "\$my_addr = $my_addr\n"; # print "\$config_ini = $config_ini\n"; } # Read the key from stdin. my $key_material = join( '', grep( /^-{5}BEGIN PGP PUBLIC KEY BLOCK-{5}$/ .. /^-{5}END PGP PUBLIC KEY BLOCK-{5}$/, <> ) ); if ( ! verify_key_format( $key_material ) ) { perish( "Input not valid" ); } my ( $out, $err ) = rwgpg( "$gpg_bin --with-colons --with-fingerprint", $key_material ); check_err( $err ); # I collect fingerprints here so that I can use them later for key deletion. my @fprlist = get_keyfpr( $out ); my @idlist = sanitize_key_id( get_keyid( $out ) ); if ( $DEBUG ) { print "Found IDs:\n"; foreach my $id ( @idlist ) { print "$id\n"; } print "Found Fingerprints:\n"; foreach my $id ( @fprlist ) { print "$id\n"; } } my $hist_fh; if ( @idlist ) { # Daemonizing doesn't work. It gets stuck signing the key. I think # the Expect module must really want STDOUT or something. # daemonize() if ( ! $DEBUG ); if ( -r $hist_file ) { read_history( $hist_file ); prune_history( $config{ $defsec }{ 'sign_freq' } || 60 * 60 * 24 ); } } # # What's somewhat silly here is that if I'm sent more than one key, # I import them ALL, sign one, export it, delete them ALL, and start over # to sign the next one. I doubt it's a common case, so I'm not too worried, # but it'd be nice to separate them out--import them all, export them # individually, and then take care of one chunk at a time. # # Maybe if I see more than one key block, I can fork and pipe the blocks to # myself one at a time. # # Make a copy of the gpghome directory, and make that our home for the rest # of the run. We delete it before exiting. my $tmphome = ''; if ( $gpg_bin !~ /--homedir/ && defined( $tmphome = mkscratch() ) && -d $tmphome ) { $gpg_bin .= " --homedir $tmphome"; } # $delete_command deletes all the keys that we import. # $abort_command == $delete_command after the import, not before. # # The delete command uses fingerprints. Before, when I used UIDs, gpg would # complain when I tried to delete the same key twice. # my $delete_command = ''; my $abort_command = ''; foreach my $keyid ( @fprlist ) { $delete_command .= qq!$gpg_bin --batch --yes --delete-key "$keyid";!; } $DEBUG && print "\$delete_command = '$delete_command'\n"; my @signed = (); foreach my $keyid ( @idlist ) { $DEBUG && print "Working on $keyid\n"; my $dest = figure_destination( $keyid ); next if ( ! $dest ); $DEBUG && print "Destination $dest\n"; # I import with --quiet so that it doesn't generate (and log as an error) # the summary of what it imported. $DEBUG && print "Importing...\n"; ( $out, $err ) = rwgpg( "$gpg_bin --quiet --import", $key_material ); check_err( $err ); $abort_command = $delete_command; $DEBUG && print "Signing...\n"; my $passphrase = $config{ $defsec }{ 'passphrase' }; if ( ! sign_key( $gpg_bin, $keyid, $passphrase ) ) { complain( "failed to sign key" ); } else { $DEBUG && print "Exporting...\n"; my $signed_key = do_export( $keyid ); $DEBUG && print "Emailing signed key to $dest...\n"; send_response( $dest, $signed_key ); complain( "signed key $keyid" ); push( @signed, $dest ); } $DEBUG && print "Cleaning keyring...\n"; system( $abort_command ); $abort_command = ''; } if ( -r $hist_file ) { write_history( $hist_file, \@signed ); } rmscratch( $tmphome ); exit; # This gets the user's ASCII armored key. It optionally includes the robot's # key as well. It takes the user's key ID as a parameter. # This also encrypts the output. I have to force a trustdb update so that # I don't get messages about it in the output. The key I'm using to encrypt # must be trusted because I just signed it. sub do_export { my ( $keyid ) = @_; system( "$gpg_bin --check-trustdb" ); my $export_com = qq!$gpg_bin -a --export "$keyid"!; if ( my $robot_key = $config{ $defsec }{ 'mykey' } ) { $robot_key =~ s/\s+//g; $export_com .= " --export $robot_key"; } $export_com .= qq! | $gpg_bin --no-auto-check-trustdb -aer "$keyid"!; ( $out, $err ) = rwgpg( $export_com, '' ); check_err( $err ); # if ( $out =~ /unusable public key/ ) return $out; } # Given a key ID, this looks for the email address in it and checks that # address for certain problems. sub figure_destination { my ( $keyid ) = @_; my $dest = get_email( $keyid ); if ( ! $dest ) { complain( "No email address in '$keyid'!" ); $dest = ''; } $dest =~ tr/A-Z/a-z/; if ( $dest eq $my_addr ) { complain( "destination $dest is my address" ); $dest = ''; } if ( $dest ne '' ) { my $digested_dest = digester( $dest ); if ( $history{ $digested_dest } && ! $DEBUG ) { complain( "Already signed $dest" ); $dest = ''; } } return $dest; } # This is supposed to look for error messages and do something useful # if it finds any. Ideally, it would safely ignore things that aren't # important to us. sub check_err { my ( $err ) = @_; if ( $err ) { complain( $err ); } } # This creates a copy of the GnuPG home directory so we can use that # during signing and delete it when we're done. # It does it this way: # - figure out where the gpg home is # - Read the files in it (not directories) # - copy some of them and link some of them # - return the path to the copy to the caller # (return undef if it failed) sub mkscratch { my $gpghome = $ENV{ 'GNUPGHOME' }; if ( ! $gpghome || ! -d $gpghome ) { $gpghome = "$home/.gnupg"; } my $dh = new IO::Dir "$gpghome"; return undef if ( ! defined( $dh ) ); my @tocp = (); my @toln = (); while ( defined( my $file = $dh->read ) ) { $file =~ s!^!$gpghome/!; next unless ( -f $file ); next if ( $file =~ /\~$/ ); if ( $file =~ /(?:gpg\.conf|random_seed)/ ) { push( @toln, $file ); next; } push( @tocp, $file ); } my $out = "$home/rcatmp$$"; return undef unless ( mkpath( [ $out ], $DEBUG, 0700 ) ); foreach my $file ( @tocp ) { if ( ! copy( $file, $out ) ) { complain( "Can't copy $file: $!" ); rmscratch( $out ); return undef; } } foreach my $file ( @toln ) { my $dest = $file; $dest =~ s!^.*/([^/]+)$!$1!; $dest = "$out/$dest"; if ( ! link( $file, $dest ) ) { complain( "Can't link $file: $!" ); if ( ! copy( $file, $out ) ) { complain( "Can't copy $file either: $!" ); rmscratch( $out ); return undef; } } } return $out; } # This is to delete the scratch gpg home. It really will delete any # directory you pass to it. sub rmscratch { my ( $scratch ) = @_; return 1 if ( ! $scratch ); return 1 if ( $scratch !~ /\S/ ); return 1 if ( ! -d $scratch ); # rmtree without 1 in third parameter is unsecure return rmtree( $scratch, $DEBUG, 1 ); } # RFC 2440 says # # Message is: # 1 - a head line # 2 - headers # 3 - blank or spaces-only line # 4 - radix-64 data # 5 - checksum # 6 - a tail line # # Head lines are: # BEGIN PGP MESSAGE # Used for signed, encrypted, or compressed files. # # BEGIN PGP PUBLIC KEY BLOCK # Used for armoring public keys # # BEGIN PGP PRIVATE KEY BLOCK # Used for armoring private keys # # BEGIN PGP MESSAGE, PART X/Y # Used for multi-part messages, where the armor is split amongst Y # parts, and this is the Xth part out of Y. # # BEGIN PGP MESSAGE, PART X # Used for multi-part messages, where this is the Xth part of an # unspecified number of parts. Requires the MESSAGE-ID Armor Header # to be used. # # BEGIN PGP SIGNATURE # Used for detached signatures, OpenPGP/MIME signatures, and # natures following clearsigned messages. Note that PGP 2.x s BEGIN # PGP MESSAGE for detached signatures. # Known headers are: # # Version # Comment # MessageID # Hash # Charset # # radix 64 is [A-Za-z0-9+/=]{1,76} (the = is padding) # The checksum looks just like it. sub verify_key_format { my ( $key_material ) = @_; return 0 unless ( $key_material =~ /\S/ ); $key_material =~ s/^\s+//; $key_material =~ s/\n[ \t]+/\n/g; # XXX We reject a good input if it's followed by garbage. # XXX luckily the caller takes care of that right now. 8-) my @keylines = split( /\n/, $key_material ); my $fail = 0; while ( @keylines ) { my $line = shift @keylines; if ( $line !~ /^-{5}BEGIN PGP PUBLIC KEY BLOCK-{5}$/ || ! @keylines ) { complain( "bad input: no BEGIN line" ); return 0; } do { $line = shift @keylines; } while ( $line =~ /^.+: \S+/ && @keylines ); if ( ! @keylines || $line !~ /^\s*$/ ) { complain( "bad input: non blank ($line) after headers" ); return 0; } do { $line = shift @keylines; } while ( $line =~ m:^[A-Za-z0-9+/=]{1,76}\s*$: && @keylines ); if ( $line !~ /^-{5}END PGP PUBLIC KEY BLOCK-{5}$/ ) { complain( "bad input: got ($line) instead of END line" ); return 0; } } # # XXX This is all the valid lines, but it doesn't check order. # my @badlines = grep( ! ( /^-{5}(BEGIN|END) PGP PUBLIC KEY BLOCK-{5}$/ # || /^.+: \S+/ # || /^\s*$/ # || m:^[A-Za-z0-9+/=]{1,76}\s*$: ), # split( /\n/, $key_material ) ); # if ( @badlines ) { # complain( grep( s/^/bad input line: /, @badlines ) ); # return 0; # } return 1; } # This is just for logging. # Pass it a message, or a list of them, and it will do the logging. # It prepends a timestamp and pid to each message, and it locks the log # file when writing. sub complain { my @messes = @_; return unless ( $log_file =~ /\S/ ); my $time = localtime(); my $pid = $$; my $logmess = ''; foreach my $mess ( @messes ) { foreach my $small_mess ( split( /\n/, $mess ) ) { $logmess .= "$time [$pid]: $small_mess\n"; } } my $fh = new IO::File; if ( ! sysopen( $fh, $log_file, O_RDWR|O_CREAT ) ) { warn "Can't open logfile $log_file: $!"; return; } if ( ! flock( $fh, LOCK_EX ) ) { warn "Can't LOCK_EX $log_file: $!"; close( $fh ); return; } if ( ! seek( $fh, 0, 2 ) ) { warn "Can't seek() $log_file: $!"; close( $fh ); return; } print $fh $logmess; $fh->close; if ( $DEBUG ) { print "LOG: $logmess"; } } # This is the best way to leave the program. # Pass it a list of messages, and it will log them before exiting. # It attempts to clean up before exiting (that's why you should use it). sub perish { my @messes = @_; foreach my $mess ( @messes ) { $mess =~ s/^/(FATAL) /; } complain( @messes ); if ( $abort_command ) { system( $abort_command ); } rmscratch( $tmphome ); exit 1; } # This is supposed to make me run as a daemon, but the Expect module # seems to have problems when I use it. sub daemonize { my $pid = $$; if ( $pid = fork ) { wait; exit 0; } elsif ( ! defined $pid ) { # can't fork return; } close( STDOUT ); close( STDERR ); close( STDIN ); # The child forks again. Its child runs while it exits. exit 0 if ( fork ); sleep 1 until ( getppid == 1 ); } # This throws too-old entries out of the history list. sub prune_history { my ( $age ) = @_; $DEBUG && print "prune_history( $age );\n"; my $now = time; my @tsil = keys %history; foreach my $signed ( @tsil ) { my $when = $history{ $signed }; if ( $when + $age < $now ) { delete( $history{ $signed } ); } } } # This is to write our history back to disk for us to read later. # It does file locking. sub write_history { my ( $hist_file, $sref ) = @_; my $fh = new IO::File; if ( ! sysopen( $fh, $hist_file, O_RDWR|O_CREAT ) ) { complain( "Can't open $hist_file: $!" ); return; } if ( ! flock( $fh, LOCK_EX ) ) { complain( "Can't LOCK_EX history handle: $!" ); close( $fh ); return; } %history = (); do $hist_file; prune_history( $config{ $defsec }{ 'sign_freq' } || 60 * 60 * 24 ); foreach my $signed ( @$sref ) { $history{ digester( $signed ) } = time; } if ( ! truncate( $fh, 0 ) ) { complain( "Can't truncate history handle: $!" ); close( $fh ); return; } $Data::Dumper::Useqq = 1; my $dump = Data::Dumper->Dump( [ \%history ], [ qw( *history ) ] ); $dump .= "1;\n"; $fh->print( $dump ); $fh->close; } # This reads the history hash so we can check whether we already # signed something. sub read_history { my ( $hist_file ) = @_; my $fh = new IO::File; if ( ! sysopen( $fh, $hist_file, O_RDWR|O_CREAT ) ) { complain( "Can't open $hist_file: $!" ); return; } if ( ! flock( $fh, LOCK_SH ) ) { complain( "Can't LOCK_SH $hist_file: $!" ); close( $fh ); return; } do $hist_file; close( $fh ); } # This emails the signed key back to the user. sub send_response { my ( $dest, $signed_key ) = @_; my $op = $config{ $defsec }{ 'operator' }; my $me = $config{ $defsec }{ 'myaddr' }; my $mailop = $config{ $defsec }{ 'mailop' }; my $url = $config{ $defsec }{ 'url' }; my $urlstring = ''; if ( $url =~ /\S/ ) { $urlstring = "For more info, see $url"; } my $msg = new Mail::Send; $msg->to( $dest ); $msg->bcc( $op ) if ( $op && $mailop ); $msg->set( 'From', "Robot CA <$me>" ); $msg->subject( "Signed key for $dest" ); my $fh = $msg->open( 'sendmail' ); print $fh <. For questions, email <$op>. $urlstring $signed_key EOF # $fh goes out of scope, and the mail is sent. } # This is used to invoke gpg with some input. # it returns the output and error messages. sub rwgpg { my ( $com, $in ) = @_; $DEBUG && print "\$ $com\n"; my $tdir = "/tmp"; my ( $rfile, $wfile, $efile ) = ( "$tdir/read$$", "$tdir/write$$", "$tdir/err$$" ); my $fh; if ( ! $in ) { $com = "$com > $wfile 2> $efile"; } else { $com = "$com < $rfile > $wfile 2> $efile"; $fh = new IO::File ">$rfile"; if ( ! $fh ) { return ( undef, undef ); } print $fh $in; close( $fh ); } my $exit = system( "$com" ); if ( $exit ) { complain( "exit code $exit from '$com'" ); } my $out = ''; my $err = ''; if ( ! -z $wfile && defined( $fh = new IO::File "$wfile" ) ) { $out = join( '', $fh->getlines ); close( $fh ); } if ( ! -z $efile && defined( $fh = new IO::File "$efile" ) ) { $err = join( '', $fh->getlines ); close( $fh ); } foreach my $file ( $rfile, $wfile, $efile ) { if ( -e $file && ! unlink( $file ) ) { complain( "Can't unlink $file: $!" ); } } return ( $out, $err ); # my ( $write, $read, $err ); # my $pid = open3( $write, $read, $err, "$com" ); # if ( $write && $write->opened ) { # print $write $in; # $write->close; # } # my @out; # if ( $read && $read->opened ) { # @out = $read->getlines; # $read->close; # } # my @err; # if ( $err && $err->opened ) { # @err = $err->getlines; # $err->close; # } # # waitpid $pid, 0; # # return ( join( '', @out ), join( '', @err ) ); } # This pulls the key ID strings out of gpg output. # We die if we find a key that appears twice because we can't deal. # Note that it's POSSIBLE to have an "ID" appear twice on what are actually # different keys. Users just have to send those separately. sub get_keyid { my ( $gpg_output ) = @_; my @lines = grep( /^(pub|uid):/, split( /\n/, $gpg_output ) ); my %out = (); foreach my $line ( @lines ) { my @fields = split( /:/, $line ); my $id = $fields[ 9 ]; next if ( ! $id ); $id =~ s/\\x([0-9a-f][0-9a-f])/chr(hex($1))/eg; if ( $out{ $id }++ ) { perish( "ID appears twice: $id" ); } } return keys %out; } # This is the same as get_keyid, but it gets fingerprints. sub get_keyfpr { my ( $gpg_output ) = @_; my @lines = grep( /^fpr:/, split( /\n/, $gpg_output ) ); my %out = (); foreach my $line ( @lines ) { my @fields = split( /:/, $line ); my $fpr = $fields[ 9 ]; next if ( ! $fpr ); if ( $out{ $fpr }++ ) { perish( "Fingerprint appears twice: $fpr" ); } } return keys %out; } # Escapes shell meta characters, so I can safely use it on the command line. # This does NOT escape spaces. What you get from this is meant to be put in # double quotes on the command line. sub shell_escape { my ( $string ) = @_; $string =~ s/\\/\\\\/g; $string =~ s/\"/\\\"/g; $string =~ s/\$/\\\$/g; $string =~ s/\`/\\\`/g; return $string; } # This is so I can use it a the command line passed to a shell. sub sanitize_key_id { my @keylist = @_; my @out = (); foreach my $key_id ( @keylist ) { $key_id = shell_escape( $key_id ); if ( $key_id !~ s/^.*[\x7f-\xff]([^\x7f-\xff]+)$/$1/ ) { $key_id = "=$key_id"; } push( @out, $key_id ); } return @out; } # # KEY SIGNING # This is a pain. We use Expect to interact with gpg as if we're a user. # # gpg: checking the trustdb # gpg: checking at depth 0 signed=3 ot(-/q/n/m/f/u)=0/0/0/0/0/1 # gpg: checking at depth 1 signed=9 ot(-/q/n/m/f/u)=1/0/0/0/2/0 # gpg: checking at depth 2 signed=0 ot(-/q/n/m/f/u)=3/3/0/3/0/0 # gpg: next trustdb check due at 2002-11-20 # pub 1024D/01A381C8 created: 2002-11-08 expires: 2002-11-22 trust: -/- # sub 1024g/0FAF5440 created: 2002-11-08 expires: 2002-11-22 # (1). Kyle Hasselbacher (TEST ONLY) # # # pub 1024D/01A381C8 created: 2002-11-08 expires: 2002-11-22 trust: -/- # Primary key fingerprint: 279B E4B7 AE51 714B FBC0 CBD7 5E22 EB08 01A3 81C8 # # Kyle Hasselbacher (TEST ONLY) # # This key is due to expire on 2002-11-22. # Do you want your signature to expire at the same time? (Y/n) # How carefully have you verified the key you are about to sign actually belongs # to the person named above? If you don't know what to answer, enter "0". # # (0) I will not answer. (default) # (1) I have not checked at all. # (2) I have done casual checking. # (3) I have done very careful checking. # # Your selection? # Are you really sure that you want to sign this key # with your key: "Kyle Hasselbacher " # # Really sign? y # # You need a passphrase to unlock the secret key for # user: "Kyle Hasselbacher " # 1024-bit DSA key, ID 2A94C484, created 1999-09-14 # # Enter passphrase: # sub sign_key { my ( $gpg_bin, $key_id, $passphrase ) = @_; my $sign_succeed = 1; my $timeout = 60; my $expire = ''; if ( $config{ $defsec }{ 'cert_expire' } ) { $expire = '--ask-cert-expire'; } my $url = ''; if ( defined( $config{ $defsec }{ 'cert_url' } ) ) { $url = $config{ $defsec }{ 'cert_url' }; } elsif ( defined( $config{ $defsec }{ 'url' } ) ) { $url = $config{ $defsec }{ 'url' }; } my $url_opt = ''; if ( $url ne '' ) { $url = '"' . shell_escape( $url ) . '"'; $url_opt = "--cert-policy-url $url"; } my $sign_com = qq!$gpg_bin $expire $url_opt --sign-key "$key_id"!; $sign_com = qq!$gpg_bin $expire $url_opt --command-fd 0 --status-fd 1 --sign-key "$key_id"!; my $expect = Expect->spawn( $sign_com ); if ( ! $expect ) { complain( "failed to spawn $gpg_bin --sign-key" ); return 0; } my $log_stdout = 1 if ( $config{ $defsec }{ 'expectlog' } && $DEBUG ); $expect->log_stdout( $log_stdout ); $expect->expect( $timeout, 'timeout', sub { complain( "expect timed out" ); $sign_succeed = 0; }, '-re', 'Really sign all user IDs\\? $|\\[GNUPG:\\] GET_BOOL keyedit\\.sign_all\\.okay', # # At this point we drop to a prompt and have to select a uid to sign. # (1) Kyle "NMI" Hasselbacher (TEST\ONLY) # (2). Object::Method (TEST ONLY) # send( 'uid 1' ); # send( 'sign' ); # Then we're back at the usual prompt # sub { my $fh = shift; sleep 1; print $fh "N\n"; my $ids = $expect->before(); my $id_to_sign = $key_id; $id_to_sign =~ s/\\([^\\])/$1/g; $id_to_sign =~ s/\\\\/\\/g; $id_to_sign =~ s/^=//; $id_to_sign =~ s/(\W)/\\$1/g; if ( $ids =~ /\n\((\d+)\)..$id_to_sign/ ) { my $select_id = $1; sleep 1; print $fh "uid $select_id\n"; sleep 1; print $fh "sign\n"; } else { complain( "Can't find $id_to_sign to sign" ); $sign_succeed = 0; } exp_continue; }, # # Check for an already signed key: # # "..." was already signed by key 975361E0 # Nothing to sign with key 975361E0 # '-re', 'Nothing to sign with key [0-9A-F]{8}', sub { complain( "key already signed: $key_id" ); $sign_succeed = 0; }, # # This key has expired! Unable to sign. # '-re', 'This key has expired! Unable to sign\\.', sub { complain( "Expired key: $key_id" ); $sign_succeed = 0; }, # # Check for an expired signature: # # Your current signature on "..." has expired. # Do you want to issue a new signature to replace the expired one? (y/N) # # [GNUPG:] GET_BOOL sign_uid.replace_expired_okay # # This prompt was added in GnuPG 1.2.2 # '-re', 'Do you want to issue a new signature to replace the expired one\\? \\(y/N\\) |\\[GNUPG:\\] GET_BOOL sign_uid\\.replace_expired_okay', sub { my $fh = shift; sleep 1; print $fh "y\n"; exp_continue; }, # # Please specify how long the signature should be valid. # 0 = signature does not expire # = signature expires in n days # w = signature expires in n weeks # m = signature expires in n months # y = signature expires in n years # Signature is valid for? (0) # # [GNUPG:] GET_LINE siggen.valid # '-re', 'Signature is valid for\\? \\(0\\) |\\[GNUPG:\\] GET_LINE siggen\\.valid', sub { my $time = $config{ $defsec }{ 'cert_expire' }; $time = 0 if ( $time !~ /^\d+[wmy]?/i ); my $fh = shift; sleep 1; print $fh "$time\n"; exp_continue; }, # # Signature expires at Mon Dec 9 22:32:19 2002 CST # Is this correct (y/n)? # # If I get prompted this way about something else, 'y' is probably still # the right answer. # '-re', 'Is this correct \\(y/n\\)\\? ', sub { my $fh = shift; sleep 1; print $fh "Y\n"; exp_continue; }, # # This key is due to expire on 2002-11-22. # Do you want your signature to expire at the same time? (Y/n) # # If the user's key expires before our signature would expire, then we want to # take the user's expiration time (it's shorter). Otherwise, say 'n' and get # prompted later for our own (shorter) time. # '-re', 'Do you want your signature to expire at the same time\\? \\(Y/n\\) |\\[GNUPG:\\] GET_LINE sign_uid\\.expire', sub { my $fh = shift; my $due = $expect->before(); my $answer = 'Y'; if ( $due =~ /This key is due to expire on (\d{4})-(\d\d)-(\d\d)\./ ) { $due = "$1$2$3"; # $time is an interval until expiration. # I need to turn it into an absolute time. my $time = $config{ $defsec }{ 'cert_expire' }; my $expire_time = 0; if ( $time =~ /^(\d+)([wmy]?)/i ) { my ( $n, $mod ) = ( $1, $2 ); if ( $n ) { if ( $mod =~ /w/i ) { $n *= 7; } elsif ( $mod =~ /m/i ) { $n *= 30; } elsif ( $mod =~ /y/i ) { $n *= 365; } $expire_time = time() + $n * 86400; } # $expire_time should be an absolute time_t # Need to convert it to "YYYYMMDD". my ( $mday, $mon, $year ) = ( localtime( $expire_time ) )[ 3,4,5 ]; $mon++; $year += 1900; $mon = "0$mon" if ( $mon < 10 ); $mday = "0$mday" if ( $mday < 10 ); my $compare_time = "$year$mon$mday"; if ( $due > $compare_time ) { $answer = 'N'; } } } sleep 1; print $fh "$answer\n"; exp_continue; }, # #How carefully have you verified the key you are about to sign actually belongs #to the person named above? If you don't know what to answer, enter "0". # # (0) I will not answer. (default) # (1) I have not checked at all. # (2) I have done casual checking. # (3) I have done very careful checking. # #Your selection? # #[GNUPG:] GET_LINE sign_uid.class # '-re', 'Your selection\\? (\\(enter \'\\?\' for more information\\)\\:)?$|\\[GNUPG:\\] GET_LINE sign_uid\\.class', sub { my $fh = shift; sleep 1; my $answer = $config{ $defsec }{ 'sigclass' }; $answer = "0" if ( ! $answer || $answer !~ /^[0123]$/ ); print $fh "$answer\n"; exp_continue; }, # # Are you really sure that you want to sign this key # with your key: "..." # # Really sign? y # # [GNUPG:] GET_BOOL sign_uid.okay # '-re', 'Really sign\\? $|\\[GNUPG:\\] GET_BOOL sign_uid\\.okay', sub { my $fh = shift; sleep 1; print $fh "Y\n"; exp_continue; }, # # You need a passphrase to unlock the secret key for # user: "Kyle Hasselbacher " # 1024-bit DSA key, ID 2A94C484, created 1999-09-14 # # Enter passphrase: # # [GNUPG:] GET_HIDDEN passphrase.enter # '-re', 'Enter passphrase: $|\\[GNUPG:\\] GET_HIDDEN passphrase\\.enter', sub { my $fh = shift; sleep 1; print $fh "$passphrase\n"; } ); $expect->soft_close(); return $sign_succeed; } # This looks for an email address in a key ID. # It's expecting something of the form 'Kyle Hasselbacher ' # It will also accept an ID that is ALL email address. # Otherwise, it can't find anything that isn't between # If 'sign_email_only' is set in the config, it can only find email addresses # when there's nothing else in the string. sub get_email { my ( $key_id ) = @_; # There is the potential for this to accept '' # but I consider that rare enough to ignore. # It's meant to match 'x@y.z' or '' # This is a bit liberal about what it considers a valid character in an # email address. if ( $key_id =~ /^\s]+\@[^@>\s]+)>?$/ ) { return $1; } elsif ( ! $config{ $defsec }{ 'sign_email_only' } && ( $key_id =~ s/<([^@>]+\@[^@>]+)>//g ) == 1 ) { # The above makes sure there's only one email address in the ID. return $1; } return undef; } sub digester { my ( $data ) = @_; my $sha1 = new Digest::SHA1; $sha1->add( $data ); my $digest = $sha1->b64digest; return $digest; } # # $Log: robotca,v $ # Revision 1.12 2004/03/05 16:43:02 kyle # Use --status-fd messages for prompts instead of human-readable prompts. # Set umask() so our directory is always readable (thanks Peter Pramberger) # Improve handling of UTF8 user IDs. Still not sure this works. # # Revision 1.11 2002/12/09 22:23:33 kyle # Use fingerprints instead of UIDs for deleting keys when I'm finished. # Use temp files to communicate with GnuPG (instead of deadlocking). # Fix a problem with how signatures expire for keys that expire. # # Revision 1.10 2002/12/09 16:18:18 kyle # Someone sent in a key that tripped up the robot somehow. I'm not sure what # it was, so I can't test this, but from the error messages in the log, I # am pretty sure this will make it ignore the problem next time it shows up. # # Revision 1.9 2002/12/08 06:33:51 kyle # Added a to-do list item. No functional change. # # Revision 1.8 2002/12/08 05:47:57 kyle # Added revision log entries from before 1.6 to the log at the end # of the file. No functional changes. # # Revision 1.7 2002/12/08 05:42:49 kyle # Added sign_email_only config option to sign only keys that don't have a # real name or comment (i.e., sign only keys that are only email addresses). # # Revision 1.6 2002/12/08 05:05:10 kyle # Added the RCS Log thingy to the end of the file # # Revision 1.5 2002/12/08 05:02:25 kyle # Use --cert-policy-url when signing keys. # # Revision 1.4 2002/12/08 04:46:37 kyle # Use --ask-cert-expire to make signatures that expire after a given time. # # Revision 1.3 2002/12/08 04:17:57 kyle # Encrypt the response email. # # Revision 1.2 2002/12/08 03:57:06 kyle # Added comments to reflect the current to-do list. No functional changes. # # Revision 1.1 2002/12/08 03:43:48 kyle # Initial revision #