#!/usr/bin/perl

use strict;

use DB_File;
use Fcntl;
use Sys::Syslog qw(:DEFAULT setlogsock);

#
# Usage: greylist.pl [-v]
#
# 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:
#
#    greylist  unix  -       n       n       -       -       spawn
#      user=mailnull argv=/usr/bin/perl /usr/libexec/postfix/greylist.pl
#
# To use this from Postfix SMTPD, use in /etc/postfix/main.cf:
#
#    smtpd_restriction_classes =
#        greylist, greylist_rcpt, greylist_mail, greylist_relay, greylist_relay_ptr, greylist_final
#    
#    greylist		= greylist_rcpt
#    greylist_rcpt	= check_recipient_access	hash:/etc/postfix/maps/greylist_rcpt
#    greylist_mail	= check_sender_access		pcre:/etc/postfix/maps/greylist_mail.pcre
#    greylist_relay	= check_client_access		cidr:/etc/postfix/maps/greylist_relay.cidr
#    greylist_relay_ptr	= check_client_access		pcre:/etc/postfix/maps/greylist_relay.pcre
#    greylist_final	= check_policy_service		unix:private/greylist
#
#    smtpd_recipient_restrictions =
#        permit_sasl_authenticated,
#        permit_mynetworks,
#        ...
#        reject_unauth_destination,
#        greylist
#
# NOTE: specify check_policy_service AFTER reject_unauth_destination
# or else your system can become an open relay.
#
# Greylisted recipients described in /etc/postfix/maps/greylist_rcpt:
#
#    postmaster@domain.tld                                      DUNNO
#    abuse@domain.tld                                           DUNNO
#    domain.tld                                                 greylist_mail
#
# Greylisted senders described in /etc/postfix/maps/greylist_mail.pcre:
#
#    /\@returns.groups.yahoo.com$/				DUNNO
#    /^owner-freebsd\@osdn\.org\.ua$/				DUNNO
#    /^gluck\@subscribe\.ru$/					DUNNO
#    /^listserv\@security\.nnov\.ru$/				DUNNO
#    /^owner-drweb-unix\@drweb\.ru$/				DUNNO
#    /^owner-freebsd-security-notifications\@freebsd\.org$/     DUNNO
#    /^spamassassin-talk-admin\@lists\.sourceforge\.net$/	DUNNO
#    /^dovecot-bounces\@procontrol\.fi$/			DUNNO
#
#    /\@domain\.tld$/						DUNNO
#    /\@another\.domain\.tld$/					DUNNO
#
#    /^$/							DUNNO
#    /^<>$/							DUNNO
#    /^postmaster\@$/						DUNNO
#
#    /./							greylist_relay
#
# Greylisted relays described in /etc/postfix/maps/greylist_relay.cidr:
#
#    10.0.0.0/8                                                 DUNNO
#    192.168.0.0/16                                             DUNNO
#    172.16.0.0/16                                              DUNNO
#    0.0.0.0/0                                                  greylist_relay_ptr
#
# Also greylisted relays described in /etc/postfix/maps/greylist_relay.pcre:
#
#    /\.one\.domain\.zone$/                                     DUNNO
#    /\.another\.domain\.zone$/                                 DUNNO
#    /./                                                        greylist_final
#
# Excluded triplets of relay address, sender address and recipient address described in
# /etc/postfix/maps/greylist_skip:
#
#    1.2.3.4|foo@bar.domain.tld|bar@foo.domain.tld		SKIP
#
# 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
#    ccert_issuer=
#    ccert_fingerprint=
#    ccert_subject=
#    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]
#

# путь к DBM файлу кеша
my($confGREYLIST_DBM_CACHE) = '/var/spool/postfix/policy/greylist.db';
# путь к DBM файлу исключений
my($confGREYLIST_DBM_SKIP) = '/etc/postfix/maps/greylist_skip.db';
# режим работы серого списка
# LEARN            - принимаем все сообщения, производится лишь обучение кеша,
#                    если запись в "сером" списке не найдена, создаем ее
# BLOCK_FIRST_ONLY - первое сообщение задерживается, остальные пропускаются, 
#                    если запись в "сером" списке не найдена, создаем ее
# NORMAL           - штатный режим работы "серого" списка
my($confGREYLIST_DBM_MODE) = 'LEARN';
my($confGREYLIST_DBM_MODE) = 'BLOCK_FIRST_ONLY';
my($confGREYLIST_DBM_MODE) = 'NORMAL';
# время блокировки записи в "сером списке" в минутах
my($confGREYLIST_DBM_BLOCKED) = 55;
# минимальное время жизни записи в "сером списке" в минутах
my($confGREYLIST_DBM_RECORD_EXPIRE_MIN) = 300;
# время жизни записи в "сером списке" в днях
my($confGREYLIST_DBM_RECORD_EXPIRE) = 36;
# сообщение, возвращаемое клиенту при задержке почтового сообщения
my($confGREYLIST_MESSAGE) = 'Message delayed as part of spam avoidance measure';
my($confGREYLIST_MESSAGE) = 'System too busy. Please try again later';
my($confGREYLIST_MESSAGE) = 'Temporary local problem - please try later';
# исключение из проверки писем от postmaster
my($confGREYLIST_EXCLUDE_POSTMASTER) = 1;

my(
    $option, $verbose, %attr,
    $db_skip_obj, %db_skip_hash,
    $db_obj, %db_hash
);

#
# 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";

#
# Demo 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.
#
sub smtpd_access_policy {
    # Key for lookups
    my($key) = lc($attr{"client_address"}."|".$attr{"sender"}."|".$attr{"recipient"});

    # Open the database on the fly.
    open_db('skip') unless $db_skip_obj;

    my($skip) = ($db_skip_obj ? read_db($key, 'skip') : '');
    $skip = ($skip =~ /^(SKIP|OK)$/i ? 1 : 0);
    syslog($syslog_priority, "skip: '$skip'") if ($verbose);

    if ($skip) {
	return("DUNNO");
    } else {
	# Open the database on the fly.
	open_db('') unless $db_obj;

	unless ($db_obj) {
	    return("DUNNO");
	} else {
	# ищем запись а рилее/отправителе/получателе в "сером списке"
	    my($cached_record) = read_db($key, '');
	    my($block_expires, $record_expires, $blocked_count, $passed_count,
	        $aborted_count, $origin_type, $create_time, $last_update) =
	        ($cached_record =~
	        /block_expires=(\d+) record_expires=(\d+) blocked_count=(\d+) passed_count=(\d+) aborted_count=(\d+) origin_type=(\S+) create_time=(\d+) last_update=(\d+)/);
	    my($now) = time();

	    if ($confGREYLIST_DBM_MODE eq 'NORMAL') {
	    # штатный режим работы серого списка
		syslog($syslog_priority, "normal mode") if ($verbose);
	    } elsif ($confGREYLIST_DBM_MODE eq 'LEARN') {
	    # принимаем все сообщения, производится лишь обучение кеша
		syslog($syslog_priority, "learn mode") if ($verbose);
	    } elsif ($confGREYLIST_DBM_MODE eq 'BLOCK_FIRST_ONLY') {
	    # первое сообщение задерживается, остальные пропускаются
		syslog($syslog_priority, "block first only mode") if ($verbose);
	    }

	    if (!$cached_record or !$last_update or ($record_expires < $now)) {
	    # если запись в "сером списке" не найдена или не отпарсена или истек record_expires, создаем запись в кеше
		syslog($syslog_priority, "cached record not found") if ($verbose);
		$cached_record = sprintf("block_expires=%d record_expires=%d".
		    " blocked_count=1 passed_count=0 aborted_count=0 origin_type=AUTO".
		    " create_time=%d last_update=%d",
		    $now+$confGREYLIST_DBM_BLOCKED*60,
		    $now+$confGREYLIST_DBM_RECORD_EXPIRE_MIN*60,
		    $now,
		    $now
		);
		update_db($key, $cached_record);
		if ($confGREYLIST_DBM_MODE eq 'LEARN') {
		    return("DUNNO");
		} else {
		    return("DEFER_IF_PERMIT ".$confGREYLIST_MESSAGE);
		}
	    } else {
		if (($block_expires > $now) and ($confGREYLIST_DBM_MODE ne 'BLOCK_FIRST_ONLY')) {
		# если запись в "сером списке" найдена, но не истек block_expires,
		# и это не режим блокирования только первого письма
		    if ($verbose) {
		        if ($confGREYLIST_DBM_MODE ne 'BLOCK_FIRST_ONLY') {
			    syslog($syslog_priority, "cached record found, but block_expires not riched");
			} else {
		    	    syslog($syslog_priority, "cached record found, non first message passed");
			}
		    }
		    $cached_record = sprintf("block_expires=%d record_expires=%d".
			" blocked_count=%d passed_count=%d aborted_count=%d origin_type=%s".
		        " create_time=%d last_update=%d",
		        $block_expires,
		        $record_expires,
		        $blocked_count+1,
		        $passed_count,
		        $aborted_count,
		        $origin_type,
		        $create_time,
		        $now
		    );
		    update_db($key, $cached_record);
		    if ($confGREYLIST_DBM_MODE eq 'LEARN') {
		        return("DUNNO");
		    } else {
			return("DEFER_IF_PERMIT ".$confGREYLIST_MESSAGE);
		    }
		} else {
		# если запись в "сером списке" найдена, block_expires истек, а record_expires не истек
		    syslog($syslog_priority, "cached record found, block_expires riched and record_expires not reached") if ($verbose);
		    $cached_record = sprintf("block_expires=%d record_expires=%d".
		        " blocked_count=%d passed_count=%d aborted_count=%d origin_type=%s".
			" create_time=%d last_update=%d",
		        $block_expires,
			$now+$confGREYLIST_DBM_RECORD_EXPIRE*24*60*60,
			$blocked_count,
			$passed_count+1,
			$aborted_count,
			$origin_type,
		        $create_time,
			$now
		    );
		    update_db($key, $cached_record);
		    return("DUNNO");
		}
	    }
	}
    }
    return("DUNNO");
}

#
# You should not have to make changes below this point.
#
sub LOCK_SH { 1 };	# Shared lock (used for reading).
sub LOCK_EX { 2 };	# Exclusive lock (used for writing).
sub LOCK_NB { 4 };	# Don't block (for testing).
sub LOCK_UN { 8 };	# Release lock.

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

#
# Open hash database.
#
sub open_db {
    my($flag) = @_;
    my($db_fd);

    if ($flag eq 'skip') {
	# Use tied database to make complex manipulations easier to express.
	unless ($db_skip_obj = tie(%db_hash, 'DB_File', $confGREYLIST_DBM_SKIP, 0, 0444)) {
	    fatal_exit("Cannot open database %s: $!", $confGREYLIST_DBM_SKIP);
	} else {
	    $db_fd = $db_skip_obj->fd;
	    unless (open(DB_SKIP_HANDLE, "+<&=$db_fd")) {
		fatal_exit("Cannot fdopen database %s: $!", $confGREYLIST_DBM_SKIP);
	    } else {
		syslog($syslog_priority, "open %s", $confGREYLIST_DBM_SKIP) if ($verbose);
	    }
	}
    } else {
	# Use tied database to make complex manipulations easier to express.
	unless ($db_obj = tie(%db_hash, 'DB_File', $confGREYLIST_DBM_CACHE, O_CREAT|O_RDWR, 0644)) {
	    fatal_exit("Cannot open database %s: $!", $confGREYLIST_DBM_CACHE);
	} else {
	    $db_fd = $db_obj->fd;
	    unless (open(DB_HANDLE, "+<&=$db_fd")) {
		fatal_exit("Cannot fdopen database %s: $!", $confGREYLIST_DBM_CACHE);
	    } else {
		syslog($syslog_priority, "open %s", $confGREYLIST_DBM_CACHE) if ($verbose);
	    }
	}
    }
}

#
# Read database. Use a shared lock to avoid reading the database
# while it is being changed. XXX There should be a way to synchronize
# our cache from the on-file database before looking up the key.
#
sub read_db {
    my($key, $flag) = @_;
    my($value);

    if ($flag eq 'skip') {
	unless (flock(DB_SKIP_HANDLE, LOCK_SH)) {
	    fatal_exit("Can't get shared lock on '%s': $!", $confGREYLIST_DBM_SKIP);
	} else {
	    # XXX Synchronize our cache from the on-disk copy before lookup.
	    $value = $db_skip_hash{$key};
	    syslog($syslog_priority, "lookup '%s': '%s'", $key, $value) if ($verbose);
	    unless (flock(DB_SKIP_HANDLE, LOCK_UN)) {
		fatal_exit("Can't unlock '%s': $!", $confGREYLIST_DBM_SKIP);
	    }
	    return($value);
	}
    } else {
	unless (flock(DB_HANDLE, LOCK_SH)) {
	    fatal_exit("Can't get shared lock on '%s': $!", $confGREYLIST_DBM_CACHE);
	} else {
	    # XXX Synchronize our cache from the on-disk copy before lookup.
	    $value = $db_hash{$key};
	    syslog($syslog_priority, "lookup %s: %s", $key, $value) if ($verbose);
	    unless (flock(DB_HANDLE, LOCK_UN)) {
		fatal_exit("Can't unlock '%s': $!", $confGREYLIST_DBM_CACHE);
	    }
	    return($value);
	}
    }
    return('');
}

#
# Update database. Use an exclusive lock to avoid collisions with
# other updaters, and to avoid surprises in database readers. XXX
# There should be a way to synchronize our cache from the on-file
# database before updating the database.
#
sub update_db {
    my($key, $value) = @_;

    syslog($syslog_priority, "store '%s': '%s'", $key, $value) if ($verbose);
    unless (flock(DB_HANDLE, LOCK_EX)) {
	fatal_exit("Can't exclusively lock '%s': $!", $confGREYLIST_DBM_CACHE);
    } else {
	# XXX Synchronize our cache from the on-disk copy before update.
	$db_hash{$key} = $value;
        if ($db_obj->sync()) {
	    fatal_exit("Can't update '%s': $!", $confGREYLIST_DBM_CACHE);
	} else {
	    unless (flock(DB_HANDLE, LOCK_UN)) {
		fatal_exit("Can't unlock %s: $!", $confGREYLIST_DBM_CACHE);
	    }
	}
    }
}

#
# 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 = $confGREYLIST_DBM_CACHE . "." . time();

    rename $confGREYLIST_DBM_CACHE, $backup || 
	fatal_exit "Can't save %s as %s: $!", $confGREYLIST_DBM_CACHE, $backup;
    fatal_exit "Caught signal 11; the corrupted database is saved as $backup";
}

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

#
# 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;

#
# We don't need getopt() for now.
#
while ($option = shift(@ARGV)) {
    if ($option eq "-v") {
	$verbose = 1;
    } else {
	syslog $syslog_priority, "Invalid option: %s. Usage: %s [-v]",
		$option, $0;
	exit 1;
    }
}

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

#
# Receive a bunch of attributes, evaluate the policy, send the result.
#
while (<STDIN>) {
    if (/([^=]+)=(.*)\n/) {
	$attr{substr($1, 0, 512)} = substr($2, 0, 512);
    } elsif ($_ eq "\n") {
	if ($verbose) {
	    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);
	print STDOUT "action=$action\n\n";
	%attr = ();
    } else {
	chop;
	syslog $syslog_priority, "warning: ignoring garbage: %.100s", $_;
    }
}
