#!/opt/bin/perl
##
## Encapsulate a message fed on the stdin inside a MIME wrapper (as a
## message/rfc822 component), and identify it as potentially harmful
## to the recipient.
##
## Useful in procmail:
##	:0 f
##	* I_THINK_THIS_IS_SPAM ?? .
##	| /etc/mail/procmail/mime-encap
##
## $Id: mime-encap,v 1.1 2002/08/19 20:47:23 dgc Exp $
## dgc@uchicago.edu
##

use Sys::Hostname;
use IO::File;

## This variable will be for encapsulating messages' Message IDs.
## That's all.  Doesn't need to be valid, just needs to be able to
## generate assurably unique Message IDs.
$id_domain = hostname;


## List of filename extentions to plonk when -p is used.
@plonk_exts = qw( bat exe lnk pif com dll );

## Sub to plonk with.
$plonk_filt = sub { $_ = shift; s/^/VERMIN./; s/$/._x_/; return $_; };


($A0 = $0) =~ s,.*/,,;
sub usage {
	print STDERR "usage: $A0 [-p] [-I header] [-t tag] [-f msg_file] [-r reason_file] \\\n";
	print STDERR "       [reason [...]]\n";
	print STDERR "       :: -f and -r may refer to \"-\" to read from stdin; however, if \"-r -\"\n";
	print STDERR "          is used, then \"-f file\" MUST be supplied. Message text comes\n";
	print STDERR "          from stdin by default.\n";
}

@insert = ();
@reason = ();
$tag = "";
$plonk = undef;
$msg = undef;
$fh = \*STDIN;
$rfile = undef;
$rfh = undef;
$need_f = 0;
while ($arg = shift @ARGV) {
	if ($arg eq "-h" || $arg eq "--help") {
		usage;
		exit(2);
	} elsif ($arg eq "-I") {
		## Header line to insert.
		push(@insert, "$arg$/") if ($arg = shift @ARGV);
	} elsif ($arg eq "-t") {
		## Subject tag.
		$tag = "[$arg] " if ($arg = shift(@ARGV));
	} elsif ($arg eq "-p") {
		## Plonk executable filenames.
		$plonk = 1;
	} elsif ($arg eq "-f") {
		## Message is in file (do not assume stdin).
		$msg = shift @ARGV;
		if ($msg eq "-") {
			## default behavior: msg on stdin
			$msg = undef;
		} else {
			## open file
			$fh =new IO::File;
			$fh->open($msg, "r");
		}
	} elsif ($arg eq "-r") {
		## Reason is in file (do not assume argv).
		$rfile = shift @ARGV;
		if ($rfile eq "-") {
			$rfile = undef;
			$rfh = \*STDIN;
			++$need_f;
		} else {
			$rfh = new IO::File;
			$rfh->open($rfile, "r");
		}
	} else {
		## Reason for flagging.
		push(@reason, $arg);
	}
}

if ($need_f && !$msg) {
	usage();
	exit 2;
}

if ($rfh) {
	while ($_ = $rfh->getline) {
		chomp;
		push(@reason, $_);
	}
	$rfh->close if ($rfile);
}

if ($#reason < 0) {
	$REASON = "No reason given.";
} else {
	$REASON = join("\n", @reason);
}


## Read in the inbound message's header, so we can steal fields from
## it at will.
@hdr = ();
while ($_ = $fh->getline) {
	last if (/^$/);
	push (@hdr, $_);
}


## This copies a header field (name and value) from a hdr list.
sub printhdr {
	my ($rx, @list) = @_;

	print grep(/$rx:/i, @list);
}


## This extracts a header field's value from a hdr list, and returns it.
sub gethdr {
	my ($rx, @list) = @_;
	my $s;

	($s, @_) = grep(/$rx:/i, @list);
	return undef unless ($s);
	$s =~ s![^:]+:\s*!!;
	chomp $s;
	return $s;
}


## Get the inbound subject and message ID.  We want to munge these.
$subj = gethdr("Subject", @hdr);
$id = gethdr("Message-ID", @hdr);
$from = gethdr("From", @hdr);

## Extract the inside of the Message-ID field.  Uniquely alter the
## LHS, and change the RHS to be local.  Use the LHS to form a MIME
## boundary string.
$id =~ s!<?([^>]*)>?!$1!;
($newid = $id) =~ s!\@.*!.encap\@$id_domain!;
($boundary = $newid) =~ s!\@.*!!;


## Make a header block for the encapsulating message.  Alter the subject a
## bit, fill in some fields unique to spam processing.  Set up the MIME
## stuff, but leave the Content-Length for later.
@nhdr = <<HDR;
From: $from
Subject: $tag$subj
Message-Id: <$newid>
Content-Type: multipart/mixed;
	boundary="$boundary"
MIME-Version: 1.0
HDR
push(@nhdr, @insert);


## Make a MIMEly-correct message body, except for the text of the
## encapsulated message and the terminating --$boundary-- string.
$nmsg_1 = <<MSG;
--$boundary
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

This message appears to contain unsolicited bulk e-mail ("spam"),
possibly including virus, worm or "trojan horse" material. It has been
enclosed here in its original form. If you open this enclosure at all,
please do so with caution.

This message was flagged because:
$REASON

MSG

$nmsg_2 = <<MSG;
--$boundary
Content-Type: message/rfc822
Content-Disposition: attachment;
	filename="$id.txt"
Content-Description: Possible spam from $from
MSG


## Suck in the rest of the message.  Unfortunately, we need to cache it
## because we have to generate an accurate Content-Length.  Strip out
## the Unix "From " line, if present -- this will screw up many mailers.
##
@msg = $fh->getlines;
if ($plonk) {
	$plonk_expr = "\\.(" . join("|", @plonk_exts) . ")\$";
	map {
		if (/^Content-(Type|Disposition)(:.*name=)"*([^"]*)"*(.*)/i) {
			$type = $1;
			$misc = $2;
			$fn = $3;
			$post = $4;
			chomp $fn;
			chomp $post;
			if ($fn =~ /$plonk_expr/o) {
				$nfn = &{$plonk_filt}($fn);
			}
			push(@plonked, [($fn, $nfn)]);
			$_ = "Content-${type}${misc}\"${nfn}\"${post}$/";
		}
	} @msg;
}
@ohdr = @hdr;
@hdr = grep(!/^From\s/, @ohdr);


## If anything was plonked, say so.
if ($#plonked > -1) {
	@PLONK = "For your protection, executable content has been renamed as follows:";
	for $plonkee (@plonked) {
		next if ($last eq $plonkee->[0]);
		push(@PLONK, "\t" . $plonkee->[0] . " -> " . $plonkee->[1]);
		$last = $plonkee->[0];
	}
	$PLONK = join("\n", @PLONK) . "\n\n";
}


## Figure out the content-length by adding up the requisite blank lines,
## the final boundary, and all the arrays of message text we've generated
## or sucked in.
$clen = 1 + 1 + + length("--$boundary--\n");
map { $clen += length($_); } ($nmsg_1, $PLONK, $nmsg_2, @hdr, @msg);


## Now copy relevant fields from the alleged spam into the capsule's
## header.  We can do this freely because this is a delivery copy, and
## we won't be passing it off to "sendmail -t" or the like.
print grep(/^From\s/, @ohdr);
printhdr("^To", @ohdr);
printhdr("^Cc", @ohdr);
printhdr("^Bcc", @ohdr);
print @nhdr;
print "Content-Length: $clen\n";
print "\n";	## Required blank line

## Message content starts here.
print $nmsg_1, $PLONK, $nmsg_2;
print "\n";	## required
print @hdr;
print "\n";	## required
print @msg;
print "--$boundary--\n";	## terminates a MIME document.

## Voila.
$fh->close if ($msg);