#!/usr/bin/perl -w

##############################################################################
#
# General configuration options
#
##############################################################################

# Print some debug stats into the qmail logfile
# Recommended for testing a new installation
my $DEBUG = 1;

# user from whom mail marked as spam appears to originate
my $SPAMUSER = 'spamtest';

# your domain
my $DOMAIN = 'perspectix.com';

# spam tag for the subject line (can also be blank)
my $SPAMTAG = '[SPAM]';

# a contact telephone number and person for external users with enquiries
my $CONTACTNUM = '+41 1 445 9523';
my $CONTACTNAME = 'the Perspectix postmaster';

# Mailer program
my $MAILER = '/usr/local/bin/new-inject';

# Where to log information for users who have activated logging
my $LOGFILE = "$ENV{HOME}/.qmail_rbllog";

# Date command - used only if the user has enabled logging
# I guess this only works on a UNIX box
my $DATECMD = "/bin/date '+%Y-%m-%d %T'";

#
# User options file location
# The options are controlled by the a single letter per line
# Currently supported user options:
#	l - log what rblcheck.pl does with mail
#	o - add the ORBS blacklist to the checkers
#	b - bounce mail, i.e. user never sees it at all
my $OPTFILE = "$ENV{HOME}/.qmail_rblcheck";

#
# The following is a list of blacklisting services who
# provide a DNS lookup service, where to check the ip
# 1.2.3.4 you would attempt to resolve the FQDN
# 4.3.2.1.blacklister.com
my @BLACKLISTS = (
	"relays.osirusoft.com",
	"relays.ordb.org",
	"list.dsbl.org",
	"unconfirmed.dsbl.org",
	"relays.visi.com",
	"blackholes.2mbit.com"
);

#
# ORBS list
# was controversial for a while since it was quite aggressive
# so it is included only as a user configurable option
my $ORBSLIST = "orbs.dorkslayers.com";

#
# The following lists provide case-insensitive regular expressions
# against which various parts of the mail header can be checked
# This provides a mechnism to mark mail as spam which has
# perhaps passed one of the 'rblcheck' tests
#

# Subject lines to summarily reject (case insensitive)
my @FILTSUBJS = (
	'adv:',
	'adv adlt:',
	'yahoo! auto response',
	'.*accept.*credit\scard'
);

# Mailers to summarily reject
my @FILTMAIL = (
	'stellar-x',
	'poplist',
	'active send mail'
);

# Hosts to summarily reject
my @FILTHOSTS = (
	'prod.itd.earthlink.net'
);

# From to summarily reject (just load "badmailfrom")
my $BADMAILFROM = "/var/qmail/control/badmailfrom";
unless (open(BMF,"< $BADMAILFROM")) {
	print "RBLCHECK.PL: can't open $BADMAILFROM\n";
	exit 0;
}
my @FILTFROM = <BMF>;
close(BMF);

##############################################################################
#
# End of User configuration section
# Nothing below this line needs to be modified
#
##############################################################################

if ($ENV{RPLINE} =~ /${SPAMUSER}.*\@${DOMAIN}/) {
	&debug("rpline environment variable set to spamtest");
	&exit0;
}

use strict;
use Socket;

my $ip = '';
my $subject = '';
my $spamflag = 0;
my $headers = 1;
my @headerbuf;
my @xheaderbuf;
my @failedheaders;
my $donesubj = 0;

my $mid = 0;
my $xmailer = 0;
my $subjline = 0;
my $received = 0;

my $annoy = 0;
my $bounce = 0;
my $log = 0;


if (-s "$OPTFILE") {
	&debug("$OPTFILE has options");
	unless (open(QM,"< $OPTFILE")) {
		print "RBLCHECK.PL: can't open $OPTFILE\n";
		exit 0;
	}
	while (<QM>) {
		if (/^b/) {
			# reject the message with a notification message to
			# the sender containing the reasons
			&debug("bounce flag set");
			$bounce = 1;
		}
		elsif (/^l/) {
			# log the filtered mails
			&debug("log flag set");
			$log = 1;
			if (/:/) {
				my ($asdf,$file) = split /:/;
				$LOGFILE = $file;
			}
		}
		elsif (/^o/) {
			# use the ORBS list as well
			&debug("ORBS flag set");
			push @BLACKLISTS, $ORBSLIST;
		}
		elsif (/^a/) {
			# this option doesn't do anything at the moment
			# the idea was to send a notification to the sender
			# but not actually bounce the mail
			&debug("annoy flag set");
		}
	}
} elsif (-f "$OPTFILE") {
	&debug("$OPTFILE is emtpy, quitting");
	exit 0;
} else {
	&debug("$OPTFILE not used");
}

while (<STDIN>) {
	if (/^\s*$/) {
		&debug("seen all the headers");
		$headers = 0;
	}

	if ($headers) {
		if (/^Received: \(ofmipd/ && $ip eq '') {
			&debug("found an ofmipd mail, exiting");
			&exit0;
		}
		if (/^Received: from .*\(.*?(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\)$/ && $ip eq '') {
			$ip = $1;
			&debug("received remote-ip is $ip");
			&check_blacklist();
		}
		elsif (/^X-Remote-IP: (.*)$/) {
			$ip = $1;
			chomp $ip;
			&debug("X-Remote-IP is $ip");
			&check_blacklist();
		}
		elsif (/Subject:/i && ! /\$SPAMTAG/) {
			&debug("checking subject line...");
			$subject = $_;
			chomp $subject;
			&bogusSubjects();
			if ($spamflag) {
				&debug("SPAMming subject line");
				s/Subject:/Subject: $SPAMTAG/i;
			} 
			$donesubj = 1;
		}
		elsif (/Message-ID:/i) {
			&debug("checking message id line");
			unless(/.*\@.*/ || /null/) {
				$spamflag = 1;
				s/.*:\s//;
				$mid = 1;
				push @xheaderbuf, "X-Orig-Message-ID: " . $_;
				push @failedheaders, "Illegal Message-ID syntax (probably bulk mailer) \n" .
					"\t(see http://sunsite.auc.dk/RFC/rfc/rfc822.html)\n";
				push @xheaderbuf, "X-Spamtest: failed - illegal Message-ID syntax " .
					"(see http://sunsite.auc.dk/RFC/rfc/rfc822.html)\n";
				$_ = "Message-ID: <MessageIdWasFaked\@${SPAMUSER}.${DOMAIN}>\n";
			}
		}
		elsif (/x-mailer:/i) {
			&debug("checking mailer line...");
			&bogusMailers($_);
		}
		elsif (/received:/i) {
			&debug("checking received line...");
			&bogusHosts($_);
		}
		elsif (/from:/i) {
			&debug("checking from line...");
			&bogusFrom($_);
		}
		push @headerbuf, $_;
	} else {
		if ($spamflag) {
			unless($donesubj) {
				push @headerbuf, "Subject: $SPAMTAG\n";
			}
			push @xheaderbuf, "Precedence: bulk\n";
			push @xheaderbuf, "X-Real-Return-Path: <$ENV{SENDER}>\n";
		}
		last;
	}
}

if ($spamflag) {
	if ($log) {
		unless(open(LOG,">> $LOGFILE")) {
			print "RBLCHECK.PL: Can't open log $LOGFILE: $!\n";
		} else {
			my $date = `$DATECMD`;
			chomp $date;
			print LOG "$date $ip $subject\n";
			close(LOG);
		}
	}
	if ($bounce) {
		unless(open(OUT,"| $MAILER -f${SPAMUSER}-bouncer\@$DOMAIN $ENV{SENDER}")) {
			print "RBLCHECK.PL: Can't open $MAILER for bounce: $!\n";
			&exit0;
		}
		#push @headerbuf, "\n";
		print "RBLCHECK.PL: bouncing from ${ip}\n";
	} else {
		my $spamfrom = $ENV{SENDER};
		$spamfrom =~ s/\@/=/g;
		$spamfrom = "${SPAMUSER}-${spamfrom}\@$DOMAIN";
		&debug("spamfrom: $spamfrom");
		unless(open(OUT,"| $MAILER -f${spamfrom} $ENV{USER}")) {
			print "RBLCHECK.PL: Can't open $MAILER for resend: $!\n";
			&exit0;
		}
		#push @headerbuf, "\n";
		# the tag is lowercase here as it should be distinguished from debugging info
		print "rblcheck.pl: filtered from ${ip}\n";
	}
	&debug("injecting new mail");
	while (@headerbuf) {
		my $line = shift @headerbuf;
		if (defined($line)) {
			if ($bounce) {
				if ($line =~ /^Subject:/) {
					print OUT "Subject: WARNING: Your mail to $ENV{RECIPIENT} has been rejected\n";
				} elsif ($line =~ /^To:/) {
					&debug("Bouncing to $ENV{SENDER}");
					print OUT "To: $ENV{SENDER}\n";
				} elsif ($line =~ /^From:/) {
					print OUT "From: ${SPAMUSER}-bouncer\@$DOMAIN\n";
				}
			} else {
				print OUT $line;
			}
		}
	}
	while (@xheaderbuf) {
		my $line = shift @xheaderbuf;
		if (defined($line)) {
			print OUT $line;
		}
	}
	print OUT "\n";
	if ($bounce) {
		print OUT <<"EOF";
####################################################
#### THIS IS AN AUTOMATICALLY GENERATED MESSAGE ####
####################################################

Please be advised that $ENV{RECIPIENT} has chosen
to use the $DOMAIN optional spam block, and your
mail has been discarded unread.

If you feel this is an error, or contact is urgently required,
please mail postmaster\@${DOMAIN}, or phone $CONTACTNUM 
to reach $CONTACTNAME.

The reason for the rejection is that the IP address of your
mailhost has been blacklisted by one or more blacklisting 
services for sending SPAM, or your mail has failed some of
our basic security checks. The precise reason(s) are listed
below:

***
EOF
		while (@failedheaders) {
			my $fh= shift @failedheaders;
			if (defined($fh)) {
				print OUT "+ $fh";
			}
		}
		print OUT <<"EOF";
***

SPAM is the bulk sending of unsolicited email messages,
and is forbidden by most Internet service providers.
For more information, please refer to:

http://openrbl.org/lookup.php?i=${ip}&e=.&b=&h=.

The first 0.5KB of your message is included below for
your reference.

-----------------------------------------------------------------
EOF
	}
	my $byteCounter= 0;
	if ($bounce) {
		my $char= getc;
		while (defined($char)) {
			if ($byteCounter++ < 500) {
				print OUT $char;
			} else {
				print OUT "\n";
				print OUT "-----------------------------------------------------------------\n";
				print OUT "\nend of mail\n";
				last;
			}
			$char= getc;
		}
	} else {
		while (<STDIN>) {
			print OUT;
		}
	}

	close(OUT);
	&exit99;
} else {
	&exit0;
}

sub debug {
	my $str = shift;
	chomp $str;
	if ($DEBUG) {
		print "RBLCHECK.PL: $str\n";
	}
}

sub exit0 {
	&debug("exiting 0");
	exit 0;
}

sub exit99 {
	&debug("exiting 99");
	exit 99;
}

sub bogusSubjects {
	my $str = $subject;
	$str =~ s/subject:\s*//i;
	&debug("subject line is --$str--");
	my @templist;
	while (@FILTSUBJS) {
		my $elem = shift @FILTSUBJS;
		if (defined($elem) && $str =~ /^$elem/i) {
			&debug("found rejected subject: $str");
			$subjline = 1;
			$spamflag = 1;
			push @xheaderbuf, "X-Spamtest: failed - filtered subject line\n";
			push @failedheaders, "Filtered subject line: $elem\n";
		}
		push @templist, $elem;
	}
	@FILTSUBJS = @templist;
	
	return 0;
}

sub bogusMailers {
	my $str = shift;
	$str =~ s/x-mailer:\s*//i;
	chomp $str;
	&debug("mailer line is --$str--");
	my @templist;
	while (@FILTMAIL) {
		my $elem = shift @FILTMAIL;
		if (defined($elem) && $str =~ /^$elem/i) {
			&debug("found rejected mailer: $str");
			$xmailer = 1;
			$spamflag = 1;
			push @xheaderbuf, "X-Spamtest: failed - filtered mailer line\n";
			push @failedheaders, "Filtered mailer line: $str\n";
		}
		push @templist, $elem;
	}
	@FILTMAIL = @templist;
	
	return 0;
}

sub bogusHosts {
	my $str = shift;
	$str =~ s/received:\s*//i;
	chomp $str;
	&debug("received line is --$str--");
	my @templist;
	while (@FILTHOSTS) {
		my $elem = shift @FILTHOSTS;
		&debug("checking host: $elem");
		if (defined($elem) && $str =~ /$elem/i) {
			&debug("found rejected host: $str");
			$received = 1;
			$spamflag = 1;
			push @xheaderbuf, "X-Spamtest: failed - blocked received line\n";
			push @failedheaders, "Blocked received line: $elem\n";
		}
		push @templist, $elem;
	}
	@FILTHOSTS = @templist;
	return 0;
}

sub bogusFrom {
	my $str = shift;
	$str =~ s/from:\s*//i;
	chomp $str;
	&debug("from line is --$str--");
	my @templist;
	while (@FILTFROM) {
		my $elem = shift @FILTFROM;
		#&debug("checking from: $elem");
		if (defined($elem) && $str =~ /$elem/i) {
			&debug("found rejected from: $str");
			$received = 1;
			$spamflag = 1;
			push @xheaderbuf, "X-Spamtest: failed - blocked from line\n";
			push @failedheaders, "Blocked from line: $elem\n";
		}
		push @templist, $elem;
	}
	@FILTFROM = @templist;
	return 0;
}

#sub checkRBL {
#	if (defined($ip)) {
#		unless(open(RBL,"$CHECKER $ip |")) {
#			print "RBLCHECK.PL: can't open $CHECKER for check\n";
#			exit 0;
#		}
#		while (<RBL>) {
#			if (/^RBL/) {
#				$spamflag = 1;
#
#				s/RBL filtered by //;
#
#				if (/rbl.maps.vix.com/) { &debug("rbl TRUE: $ip"); $rbl = 1; }
#				elsif (/orbs.org/) { &debug("orbs TRUE: $ip"); $orbs = 1; }
#				elsif (/relays.mail-abuse.org/) { &debug("relays TRUE: $ip"); $relays = 1; }
#				elsif (/dul.maps.vix.com/) { &debug("dul TRUE: $ip"); $dul = 1; }
#
#				push @xheaderbuf, "X-Blacklisted: ($ip) " . $_;
#				push @xheaderbuf, "X-Spamtest: failed - $ip blacklisted\n";
#				push @failedheaders, "Blacklisted: ($ip) " . $_;
#			}
#		}
#		close(RBL);
#	}
#}

sub check_blacklist {
	&debug("checking blacklists...");
	if (defined($ip)) {
		foreach my $srv (@BLACKLISTS) {
			my $check = join(".", reverse(split(/\./, $ip))) . "." . $srv;
			&debug("Checking $check");
			my ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($check);
	
			next unless (@addrs);
	
			my $result = inet_ntoa($addrs[0]);
	
			if ($result =~ /^127\.0\.0\./) {
				&debug("$ip found in $srv, mail is probably spam.");
				$spamflag = 1;
				push @xheaderbuf, "X-Blacklisted: ($ip) $srv\n";
				push @xheaderbuf, "X-Spamtest: failed - $ip blacklisted\n";
				push @failedheaders, "Blacklisted: ($ip) $srv\n";
			}
			next;
		}
	}
}