# -*- Perl -*-
#***********************************************************************
#
# mimedefang-filter
#
# Suggested minimum-protection filter for Microsoft Windows clients, plus
# SpamAssassin checks if SpamAssassin is installed.
#
# Copyright (C) 2002 Roaring Penguin Software Inc.
#
# This program may be distributed under the terms of the GNU General
# Public License, Version 2, or (at your option) any later version.
#
# $Id: suggested-minimum-filter-for-windows-clients,v 1.58 2002/12/31 14:17:12 dfs Exp $
#***********************************************************************

#***********************************************************************
# Set administrator's e-mail address here.  The administrator receives
# quarantine messages and is listed as the contact for site-wide
# MIMEDefang policy.  A good example would be 'defang-admin@mydomain.com'
#***********************************************************************
$AdminAddress = 'xxxx@xxxx.com';
$AdminName = "xxxx";

#***********************************************************************
# Set the e-mail address from which MIMEDefang quarantine warnings and
# user notifications appear to come.  A good example would be
# 'mimedefang@mydomain.com'.  Make sure to have an alias for this
# address if you want replies to it to work.
#***********************************************************************
$DaemonAddress = 'xxxxx@xxxxx.com';
$DaemonName = 'xxxxxx';
#***********************************************************************
# If you set $AddWarningsInline to 1, then MIMEDefang tries *very* hard
# to add warnings directly in the message body (text or html) rather
# than adding a separate "WARNING.TXT" MIME part.  If the message
# has no text or html part, then a separate MIME part is still used.
#***********************************************************************
$AddWarningsInline = 1;

#***********************************************************************
# To enable syslogging of virus and spam activity, add the following
# to the filter:
# md_log_enable();
# You may optionally provide a syslogging facility by passing an
# argument such as:  md_log_enable('local4');  If you do this, be
# sure to setup the new syslog facility (probably in /etc/syslog.conf).
# Comment this line out to disable logging.
#***********************************************************************
md_log_enable('mail');

#***********************************************************************
# Uncomment this to block messages with more than 50 parts.  This will
# *NOT* work unless you're using Roaring Penguin's patched version
# of MIME tools, version MIME-tools-5.411a-RP-Patched-02 or later.
#
# WARNING: DO NOT SET THIS VARIABLE unless you're using at least
# MIME-tools-5.411a-RP-Patched-02; otherwise, your filter will fail.
#***********************************************************************
# $MaxMIMEParts = 50;

#***********************************************************************
# Set various stupid things your mail client does below.
#***********************************************************************

# Set the next one if your mail client cannot handle nested multipart
# messages.  DO NOT set this lightly; it will cause action_add_part to
# work rather strangely.  Leave it at zero, even for MS Outlook, unless
# you have serious problems.
$Stupidity{"flatten"} = 0;

# Set the next one if your mail client cannot handle multiple "inline"
# parts.
$Stupidity{"NoMultipleInlines"} = 0;





#############################
#### GREYLIST Section 1 #####
#############################


#Settings for greylisting.
#
# For an explanation of what the purpose of this is, and maybe a hint as to
# what values to enter, "check http://projects.puremagic.com/greylisting/".
# I think they recommend something like this:
# $gdb_black = 1*60*60;
# $gdb_grey = 5*60*60;
# $gdb_white = 36*24*60*60;
# $gdb_subnet = 1;
# 
#
# If greylist is 1, greylisting will be used.
#
# Greylisting is done on a triplet of sending hosts IP, mail from: and
# rcpt to:.
#
# When a session with a new triplet arrives, all sessions with that
# triplet will be tempfailed for $gdb_black seconds.
# After $gdb_black seconds it will be white-listed for $gdb_grey
# seconds.
# If a session for the triplet arrives within the $gdb_grey white-listing
# period, it will then be white-listed for $gdb_white seconds.
# If a session for a triplet arrives within the $gdb_white white-listing
# period, it will be white listed for another $gdb_white seconds.
#
# When a mail gets a spam-score above $gdb_reset, the greylist status for it's
# triplet will be reset (wich means the next session with that triplet will be
# treaded as though it's a new triplet).
# If $gdb_reset_host is true, all triplets from the same host IP will be reset
# whenever a spam triggers the reset.
#
# If $gdb_subnet is true, only the first 3 octes of the IP-addresses will be
# used in the greylist.
# If $gdb_from_domain is true, only the domain part of the mail from: address
# will be used in the greylist.
# If $gdb_to_domain is true, only the domain part of the rcpt to: address
# will be used in the greylist.
# If $gdb_from_strip is true, some stuff in the user part of the mail from:
# address will be replaced in order to handle mailinglists and some other
# stuff better.
# If $gdb_to_strip is true, some stuff in the user part of the rcpt to:
# address will be replaced in order to handle use parameters and some other 
# stuff better.
#***********************************************************************
$greylist = 0;
$gdb_black = 1*60;
$gdb_grey = 36*60*60;
$gdb_white = 36*24*60*60;
$gdb_reset = 20;
#$gdb_reset_host = 0;
$gdb_subnet = 1;
$gdb_from_domain = 0;
$gdb_from_strip = 1;
$gdb_to_domain = 0;
$gdb_to_strip = 1;
$gdb_log = 1;

use DB_File;
use Fcntl ':flock';

$DBFilename = "/var/spool/MIMEDefang/.greylistdb";

###############################
#Greylist Subroutines  ########
###############################


sub lock_db () {
    open(LOCKFILE, ">>$DBFilename.lock") or return 0;
    flock(LOCKFILE, LOCK_EX);
    return 1;
}

sub unlock_db () {
    flock(LOCKFILE, LOCK_UN);
    close(LOCKFILE);
    unlink("$DBFilename.lock");
    return 1;
}



#Strip strings
sub address_strip ($) {
	my($a) = @_;
	$a = "" if (!defined($a));
	$a =~ s/^[<\[]//;
	$a =~ s/[>\]]$//;
	return lc($a);
}

# return a time string...
sub time_string($) {
	my ($time) = @_;
	my $h = int($time / (60*60));
	$time = $time % (60*60);
	my $m = int($time / 60);
	my $s = $time % 60;
	my $r = "";
	$r.="$h hours, " if ($h);
	$r.="$m minutes and " if ($h || $m);
	$r.="$s seconds";
	return $r;
}


#Strip strings for use in the greylist.
sub greylist_strip ($) {
	my($a) = @_;
	$a =~ s/;/:/g;
	return $a;
}

sub greylist_strip_mail($$$) {
	my($a,$d,$s) = @_;
	$a = address_strip($a);
	my $au = $a;
	my $ad = $a;
	$ad =~ s/.*@([^@]*)$/$1/;
	$au =~ s/@[^@]*$//;
	if ($d) {
		$au = "*";
	} elsif ($s) {
		$au =~ s/(.+)\+.*$/$1/;
		my $aut;
		my $autt = $au;
		do {
			$aut = $autt;
			$autt =~ s/^(|.*[^a-z0-9])[a-f0-9]*\d[a-f0-9]*(|[^a-z0-9].*)$/$1#$2/;
		} until ($autt eq $aut);
		$au = $aut if ($aut =~ /[a-z0-9]/);
		#$au =~ s/[^-a-z0-9_.#]/?/g;
	}
	return greylist_strip($au."@".$ad);
}


sub greylist_strip_ip($) {
	my($a) = @_;
	$a =~ s/(.*)\.[0-9]+$/$1\.*/ if (defined($gdb_subnet) && $gdb_subnet);
	return greylist_strip(address_strip($a));
}

sub greylist_strip_triplet(@) {
	my(@p) = @_;
	my($i,$s,$r) = @p;
	my $sr;
	my $sn;
	$s = greylist_strip_mail($s,(defined($gdb_from_domain) && $gdb_from_domain),(defined($gdb_from_strip) && $gdb_from_strip));
	$r = greylist_strip_mail($r,(defined($gdb_to_domain) && $gdb_to_domain),(defined($gdb_to_strip) && $gdb_to_strip));
	$i = greylist_strip_ip($i);
	return ($i,$s,$r);
}


#Checks if a triplet is in the grey-list.
# Returns seconds until the triplet will be accepted, or -1 for error.
sub greylist_check($$$) {
	my ($ip,$sender,$recipient) = greylist_strip_triplet(@_);
	my $result = -1;

	my %GDB;
	my $key = "I:<$ip><$sender><$recipient>";
	my $now = time();
	lock_db();
	if (tie(%GDB,'DB_File', $DBFilename)) {
		my $event = "";
		my $data = $GDB{$key};
		if (!$data) {
			$GDB{$key} = join(';',$now,$now,$now,0,0,$ip,$sender,$recipient,"");
			$result = $gdb_black;
			$event = 'new';
		} else {
			#debug_log(5,"greylist_check, data $data");
			my ($created,$modified,$reset,$accepted,$count,$ip,$sender,$recipient,$x) = split(/;/,$data,9);
			#debug_log(5,"greylist_check, $created, $reset, $accepted, $count, $ip, $sender, $recipient, $x");
			if ($now < $reset+$gdb_black) {
				$result = ($reset+$gdb_black)-$now;
				$event = 'black';
			} elsif (($now < $reset+$gdb_grey) || 
				  (($accepted > 0) && ($now < $accepted + $gdb_white))) {
				$count++;
				$GDB{$key} = join(';',$created,$now,$reset,$now,$count,$ip,$sender,$recipient,$x);
				$result = 0;
				$event = 'white';
			} else {
				$GDB{$key} = join(';',$created,$now,$now,0,$count,$ip,$sender,$recipient,$x);
				$result = $gdb_black;
				$event = 'old';
			}
		}
		untie %GDB;
		unlock_db();
		md_syslog('info', "greylist: $event; $result; $ip; $sender; $recipient") if (defined($gdb_log) && $gdb_log);
	}
	return $result;
}




#Resets record(s) in the grey list.
sub greylist_reset($$$) {
	my ($p_ip,$p_sender,$p_recipient) = greylist_strip_triplet(@_);

	my %GDB;
	my $now = time();
	lock_db();
	if (tie(%GDB,'DB_File', $DBFilename)) {
		if ($p_sender && $p_recipient) {
			#debug_log(5,"greylist_reset, = $p_sender @ $p_ip -> $p_recipient");
			my $key = "I:<$p_ip><$p_sender><$p_recipient>";
			my $data = $GDB{$key};
			if ($data) {
				my ($created,$modified,$reset,$accepted,$count,$ip,$sender,$recipient,$x) = split(/;/,$data,9);
				#debug_log(5,"greylist_reset, ! $sender @ $ip -> $recipient");
				$GDB{$key} = join(';',$created,$now,0,0,$count,$ip,$sender,$recipient,$x);
				md_syslog('info', "greylist: reset; -; $ip; $sender; $recipient") if (defined($gdb_log) && $gdb_log);
			}
		} else {
			#debug_log(5,"greylist_reset, = $p_sender @ $p_ip -> $p_recipient");
			foreach my $key ( keys %GDB) {
				my $data = $GDB{$key};
				if ($data) {
					my ($created,$modified,$reset,$accepted,$count,$ip,$sender,$recipient,$x) = split(/;/,$data,9);
					#debug_log(5,"greylist_reset, ? $sender @ $ip -> $recipient");
					if ($p_ip eq $ip &&
					   (!$p_sender || $p_sender eq $sender) &&
					   (!$p_recipient || $p_recipient eq $recipient)) {
						#debug_log(5,"greylist_reset, ! $sender @ $ip -> $recipient");
						$GDB{$key} = join(';',$created,$now,0,0,$count,$ip,$sender,$recipient,$x);
						md_syslog('info', "greylist: reset; -, $ip; $sender; $recipient") if (defined($gdb_log) && $gdb_log);
					}
				}
			}
		}
		untie %GDB;
		unlock_db();
	}
}


#***********************************************************************
# PrOCEDURE: filter_recipient
# %ARGUMENTS:
#  recipient, sender, ip, host, first, helo, rcpt_mailer, rcpt_host, rcpt_addr
# %RETURNS:
#  action
# %DESCRIPTION:
#  Called just after RCPT TO
#  Requires -t
#***********************************************************************
sub filter_recipient ($$$$$$$$$) {
	my($recipient, $sender, $ip, $hostname, $first, $helo, $rcpt_mailer, $rcpt_host, $rcpt_addr) = @_;
	md_syslog('info', "filter_recipient: From $sender to $rcpt_addr at $rcpt_host with $rcpt_mailer");

	Check greylist
	if ($greylist) {
		$grey = greylist_check($ip,$sender,$recipient);
		if ($grey > 0) {
			my $greys = time_string($grey);
			#debug_log(2, "filter_recipient: Greylisted ($greys), $sender at $ip to $recipient");
			md_syslog('info', "MDLOG,$MsgID,grey,$grey,$ip,$sender,$recipient,?");
			return ('TEMPFAIL', "We will accept the mail in $greys.");
		} elsif ($grey < 0) {
			md_syslog('warning', "filter_recipient: greylist_check returned error!");
			return ('TEMPFAIL', "Something is not working right here. Please try again.");
		}
	}
	return ('CONTINUE', "Ok, go ahead.");
}



#############################
#### GREYLIST Section 1 #####
#############################





# This procedure returns true for entities with bad filenames.
sub filter_bad_filename ($) {
    my($entity) = @_;
    my($bad_exts, $re);

    # Bad extensions
    $bad_exts = '(ade|adp|app|asd|asf|asx|bas|bat|chm|cmd|com|cpl|crt|dll|exe|fxp|hlp|hta|hto|inf|ini|ins|isp|jse?|lib|lnk|mde|msc|msi|msp|mst|ocx|pcd|pi|pif|prg|reg|scr|sct|sh|shb|shs|sys|url|vb|vbe|vbs|vcs|vxd|wmd|wms|wmz|wsc|wsf|wsh|\{)';

    # Do not allow:
    # - curlies
    # - bad extensions (possibly with trailing dots) at end or
    #   followed by non-alphanum
    $re = '\.' . $bad_exts . '\.*([^-A-Za-z0-9_.,]|$)';
    return re_match($entity, $re);
}

#***********************************************************************
# %PROCEDURE: filter_begin
# %ARGUMENTS:
#  None
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  Called: just before e-mail parts are processed
#***********************************************************************
sub filter_begin () {
    
    ################################
    ####  Stream by domain to   ####
    ####  allow per domain SA   ####
    ####  configurations.       ####
    ################################
    if (stream_by_domain()) {
	#More than one domain -- do nothing!
	return;
    }
    # ALWAYS drop messages with suspicious chars in headers
    if ($SuspiciousCharsInHeaders) {
        md_log('suspicious_chars');
	action_quarantine_entire_message("Message quarantined because of suspicious characters in headers");
	# Do NOT allow message to reach recipient(s)
	return action_discard();
    }


    #################################
    ####  Added clamd to filter  ####
    ####  worm viruses.          ####
    #################################
    my ($code, $category, $action) = message_contains_virus_clamd();
    if ($category eq 'virus') {
        $FoundVirus = 1;
    } elsif ($category ne 'ok') {
        md_syslog('err',"$QueueID: clamd error: code=$code, category=$category, action=$action");
        action_tempfail("error: problem running virus scanner");
        return;
    }


}


#***********************************************************************
# %PROCEDURE: filter
# %ARGUMENTS:
#  entity -- a Mime::Entity object (see MIME-tools documentation for details)
#  fname -- the suggested filename, taken from the MIME Content-Disposition:
#           header.  If no filename was suggested, then fname is ""
#  ext -- the file extension (everything from the last period in the name
#         to the end of the name, including the period.)
#  type -- the MIME type, taken from the Content-Type: header.
#
#  NOTE: There are two likely and one unlikely place for a filename to
#  appear in a MIME message:  In Content-Disposition: filename, in
#  Content-Type: name, and in Content-Description.  If you are paranoid,
#  you will use the re_match and re_match_ext functions, which return true
#  if ANY of these possibilities match.  re_match checks the whole name;
#  re_match_ext checks the extension.  See the sample filter below for usage.
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  This function is called once for each part of a MIME message.
#  There are many action_*() routines which can decide the fate
#  of each part; see the mimedefang-filter man page.
#***********************************************************************
sub filter ($$$$) {
    my($entity, $fname, $ext, $type) = @_;

    return if message_rejected(); # Avoid unnecessary work


    ##################################
    ####  Drop worm virus emails  ####
    ####  and quarantine all      ####
    ####  other virus emails.     ####
    ##################################
    if ($FoundVirus) {
        $VirusScannerMessages = '';
        my ($code, $category, $action) = entity_contains_virus_clamd($entity);
        if ($category eq 'virus') {
            #md_graphdefang_log('virus', $VirusName, $RelayAddr);
            md_log('virus', $VirusName, $RelayAddr);
            if ($VirusName eq 'Worm.SCO.A') {
                action_discard();
                return;
            } elsif ($VirusName eq 'Worm.Gibe.F') {
		action_discard();
		return;
            } elsif ($VirusName eq 'Worm.Mimail.J') {
		action_discard();
		return;
            } elsif ($VirusName eq 'Worm/Klez.H') {
		action_discard();
		return;
	    }
	    action_quarantine($entity, "XXXXXXXX!!!!   An attachment named $fname was removed from this document as it\nconstituted a security hazard as it is infected with the $VirusName virus.  .\n");
            return; 
	} elsif ($category ne 'ok') {
            md_syslog('err',"$QueueID: clamd error: code=$code, category=$category, action=$action");
            action_tempfail("error: problem running virus scanner");
            return;
        }
    }








    # Block message/partial parts
    if (lc($type) eq "message/partial") {
        md_log('message/partial');
	action_bounce("MIME type message/partial not accepted here");
	return action_discard();
    }


    #########################################
    ####  Dropping specific attachments  ####
    ####  because of worm virus.         ####
    #########################################

    if (filter_bad_filename($entity)) {
        if ($fname =~ /upgrade|patch|Q437232|wendy|pack1537|update249|upgrade349|ref-394755|approved|password|doc_details|screen_temp|screen_doc|movie28|your_document|document_all|thank_you|your_details|details|document_9446|application|wicked_scr|movie0045/i){
            #md_log('warning', "attachement $fname of type $ext discarded");
            return action_discard();
        }
        md_log('bad_filename', $fname, $type);
	return action_quarantine($entity, "An attachment named $fname was removed from this document as it\nconstituted a security hazard.  If you require this document, please contact\nthe sender and arrange an alternate means of receiving it.\n");
    }
		
    # eml is bad if it's not multipart
    if (re_match($entity, '\.eml')) {
        md_log('non_multipart');
	return action_quarantine($entity, "A non-multipart attachment named $fname was removed from this document as it\nconstituted a security hazard.  If you require this document, please contact\nthe sender and arrange an alternate means of receiving it.\n");
    }
    return action_accept();
}

#***********************************************************************
# %PROCEDURE: filter_multipart
# %ARGUMENTS:
#  entity -- a Mime::Entity object (see MIME-tools documentation for details)
#  fname -- the suggested filename, taken from the MIME Content-Disposition:
#           header.  If no filename was suggested, then fname is ""
#  ext -- the file extension (everything from the last period in the name
#         to the end of the name, including the period.)
#  type -- the MIME type, taken from the Content-Type: header.
# %RETURNS:
#  Nothing
# %DESCRIPTION:
#  This is called for multipart "container" parts such as message/rfc822.
#  You cannot replace the body (because multipart parts have no body),
#  but you should check for bad filenames.
#***********************************************************************
sub filter_multipart ($$$$) {
    my($entity, $fname, $ext, $type) = @_;

    if (filter_bad_filename($entity)) {
        md_log('bad_filename', $fname, $type);
	action_notify_administrator("A MULTIPART attachment of type $type, named $fname was dropped.\n");
	return action_drop_with_warning("An attachment of type $type, named $fname was removed from this document as it\nconstituted a security hazard.  If you require this document, please contact\nthe sender and arrange an alternate means of receiving it.\n");
    }

    # eml is bad if it's not message/rfc822
    if (re_match($entity, '\.eml') and ($type ne "message/rfc822")) {
        md_log('non_rfc822',$fname);
	return action_drop_with_warning("A non-message/rfc822 attachment named $fname was removed from this document as it\nconstituted a security hazard.  If you require this document, please contact\nthe sender and arrange an alternate means of receiving it.\n");
    }

    # Block message/partial parts
    if (lc($type) eq "message/partial") {
        md_log('message/partial');
	action_bounce("MIME type message/partial not accepted here");
	return;
    }

    return action_accept();
}


#***********************************************************************
# %PROCEDURE: defang_warning
# %ARGUMENTS:
#  oldfname -- the old file name of an attachment
#  fname -- the new "defanged" name
# %RETURNS:
#  A warning message
# %DESCRIPTION:
#  This function customizes the warning message when an attachment
#  is defanged.
#***********************************************************************
sub defang_warning ($$) {
    my($oldfname, $fname) = @_;
    return
	"An attachment named '$oldfname' was converted to '$fname'.\n" .
	"To recover the file, right-click on the attachment and Save As\n" .
	"'$oldfname'\n";
}

# If SpamAssassin found SPAM, append report.  We do it as a separate
# attachment of type text/plain
sub filter_end ($) {
    my($entity) = @_;

    # If you want quarantine reports, uncomment next line
    # send_quarantine_notifications();

    # IMPORTANT NOTE:  YOU MUST CALL send_quarantine_notifications() AFTER
    # ANY PARTS HAVE BEEN QUARANTINED.  SO IF YOU MODIFY THIS FILTER TO
    # QUARANTINE SPAM, REWORK THE LOGIC TO CALL send_quarantine_notifications()
    # AT THE END!!!

    # No sense doing any extra work
    return if message_rejected();

#	append_text_boilerplate($entity, "All information contained in " .
#	"this email is confidential and may be used by the intended " .
#	"recipient only.", 0);

#	append_html_boilerplate($entity, "All information contained in " .
#	"this email is confidential and may be used by the intended " .
#	"recipient only.", 0);

    #  Domain name check, depending on the client we will perform necessary filtering
    action_change_header("X-Scanned-By", "XXXXXXXXX");

    ################################
    ####  Set SALocalTestsOnly  ####
    ####  to allow SA rbl tests.####
    ################################
    $SALocalTestsOnly = 0;

    ##############################
    ####  Change $domain to   ####
    ####  lowercase as domains####
    ####  came across with    ####
    ####  differing case.     ####
    ##############################
    $Domain = lc($Domain);

    if ($Domain eq "XXXXX.com") {
        if ($Features{"SpamAssassin"}) {
	    if (-s "./INPUTMSG" < 100*1024) {
	        # Only scan messages smaller than 100kB.  Larger messages
	        # are extremely unlikely to be spam, and SpamAssassin is
	        # dreadfully slow on very large messages.
	        my($hits, $req, $names, $report) = spam_assassin_check();

                ##############################
                ####  Greylist Section 2  ####
                ##############################

		#Reset greylist triplet(s)?
	        if (defined($greylist) && $greylist && defined($gdb_reset) && $hits > $gdb_reset) {
		    if ($gdb_reset_host) {
		        #debug_log(1,"filter_end, reset greylist for data $ip");
		        greylist_reset($ip,"","");
		    } else {
		    foreach my $currecipient(@Recipients) {
			#debug_log(1,"filter_end, reset greylist for data $Sender at $RelayAddr to $currecipient");
			greylist_reset($RelayAddr,$Sender,$currecipient);
    		        }
		    }
	        }
                ##############################
                ####  Greylist Section 2  ####
                ##############################

	        if ($hits >= 5) {
                    #md_log('spam', $hits, $RelayAddr);
		    my($score);
		    if ($hits < 40) {
		        $score = "*" x int($hits);
		    } else {
		        $score = "*" x 40;
		    }
		    action_change_header("X-Spam-Score", "$hits ($score) $names");
		    action_change_header("Subject", "***SPAM*** $Subject");
	        } else {
		    action_change_header("X-Spam-Score", "$hits ($score) $names");
	        }
	    }
        }
    
    } else {
	if ($Features{"SpamAssassin"}) {
	    if (-s "./INPUTMSG" < 100*1024) {
	        my($hits, $req, $names, $report) = spam_assassin_check();
	        if ($hits >= 12) {
		    my($score);
		    action_change_header("X-Spam-Score", "$hits : $names");
		    action_change_header("X-Spam-Listing", "***SPAM***");
	        } else {
		    action_change_header("X-Spam-Score", "$hits");
	        }
	    }
        }
    }
#    remove_redundant_html_parts($entity);
}

# DO NOT delete the next line, or Perl will complain.
1;