#!/usr/bin/perl -w
#
# Usage: greylist.pl [-v]
#
# Demo delegated Postfix SMTPD policy server. This server implements
# greylisting. State is kept in a Berkeley DB database.  Logging is
# sent to syslogd.
#
# How it works: each time a Postfix SMTP server process is started
# it connects to the policy service socket, and Postfix runs one
# instance of this PERL script.  By default, a Postfix SMTP server
# process terminates after 100 seconds of idle time, or after serving
# 100 clients. Thus, the cost of starting this PERL script is smoothed
# out over time.
#
# To run this from /etc/postfix/master.cf:
#
#    policy  unix  -       n       n       -       -       spawn
#      user=nobody argv=/usr/bin/perl /usr/libexec/postfix/greylist.pl
#
# To use this from Postfix SMTPD, use in /etc/postfix/main.cf:
#
#    smtpd_recipient_restrictions =
#	...
#	reject_unauth_destination
#	check_policy_service unix:private/policy
#	...
#
# NOTE: specify check_policy_service AFTER reject_unauth_destination
# or else your system can become an open relay.
#
# To test this script by hand, execute:
#
#    % perl greylist.pl
#
# Each query is a bunch of attributes. Order does not matter, and
# the demo script uses only a few of all the attributes shown below:
#
#    request=smtpd_access_policy
#    protocol_state=RCPT
#    protocol_name=SMTP
#    helo_name=some.domain.tld
#    queue_id=8045F2AB23
#    sender=foo@bar.tld
#    recipient=bar@foo.tld
#    client_address=1.2.3.4
#    client_name=another.domain.tld
#    instance=123.456.7
#    sasl_method=plain
#    sasl_username=you
#    sasl_sender=
#    size=12345
#    [empty line]
#
# The policy server script will answer in the same style, with an
# attribute list followed by a empty line:
#
#    action=dunno
#    [empty line]
#
# In case of database corruption, this script saves the database as
# $database_name.time(), so that the mail system does not get stuck.
#

use strict;
use DB_File::Lock;
use Fcntl qw(:flock O_RDWR O_CREAT);
use Sys::Syslog qw(:DEFAULT setlogsock);
use Getopt::Long;

#
# configuration data
#
# greylist status database and greylist time interval. DO NOT create the
# greylist status database in a world-writable directory such as /tmp
# or /var/tmp. DO NOT create the greylist database in a file system
# that can run out of space.
my $database_name = '/var/mta/greylist.db';
my $greylist_delay = 300;
# domains not to be greylisted 
my $nogreylist_name = '/etc/postfix/nogreylist';

#
# Syslogging options for verbose mode and for fatal errors.
# NOTE: comment out the $syslog_socktype line if syslogging does not
# work on your system.
#
my $syslog_socktype = 'unix'; # inet, unix, stream, console
my $syslog_facility = 'mail';
my $syslog_options  = 'pid';
my $syslog_priority = 'info';

#
# Other global variables
#
my $verbose = 0;
my $whitelist = '';
my %attr = ();

# 
# Procedures
#

#
# Log an error and abort.
#
sub fatal_exit {
    my $first = shift @_;
    syslog "err", "fatal: $first", @_;
    exit 1;
}

#
#
# Signal 11 means that we have some kind of database corruption (yes
# Berkeley DB should handle this better).  Move the corrupted database
# out of the way, and start with a new database.
#
sub sigsegv_handler {
    my $backup = $database_name . "." . time();
    rename $database_name, $backup || 
	fatal_exit "Can't save %s as %s: $!", $database_name, $backup;
    fatal_exit "Caught signal 11; the corrupted database is saved as $backup";
}

$SIG{'SEGV'} = 'sigsegv_handler';

# SMTPD access policy routine. The result is an action just like
# it would be specified on the right-hand side of a Postfix access
# table.  Request attributes are available via the %attr hash.
#
# The result can be any action that is allowed in a Postfix access(5) map.
#
# To label mail, return ``PREPEND'' headername: headertext
#
# In case of success, return ``DUNNO'' instead of ``OK'' so that the
# check_policy_service restriction can be followed by other restrictions.
#
# In case of failure, specify ``DEFER_IF_PERMIT optional text...''
# so that mail can still be blocked by other access restrictions.
#
sub smtpd_access_policy() {
  my($key, $value, $ctime, $atime, $now, $age, %db);
  my $count = 0;
  # Check if the sender isn't greylist-exempted
  $key = lc
      join('/', $attr{'client_address'}, $attr{'sender'}, $attr{'recipient'});
  if($key =~ m/($whitelist)/o) {
    syslog $syslog_priority, "whitelisted: %s as %s", $key, $1
      if $verbose;
  } else {
    # DB_File::Lock provides write-locking for the database
    tie %db, 'DB_File::Lock', $database_name,
      O_CREAT|O_RDWR, 0644, $DB_BTREE, 'write' or
      fatal_exit "Cannot open database %s: $!", $database_name;
    syslog $syslog_priority, "open %s", $database_name if $verbose>2;

    # Lookup this client/sender/recipient
    $value = defined $db{$key} ? $db{$key} : '0/0/0';
    syslog $syslog_priority, "lookup %s: %s", $key, $value if $verbose>1;
    ($ctime,$atime,$count) = split '/', $value;
    $now = time();
    if ($ctime == 0) {
      # If this is a new request add client/sender/recipient to the database.
      $ctime = $now;
      $count = $atime = 0;
    } else {
      # Update last access time and count
      $atime = $now;
      $count++;
    }
    $value = "$ctime/$atime/$count";
    # Update database. Use an exclusive lock to avoid collisions with
    # other updaters, and to avoid surprises in database readers. 
    $db{$key} = $value;
    # end of critical section - close & unlock the database
    untie %db;

    $age = $now - $ctime;

    syslog $syslog_priority, "%s: %s, age %d, count %d",
      $key, $value, $age, $count if $verbose;

    # return DEFER_IF_PERMIT if greylisted
    return "defer_if_permit Service is temporarily unavailable"
      if $age < $greylist_delay;
  }
  # in any other case return DUNNO
  return "dunno";
}


#
# Main program
#

#
# This process runs as a daemon, so it can't log to a terminal. Use
# syslog so that people can actually see our messages.
#
setlogsock $syslog_socktype;
openlog $0, $syslog_options, $syslog_facility;

unless(GetOptions('v:+' => \$verbose)) {
  syslog $syslog_priority, "Invalid option. Usage: %s [-v] [-v] ...", $0;
  exit 1;
}

#
# Unbuffer standard output.
#
select((select(STDOUT), $| = 1)[0]);

#
# Read and compile the whitelist 
#
if(-f $nogreylist_name) {
  open WH, $nogreylist_name or
    fatal_exit "Cannot open whitelist %s: $!", $nogreylist_name;
  # comments begin with # in column 1
  $whitelist = join '|', map { chomp; m/^([^#].+)/ ? $1 : () } <WH>;
  close WH;
}
syslog $syslog_priority, "Whitelist: %s", $whitelist if $verbose>2;

#
# Receive a bunch of attributes, evaluate the policy, send the result.
#
while (<STDIN>) {
  chomp;
  if (/^([^=]+)=(.*)$/) {
    $attr{substr($1, 0, 512)} = substr($2, 0, 512);
  } elsif ($_ eq '') {
    if ($verbose>2) {
      for (keys %attr) {
	syslog $syslog_priority, "Attribute: %s=%s", $_, $attr{$_};
      }
    }
    fatal_exit "unrecognized request type: '%s'", $attr{'request'}
      unless $attr{'request'} eq 'smtpd_access_policy';
    my $action = smtpd_access_policy();
    syslog $syslog_priority, "Action: %s", $action if $verbose>1;
    print STDOUT "action=$action\n\n";
    %attr = ();
  } else {
    syslog $syslog_priority, "warning: ignoring garbage: %.100s", $_;
  }
}

exit 0;
# ;-)