#!/usr/bin/perl

# Copyright (c) 2004 Cyrille Lefevre <Cyrille.Lefevre [at] laposte.net>.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in
#    the documentation and/or other materials provided with the
#    distribution.
# 3. The name of the authors and contributors may not be used to
#    endorse or promote products derived from this software without
#    specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS''
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
# PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS
# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
# USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
# OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.

=head1 NAME

pgp-verify - validate and transform a PGP signed message

=head1 SYNOPSIS

B<pgp-verify> [-B<abcfkm>] [-B<i> I<infile>] [-B<o> I<outfile>]
[-B<r> I<retry_count>] [--B<attach>] [--B<core>] [--B<footer>]
[--B<keep>] [--B<mbox>] [--B<in> I<file>] [--B<out> I<file>]
[--B<retry> I<count>]

B<pgp-verify> -B<h> or --B<help>

B<pgp-verify> --B<man>

=head1 OPTIONS

=over 8

=item -B<a> or --B<attach>

The I<GnuPG> output is attached instead of inlined.

=item -B<b> or --B<binmode>

Do CR/LF translation on the input stream.

=item -B<c> or --B<core>

Parse the input file in memory instead of using temporary files.

=item -B<f> or --B<footer>

The I<GnuPG> output is appended to the message body instead of prepended.

=item -B<k> or --B<keep>

Keep a copy of the original signed message for futher verification.
The default is to delete the signed message and the signature.

=item -B<m> or --B<mbox>

Prepend the B<From > header required by the Unix mbox format.

=item -B<i> I<file> or --B<in> I<file>

I<file> contains the signed message instead of B<stdin>.

=item -B<o> I<file> or --B<out> I<file>

Output the verified message to I<file> instead of B<stdout>.

=item -B<r> I<count> or --B<retry> I<count>

Retry I<count> times to verify the signed message.
Use this if you specify C<hkp://subkeys.pgp.net> as
your key server in your I<GnuPG> configuration file.

=item -B<h> or --B<help>

Print a brief help message and exits.

=item --B<man>

Prints the manual page and exits.

=back

=head1 DESCRIPTION

The B<pgp-verify> utility validates and transforms a I<PGP> signed
message in a way it can be viewed using a non I<PGP> capable mail
reader such as I<Outlook Express>.

Input must be:

=over 4

=item *

A I<multipart/signed> message.

=item *

A I<multipart/mixed> message containing a I<multipart/signed> message.

=item *

An I<application/pgp> signed message.

=item *

A I<multipart/mixed> message containing an I<application/pgp> signed message.

=back

A non I<PGP> signed message will be printed as-is.

Output will be a I<multipart/mixed> message containing the
signed part of the original message without the signature.

If the B<--attach> option is given, the I<GnuPG> output will be
provided as an attachment instead of inlined in the I<preamble> or
I<epilogue> part of the message.

If the B<--keep> option is given, the original signed message
and signature are kept as an attachment for futher verification
if any.

=head1 EXAMPLES

Insert the following code in your I<procmail> configuration file:

=pod

 PMDIR=${HOME}
 LOCKEXT=.lock
 NL="
 "

 COPY_MBOX=pgp-prec
 PGP_MBOX=pgp-post
 PGP_LOCK=${PGP_MBOX}${LOCKEXT}
 PGP_VERIFY=NO

 :0 H
 * ^Content-Type: (multipart/signed.*$.*application/pgp|application/pgp.*=sign)
 { PGP_VERIFY=YES }

 :0 EB
 * ^Content-Type: (multipart/signed.*$.*application/pgp|application/pgp.*=sign)
 { PGP_VERIFY=YES }

 :0
 * PGP_VERIFY ?? YES
 {
 	LOG="*** Verifying Signed PGP message.${NL}"
 	INCORE=

 	# this is optional.
 	:0 c:
 	${COPY_MBOX}

 	:0
 	* < 256000
 	{ INCORE=-c }

 	# ``: ${PGP_LOCK}'' is optional too, if
 	# ``| tee -a ${PGP_MBOX}'' is deleted.
 	:0 fw: ${PGP_LOCK}
 	| ${PMDIR}/pgp-verify.pl -akmv -r 3 ${INCORE} | tee -a ${PGP_MBOX}
 }

=head1 DIAGNOSTICS

The B<pgp-verify> utility exits 0 on success, and >0 if an error occurs.

=head1 ENVIRONMENT

=over 8

=item B<GNUPGHOME>

If set, directory used instead of C<~/.gnupg>.

=back

=head1 FILES

=over 8

=item B<~/.gnupg/gpg.conf>

Default I<GnuPG> configuration file.

=item B<~/.gnupg/options>

Old style I<GnuPG> configuration file; only used when gpg.conf is not found.

=item B<~/.procmailrc>

Default I<procmail> configuration file.

=back

=head1 SEE ALSO

B<gpg>(1), B<procmail>(1), B<procmailrc>(5).

=head1 DEPENDENCIES

B<MIME-tools> (MIME::Parser, MIME::Entity), B<Mail-GnuPG> (Mail::GnuPG),
B<MailTools> (Mail::Address), B<TimeDate> (Date::Parse, Date::Format).

=head1 AUTHOR

Copyright (c) 2004 Cyrille Lefevre <B<Cyrille.Lefevre [at] laposte.net>>.
All rights reserved.

You may redistribute and/or modify this program under the terms of the
new B<BSD> license included in the program itself.

=head1 HISTORY

 29 May 2004	1.0	Cyrille Lefevre <Cyrille.Lefevre [at] laposte.net>
 01 Jun 2004	1.1	Cyrille Lefevre <Cyrille.Lefevre [at] laposte.net>
	"multipart/signed" messages may be of type "application/pgp" or
	"application/x-pkcs7-signature".  For instance, this utility 
	only known how to handle "application/pgp" ones.
	"application/pgp" messages may be of type "sign" or "encrypt".
	For instance, this utility only known how to handle "sign" ones.
 04 Jun 2004	1.2	Cyrille Lefevre <Cyrille.Lefevre [at] laposte.net>
	main() and from_line() added. Generate a From_ line on error.
	Dump the message to $outfile instead of to *STDOUT on error.
	-b/-binmode option added.  X-PGP-Autoconverted: header added.
 07 Jun 2004	1.3	Cyrille Lefevre <Cyrille.Lefevre [at] laposte.net>
	EXAMPLES section updated to handle multi-line headers with CR (^M).

=head1 BUGS

In I<multipart/mixed> messages, the first part have to be the
I<multipart/signed> or I<application/pgp> message.

In I<multipart/signed> messages, the first part have to be the
signed message and the second part, the signature.

The I<preamble> or I<epilogue> of a MIME message aren't visible
under a MIME capable mail reader.

This utility does not handle recursively signed messages, only
the top level signed message will be validated.

=cut

use 5.006;
# use strict;
# use warnings;

our $VERSION = '1.3';

use English;
use Getopt::Long qw(:config bundling_override);
use Pod::Usage;
use MIME::Parser;
use MIME::Entity;
use Mail::GnuPG;
use Mail::Address;
use Date::Parse qw(str2time);
use Date::Format qw(ctime);

sub is_signed ($) {
	my ($entity) = @_;

	return ((($entity->effective_type =~ m!multipart/signed!) and
	 ($entity->head->mime_attr("Content-Type.protocol") =~ m!application/pgp!)) or
	(($entity->effective_type =~ m!application/pgp!) and
	 ($entity->head->mime_attr("Content-Type.x-action") =~ m!sign!)) or
	($entity->bodyhandle->as_string =~ m!^-----BEGIN PGP SIGNED MESSAGE-----!m));
}

sub from_line ($) {
	my ($entity) = @_;
	my @froms = (
		"Resent-Reply-To", "Resent-From", "Resent-Sender",
		"Reply-To", "From", "Sender",
		"Return-Path", # "From_",
		"Errors-To", "Return-Receipt-To", "Path", "X-Envelope-From"
	);
	my $from = undef;
	foreach (@froms) {
		my $value = $entity->head->get($_);
		next if (!defined($value));
		my @addrs = Mail::Address->parse($value);
		next if (!scalar(@addrs));
		$from = $addrs[0]->address;
		last;
	}
	$from = "nobody" if (!defined($from));
	@dates = ( "Resent-Date", "Date", "Posted-Date", "Received-Date" );
	my $date = undef;
	foreach (@dates) {
		my $value = $entity->head->get($_);
		next if (!defined($value));
		$date = ctime(str2time($value));
		last;
	}
	$date = ctime(time) if (!defined($date));
	print "From $from $date";
}

sub main {
	my $args = $ARGV[$#ARGV];
	my %opts = (
		'attach' => 0,
		'binmode' => 0,
		'core' => 0,
		'footer' => 0,
		'help' => 0,
		'keep' => 0,
		'man' => 0,
		'mbox' => 0,
		'retry' => 1,
		'verbose' => 0
	);
	my @optkeys = (
		'attach|a!',
		'binmode|b!',
		'core|c!',
		'footer|f!',
		'help|h|?',
		'in|i=s',
		'keep|k!',
		'man',
		'mbox|m!',
		'out|o=s',
		'retry|r=i',
		'verbose|v!'
	);
	GetOptions(\%opts, @optkeys) or pod2usage(-exitval => 2);
	pod2usage(-exitval => 1) if ($opts{help});
	pod2usage(-verbose => 2) if ($opts{man});

	my $infile = \*STDIN;
	open($infile, $opts{infile}) or die "open: $!"
		if (defined($opts{infile}));
	binmode($infile,":crlf")
		if ($opts{binmode});

	my $outfile = \*STDOUT;
	open($outfile, '>>', $opts{outfile}) or die "open: $!"
		if (defined($opts{outfile}));

	my $parser = new MIME::Parser;

	# keep message in memory, no writing to disk.
	if ($opts{core}) {
		$parser->output_to_core(true);
		$parser->tmp_recycling(true);
		$parser->tmp_to_core(true);
		$parser->use_inner_files(true)
			if (defined($opts{infile}));
	}

	# parse message
	# we use the "ultra-tolerant" mechanism from the
	# manpage and simply do nothing at all if parsing fails.
	#
	$parser->ignore_errors(1);
	my $top = eval { $parser->parse($infile) };
	my $error = ($@ || $parser->last_error);

	# if an error occurred, do nothing. just give back the mail on STDOUT.
	if ($error) {
		print STDERR "parse error!\n$parser->last_error\n" if ($opts{verbose});
		from_line($top)
			if ($opts{mbox});
		$top->print($outfile);
		exit(0);
	}

	my $gnupg = new Mail::GnuPG();
	$sub = $top->effective_type =~ m!multipart/mixed! ? $top->parts(0) : $top;
	if (!is_signed($sub)) {
		print STDERR "unsigned message!\n" if ($opts{verbose});
		from_line($top)
			if ($opts{mbox});
		$top->print($outfile);
		exit(0);
	}

	my $type = $sub->effective_type;
	while ($opts{retry}-- > 0) {
		my ($success, $keyid, $email) = $gnupg->verify($sub);
		last if (!$success);
	}

	my $pgpmime = $sub->is_multipart;
	if ($pgpmime) {
		if ($opts{keep}) {
			my $head = $sub->parts(1)->head;
			$head->mime_attr("Content-Type.name", "signature.asc")
				if (!defined($head->recommended_filename));
			$top->make_multipart("mixed", Force => 1)
				if ($sub == $top);
			$top->add_part($top->parts(0)->parts(0)->dup, 0);
			$sub = $top;
		} else {
			my @parts = grep {
				$_->mime_type !~ "application/pgp-signature"
			} $sub->parts;
			$sub->parts(\@parts);
			my $head = $sub->head;
			my $boundary = $head->multipart_boundary;
			$head->replace("Content-Type", "multipart/mixed");
			$head->mime_attr("Content-Type.boundary", $boundary);
		}
	} else {
		$top->make_multipart
			if ($sub == $top);
		$top->add_part($sub->parts(0)->dup)
			if ($opts{keep});
		my $part = $sub->parts(0);
		my $head = $part->head;
		$head->replace("Content-Type", "text/plain");
		$head->mime_attr("Content-Type.charset" =>
			($head->mime_encoding eq "7bit" ? "us-ascii" : "unknown-8bit"));
		$head->replace("Content-Disposition", "inline");
		my ($skip, @lines) = (0, ());
		foreach ($part->bodyhandle->as_lines) {
			$skip = 0 if (($skip == 1 and !/^Hash/) or $skip == 3);
			$skip = 1 if (/^-----BEGIN PGP SIGNED MESSAGE-----/);
			$skip = 2 if (/^-----BEGIN PGP SIGNATURE-----/);
			$skip = 3 if (/^-----END PGP SIGNATURE-----/);
			push @lines, $_ unless ($skip);
		}
		if ($opts{core}) {
			$part->bodyhandle(new MIME::Body::InCore [@lines]);
		} else {
			$part->bodyhandle(new MIME::Body::Scalar [@lines]);
		}
	}

	$sub->head->replace("Content-Disposition", "inline");
	$top->head->replace("Content-Disposition", "inline")
		if ($sub != $top);

	if ($opts{attach}) {
		my $part = MIME::Entity->build(Type => "text/plain",
					       Charset => "iso-8859-1",
					       Disposition => "inline",
					       Encoding => "quoted-printable",
					       Data => $gnupg->{last_message});
		$sub->add_part($part, $opts{footer} ? undef : 0);
	} else {
		if ($opts{footer}) {
			my @lines = @{$top->epilogue};
			push @lines, $_ foreach (@{$gnupg->{last_message}});
			$top->epilogue(\@lines);
		} else {
			my @lines = @{$top->preamble};
			push @lines, "This is a multi-part message in MIME format...\n"
				if (!scalar(@lines) or !length($lines[0]));
			push @lines, $_ foreach (@{$gnupg->{last_message}});
			$top->preamble(\@lines);
		}
	}

	$top->head->replace("Content-Length", length($top->body_as_string));
	$top->head->replace("X-PGP-Autoconverted",
		"from $type to multipart/mixed by pgp-verify.pl $VERSION");

	from_line($top)
		if ($opts{mbox});
	$top->print($outfile);

	exit($success);
}

&main;

END {
	$parser->filer->purge
		if (defined($parser) and !$opts{core});
}