#!/usr/bin/perl -w
use strict;

# Copyright (c) 2003 Jon Atkins http://www.jonatkins.com/
# Patched for MySQL support, 2006, by Rob Bos (http://novylen.net)
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.


my $version = "0.2-mysql";


# TODO: alternative logging options, instead of syslog?

use Sys::Syslog;
use DBI;

openlog "greylist", "pid", "mail";

# syslog "level", "%s", "message"
# level is one of emerg, alert, crit, err, warning, notice, info, debug

$| = 1;

my $verbose = 1;  # if set, log connecting IP addresses...
my $debugmsg = 0; # for more detailed debugging messages...
my $control = "/etc/qmail/control"; # location of qmail control files (for smtpgreeting or me)
my $domain = "novylen.net"; # domain name: used in smtp greetings, etc
my $cleanup = 1;  # if set, clean up old entries (you might not, for instance, want your secondary MX doing the cleanup)

# Database information.
my $host="localhost";
my $database="greylist";
my $username="greylist";
my $password="";


if ( open DOM, "$control/smtpgreeting" or open DOM, "$control/me" )
{
	$domain = <DOM>;
	chomp $domain;

	close DOM;
}


# location for whitelist files (eg. yahoo groups - they don't retry!)
# UNIMPLEMENTED
my $whitelist = "";

# how long, after 1st seening an ip address, is it kept on the greylist
# (a minute or two is good enough - a few spammers retry within 30 seconds
#  or so, then never again. the others that do retry will do so for long enough
#  to bypass any sensible value for this)
my $greytime = 2 * 60;

# how long, after seeing an ip address once, before is it forgotten about
# (this needs to be high enough to allow for retry intervals of the
#  most overloaded mail server, but low enough to avoid a 2nd spam from
#  the same IP address) 
my $maxageonce = 24 * 60 * 60;

# how long, after seeing an ip address several times, before it is forgotten about
# (this should be high enough that messages from weekly, if not monthly,
#  mail lists do not expire from the list)
my $maxagegood = 32 * 24 * 60 * 60;

# how often to run IP address expiry (a minimum - this is only checked when mail arrives)
# (when this runs the script does a stat() on every IP address file,
#  but it does need to be small enough that the $maxage* values work)
my $cleanupinterval = 15 * 60;

# timeout to use waiting for smtp commands
# (rfc2821 recommends at least 5 minutes for most commands)
my $smtptimeout = 5 * 60;

# greylist against entire class-c (/24) networks rather than IP addresses
# if set to 1, greylist entire class-c networks rather than single IP addresses
# this should help with clusters of mailservers which connect from separate
# IP addresses with each delivery attempt (eg. yahoo groups)
my $greylistclassc = 1;


# Open database.
my $dbh = DBI->connect("DBI:mysql:$database:host=$host", $username, $password) or run_next_stage(); #die "Can't connect to $database.\n";

# Set modification time of the greylist entry.  Creates it if necessary.
sub set_mtime {
	my ( $file ) = @_;
	my $row="";
	my $query="select * from ips where ip_addr='$file';";
	my $sth = $dbh->prepare($query);
	$sth->execute or die "Unable to execute query: $dbh->errstr\n";
	$row = $sth->fetchrow_arrayref or $row = -1; 

	if ( $row == -1 ) {
		$query="insert into ips (atime, mtime, ip_addr) values (now(), now(), '$file');";
	} else {
		$query="update ips set mtime=now() where ip_addr='$file';";
	}
	$sth = $dbh->prepare($query);
	$sth->execute or die "Unable to execute query: $dbh->errstr\n";
	$sth->finish;
}

# Set last access time of the greylist entry.
sub set_atime {
	my ( $file ) = @_;
	# my $query="update ips set atime=now() where ip_addr='$file';";
	my $query="update ips set atime=now(), times_seen=times_seen+1 where ip_addr='$file';";
	my $sth = $dbh->prepare($query);
	$sth->execute or die "Unable to execute query: $dbh->errstr\n";
	$sth->finish;
}

# Return a two-member array with atime and mtime.
sub get_atime_mtime {

	my ( $file ) = @_;
	my $query="select UNIX_TIMESTAMP(atime),UNIX_TIMESTAMP(mtime) from ips where ip_addr='$file';";
	my $sth = $dbh->prepare($query);
	$sth->execute or die "Unable to execute query: $dbh->errstr\n";
	my $row = $sth->fetchrow_arrayref or return -1; 
	$sth->finish;

	return $row;
}


# check the ip file, or a network file matching the ip, exists
# and return the atime + mtime of the file
sub check_ip
{
	my ( $ip ) = @_;
	print "ip: $ip\n" if $debugmsg;

	return () unless $ip =~ m{^(\d+)\.(\d+)\.(\d+)\.(\d+)$};
	print "check for empty ip\n" if $debugmsg;
	my ( $a, $b, $c, $d ) = ( $1, $2, $3, $4 );

	my $stat = get_atime_mtime "$a.$b.$c.$d";
	print "4: check_ip $stat\n" if $debugmsg;
	return ($stat->[0], $stat->[1]) if ( $stat != -1 );

	$stat = get_atime_mtime "$a.$b.$c.";
	print "3: check_ip $stat\n" if $debugmsg;
	return ($stat->[0], $stat->[1]) if ( $stat != -1 );

	$stat = get_atime_mtime "$a.$b.";
	print "2: check_ip $stat\n" if $debugmsg;
	return ($stat->[0], $stat->[1]) if ( $stat != -1 );

	return ();
}

sub run_next_stage
{
#	syslog "debug", "%s", "starting ".(join ' ', @ARGV) if $debugmsg;

	exec @ARGV or print "450 temporary problem - failed to start next process\r\n";

	syslog "err", "failed to run next stage!";
	exit;
}

# option 2: perform a basic smtp responder
# Why? See rfc2821 - 4.3.2 - it only mentions 220 and 521 as codes to be
# expected on a new connection. some buggy MTAs may see an initial 4xx code
# as a permanent error.
# Another advantage of delayed rejection of messages is that we can log
# the envelope information. This can be useful for debugging and/or monitoring.
sub smtp_temp_fail
{
	my ( $message ) = ( @_ );

	my %commands =
	(
		'HELO' => "250 hello",
		'EHLO' => "250 hello",
		'MAIL' => "250 Mail from <>",
		'RCPT' => "450 Rcpt to <> - $message",
		'DATA' => "451 $message",
		'RSET' => "250 ready",
		'VRFY' => "502 not implemented",
		'EXPN' => "502 not implemented",
		'HELP' => "502 not implemented",
		'NOOP' => "250 noop",
		'QUIT' => "221 $domain Bye",
	);



# you may want to change the greeting to something else...
	print "220 $domain qgreylist $version\r\n";


	$SIG{ALRM} = sub
	{
		syslog "debug", "SMTP: timeout: connection closed" if $debugmsg;

		print "421 $domain timeout\r\n";
		exit;
	};


	alarm $smtptimeout;
	while ( my $line = <STDIN> )
	{
		alarm 0;

		sleep 1;	# brief delay, to annoy spammers

		alarm $smtptimeout;


		$line =~ s/\r?\n?$//;

##		syslog "debug", "SMTP debug: >>> %s", $line if $debugmsg;
		my ( $command, $parms ) = split / +/, $line, 2;
		$command = uc $command;
		if ( defined $commands{$command} )
		{
			my $reply = $commands{$command};
			if ( $reply =~ m/<>/ )
			{
				my $addr = $parms || "?";
				$addr =~ s/^(from|to):? *//i;
				$reply =~ s/<>/$addr/;
			}

			syslog "debug", "SMTP: %s: %s", $command, $reply if $debugmsg;
			print "$reply\r\n";
		}
		else
		{
			print "500 $command not known\r\n";
		}
		last if $command eq 'QUIT';
	}

	syslog "debug", "SMTP: connection closed" if $debugmsg;
	exit;
}


sub isotime
{
	my ( $time ) = @_;
	my ( $sec, $min, $hour, $mday, $mon, $year, undef, undef, undef ) = localtime $time;
	my $isotime = sprintf "%04d-%02d-%02d %02d:%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec;
	return $isotime;
}

# Runs cleanup only if it hasn't been run in the last 15 minutes.
# if $atime < $time - $maxageonce,
# or $atime < $time - $magagegood

sub cleanup_maybe
{
	return if !$cleanup;
	my $found=0;	
	my $query="select UNIX_TIMESTAMP(mtime) from ips where ip_addr='LAST_CLEANED';";
	my $sth = $dbh->prepare($query);
	$sth->execute or die "Unable to execute query: $dbh->errstr\n";
	my $row = $sth->fetchrow_arrayref or $found=-1; 
	print "last checked: $row->[0]\n" if ($debugmsg and $found!=-1);

	if ($found==-1) {
		# first run, not found
		$query="insert into ips (ip_addr,mtime) values ('LAST_CLEANED', now());";
		$sth = $dbh->prepare($query);
		$sth->execute or die "Unable to execute query: $dbh->errstr\n";
		$row = $sth->fetchrow_arrayref or $found=-1;
	}
	my $time=time;
	if ($time - $row->[0] > $cleanupinterval) {
		print "Cleaning old entries.\n" if $debugmsg;
		# Note: COULD combine these two SQL statements, but it's nice to have them separate for logging purposes.
		#
		# if ( $atime < $time - $maxageonce )
		# Log 'em.
		$query="select ip_addr, mtime, atime from ips where (UNIX_TIMESTAMP(atime) < $time - $maxagegood);";
		$sth = $dbh->prepare($query);
		$sth->execute or die "Unable to execute query: $dbh->errstr\n";
		while ($row = $sth->fetchrow_arrayref) {
			syslog "info", "forgetting $row->[0] (first seen $row->[1], last $row->[2])" if $verbose;
		}
		# Delete them.
		$query="delete from ips where (UNIX_TIMESTAMP(atime) < $time - $maxagegood);";
		print "$query\n" if $debugmsg;
		$sth = $dbh->prepare($query);
		$sth->execute or die "Unable to execute query: $dbh->errstr\n";

		# if ( $atime < $time - $maxagegood )
		$query="select ip_addr, atime from ips where (atime=mtime) and (UNIX_TIMESTAMP(atime) < $time - $maxageonce);";
		$sth = $dbh->prepare($query);
		$sth->execute or die "Unable to execute query: $dbh->errstr\n";
		while ($row = $sth->fetchrow_arrayref) {
			syslog "info", "forgetting $row->[0] (seen once at $row->[1])" if $verbose;
		}
		$query="delete from ips where (atime=mtime) and (UNIX_TIMESTAMP(atime) < $time - $maxageonce);";
		print "$query\n" if $debugmsg;
		$sth = $dbh->prepare($query);
		$sth->execute or die "Unable to execute query: $dbh->errstr\n";

		# touch LAST_CLEANED
		$query="update ips set mtime=now() where ip_addr='LAST_CLEANED';";
		$sth = $dbh->prepare($query);
		$sth->execute or die "Unable to execute query: $dbh->errstr\n";
	}

	$sth->finish;
	
	# avoid doing this on every smtp connection
	# if ( !defined $lastclean or $lastclean > $cleanupinterval / (24*60*60) )
	# {
		# syslog "debug", "running cleanup" if $debugmsg;
		# cleanup;
	# }
}



# ------------------------------------------------------------
# main code starts here......

# clean up old IPs from the greylist folder...
cleanup_maybe;


# TODO: change to an immediate error here..?
unless ( defined $ENV{TCPREMOTEIP} )
{
	syslog "err", "ENV{TCPREMOTEIP} not set!";
	smtp_temp_fail "Cannot find remote IP";
}

# now this should never happen...
unless ( $ENV{TCPREMOTEIP} =~ m{^(\d+\.\d+\.\d+\.\d+)$} )
{
	syslog "err", "ENV{TCPREMOTEIP} = $ENV{TCPREMOTEIP} - bad format!";
	smtp_temp_fail "Bad format for remote IP";
}

my $remoteip = $1;


# IPs we relay for don't get greylisted...
if ( defined $ENV{RELAYCLIENT} )
{
	syslog "debug", "Local IP accepted" if $debugmsg;
	run_next_stage;
}


# ok - now check to see if we should greylist this ip address...

my $checkfile;
if ( $greylistclassc )
{
	$remoteip =~ m{^(\d+\.\d+\.\d+\.)\d+$};
	$checkfile = $1;
}
else
{
	$checkfile = $remoteip;
}

print "ip to check for: $checkfile\n" if $debugmsg;

my ( $atime, $mtime ) = check_ip($remoteip);

print "returned \"$atime, $mtime\" from check_ip\n" if $debugmsg;
# print "$mtime: (".time() - $mtime.")\n";

if ( !defined($mtime)) {
	# we don't know of this IP address - return a temporary error
	syslog "info", "IP %s new - temp error", $remoteip if $verbose;

	# record the IP for next time
	set_mtime $checkfile;

	smtp_temp_fail "Temporary local problem - try later";
} elsif ( (time - $mtime) < $greytime ) {
	# we already knew of the ip, but very recently - temp error again
	syslog "info", "IP %s back too soon - temp error again", $remoteip if $verbose;
	smtp_temp_fail "Temporary local problem - I said try later";
}

# ok - we already knew and more than a few minutes ago
syslog "info", "IP %s OK - accepting", $remoteip if $verbose;

# access the check file as it's a good IP
set_atime $checkfile;

# then launch qmail-smtpd or whatever...
run_next_stage;

$dbh->disconnect;