#!/usr/bin/perl -w

# $Id: ca-sendout 145 2004-04-26 21:22:59Z weasel $

# Copyright (c) 1998 Ian Jackson
#           (c) 2001, 2003, 2004 Peter Palfrader
#
# 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, 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 GNU Privacy Guard; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
# 02111-1307, USA.


use strict;
use English;
use IO::Handle;
use File::Path;
use Cabot qw(%CONFIG $VERSION genrandstring getkeydir makekeydir mkfds ask readwritegpg);

my $config = $ENV{'HOME'} . '/.cabotrc';
-f $config or die "No file $config present.  See ca-config(5).\n";
unless (scalar eval `cat $config`) {
        die "Couldn't parse $_: $@.\n" if $@;
};

open URANDOM, "< /dev/urandom" or die $!;

sub randhex ($) {
	my ($length) = @_;
	my $rand_data;
	sysread(URANDOM,$rand_data,$length) == $length or die $!;
	$rand_data = uc unpack 'h*',$rand_data;
};

sub send_encrypted_mail($$$$) {
	my ($to, $key, $subject, $text) = @_;
	
	my $gnupg = GnuPG::Interface->new();
	$gnupg->options->hash_init( 'armor'        => 1,
	                            'always_trust' => 1);
	$gnupg->options->push_recipients( $key );
	$gnupg->options->push_recipients( $CONFIG{'keyid'} );
	my ($inputfd, $stdoutfd, $stderrfd, $statusfd, $handles) = mkfds();
	my $pid = $gnupg->encrypt( handles => $handles );
	my ($stdout, $stderr, $status) = readwritegpg($text, $inputfd, $stdoutfd, $stderrfd, $statusfd);
	waitpid $pid, 0;

	if ($status =~ /^\[GNUPG:\] \s+ INV_RECP/mx) {
		print STDERR "$PROGRAM_NAME: GnuPG says Invalid Recipient\n";
		return undef;
	};
	unless ($status =~ /^\[GNUPG:\] \s+ BEGIN_ENCRYPTION/mx &&
	        $status =~ /^\[GNUPG:\] \s+ END_ENCRYPTION/mx) {
		print STDERR "$PROGRAM_NAME: Encryption apparently didn't suceed.  GnuPG Status:\n$status\n";
		return undef;
	};

	my $clear_body = $CONFIG{'preamble'};# . $stdout;

        my $second_level_boundary = "bar";
        $second_level_boundary = genrandstring(8) 
            while (grep /$second_level_boundary/, $stdout);
        
        my $openpgp_part = << "EOF";
Content-Type: multipart/encrypted; protocol="application/pgp-encrypted";
   boundary="$second_level_boundary"


--$second_level_boundary
Content-Type: application/pgp-encrypted

Version: 1

--$second_level_boundary
Content-Type: application/octet-stream

$stdout

--$second_level_boundary--
EOF
        my $first_level_boundary = "foo";
        $first_level_boundary = genrandstring(8) 
            while (grep /$first_level_boundary/, $clear_body . $openpgp_part);
	
	my $msg = << "EOF";
Subject: $subject
To: $to
Bcc: $CONFIG{'BCCmail'}
From: $CONFIG{'bot'}
User-Agent: cabot $VERSION, (c) 1998 Ian Jackson, (c) 2001, 2003, 2004 Peter Palfrader
X-URL: http://www.palfrader.org/cabot/
MIME-Version: 1.0
Content-Type: multipart/mixed; boundary="$first_level_boundary"

--$first_level_boundary

$clear_body
--$first_level_boundary
$openpgp_part
--$first_level_boundary--
EOF
	open(MAIL, $CONFIG{'sendmail'}) || die ("Cannot execute sendmail: $!\n");
	print MAIL $msg;
	close(MAIL);

	return $msg;
};


opendir(SENDOUTDIR, $CONFIG{'sendoutdir'}) || die ("Cannot read ".$CONFIG{'sendoutdir'}.": $!\n");
my @dirs = grep {/^[0-9A-F]{8}$/} readdir(SENDOUTDIR);
closedir(SENDOUTDIR);

# Uncomment next lines if you want to test.
# send_encrypted_mail("Laurent Fousse <laurent\@komite.net>",
#                    "A1696D2B", "Cabot Test", "This is the encrypted part.");

for my $keyid (@dirs) {
	opendir(UIDSDIR, getkeydir('sendoutdir', $keyid)) || die ("Cannot read ".getkeydir('sendoutdir', $keyid).": $!\n");
	my @uids = grep {! /^\./} readdir(UIDSDIR);
	closedir(UIDSDIR);

	for my $uid (@uids) {
		unless ($uid =~ /@/) {
			warn("UID $uid has no email address. Skipping.\n");
			next;
		};

		my $magic = randhex(24);
		open(MAGIC, '>'.getkeydir('sendoutdir', $keyid, $uid).'/MAGIC') ||
			die("Cannot open ".getkeydir('sendoutdir', $keyid, $uid).'/MAGIC'.": $!\n");
		print MAGIC $magic;
		close(MAGIC);

		my $text = <<"EOF";
This message is sent as part of my certification process.
It is to verify that you, the keyholder of $keyid
can read email sent to the associated address
$uid

Please, now that you have decrypted this message,
simply reply to the bot email address
  $CONFIG{'bot'}
quoting

| Key: $keyid
| Magic: $magic
| Upload to keyservers: Yes

in the body of your mail.

If you asked me to certify more than one userid or email address
on your key you should receive one of these messages for each
address - in that case please send one reply per address, too.

If you do not want the signed key to be uploaded to the keyserver
network simply remove or change the line 'Upload to keyservers'.

Please do NOT encrypt or MIME-encode the resulting mail; the bot
does not have access to my key and does not run MIME software.

Thanks,
 $CONFIG{'signoff'}
EOF
                $text = "\n" . $text;  # see rfc 3156, 4.
		print "Sending mail to $uid\n";
		my $mail = send_encrypted_mail($uid, $keyid, "PGP/GPG key exchange formalities", $text);
		if (defined $mail) {
			print "done.\n";

			makekeydir('sentdir', $keyid);
			rename(getkeydir('sendoutdir', $keyid, $uid), getkeydir('sentdir', $keyid, $uid)) ||
				die("Cannot move ".getkeydir('sendoutdir', $keyid, $uid)." to "
				    .getkeydir('sentdir', $keyid, $uid).": $!\n");
			rmdir(getkeydir('sendoutdir', $keyid)); # may fail

			open(SENTOUT, '>'.getkeydir('sentdir', $keyid, $uid).'/CHALLENGE') ||
				die("Cannot open ".getkeydir('sentdir', $keyid, $uid).'/CHALLENGE'.": $!\n");
			print SENTOUT $mail;
			close (SENTOUT);
		} else {
			print STDERR "Sending mail to $uid aborted.\n"
		};
	};

};

close URANDOM;

__END__

=pod

=head1 NAME

ca-sendout - send GPG challenges for email verification

=head1 SYNOPSIS

B<ca-sendout>

=head1 DESCRIPTION

B<ca-sendout> sends an encrypted email containing a random cookie (generated
using the C</dev/urandom> interface) to all email adresses found in the uid's
of all public keys in C<sendoutdir>.  These emails are encrypted using the
uid's public keys.  Once the mails are sent, C<sendoutdir>/I<keyid>/ is moved
to C<sentdir>/I<keyid>/, where files MAGIC and CHALLENGE are stored.

The text in the preamble config setting is prepended to the email body, and
send in clear text.  See the source of this script for other texts which will
appear in the message.  ( FIXME embed pod for easy doc maintaining, or, even
better, make it configurable. )

ca-sendout is one of the ca-bot scripts, see ca-bot(7) for more information.

=head1 CONFORMING TO

ca-sendout tries to conform to the RFCs which are relevant to email
messages in general and encrypted emails in particular, namely:

=over

=item o 
B<RFC 2046>, Multipurpose Internet Mail Extensions (MIME) Part Two:
Media Types.

=item o
B<RFC 3156>, MIME Security with OpenPGP.

=back

=head1 SEE ALSO

ca-bot(7)

=head1 VERSION

$Id: ca-sendout 145 2004-04-26 21:22:59Z weasel $

=head1 AUTHORS

Ian Jackson and Peter Palfrader

=cut


