#!/usr/bin/perl
#  Last-modified: 2009-10-24 12:45:24 -0400 tmz
#
#  Copyright 2002-2006 Ingo Kloecker <mail@ingo-kloecker.de>
#  Copyright 2006 Todd Zullinger <tmz@pobox.com>
#
#  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., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#
#  Ingo's script is available in the gnupg-users list archives:
#   http://marc.theaimsgroup.com/?l=gnupg-users&m=115230269710683&q=p7
#
#  This version is quite different than his original, so if you find bugs
#  in it, they're likely mine.  Complain to me (Todd) instead of Ingo.

use strict;
use warnings;
use File::Basename;
use File::Path;
use File::Temp qw(tempfile);
use Getopt::Long qw(:config bundling);
use Pod::Usage;
use Text::Autoformat qw(autoformat break_wrap);
use Text::Template;

# default settings
chomp (my $gpghome      = glob(`gpg --version | awk '/^Home:/ {print \$2}'`));
my  $gpgconf            = "$gpghome/gpg.conf";
my  $challenge_dir      = "$gpghome/challenges";
my  $challenge_length   = 24;
my  $challenge_mbox     = "mbox";
my  $gpgopts            = "";
my  $keyring            = "";
my  $mail_client        = "mbox";
my  $def_template_file  = "$challenge_dir/challenge.tmpl";
my  $template_file      = $def_template_file;
my  $wrap_width         = 74;
# variables used in the template need to be declared with our instead of my
our $event              = "a recent key signing party";
our $myaddr             = ""; # escape @! usually can be pulled from $mykeyid
our $mykeyid            = ""; # set this to your keyid, like DEADBEEF
our $myname             = ""; # usually can be pulled from $mykeyid
our $subject            = "OpenPGP key certification challenge";
chomp (our $cert_policy = `awk '/^cert-policy-url/ {print \$2}' $gpgconf`);

# default template
my $def_template = "Hi {\$name},

We exchanged PGP key information at {\$event}.  As part of my key certification
process I would like you to reply to this message and sign it with your key
({\$keyid}).  You must quote this challenge string in your reply:

{\$keyid}:{\$challenge}:{\$uid}

Thanks,

{\$myname}";

# Getopt variables
my ($help, $list_mail_clients, $list_replacements, $verbose);

# valid mail-clients
my @mail_clients = qw(mail mbox mutt kmail);

# valid replacement variables for use in the challenge template
my %replacements = (
    address     => "address of the user id being challenged",
    cert_policy => "url of your signing/certification policy",
    challenge   => "challenge string",
    event       => "event where key information was exchanged",
    keyid       => "key id being challenged",
    keyinfo     => "key information (as printed by gpg --fingerprint)",
    myaddr      => "your address",
    mykeyid     => "your key id",
    myname      => "your name",
    name        => "name from the user id being challenged",
    subject     => "subject of the email",
    uid         => "complete user id string being challenged",
);

# meanings for various key status codes
my %codes = (
    d => "disabled",
    e => "expired",
    i => "invalid",
    r => "revoked",
);

# command line opts
GetOptions (
    "cert-policy|p=s"       => \$cert_policy,
    "challenge-dir|d=s"     => \$challenge_dir,
    "challenge-length|l=i"  => \$challenge_length,
    "event|e=s"             => \$event,
    "help|h|?"              => \$help,
    "keyring|K=s"           => \$keyring,
    "list-mail-clients|M"   => \$list_mail_clients,
    "list-replacements|r"   => \$list_replacements,
    "mail-client|m=s"       => \$mail_client,
    "my-addr|a=s"           => \$myaddr,
    "my-key|k=s"            => \$mykeyid,
    "my-name|n=s"           => \$myname,
    "subject|s=s"           => \$subject,
    "template|t=s"          => \$template_file,
    "verbose|v"             => \$verbose,
    "wrap-width|w=i"        => \$wrap_width,
) or pod2usage();

pod2usage(1)    if $help;
mail_clients()  if $list_mail_clients;
replacements()  if $list_replacements;
pod2usage()     if @ARGV < 1;
pod2usage("\nPlease specify the keyid of your own private key.\n")
                unless $mykeyid;
pod2usage("'$mykeyid' doesn't look like a valid Key ID.  It should be 8 or 16 characters.\n")
                unless $mykeyid =~ /^([A-F0-9]{8}|[A-F0-9]{16})$/i;
pod2usage("\nInvalid mail client ($mail_client).\n")
                if not grep(/^$mail_client$/, @mail_clients);

# try to get $myname and $myaddr from $mykeyid
if ( not ($myname and $myaddr) ) {
    open( GPG, "gpg --with-colon --list-secret-keys $mykeyid 2>/dev/null|" )
        or die "Cannot run gpg: $!\n";
    my $myuid = "";
    while ( <GPG> ) {
        $myuid = (split /:/)[9] if /^sec:/;
    }
    close GPG;
    my ($keyname, $keyaddr) = (split_uid($myuid))[0,2];
    $myname = $keyname unless $myname;
    $myaddr = $keyaddr unless $myaddr;
}

pod2usage("\nPlease specify your name and address (used in the From header).\n")
                unless $myname and $myaddr;

# create the challenge_dir if it doesn't exist
if ( not -d $challenge_dir ) {
    print "Creating $challenge_dir\n" if $verbose;
    eval { mkpath( $challenge_dir ) };
    die "Couldn't create $challenge_dir: $@\n" if $@;
}

if ( not -f $template_file and $template_file eq $def_template_file ) {
    my $template_dir = dirname($template_file);
    if ( not -d $template_dir ) {
        print "Creating $template_dir\n" if $verbose;
        eval { mkpath( $template_dir ) };
        die "Couldn't create $template_dir: $@\n" if $@;
    }
    print "Creating default template: $template_file.\n" if $verbose;
    open TEMPLATE, "> $template_file"
        or die "failed to write $template_file: $!\n";
    print TEMPLATE "$def_template";
}

# make a fresh challenge mbox if mbox is the mail client
if ( $mail_client =~ /^mbox$/i ) {
    $challenge_mbox = join( '/', $challenge_dir, $challenge_mbox );
    # FIXME should prompt before truncating an existing mbox
    open MBOX, "> $challenge_mbox" or die "failed to open $challenge_mbox: $!\n";
}

$gpgopts = "--no-default-keyring --keyring $keyring --trust-model always"
    if $keyring;

my $count = 0;

foreach our $keyid (@ARGV) {
    die qq("$keyid" doesn't look like a valid Key ID!\n)
        if $keyid !~ /^([A-F0-9]{8}|[A-F0-9]{16})$/i;

    print "Key ID: $keyid\n" if $verbose;

    my %uids;
    my $uid = "";
    my $disabled = 0;
    my $can_encrypt = 0;

    my $gpglistsigopts = $gpgopts;
    $gpglistsigopts .= ' --no-options' if $gpgopts =~ /--keyring/;

    open( GPG, "gpg --with-colon --list-sigs --fixed-list-mode $gpglistsigopts $keyid 2>/dev/null|" )
        or die "Cannot run gpg: $!\n";

    while ( <GPG> ) {
        my ($status, $keycap);

        # check for unusable keys and encryption capability
        if ( /^pub:/ ) {
            ($status, $keycap) = (split /:/)[1,11];

            # skip disabled, expired, invalid, and revoked keys
            if ( $keycap =~ /(D)/ or $status =~ /^(e|i|r)$/ ) {
                print "This key is $codes{$1}.\n" if $verbose;
                last;
            }

            # check for encryption capability
            if ( $keycap =~ /E/ ) {
                $can_encrypt = 1;
                print "Key has encryption capabilities, will encrypt the challenge.\n"
                    if ( $verbose && $mail_client !~ /^kmail$/ );
            }

            $count++;
        }

        # parse user id field(s)
        elsif ( /^uid:/ ) {
            ($status, $uid) = (split /:/)[1,9];

            # skip expired and revoked user id's
            if ( $status =~ /^(e|r)$/ ) {
                print "Skipping $codes{$1} user id ($uid)\n" if $verbose;
                $uid = "";
                next;
            }

            # convert some UTF-8 to latin1
            $uid = utf2latin($uid);

            # check for a valid-looking email address
            # FIXME check for a valid name here as well?
            unless ( valid_email($uid) ) {
                print "No valid email address found for user id ($uid)\n" if $verbose;
                print "Skipping key (0x$keyid)\n" if $verbose;
                $uid  = "";
                %uids = ();
                last;
            }
        }

        # check if $mykeyid has already signed this user id
        elsif ( /^sig:/ ) {
            my ($kid, $exp, $class) = (split /:/)[4,6,10];
            if ( $mykeyid =~ /$kid$/ ) {
                # skip if the sig is non-exportable
                next unless $class =~ /\d*x$/;

                # skip if the sig has expired
                next if $exp and $exp < time;

                print "You already signed this user id ($uid).\n" if $verbose;
                delete $uids{$uid} if exists $uids{$uid};
                $uid = "";
            }
        }

        # save valid user id in the %uids hash
        if ( defined( $uid ) and $uid ne "" ) {
            $uids{$uid} = $uid;
        }

    }
    close GPG;

    # exit if no keys were found
    unless ($count) {
        print "No keys were found for the Key ID's you specified.\n";
        exit (1);
    }

    if ( defined( $uid ) and $uid ne "" ) {
        $uids{$uid} = $uid;
    }

    foreach our $uid ( keys %uids ) {
        # get a random string
        chomp (our $challenge = `gpg -a --gen-random 1 $challenge_length 2>/dev/null`);
        $challenge = substr($challenge, 0, 24);
        die "Failed to get a random challenge string.\n"
            if length($challenge) < $challenge_length;

        # Pull the name, comment, and address out of the user id
        our ($name, $comment, $address) = split_uid($uid);

        # get the key information
        our $keyinfo = "";
        open ( GPG, "gpg $gpgopts --list-options no-show-uid-validity --fingerprint $keyid|" )
            or die "Cannot open gpg: $!\n";
        while ( <GPG> ) {
            $keyinfo .= $_ unless /^$/;
        }
        chomp $keyinfo;

        # Create the body of the message from a template
        my $template = Text::Template->new(SOURCE => $template_file)
            or die "Couldn't construct template: $Text::Template::ERROR";

        my %vars;
        for my $var (keys %replacements) {
            no strict 'refs';
            if ($var eq "keyinfo") {
                # argghhhh, autoformat fucks this up
                $vars{$var} = '__keyinfo__';
                next;
            }
            $vars{$var} = $$var;
            use strict 'refs';
        }

        my $body = $template->fill_in(HASH => \%vars);

        die "Couldn't fill in template: $Text::Template::ERROR"
            if (not defined $body);

        # rewrap the text
        my %format_opts = (
            all     => 1,
            break   => break_wrap,
            right   => $wrap_width,
        );
        $body = autoformat($body, { %format_opts });

        # replace the key info (special casing needed due to autoformat annoyances)
        $body =~ s/__keyinfo__/$keyinfo/g;

        # encrypt the message if the key has encryption capabilities and we're
        # using the mail program as $mail_client
        if ( $can_encrypt and $mail_client =~ /^mail$/i ) {
            $SIG{PIPE} = 'IGNORE';
            my ($encfd, $encfile) = tempfile();
            open( GPG, "|gpg $gpgopts --batch --encrypt --armor --textmode -r 0x$mykeyid --encrypt-to $keyid > $encfile" )
                or die "Cannot run gpg: $!\n";
            print GPG $body;
            close GPG or die "Cannot close gpg command: $!\n";
            die qq("$encfile" doesn't exist\n) if not -e $encfile;
            die qq("$encfile" is empty\n)      if -z $encfile;
            my $encbody;
            while ( <$encfd> ) {
              $encbody .= $_;
            }
            close $encfd;
            unlink $encfile;
            delete $SIG{PIPE};

            $body = $encbody;
        }

        # mail the message using $mail_client
        if ( not defined( $mail_client ) or $mail_client eq "" ) {
            pod2usage("\nYou must specify the mail-client to use!\n");
        }

        elsif ( $mail_client =~ /^mail$/i ) {
            # send immediately using the mail command
            $SIG{PIPE} = 'IGNORE';
            open( MAIL, qq(|mail -s "$subject" "$uid") )
                or die "Cannot run mail: $!\n";
            print MAIL $body;
            close MAIL or die "Can't close mail command: $!\n";
            delete $SIG{PIPE};
        }

        elsif ( $mail_client =~ /^mbox$/i ) {
            # save the mail in an mbox for later sending
            my $date = localtime;
            my $xmst = "S"; # XXX add I for inline pgp -- optional?
            $xmst   .= "E" if $can_encrypt;
            print MBOX "From $myaddr $date\n"
                     . "To: " . quote_uid($uid) . "\n"
                     . "From: \"$myname\" <$myaddr>\n"
                     . "Subject: $subject\n"
                     . "X-Mutt-Fcc: =sent\n"
                     . "X-Mutt-PGP: $xmst\n"
                     . "\n"
                     . "$body\n\n";
        }

        elsif ( $mail_client =~ /^mutt$/i ) {
            # send using mutt, allowing to check before sending
            my ($muttfd, $muttfile) = tempfile();
            my $header = "To: " . quote_uid($uid) . "\n"
                       . "From: \"$myname\" <$myaddr>\n"
                       . "Subject: $subject\n";
            print $muttfd "$header\n$body";

            # sign messages by default. encrypt if possible
            # XXX should inline (pgp_create_traditional) be an option?
            my $muttopts = qq(-e "set crypt_autosign" );
            $muttopts   .= qq(-e "set crypt_autoencrypt") if $can_encrypt;

            !system( "mutt $muttopts -H $muttfile 2>/dev/null" )
                or die "Cannot run mutt: $!\n";
            close $muttfd;
            unlink $muttfile;
        }

        elsif ( $mail_client =~ /^kmail$/i ) {
            # send using KDE's DCOP interface, allowing to check before sending
            open( DCOP, qq(dcop kmail KMailIface openComposer "$uid" "" "" "$subject" "$body" false|) )
                or die "Cannot access Kmail DCOP interface: $!\n";
            my $dcopRef = <DCOP>;
            close DCOP or die "Error running KMail.\n";
            chomp $dcopRef;
        }
        else {
            die "Unrecognized mail-client: $mail_client\n";
        }

        # print the challenge if we're being verbose
        print "$keyid:$challenge:$uid\n" if $verbose;

        # save the challenge string to a file for later validation against
        # signed reply and for future reference
        chomp (my $date = qx'date +%Y%m%d');
        my $cdir  = join( "/", $challenge_dir, $date );
        mkpath( $cdir ) if not -d $cdir;
        my $cfile = "$cdir/$keyid";
        #print "Saving the challenge string to $cfile\n" if $verbose;
        open( CFILE, ">> $cfile" )
            or die "Failed to open $cfile for writing: $!\n";
        print CFILE "$keyid:$challenge:$uid\n";
        close CFILE;
    }
    print "\n" if $verbose;
}

if ( $mail_client =~ /^mbox$/i ) {
    print "Challenge emails have been stored in $challenge_mbox.\n"
}

sub mail_clients {
    print "Valid mail-clients (for use with the --mail-client|-m option):\n";
    for my $client (sort @mail_clients) {
        print "    $client\n"
    }
    exit(1);
}

sub replacements {
    print "Valid replacement strings for use in the challenge template:\n";
    for (sort keys %replacements) {
        printf "    %-12s %s\n", $_, $replacements{$_};
    }
    exit(1);
}

# quote a uid in a manner suitable for sending via smtp
sub quote_uid {
    my $uid = shift;
    my ($name, $comment, $address) = split_uid($uid);
    return qq("$name ($comment)" <$address>) if $comment;
    return qq("$name" <$address>);
}

# Pull the name, comment, and address out of the user id
sub split_uid {
    my $uid = shift;
    my ($name, $comment, $address);
    if ($uid =~ /^([^(<]+) \(([^)]+)\) <([^>]+)>$/) {
        # name (comment) <address>
        ($name, $comment, $address) = ($1, $2, $3);
    }
    elsif ($uid =~ /^([^(<]+) <([^>]+)>$/) {
        # name <address>
        ($name, $comment, $address) = ($1, "", $2);
    }
    return ($name, $comment, $address);
}

# convert some UTF-8 to latin1
# FIXME isn't there a cleaner way to do this?
sub utf2latin {
    my $str = shift;
    $str =~ s/Ã\\x9f/ß/g;
    $str =~ s/Ã\\x89/É/g;
    $str =~ s/ä/ä/g;
    $str =~ s/á/á/g;
    $str =~ s/é/é/g;
    $str =~ s/è/è/g;
    $str =~ s/ø/ø/g;
    $str =~ s/ö/ö/g;
    $str =~ s/ü/ü/g;
    $str =~ s/Ä\\x8c/C/g;
    $str =~ s/Å\\x99/r/g;
    $str =~ s/\\x3a/:/g;
    return $str;
}

sub valid_email {
    my $str = shift;
    if ($str =~ /([0-9a-zA-Z]([-.\w]*[0-9a-zA-Z])*@([0-9a-zA-Z][-\w]*[0-9a-zA-Z]\.)+[a-zA-Z]{2,9})/ ) {
        return 1;
    }
    return 0;
}


__END__

=head1 NAME

gpg-send-challenges - Generate email challenges after a keysigning event

=head1 SYNOPSIS

gpg-send-challenges [options] <key-id ...>

 Options:
    --cert-policy, -p           url of your signing/certification policy
    --challenge-dir, -c         directory to save challenge strings
    --challenge-length, -l      length of the challenge string
    --event, -e                 string describing the key signing event
    --help, -h, -?              print this help message
    --list-mail-clients, -M     list valid mail clients
    --list-replacements, -r     list valid replacements in templates
    --keyring, -K               the keyring to use
    --mail-client, -m           mail client to use
    --my-addr, -a               email address you're sending from
    --my-key, -k                key id of the key you're signing with
    --my-name, -n               your name
    --subject, -s               subject of the challenge email(s)
    --template, -t              location of the challenge template file
    --verbose, -v               be more verbose
    --wrap-width, -w            width in characters to wrap text at

=head1 OPTIONS

=over 8

=item B<--cert-policy>, B<-p>

The location of your key signing/certification policy.  By default the value
that is set in your gpg.conf file for cert-policy-url is used.

=item B<--challenge-dir>, B<-d>

The directory where challenge strings are saved.  The default is
~/.gnupg/challenges.  The date, formatted as YYYYMMDD and the short key id of
the key being challenged are appended to this to form the full path.

=item B<--challenge-length>, B<-l>

The length of the challenge string.  The default is 24 characters.

=item B<--event>, B<-e>

This is a string describing the key signing event.  It will be used in the
message to help remind the recipient where the key signing took place.

=item B<--help>, B<-h>, B<-?>

Prints this help message

=item B<--keyring>, B<-K>

The gpg keyring to use.  See L<gpg(1)> for a description of how this option
works

=item B<--mail-client>, B<-m>

The mail client to use for sending challenges.

For a list of valid mail clients, use the --list-mail-clients (-M) option.

=item B<--my-addr>, B<-a>

This is the email address that you are sending the challenges from.

=item B<--my-key>, B<-k>

This is the key id of the key you're signing with.  You must use the long form
of the key id here, which is 16 characters.

=item B<--my-name>, B<-n>

This is your name as it should appear in the message body and the from header of
the email.

=item B<--subect>, B<-s>

The subject to use for the challenge email(s)

=item B<--template>, B<-t>

The location of the challenge template file.  This files contains the basic
template to use for the challenge message body.  Variables enclosed in curly
brackets are replaced.  E.g. {$event} is replaced by the value specified using
the --event option.  (Uses the L<Text::Template> module.)

A very terse challenge file might look like this:

=over 4

Hi {$name},

We exchanged PGP key information at {$event}.  As part of my key certification
process I would like you to reply to this message and sign it with your key
({$keyid}).  You must quote this challenge string in your reply:

{$keyid}:{$challenge}:{$uid}

Thanks,

{$myname}

=back

For a list of valid replacement strings, use the --list-replacements (-r) option.

=item B<--wrap-width>, B<-w>

The width in characters to wrap text at.  The default is 74.

=back

=head1 ARGUMENTS

=over 8

=item B<key id>

A list of key id's you wish to send challenges to.  The key id's may be
specified using either the short or long form (8 or 16 characters).

=back

=head1 DESCRIPTION

B<gpg-send-challenges> accepts a list of key id's (both short or long form) and
will generate a random challenge string for each user id with a valid email
address for each key id.  It can send the challenge messages automatically using
the mail command or it can create a draft that you may review in your mail
client before sending.  It also saves the key id, challenge string, and user id
to a file for you to check against the messages you recieve from the owners of
the keys you have been asked to certify.

=cut