#!/usr/bin/perl -w

# Greytrapping daemon for OpenBSD spamd

# Copyright (c) 2006 Bob Beck <beck@openbsd.org>.  All rights reserved.
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
# 
# Processing of DNS entries for MTAs (hosts delivering a bounce
# i.e sender = <>), and using a spamtrap file added 2008
# by Raimo Niskanen. The original license applies also
# to those changes and others made by this author.

# Process spamdb output and look for patterns. Mainly we look
# at the greylist entries, and make some decisions about them. if they
# look excessively spammish, we take some action against them, by
# running spamdb -t -a to add them as a TRAPPED entry to spamd, meaning
# spamd in greylist mode will tarpit them for the next 24 hours.

use strict;
use Net::DNS;
use Email::Valid;
use Sys::Syslog qw(:DEFAULT setlogsock);
use POSIX qw(setsid);


######################################################################

# How often to scan spamdb - in seconds. 
# Don't make this too quick! the point of it is to see MULTIPLE
# greylist attempts. This should be run more frequently than the greylist
# pass time, enough so you can get two scans in, but not much more. 
# a good suggestion is every 10 minutes, which allows for two runs
# every 30 minutes even if DNS lookups take a long time.
my $SCAN_INTERVAL = 600;

# How many sockets will we use for DNS lookups in parallel. A good suggestion
# which works for me at a busy site is 50. Don't crank it too high or
# you'll hit maxfiles, etc. Setting this to 0 will *disable* the dns MX
# and A checking.
my $DNS_SOCK_MAX=50;

# Perfom count checks on hosts with more than this many tuples
my $SUSPECT_TUPLES = 5; 

# Count Checks - how many unique sender domains allowed (max) from one host.
# If any host in the greylist has more than SUSPECT_TUPLES, and is sending
# from more than MAX_DOMAINS, they get trapped. 
my $MAX_DOMAINS = 3;

# Count Checks - Max unique sender/tuple ratio.
# If any host in the greylist has more than SUSPECT_TUPLES, we count
# the number of unique senders in the tuple. if ths number of unique
# senders divided by the number of tuples is greater than MAX_SENDERS_RATIO
# we trap the host.
my $MAX_SENDERS_RATIO = 0.75;


# List of regexen which, on a case insensitive match to the RCPT, greytrap
# the host. Just like spamd greytraps, but these can be regexed. If any
# recipient matches any of these regexs, we trap the host. Old domains
# or mailservers make great additions to this.
my @BADRERCPT = (
        "\@oldmailserver.mydomain.com\$",
        "\@unusedomain.org\$",
);

# Exclusions from @BADRERCPT and $EXTERNAL_ADDRESS_CHECKER
my @GOODRERCPT = (
	"^(abuse|security|hostmaster|webmaster)\@",
);

# External address checker. if this file exists and is executable, 
# we will run it for every recipient, giving the recipient address
# as an argument on the command line. If the program then exits with
# a non-zero exit status, we trap the host sending to this address.
# for example, if you maintain an ldap directory for all your users
# write a quick script to validate a mail address, and you've got
# real power here by trapping any greylisted host that mails to
# a bogus address. 
my $EXTERNAL_ADDRESS_CHECKER = "/etc/mail/greytrap_checkrcpt";

# Spamtrap users file with one user per line. If an attempt is made
# to send a non-DSN (i.e non-empty sender) to any of these users,
# in any domain, the host is trapped. A suitable source for
# spamtrap users are "Unknown user" in your maillog a'la:
# zcat /var/log/maillog.0.gz \
#     | sed -n 's/.*: <\([^@]*\)@.*\.\.\. User unknown$/\1/p' \
#     | sort -u 
# 
# If a user is on the form /^\^/ or /\$$/ it is interpreted
# as a prefix or suffix, respectively.

my $SPAMTRAP_PATTERNS = "/var/db/spamtrap_patterns";

######################################################################

my $DEBUG = 0;
my %TOAST;

sub daemonize {
    chdir '/' or die "can't chdir to /";
    open STDIN, '/dev/null' or die "can't open /dev/null";
    open STDOUT, '>>/dev/null' or die "can't open /dev/null";
    open STDERR, '>>/dev/null' or die "can't open /dev/null";
    defined (my $pid = fork) or die "Can't fork: $!";
    exit if ($pid);
    setsid   or die "can't setsid: $!";
    # umask 0;
}

# Trap a host. Adds them as TRAPPED to spamdb, meaning they will be
# tarpitted by spamd for 24 hours from the time we run this.
sub trap {
    my $ip = shift;
    my $reason = shift;
    
    if (!$TOAST{$ip}) {
	$TOAST{$ip}=1;
	if ($DEBUG) {
	    print ('info: ', "Trapped $ip: $reason", "\n");
	} else {
	    system "spamdb -t -a $ip\n";
	    syslog ('info', "Trapped $ip: $reason");
	}
    }
}

# Binary search for a prefix match
sub match ($@) {
    my $string = shift;
    my $low = 0;
    my $high = @_;
    while ($low+1 < $high) {
	my $mid = ($low + $high) >> 1;
	if ($_[$mid] le $string) {
	    $low = $mid;
	} else {
	    $high = $mid;
	}
    }
    $_ = $_[$low];
    return '' if length() > length($string);
    $string = substr($string, 0, length);
    return ($_ eq $string) ? $_ : '';
}

my %SPAMTRAP_NAMES = ();
my @SPAMTRAP_PREFIXES = ();
my @SPAMTRAP_SUFFIXES = ();
# Read in the patterns file
sub read_patterns {
    if ($SPAMTRAP_PATTERNS && -r $SPAMTRAP_PATTERNS) {
	open(SPAMTRAP, "<", $SPAMTRAP_PATTERNS) 
	    or die "can't open $SPAMTRAP_PATTERNS: $!";
	while (<SPAMTRAP>) {
	    chomp;
	    if (s/^\^//) {
        	push @SPAMTRAP_PREFIXES, $_;
	    } elsif (s/\$$//) {
	        push @SPAMTRAP_SUFFIXES, scalar reverse;
	    } else {
	        $SPAMTRAP_NAMES{$_} = 1;
	    }
	}
	close(SPAMTRAP)
	    or die "can't close $SPAMTRAP_PATTERNS: $!";
	@SPAMTRAP_PREFIXES = sort(@SPAMTRAP_PREFIXES);
	@SPAMTRAP_SUFFIXES = sort(@SPAMTRAP_SUFFIXES);
    }
}

# This routine tells us if a single destination rcpt is bogus
sub badrcpt {
    my $rcpt = shift;
    
    # 0) check against the GOODRERCPT...
    foreach my $re (@GOODRERCPT) {
	if ($rcpt =~ /$re/i) {
	    # match. do not trap the host.
	    return "";
	}
    }
    
    # 1) check against the BADRERCPT...
    foreach my $re (@BADRERCPT) {
	if ($rcpt =~ /$re/i) {
	    # match. trap the host.
	    return "Mailed to trap re $rcpt";
	}
    }
    
    if (-x $EXTERNAL_ADDRESS_CHECKER) {
	if (system(("$EXTERNAL_ADDRESS_CHECKER", "$rcpt")) != 0) {
	    # address checker says $re is bad - trap the host
	    return "Mailed to trap address $rcpt";
	}
    }
    
    $rcpt =~ s/\@.*$//;
    return "Mailed to trap name $rcpt"
	if defined($SPAMTRAP_NAMES{$rcpt});
    return "Mailed to trap prefix $rcpt"
	if &match($rcpt, @SPAMTRAP_PREFIXES);
    my $rrcpt = reverse($rcpt);
    return "Mailed to trap suffix $rcpt"
	if &match($rrcpt, @SPAMTRAP_SUFFIXES);
    
    #rcpt is ok
    return "";
}


sub scan {
    my %WHITE;
    my %GREY;
    my %TRAPPED;
    my %HELO;
    my %FROM;
    my %RCPT;
    my %DSN;
    my %SENDERS;
    my @line;
    
    open (SPAMDB, "spamdb|") || die "can't invoke spamdb!";
    while (<SPAMDB>) {
	# read add to associative arrays..
	chomp;
	if (/^WHITE\|/) {
	    #Remember the whitelisted entries.
	    @line=split('\|');
	    $WHITE{$line[1]} = $_;
	    
	} elsif (/^TRAPPED\|/) {
	    #Remember any TRAPPED entries.
	    #Remember the whitelisted entries.
	    @line=split('\|');
	    $TRAPPED{$line[1]} = $_;
	    
	} elsif (/^GREY\|/) {
	    # process a greylist entry
	    @line=split('\|');
	    $line[3] =~ s/^<//;
	    $line[3] =~ s/>$//;
	    $line[4] =~ s/^<//;
	    $line[4] =~ s/>$//;
	    if (defined $GREY{$line[1]}) {
		$GREY{$line[1]} .= "\000$_";
		# strip off enclosing <> if present
		$HELO{$line[1]} .= "\000$line[2]";
	    } else {
		$GREY{$line[1]} = $_;
		$HELO{$line[1]} = $line[2];
	    }
	    if ($line[3] eq '') {
		if (defined $DSN{$line[1]}) {
		    $DSN{$line[1]} .= "\000$line[4]";
		} else {
		    $DSN{$line[1]} = $line[4];
		}
	    } else {
		if (defined $FROM{$line[1]}) {
		    $FROM{$line[1]} .= "\000$line[3]";
		    $RCPT{$line[1]} .= "\000$line[4]";
		} else {
		    $FROM{$line[1]} = $line[3];
		    $RCPT{$line[1]} = $line[4];
		}
	    }
	}
    }
    close (SPAMDB);
    
    &read_patterns;

    my $wi = keys %WHITE;
    my $tr = keys %TRAPPED;
    my $gr = keys %GREY;
    if ($DEBUG) {
	print STDERR "debug: ",
	    "scanned $wi whitelisted, $tr trapped, $gr unique greys\n";
    } else {
	syslog ('debug',
		"scanned $wi whitelisted, $tr trapped, $gr unique greys\n");
    }
    
    GREY: foreach my $grey (keys %GREY) {
	# ignore if it's already done
	next if ($TRAPPED{$grey} || $WHITE{$grey});
	
	# check for inconsistent HELO
	my @helos = split("\000", $HELO{$grey}, -1);
	if (@helos > 1) {
	    my $h;
	    ($h, @helos) = @helos;
	    $HELO{$grey} = $h;
	    foreach (@helos) {
		if ($_ ne $h) {
		    &trap($grey, "Inconsistent HELO: @helos");
		    last;
		}
	    }
	}
	
	# check the senders. if any are malformed, give the host the boot.
	my @from = ();
	@from = split("\000", $FROM{$grey}, -1) if defined $FROM{$grey};
	foreach (@from) {
	    unless(Email::Valid->address(-address =>"$_",
				         -fudge => 1,
				         -local_rules => 1)) {
		&trap($grey,
		      "Invalid source address <$_> ($Email::Valid::Details)");
		next GREY;
	    }
	}
	
	my @rcpt = ();
	@rcpt = split("\000", $RCPT{$grey}, -1) if defined $RCPT{$grey};
	my @dsn = ();
	@dsn = split("\000", $DSN{$grey}, -1) if defined $DSN{$grey};
	foreach ((@rcpt, @dsn)) {
	    unless(Email::Valid->address(-address =>"$_",
				         -fudge => 1,
				         -local_rules => 1)) {
		&trap($grey,
		      "Invalid destination address <$_> ($Email::Valid::Details)");
		next GREY;
	    }

	}

	# if the host has queued up more than our suspect threshold, look
	# at a few things...
	my $count = @from;
	if ($count > $SUSPECT_TUPLES) {
	    my $reason = "";
	    my %R;
	    my %S;
	    my %D;
	    
	    # check how many unique senders and recipients, and domains. 
	    foreach (@rcpt) {
		$R{$_}++;
	    }
	    foreach (@from) {
		$S{$_}++;
		s/[^\@]+\@//;
		$D{$_}++;
	    }
	    my $rcount = keys %R;
	    my $scount = keys %S;
	    my $dcount = keys %D;
	    print STDERR "$grey: c=$count r=$rcount s=$scount d=$dcount\n"
		if $DEBUG;
	    
	    if ($dcount > $MAX_DOMAINS) {
		$reason = "Host sending from " . $dcount .
		    " domains (> $MAX_DOMAINS)";
	    } elsif ($scount/$count > $MAX_SENDERS_RATIO) {
		$reason = "Senders/Tuples ration is  $scount/$count"
		    . " senders/tuples (> $MAX_SENDERS_RATIO)";
	    } else {
		# We could do checks on number of recipients, however, we 
		# must be careful here. a mailing list server mails from a 
		# small number of senders to a  potentially large number of
		# recipients. While this could also be a spammer using a 
		# small number of source addresses that's not been typical
		# observed behaviour (at least in 2006)
		
		# XXX wait and see here.. we may or may not need to do 
		# more stuff here.
	    }
	    
	    if ($reason) {
		&trap($grey, $reason);
                next GREY;
	    }
	}
	
	#  now check destination addresses...
	foreach (@rcpt) {
	    my $reason = &badrcpt($_);
	    if ($reason) {
		&trap($grey, $reason);
		next GREY;
	    }
	}
        
	next unless $DNS_SOCK_MAX; # skip rest if not using DNS checks;
	
	# finally, we will check for an MX or A record of the source address.
	# first we build a hash of all the senders, keyed by host part
	# of the address, so we only look each host part up once, no matter
	# how many hosts are sending mail with it as the sender.

	foreach (@from) {
	    # extract the host part.
	    s/^.*@(.*)$/$1/;
	    s/\s_+//g;
	    next if $_ eq '';
	    
	    if (defined $SENDERS{$_}) {
		$SENDERS{$_} .= "\000$grey";
	    } else {
		$SENDERS{$_} = "$grey";
	    }
	}
    }
    
    exit(0) unless $DNS_SOCK_MAX;
    
    
    # DNS sucks moose rocks. So we have to do a bazillion queries in
    # parallel to get any kind of speed. Sigh... Whip through the list of
    # addresses being sent, and validate them by checking for an A or
    # MX record. We don't use Email::Validate because it can't do background
    # queries. instead we use Net::DNS directly and call select..
    
    my $timeouts = 5;
    my $timeout = 5;
    my $sel = IO::Select->new;
    my $res = Net::DNS::Resolver->new;
    my @domains = (keys %SENDERS);

    print STDERR "Resolving ", scalar @domains, " sender domains\n"
	if $DEBUG;

    while ($timeouts > 0) {
	my @active = $sel->handles;
	while (@domains > 0  && @active < $DNS_SOCK_MAX) {
	    # queue up a query for this domain.
	    my $d = shift(@domains);
	    $sel->add($res->bgsend($d, "A"));
	    $sel->add($res->bgsend($d, "MX"));
	    @active = $sel->handles;
	}
	last if @domains+@active == 0;
	my @ready = $sel->can_read($timeout);
	if (@ready) {
	    foreach my $sock (@ready) {
		my $packet = $res->bgread($sock);
		if ($packet->header->ancount) {
		    my @q = $packet->question;
		    if ($q[0]->qtype eq "A" || $q[0]->qtype eq "MX") {
			my $d = $q[0]->qname;
			delete $SENDERS{$d};
		    }
		}
		# Check for the other sockets.
		$sel->remove($sock);
		$sock = undef;
	    }
	} else {
	    $timeouts-- if @domains == 0;
	}
    }

    # now whatever is left in $SENDERS is evil - we removed everything
    # we could find a mailer for. We go through the evil addresses
    # and trap anyone sending from one...
    
    my @Evil = keys %SENDERS;
    foreach my $evil (@Evil) {
	my @deaders = split("\000", $SENDERS{$evil}, -1);
	foreach my $dead (@deaders) {
	    &trap($dead, "Mailed from sender $evil with no MX or A");
	    $DSN{$dead} = undef;
	}
	@deaders = undef;
    }
    
    # Do DNS lookups for the hosts appearing to be MTAs, that is
    # the ones trying to deliver to us with empty envelope sender.
    
    $timeouts = 5;
    $timeout = 5;
    $sel = IO::Select->new;
    #my $res = Net::DNS::Resolver->new;
    my @addrs = keys %DSN;
    @domains = ();
    my %Q; # X.X.X.X.in-addr.arpa reverse domain -> IP
    my %D; # IP -> domain name (reverse lookup result)
    
    print STDERR "Resolving ", scalar @addrs, " acclaimed MTAs\n"
	if $DEBUG;

    while ($timeouts) {
	my @active = $sel->handles;
	while (@addrs+@domains > 0 && @active < $DNS_SOCK_MAX) {
	    # queue up a query for this domain.
	    my $p;
            my $ip = shift(@addrs);
	    if (defined $ip) {
		$p = Net::DNS::Packet->new($ip, "PTR");
		my ($question) = $p->question;
		my $n = $question->qname;
		$Q{$n} = $ip;
		#print STDERR "Resolving $n\[$ip\]\n";
	    } else {
		my $d = shift(@domains);
		$p = Net::DNS::Packet->new($d, "A");
		#print STDERR "Resolving $d\n";
	    }
            $sel->add($res->bgsend($p));
	    @active = $sel->handles;
	}
	#print STDERR "addrs=", scalar @addrs, " domains=", scalar @domains, " active=", scalar @active, "\n";
	last if @addrs+@domains+@active == 0;
	my @ready = $sel->can_read($timeout);
	if (@ready) {
	    foreach my $sock (@ready) {
		my $p = $res->bgread($sock);
		my ($q) = $p->question;
		my $n = $q->qname;
		my @answers = $p->answer;
		foreach my $a (@answers) {
		    if ($q->qtype eq 'PTR' && $a->type eq 'PTR') {
			my $d = $a->ptrdname;
			my $ip = $Q{$n};
			if (lc($d) eq lc($HELO{$ip})) {
			    # 'PTR' lookup matched - Continue with an 'A' lookup
			    $D{$ip} = $d;
			    push @domains, $d;
			} else {
			    #print STDERR
			    #    "Resolved $n\[$ip\] unexpectedly to $d for $HELO{$ip}\n";
			}
		    } elsif ($q->qtype eq 'A' && $a->type eq 'A') {
			my $ip = $a->address;
			if (defined($D{$ip}) && $n eq $D{$ip}) {
			    #print STDERR "Resolved $n to $ip: OK\n";
			    delete $DSN{$ip};
			} else {
			    #print STDERR "Resolved $n to $ip: INCONSISTENT\n";
			}
		    }
		}
		# Check for the other sockets.
                $sel->remove($sock);
                $sock = undef;
	    }
	} else {
	    $timeouts-- if @addrs+@domains == 0;
	}
    }
    foreach my $a (keys %DSN) {
	my $mta;
	($mta) = split("\000", $HELO{$a}, -1);
	&trap($a, "MTA $mta resolved inconsistently");
    }
}



$DEBUG = shift;
if (defined $DEBUG && $DEBUG eq '-d') {
    $DEBUG = 1;
} else {
    $DEBUG = 0;
}

# daemonize and scan in a loop.

&daemonize unless $DEBUG;
while (1) {
    unless ($DEBUG) {
	setlogsock('unix');
	openlog("greytrapper", 'pid', 'mail') || die "can't openlog";
	syslog('debug', "Scan started") unless $DEBUG;
    }
    my $pid;
    $pid = fork();
    if (!$pid) {
	# child. scan away...
	&scan;
	exit(0);
    }
    # parent waits and sleeps.
    wait;
    syslog('debug', "Scan completed") unless $DEBUG;
    exit(0) if $DEBUG;
    sleep($SCAN_INTERVAL);
}