#! /usr/bin/perl
#
# A prototype version of smtpserver content policy filter
#
# This is *not* a fast one, but shows the interface
#
# - smtpserver tells this program relative pathname of the spoolfile to check
# - this reports by telling numeric return value, plus commentary string:
#    negative values:  instant rejections
#               zero:  normal acceptance
#    positive values:  the message is to be placed into the freezer
#

%UNIQSET = ('from' => 1, 'message-id' => 1, 'mime-version' => 1,
	    'content-type' => 1, 'content-transfer-encoding' => 1,
	    'subject' => 1, 'date' => 1, 'reply-to' => 1,
	    'in-reply-to' => 1, 'errors-to' => 1);
@MANDATORYSET = (); #('from', 'to');  # 'date', 'message-id' ## Bloody qmail does not create date, nor message-id in outgoing error messages! ## damn many others fail either 'to' or 'from', OR BOTH!

$passallrcpts='postmaster[@]|bk-commits-';

%RFC822 = ();

%BADATTACHMENTS = (
        'application.zip' => 'sobig.f',
        'details.zip' => 'sobig.f',
        'document_9446.zip' => 'sobig.f',
        'document_all.zip' => 'sobig.f',
        'movie0045.zip' => 'sobig.f',
        'thank_you.zip' => 'sobig.f',
        'your_details.zip' => 'sobig.f',
        'your_document.zip' => 'sobig.f',
        'wicked_scr.zip' => 'sobig.f',
        'your_document.pif' => 'sobig.f',
        'document_all.pif' => 'sobig.f',
        'thank_you.pif' => 'sobig.f',
        'your_details.pif' => 'sobig.f',
        'details.pif' => 'sobig.f',
        'document_9446.pif' => 'sobig.f',
        'application.pif' => 'sobig.f',
        'wicked_scr.scr' => 'sobig.f',
        'movie0045.pif' => 'sobig.f'
);


select(STDOUT); $| = 1;

printf "#hungry\n";
while (<>) {
	chomp;
	$fname = $_;

	%RFC822 = ();

	$rc = & filter( $fname );
	printf "%s\n", $rc;
	printf "#hungry\n";
}
exit 0;

sub filter {
	local($fname) = @_;
	local($rc) = '0 250 2.7.0 nothing set';

	open(SP, "< ".$fname) ||
		return "0 Oops.. filter can't open file $fname";

        local($cnt_to,$passall_to) = (0,0);

	# Scan the envelope thru to spot the magic "env-end" line
	local $pline = '';
	while (<SP>) {
		chomp;
		last if ($_ eq 'env-end');
		$line = $_;


                if ($line =~ m/^to <(.*)>/o) {
                        $toaddr = $1;
                        ++$cnt_to;
                        if ($toaddr =~ m/^($passallrcpts)/io) {
                                ++$passall_to;
                        }
                }

	}
	# Ok, either EOF, or got that "env-end" token.

        #if (($cnt_to < $passall_to + 3) && ($passall_to > 0)) {
        if ($cnt_to == $passall_to) {
                $s = sprintf("0 250 2.7.0 message accepted; tocnt:%d/%d",
                             $cnt_to, $passall_to);
                close(SP);
                return $s;
        }

	my(@RFC822) = ();
	undef $HDR822;

	# Collect RFC 822 headers
	while (<SP>) {
		chomp;
		last if ($_ eq '');
		if ($_ =~ m/^[^ \t]+/o) {
			if (defined ($HDR822)) {
				push(@RFC822, $HDR822);
				my($HDR,$REST)    = split(/:/, $HDR822, 2);
				$RFC822{lc($HDR)} = $REST;
				$RFC822{$HDR}     = $REST;

				# Analyze the 822 header
				$rc = &rfc822syntax($HDR,$REST);
				goto DONEIT if (defined $rc);
			}
			$HDR822  = $_;
		} else {
			$HDR822 .= $_;
		}
	}
	if (defined $HDR822) {
		push(@RFC822, $HDR822);
		my($HDR,$REST)    = split(/:/, $HDR822, 2);

		# Analyze the 822 header
		$rc = &rfc822syntax($HDR,$REST);
		goto DONEIT if (defined $rc);
	}

	# stand-alone RFC 822 (et.al.) piecemal syntax analysis is done,
	# now do multi-header dependent things, and check for MISSING
	# headers...

	# XXXX: TODO!

	foreach $hdr (@MANDATORYSET) {
	    if (!defined($RFC822{$hdr})) {
		close(SP);
		return "400 550 5.7.1 Missing mandatory header: '$hdr'"
	    }
	}


	if ($RFC822{'content-type'} =~ m!text/html!i) {
	    close(SP);
	    return "-1 550 5.7.1 The message contains HTML, therefore we consider it SPAM.  Send pure TEXT/PLAIN if you are not a spammer.";
	}


	if ($RFC822{'subject'} =~ m!XXX!) {
	    close(SP);
	    return "-1 550 5.7.1 The capital Triple-X in subject is way too often associated with junk email, please rephrase. ";
	}

	if ($RFC822{'from'} =~ m!MAILER-DAEMON.nmp1.bergen.kommune.no!) {
	    close(SP);
	    return "-1 550 5.7.1 Endless flood of error messages from misconfigured MTA is no fun to receive...";
	}


	# Scan the body ...
	while (<SP>) {
		$line = $_;
		chomp $line;
		# XXXX: TODO!

		if ($line =~ m!^\tfilename="[^"]+"!o &&
		    $pline =~ m!Content-Disposition:\s+attachment;!o) {
		    if ($line =~ m!^\tfilename="([^"]+)"!o) {
			local $ba = $BADATTACHMENTS{$1};
			if ($ba) {
			    close(SP);
			    return "-205 550 5.7.1 smells of a virus; attachment named: '${1}' is associated with '${ba}'";
			}
		    }
		    if ($line =~ m!^\tfilename="[^"]+\.pif"!o) {
			close(SP);
			return "-206 550 5.7.1 smells of a virus; attachment filename ending with: .pif";
		    }
		    if ($line =~ m!^\tfilename="[^"]+\.scr"!o) {
			close(SP);
			return "-207 550 5.7.1 smells of a virus; attachment filename ending with: .scr";
		    }
		}

		if ($line =~ m!and even Oprah!io) {
		    return "-1 550 5.7.1 Marketing something on American TV does not make it any less crap, spammer, stay away!";
		}
		if ($line =~ m!Section 301!io) {
		   return "-1 550 5.7.1 Referring to 'Murkowsky Bill' is direct admission of the message being spam.";
		}
		if ($line =~ m!centralremovalservice!io) {
		    return "-1 550 5.7.1 'centralremovalservice' is known excuse for spammers, stay away!";
		}
		if ($line =~ m!templatestyles.com!io) {
		    close(SP);
		    return "205 550 5.7.1 very active spammer";
		}
		if ($line =~ m!^\tfilename="[^.]+\.pif"!o) {
		    close(SP);
		    return "-206 550 5.7.1 virus...  .pif";
		}
		if ($line =~ m!^\tfilename="[^.]+\.scr"!o) {
		    close(SP);
		    return "-207 550 5.7.1 virus... .scr";
		}
		if ($line =~ m!^Content-Type:.*;;;!io) {
		    return "-1 550 5.7.1 Invalidly formatted message headers, considering it SPAM!";
		}
		if ($line =~ m!^Content-Type:\s*text/html!io) {
		    return "-1 550 5.7.1 The message contains HTML subpart, therefore we consider it SPAM or Outlook Virus.  TEXT/PLAIN is accepted.!";
		}
                $pline = $line;
	}

	$rc = '0 250 2.7.0 nothing apparently wrong in the message.';

DONEIT:
	close(SP);

	return $rc;
}


sub rfc822syntax {
	local($inphdr,$inprest) = @_;
	local($lchdr) = lc($inphdr);

	# XXX: Uniqueness tests ???

#	if (defined $UNIQSET{$lchdr} &&
#	    defined $RFC822{$lchdr}) {
#		return "-3 Multiple occurrances of unique RFC822 header: '$inphdr'";
#	}

	$RFC822{$lchdr}  = $inprest;
	$RFC822{$inphdr} = $inprest;

	return undef;
}