#!/usr/bin/perl -w

# MHOnArc plugin for managing PKCS#7 signed data.
# ©-IDEALX 2001. May be freely used and distributed under the
# terms of the GNU General Public License v2.

package IDX::MHOnArcAddOns;

use strict;
use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
use Errno;

sub filter_pkcs7_mime {
	my (undef, undef, $bodysymbol, $isdecoded, $args)=@_;
	local *FULLSIG; local *OPENSSL;
	my $bodyref=*{$bodysymbol}{SCALAR};

	# We keep the signature around
	my $sigfilepfx=$mhonarc::OUTDIR; # Fixes silly warning
	$sigfilepfx="pkcs7sig-$$-".time();
	my ($sigfile,$fullsigfile);
	for(my $i=0; $i<1000; $i++) {
		# FIXME: not NFS resistant.
		$!=0;
		$fullsigfile=$mhonarc::OUTDIR."/$sigfilepfx-$i.bin";
		sysopen(FULLSIG,$fullsigfile, O_WRONLY|O_CREAT|O_EXCL);
		$! && do {
			next if $!{EEXIST};
			last;
		};
		$sigfile="$sigfilepfx-$i.bin";
		last;
	};

	die "Could not open a file beginning with name $sigfilepfx" if
	  (!defined $sigfile);

	print FULLSIG $$bodyref;
	close(FULLSIG);

	my $ispem=scalar( $$bodyref =~ m/^-*BEGIN PKCS7/ );

	# FIXME: configurable path for openssl ?
	open(OPENSSL,"openssl smime -verify -noverify ".
		 ($ispem? "-inform pem ": "-inform der ").
		 "-in $fullsigfile 2>/dev/null |");

	my $body=join('',<OPENSSL>);
	close(OPENSSL);
	# FIXME: should check return code of openssl so as to do something
	# with non-extractible messages.

	# OK now we have some kind of bogus MIME document in $headersandtext.
	# We must recurse through MHOnArc's innards (which are quite well
	# thought, fortunately) to get an HTML vision of same.

	my %headfields; my %junk;
	my $header=readmail::MAILread_header(\$body,\%headfields, {});

	my ($text,@files)=readmail::MAILread_body
	  ($header,$body,
	   ($headfields{"content-type"} || "text/plain"),
	   ($headfields{"content-transfer-encoding"} || "US-ASCII"));

	return ( ("$text\n"."<PRE>".# $$bodyref."</PRE>". Data::Dumper::Dumper(\@_).
			qq{<BR><A HREF="$sigfile">Original signed message (PKCS#7, }.
			($ispem ? "PEM format": "DER format").")</A>"),
			$fullsigfile,@files);
			# FIXME: shall we not return relative path ($sigfile instead of
			# $fullsigfile)?
}


######################## TEST SUITE #############################

eval join('',<main::DATA>) || die "$@" unless caller();
__END__

use Test;

BEGIN { plan tests => 4 };

#### FIRST TEST: openssl availability, DER recoding

use vars qw($pkcs7pem $pkcs7der);

$pkcs7pem=<<ZONK;
-----BEGIN PKCS7-----
MIINQAYJKoZIhvcNAQcCoIINMTCCDS0CAQExCzAJBgUrDgMCGgUAMGoGCSqGSIb3
DQEHAaBdBFtDb250ZW50LVR5cGU6IHRleHQvcGxhaW47DQoJY2hhcnNldD0iaXNv
LTg4NTktMSINCkNvbnRlbnQtVHJhbnNmZXItRW5jb2Rpbmc6IDdiaXQNCg0KDQp0
ZXN0oIIKozCCBKEwggKJoAMCAQICASIwDQYJKoZIhvcNAQEFBQAwRTELMAkGA1UE
BhMCRlIxDzANBgNVBAoTBklERUFMWDEMMAoGA1UECxMDUzNQMRcwFQYDVQQDEw5v
cGVyYXRpb25hbCBDQTAeFw0wMTExMDkwOTMwMDRaFw0wMjExMDkwOTMwMDRaMDcx
CzAJBgNVBAYTAkZSMQ8wDQYDVQQKEwZJREVBTFgxFzAVBgNVBAMTDlNlYmFzdGll
biBBYmRpMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDK+HZTT0R/0HIkJD5J
Hs+tnrSyqoqBhN3tuBE94XKeqr3WiCxM2X1pzwdzNY92qPuFyiDM1DYX3Jx07gkX
NDJhqoFRobmQ9V8Iv0Uhvz14aP4D/F2zY7wwwo0WR78mYmmC3ImczPFW82hf14ol
rxB1pVkGIreLEGUAa7BLL4yB3wIDAQABo4IBLDCCASgwHQYDVR0OBBYEFPtfH/wl
jlWq36uhObDqZ5IyD3zFMGYGA1UdIwRfMF2AFJ/DUfjotR4vsPTu6sPgGs1Nq1WF
oUKkQDA+MQwwCgYDVQQLEwNTM1AxDzANBgNVBAoTBklERUFMWDELMAkGA1UEBhMC
RlIxEDAOBgNVBAMTB3Jvb3QgQ0GCAQEwNwYDVR0fBDAwLjAsoCqgKIYmaHR0cDov
L3N1ZXouc3BkYS5pZGVhbHguY29tOjgwL2NybC5jcmwwDgYDVR0PAQH/BAQDAgXg
MB0GA1UdJQQWMBQGCCsGAQUFBwMEBggrBgEFBQcDAjARBglghkgBhvhCAQEEBAMC
BaAwJAYDVR0RBB0wG4EZc2ViYXN0aWVuLmFiZGlAaWRlYWx4LmNvbTANBgkqhkiG
9w0BAQUFAAOCAgEAOf83Ues9lXZFX9AqH1l3A5vUAJpZvQ6VX/DHnqLS4lznTC1z
eFs3jzm3Note+8/JJkTUYNEADF+2O60JC+bxbD5C3OEl7Mq/A/hIgfYuedO6kRyH
sz94v+A1pkyOjCdItPXMubeD5Rdw/h7qslwScAIOY8xfUYXyNW/c2gViJHfFJDnh
jO14Kt4XeO2IAaWQfGuKawHW7aou++1rmZtiqlTWk/0SBqaKLZMrgxAtUpk79K/W
gcbjWooWvE7scD+AcOnlLRxafOJhp6hTSmvzDD5tQnuCuiiybozHRDRQlfViWnAb
z45xhM9QHbunstyTtzgsFvrmcALqKw/G0GEpO+lKc+TrPS1S1/aai1NaQZ54fssS
8C8n4TfBT6HX7I1dAobxJz2ZUElZPzIzMCLfInaJ1TE6pq7FFlW/lO/GkBDcxDHw
fooSF5D6jNQjdIsZg+tJelfhcXKeNfeOb0MjmUSu6APwzvQa86icH5CLBLcXh7oy
hcKMSlSg1/KiDaqVaeIUWt/agHBEKDMNvTNcCJUdkxLngH0mrRDbXy2MikZCUFDo
bli2rvEqL83B3XIMsyZ/mdLt5Y6KYhYrQwxjp06B7h0uZ8XUHXq/FfjQ/CgSZhpE
UfK6CVy4sp7vuDiyEleghIFHs7TXyZL1aDRtWjkoMULAMJJE7SGl/8XpuTwwggX6
MIID4qADAgECAgEBMA0GCSqGSIb3DQEBBQUAMD4xDDAKBgNVBAsTA1MzUDEPMA0G
A1UEChMGSURFQUxYMQswCQYDVQQGEwJGUjEQMA4GA1UEAxMHcm9vdCBDQTAeFw0w
MTExMDIxMjE4MzZaFw0wNjExMDExMjE4MzZaMEUxCzAJBgNVBAYTAkZSMQ8wDQYD
VQQKEwZJREVBTFgxDDAKBgNVBAsTA1MzUDEXMBUGA1UEAxMOb3BlcmF0aW9uYWwg
Q0EwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQC/EAD5D3TV9txBCnCu
uoAbAhBadRP9hGtBZiSNGmHZmNjIeS1DAQY7/D0QTT+0Ufw0uAHySjLZJT5YctpX
BWduw8SmnyhpDPWpeSeee8JJx7egZz4k02yGqXavoFzfiyxCL9RfXqzSZUYdVPiX
KVPEwcHru6nVkRFIFWJgFaGmdoPDwfrwT4hRsMWf/sHD391HHPd7gTXOGPfxSPkN
lN6L7gdZCf6lpK3hfOAHZqYUHBAHeNPv/awmOFTRBStXAYAB9HAcYtfE5YoZqOcI
jEBKZD53swLrHYbDmThso96m/nYCV7PKrLrIyVy8QT7y44Gp/ULcMtw8qT20UBjw
XuUse7tnhiVEXzWozm+rTCjwWy/tFN8uZCS2wvUL8/+EzhCEmcKeUr/Br6mxVN5i
W0I0++K0dGtwCIFoxBkhU9r4R7GLKT4OAvMSOHHI7PEvApVZpV52jkgxogHIdghz
FuFzMAskC6Ktup/0p4flhXJna4nEJPxZf/Bj/5HlzaoVcEIc6vdXRQ4O9CoHgl4V
hSPjDh9HVHebs1FLbzHvn05lon3KZFNiODdpizcgEXk8XGbRYD0h4+MzMmYzTZA1
+AToVO6prC6nsTtmRTpI0aTzfyu15BLSIiypzxuIh/eT0uh/+gkZ32e+lujsEPQy
LtAsVbEvPD4sIkyU6HgrrNfXsQIDAQABo4H7MIH4MA8GA1UdEwEB/wQFMAMBAf8w
HQYDVR0OBBYEFJ/DUfjotR4vsPTu6sPgGs1Nq1WFMGYGA1UdIwRfMF2AFA3EUxi5
FUSp0Rcyuv3qGtcRQMrHoUKkQDA+MQwwCgYDVQQLEwNTM1AxDzANBgNVBAoTBklE
RUFMWDELMAkGA1UEBhMCRlIxEDAOBgNVBAMTB3Jvb3QgQ0GCAQAwOwYDVR0fBDQw
MjAwoC6gLIYqaHR0cDovL3N1ZXouc3BkYS5pZGVhbHguY29tOjgwL3Jvb3Rjcmwu
Y3JsMA4GA1UdDwEB/wQEAwIBBjARBglghkgBhvhCAQEEBAMCAAcwDQYJKoZIhvcN
AQEFBQADggIBAEyUYQrAg+3tmnVVBjyTJnNTzq5iBmkMetezKRV5eHEnYTMQ4TZy
6Jw+ydYMI2DGsfWcg4F07PQ2U+4SghoBRM1Wh5ZJ16eCrakLIU6m/oSvV803TXi9
xmpbCAe7dpbZ9HOzKI/adYJCQ4Eo8ikCa2dL8XsEDfCOB99ldAO2uFpbo4Et1lZ5
+cRiN9IdvhIjHgL2fGrgxeom8YEds+n8QhcC3yhh+soMC37/kORvSw9XutOtvdsz
Rxtlpegpy46aUsIbNSok7Ba/RR+NAYimWwGcUbCxcSgAGmpSzgHh+y3hQIUtkGeM
vj8duVPU5ZjjPCqhyDyn2WWwjFg9A7ACM6KnsSSYPux7kUmOWN8kdpDKM9sVXoYx
Y/uSltBPs+Rmh04uAwxXW2AupllGAaWxRgV7VBIiCstmY2trrWwvhzTC3yQQMah2
FbhugF7RmaUCDq2haubr2WSK1UiUNwoX+ARmc7zHMGTpvorOIlWS6z+iVIXotvkS
4Co1S1Ncyu6BCE7xjr9kvzkPuDWZUUaVQ0AdilRinOVpFX77ad8qaExKlNEsXgEQ
HBzEqHz0mEcvx5Mcq4GF37F5WnxEv5hv6+JXZKQo+P1yQbr5yvWR0KnzIHviDCK/
Ztu2kWDzQxvtyrRTqBkPZKv1Qu1MRN7CBX/DqH7Ilz1dKE3oOgpfbVmYMYICBjCC
AgICAQEwSjBFMQswCQYDVQQGEwJGUjEPMA0GA1UEChMGSURFQUxYMQwwCgYDVQQL
EwNTM1AxFzAVBgNVBAMTDm9wZXJhdGlvbmFsIENBAgEiMAkGBSsOAwIaBQCgggES
MBgGCSqGSIb3DQEJAzELBgkqhkiG9w0BBwEwHAYJKoZIhvcNAQkFMQ8XDTAxMTEw
OTExMDMxNlowIwYJKoZIhvcNAQkEMRYEFGpYg5mz3OkBp+HRAl3Nkh5ZHaRlMFgG
CSqGSIb3DQEJDzFLMEkwCgYIKoZIhvcNAwcwDgYIKoZIhvcNAwICAgCAMAcGBSsO
AwIHMA0GCCqGSIb3DQMCAgEoMAcGBSsOAwIaMAoGCCqGSIb3DQIFMFkGCSsGAQQB
gjcQBDFMMEowRTELMAkGA1UEBhMCRlIxDzANBgNVBAoTBklERUFMWDEMMAoGA1UE
CxMDUzNQMRcwFQYDVQQDEw5vcGVyYXRpb25hbCBDQQIBIjANBgkqhkiG9w0BAQEF
AASBgBbINSMTJaDPvmWPpnt7giB+N6r5DiWx4q9v91kNteT33wGuARlWbKe1p+Nt
sShNgn/KFYc5b5YpNF+AURZpEqV59spM9+i70r/5VSbpuajQK6weS/aW9GS2PrXd
Nfj7CXZKrEC7wvyoeUhMH5d+8SQXYkL5FjYAACV5d9G9kkHx
-----END PKCS7-----
ZONK

my $tmpfile="/tmp/mhsite.tests.$$";

open(OPENSSL,"| openssl pkcs7 -outform der -out $tmpfile");
print OPENSSL $pkcs7pem;
close(OPENSSL);

open(RECODED,"<$tmpfile");
$pkcs7der=join('',<RECODED>);
close(RECODED);
unlink($tmpfile);

open(OPENSSL,"| openssl pkcs7 -inform der -out $tmpfile");
print OPENSSL $pkcs7der;
close(OPENSSL);

open(RECODED,"<$tmpfile");
my $pkcs7pemagain=join('',<RECODED>);
close(RECODED);
unlink($tmpfile);

ok($pkcs7pemagain eq $pkcs7pem);

########## Test 2: actually doing something

# Copy-pasted from MHOnArc 2.4.9

no strict;
sub readmail::MAILread_header {
    local(*mesg, *fields, *l2o) = @_;
    local($label, $olabel, $value, $tmp, $header);

    $header = '';  %fields = ();  %l2o = ();  $label = '';

    ## Read a line at a time.
    while ($mesg =~ s/^([^\n]*\n)//) {
        $tmp = $1;                      # Save off match
        last  if $tmp =~ /^[\r]?$/;     # Done if blank line

        $header .= $tmp;                # Store original text
        $tmp =~ s/[\r\n]//g;            # Delete eol characters

        ## Decode text if requested
        $tmp = &MAILdecode_1522_str($tmp,1)  if $DecodeHeader;

        ## Check for continuation of a field
        if ($tmp =~ s/^\s//) {
            $fields{$label} .= $tmp  if $label;
            next;
        }

        ## Separate head from field text
        if ($tmp =~ /^([^:\s]+):\s*([\s\S]*)$/) {
            ($olabel, $value) = ($1, $2);
            ($label = $olabel) =~ tr/A-Z/a-z/;
            $l2o{$label} = $olabel;
            if ($fields{$label}) {
                $fields{$label} .= $FieldSep . $value;
            } else {
                $fields{$label} = $value;
            }
        }
    }
    $header;
}

use strict;

# This one is bogus.
sub readmail::MAILread_body {
	my ($header, $body, $ctypeArg, $encodingArg, $inaltArg) = @_;

	return ("<PRE>$body</PRE>");
}


$mhonarc::OUTDIR="/tmp";

use vars qw(%header); %header=("from" => [ "me" ], "to" => [ "you" ]);

my ($text,$sigfile)=
  IDX::MHOnArcAddOns::filter_pkcs7_mime("From: me\nTo: you\n",*header,*pkcs7pem,1,"");

die if (!defined $sigfile);
ok(`cat $sigfile` eq $pkcs7pem);

ok($text =~ m/test/); # This is the original contents of the message.

ok($text !~ m/Content/); # Headers should have been wiped off by now


my ($text2,$sigfile2)=
  IDX::MHOnArcAddOns::filter_pkcs7_mime("From: me\nTo: you\n",*header,*pkcs7der,1,"");

die if (!defined $sigfile);
ok($sigfile ne $sigfile2);
ok(`cat $sigfile2` eq $pkcs7der);
unlink($sigfile);
unlink($sigfile2);

ok($text2 =~ m/test/); # This is the original contents of the message.

ok($text2 !~ m/Content/); # Headers should have been wiped off by now