#!/usr/bin/perl -w
# -*- cperl -*-
# $Id: selective-greylist,v 1.4 2006/12/11 22:49:08 cm Exp $
#
# selective greylister for postfix, see http://www.tahina.priv.at/spam.html
# Copyright (C) 2006  christian mock <cm@tahina.priv.at>
#
# contributions by:
#  Raphael Wegmann <raphael@psi.co.at>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

use strict;
use Mail::SPF::Query;
use Net::DNS;
use Sys::Syslog;
use IO::Handle;
use Getopt::Std;
use Fcntl ':flock';
use DBI;

## config
my $greylist_db = "/var/spool/postfix/db/greylist/greylist.sqlite";
my $whitelist_expiry = 30; # days
my $greylist_expiry = 1; # days

my $greylist_time = 5; # minutes

my $expiry_chance = 0.001;

my $maxload = -1;

my $usage = "usage: $0 [-D] [-d dbfile] [-g greylist time] [-l maxload]
[-x expiry chance] [-e greylist expiry time] [-E whitelist expiry time]
  -D: debug logging
  -d: DB file, default $greylist_db
  -g: period for greylisting, default $greylist_time minutes
  -l: greylist all connections above this load average, default $maxload
  -e: expiry time for inactive greylist entries, default $greylist_expiry days
  -E: expiry time for inactive whitelist entries, default $whitelist_expiry days
  -x: probability of an expire run, default $expiry_chance
";



## global vars
my ($dbh, %attrs, $res, $dberr, $lock_db_fh, %opts);

sub policy {
  my $suspect = 0;

  ## already whitelisted?
  lock_db();
  my $wl_status = get_status();
  unlock_db();
  if($wl_status eq 'W') {
    return 'DUNNO';
  } elsif($wl_status eq 'G') {
    return "450 Greylisted, try again later";
  } elsif($wl_status eq 'OK') {
    return "OK";
  }

  ## no reverse lookup
  if($attrs{client_name} eq 'unknown') {
    mylog('debug', 'no reverse lookup for %s', $attrs{client_address});
    $suspect++;
  }

  ## HELO
  if($attrs{helo_name} !~ /\./) { # host without domain
    mylog('debug', 'HELO name %s is not FQDN', $attrs{helo_name});
    $suspect++;
  } elsif($attrs{helo_name} =~ /^\[?\d+\.\d+\.\d+\.\d+\]?$/) {
    mylog('debug', 'HELO name %s is IP addr', $attrs{helo_name});
    $suspect++;
  } else { # check helo name in DNS
    unless(has_A_or_MX($attrs{helo_name})) { # helo name not in DNS
      mylog('debug', 'HELO name %s has no A or MX records',
	    $attrs{helo_name});
      $suspect++;
    }
  }

  ## dialups
  if(my $r = check_rbls(["dul.dnsbl.sorbs.net", "dynablock.njabl.org",
			 "dialups.visi.com" ],
			$attrs{client_address})) {
    mylog('debug', 'dialup (%s): %s', $r, $attrs{client_address});
    $suspect++;
  }

  ## SPF
  my $spf = new Mail::SPF::Query(ip => $attrs{client_address},
				 sender => $attrs{sender},
				 helo => $attrs{helo_name},
				 trusted => 1,
				 guess => 1);
  unless (defined $spf) {
    mylog('debug','new Mail::SPF::Query failed');
  } else {
    my ($result, $smtp_comment) = $spf->result();
    mylog('debug', 'SPF result %s/%s', $result, $smtp_comment);
    if($result !~ /pass|none/) {
      $suspect++;
    }
  }

  mylog('debug', 'suspect level %d', $suspect);

  if($suspect == 0) {
    lock_db();
    set_whitelisted();
    unlock_db();
    return "DUNNO";
  } else {
    lock_db();
    set_greylisted($greylist_time);
    unlock_db();
    return "450 Greylisted, try again later";
  }
}



## main
getopts('Dd:g:l:x:e:E:', \%opts) || die $usage;

my $debug = $opts{D};

$greylist_db =      $opts{d} if $opts{d};
$greylist_time =    $opts{g} if $opts{g};
$maxload =          $opts{l} if $opts{l};
$greylist_expiry =  $opts{e} if $opts{e};
$whitelist_expiry = $opts{E} if $opts{E};
$expiry_chance =    $opts{x} if $opts{x};

openlog("selective-greylist", "pid", "mail");
mylog('info', 'starting');


$res = Net::DNS::Resolver->new;
$res->persistent_udp(1);


autoflush STDOUT 1;

open_db();
while(<>) {
  chomp;

  my $answer;

  if(/^$/) {
    if($attrs{request} ne 'smtpd_access_policy') {
      mylog('info', 'request = %s != smtpd_access_policy', $attrs{request});
      $answer = "DUNNO";
    } elsif($attrs{protocol_state} ne 'RCPT') {
      mylog('info', 'protocol_state = %s != RCPT', $attrs{protocol_state});
      $answer = "DUNNO";
     } elsif ($maxload > 0 && (my $load = &system_load()) > $maxload) {
       mylog('info', 'system load [%.2f] is too high', $load);
       $answer = "450 system is busy, please try again later";
    } else {
      ($attrs{sender_domain} = $attrs{sender}) =~ s/^.*\@//g;
      $answer = policy(\%attrs);
    }

    chomp($answer);
    mylog('debug', 'action=%s', $answer);
    printf("action=%s\n\n", $answer);
    %attrs = ();
    next;
  }
  my($k,$v) = split(/=/,$_,2);
  $attrs{$k} = $v;
  mylog('debug', 'attr %s=%s', $k, $v);
}
close_db();
mylog('info', 'terminating (EOF)');

sub mylog {
  my $level = shift;
  if($level eq 'debug' && $debug) {
    $level = 'info';
  }
  if($level ne 'debug') {
    syslog($level, @_);
  }
}

sub has_A_or_MX {
  my $fqdn = shift;

  my $q = $res->send($fqdn,'A');
  return undef unless $q;
  foreach my $rr ($q->answer) {
    mylog('debug','has_A_or_MX (A): %s RR %s', $fqdn, $rr->type);
    if($rr->type eq 'A') {
       return 1;
    }
  }
  $q = $res->send($fqdn,'MX');
  return undef unless $q;
  foreach my $rr ($q->answer) {
    mylog('debug','has_A_or_MX (MX): %s RR %s', $fqdn, $rr->type);
    if($rr->type eq 'MX') {
      return 1;
    }
  }
  return 0;
}

sub check_rbl {
  my $rbl = shift;
  my $ipaddr = shift;

  my $revaddr = join('.',reverse(split(/\./,$ipaddr))) . '.' . $rbl;

  my $q = $res->send($revaddr, 'A');
  #mylog('debug', 'check_rbl %s', $revaddr);
  return undef unless $q;
  foreach my $rr ($q->answer) {
    if($rr->type eq 'A') {
      return 1;
    }
  }
  return 0;
}

sub check_rbls {
  my $rbls = shift;
  my $ipaddr = shift;

  foreach my $rbl (@$rbls) {
    if(check_rbl($rbl, $ipaddr)) {
      return $rbl;
    }
  }
  return undef;
}

sub get_status {
  my($sth, @r);

  my $x = $dbh->selectall_arrayref("SELECT * FROM forwarders
              WHERE hostname = ?", {}, $attrs{client_name});
  if (@$x) {
    mylog('debug', '%s is forwarder', $attrs{client_name});
    return 'OK';
  }

  $sth = $dbh->prepare_cached("SELECT status, expire FROM greylist
                                 WHERE client = ? AND helo = ?
                                 AND sender = ?");
  $sth->execute($attrs{client_address}, $attrs{helo_name},
		$attrs{sender_domain});
  if (@r = $sth->fetchrow_array) {
    if ($r[0] eq 'W') {
      $dbh->do("UPDATE greylist SET expire = ?, count = count + 1
                  WHERE client = ? AND helo = ? AND sender = ?", {},
	       time() + $whitelist_expiry * 86400,
	       $attrs{client_address}, $attrs{helo_name},
	       $attrs{sender_domain});
      mylog('info', '%s:%s:%s is whitelisted', $attrs{client_address},
	    $attrs{helo_name}, $attrs{sender_domain});
      return 'W';
    } elsif ($r[0] eq 'G') {
      if ($r[1] >= time()) {
	mylog('info', '%s:%s:%s is greylisted', $attrs{client_address},
	      $attrs{helo_name}, $attrs{sender_domain});
	return 'G';
      } else {
	mylog('info', '%s:%s:%s changing to whitelisted',
	      $attrs{client_address},	$attrs{helo_name},
	      $attrs{sender_domain});
	set_whitelisted();
	return 'W';
      }
    } else {
      mylog('err', 'impossible status row: %s', $r[0]);
      return 'W';
    }
  } else {
    mylog('debug', '%s:%s:%s is not in DB', $attrs{client_address},
	  $attrs{helo_name}, $attrs{sender_domain});
    return 'U';
  }
}

sub set_whitelisted {

  my $x = $dbh->selectall_arrayref("SELECT * FROM greylist WHERE
              client = ? AND helo = ? AND sender = ?", {},
				   $attrs{client_address},
				   $attrs{helo_name},
				   $attrs{sender_domain});
  if (@$x) {
    $dbh->do("UPDATE greylist SET status = 'W', expire = ?, count = 1
              WHERE client = ? AND helo = ? AND sender = ?", {},
	     time() + $whitelist_expiry * 86400,
	     $attrs{client_address}, $attrs{helo_name},
	     $attrs{sender_domain});
  } else {
    $dbh->do("INSERT INTO greylist (client, helo, sender, status, expire,
                count) VALUES(?,?,?,'W',?,1)", {},
	     $attrs{client_address}, $attrs{helo_name}, $attrs{sender_domain},
	     time() + $whitelist_expiry * 86400);
    mylog('info', '%s:%s:%s set to whitelisted', $attrs{client_address},
	  $attrs{helo_name}, $attrs{sender_domain});
  }
}


sub set_greylisted {
  my $duration = shift;

  unless(defined $duration) {
    $duration = $greylist_time;
  }

  $dbh->do("INSERT INTO greylist (client, helo, sender, status, expire, count)
              VALUES(?,?,?,'G',?,0)", {},
	   $attrs{client_address}, $attrs{helo_name},
	   $attrs{sender_domain}, time() + $duration * 60);
  mylog('info', '%s:%s:%s set to greylisted (%d)', $attrs{client_address},
	$attrs{helo_name}, $attrs{sender_domain}, $duration);
}

sub open_db {
  unless(open($lock_db_fh, ">>$greylist_db")) {
    mylog('err', 'open %s: %s', $greylist_db, $!);
    exit(4);
  }
  lock_db();
  ## at least debian has SQLite (v2 in woody, v3 in sarge),
  ## and SQLite2 (v2 in sarge)... prefer v2 for backward compatiblity
  unless(($dbh = DBI->connect("dbi:SQLite2:dbname=$greylist_db",'','',
			      { RaiseError => 0,
				PrintError => 0,
				AutoCommit => 1})) ||
	 ($dbh = DBI->connect("dbi:SQLite:dbname=$greylist_db",'','',
			      { RaiseError => 0,
				PrintError => 0,
				AutoCommit => 1}))) {
    mylog("error connecting to DB %s", $greylist_db);
    exit 1;
  }
  $dbh->{RaiseError} = 1;
  $dbh->{HandleError} = \&log_db_error;
  $dbh->{ShowErrorStatement} = 1;
  eval {
    $dbh->do("select client, helo, sender, status, expire, count
                      from greylist where expire = 0");
  };
  if ($@) {
    eval {
      $dbh->do("create table greylist (
                       client text,
                       helo text,
                       sender text,
                       status text,
                       expire integer,
                       count integer)");
      $dbh->do("create unique index greylist_main
                       on greylist(client, helo, sender)");
      $dbh->do("create index greylist_time
                       on greylist(expire)");
      mylog('info', 'initialized DB %s', $greylist_db);
    };
    if ($@) {
      mylog('err', "error creating DB: %s", $@);
      exit 2;
    }
  }

  eval {
    $dbh->do("select hostname from forwarders");
  };
  if ($@) {
    eval {
      $dbh->do("create table forwarders (
                hostname text primary key)");
      mylog('info', 'created table forwarders');
    };
    if($@) {
      mylog('err', 'error creating table forwarders');
      exit 3;
    }
  }
  ## maybe we should expire the DB?
  ## since there's no central coordination between processes, we'll just
  ## do it randomly...
  if(rand() < $expiry_chance) {
    my $del_w =
      $dbh->do("delete from greylist where status = 'W' and expire < ?",
	       {}, time());
    my $del_g =
      $dbh->do("delete from greylist where status = 'G' and expire < ?",
	       {}, time() - $greylist_expiry * 86400);
    mylog('info',
	  'expiring database: %d whitelisted, %d greylisted entries purged',
	  $del_w, $del_g);
  }
  unlock_db();
}

sub log_db_error {
  my $msg = shift;

  unless($msg =~ /database is locked/i) {
    mylog('err', 'DBI error: %s', $msg);
  }
  $dberr = $msg;
  return undef;
}

sub close_db {
  $dbh->disconnect();
}

sub lock_db {
  flock($lock_db_fh, LOCK_EX);
}

sub unlock_db {
  flock($lock_db_fh, LOCK_UN);
}

sub system_load {
  open LOAD, "< /proc/loadavg" || return 0.0;
  my ($load) = <LOAD> =~ /^\s*([\d\.]+)/;
  close LOAD;
  return $load;
}

__END__

#
# $Log: selective-greylist,v $
# Revision 1.4  2006/12/11 22:49:08  cm
# forgot "sub system_load"
#
# Revision 1.3  2006/11/20 16:27:52  cm
# debianized
#
# Revision 1.2  2006/11/14 16:50:59  cm
# rework
#
# Revision 1.1  2006/11/13 15:41:13  cm
# selective-greylist: moved, start of packaging
#
# Revision 1.2  2006/10/16 17:06:53  cm
# locking, retrying, etc to withstand big loads
#
# Revision 1.1  2006/10/16 16:14:43  cm
# initial
#
#

=pod

=head1 NAME

selective-greylist - gentle greylister for Postfix

=head1 SYNOPSIS

selective-greylist [options]

=head1 DESCRIPTION

selective-greylist is a greylisting service to be used with Postfix as
a policy delegation daemon.

If any one of the following conditions is met, the message is
greylisted; else, it is whitelisted.

=over

=item - Client doesn't have a valid reverse DNS entry

=item - HELO name is not an FQDN

=item - HELO name doesn't have an A or MX DNS entry

=item - Client is on a dialup DNSBL

=item - SPF status is neither "pass" nor "none"

=back

Clients whose hostname is listed in the 'forwarders' table are
whitelisted.

The tuple used to grey- and whitelist is I<(client IP address, HELO
name, sender domain)>.

=head1 OPTIONS

=over

=item B<-d dbfile>

Location of the sqlite database file. Will be created and populated if
it doesn't exist.

=item B<-D>

Enable logging of debug messages to syslog.

=item B<-e days>

Time after which to expire inactive greylisted entries (i.e. ones that
have never been promoted to whitelisted).

=item B<-E days>

Time after which to expire inactive whitelisted entries.

=item B<-g minutes>

Greylisting timeout, i.e. time after first contact until the message
is accepted.

=item B<-l loadavg>

Reject (with a temporary error code) all messages when system load
average is above the given value. Defaults to off.

=item B<-x float>

Probability that a process startup results in an expiry run.

=back


=head1 AUTHOR

Christian Mock <cm@tahina.priv.at>

=head1 COPYRIGHT

Copyright 2006 Christian Mock

This is free software. You may redistribute copies of it under the
terms of the GNU General Public License
<http://www.gnu.org/licenses/gpl.html>. There is NO WARRANTY, to the
extent permitted by law.

=head1 SEE ALSO

Postfix' SMTPD_POLICY_README.

=cut