postgate

#!/usr/bin/perl -T -w

###
### postgate, based on postgrey
###

push @INC, "/usr/local/lib/perl5/site_perl/5.12.3/i486-linux-thread-multi";


package postgate;
use strict;
use Pod::Usage;
use Getopt::Long 2.25 qw(:config posix_default no_ignore_case);
use Net::Server; # used only to find out which version we use
use Net::Server::Multiplex;
use Fcntl ':flock'; # import LOCK_* constants
use Sys::Hostname;
use Sys::Syslog; # used only to find out which version we use
use POSIX qw(strftime setlocale LC_ALL);
use DBI;

use vars qw(@ISA);
@ISA = qw(Net::Server::Multiplex);

my $VERSION = '0.2';
my $DEFAULT_DBDIR = '/var/spool/postfix/postgate';
my $CONFIG_DIR = '/etc/postfix';

my %COUNTER = ();

my $dbh;
my $table_quota = "`quota`";
my $table_stat = "`stat`";


sub read_sender_whitelists($)
{
    my ($self) = @_;

    my @whitelist_senders = ();
    for my $f (@{$self->{postgate}{whitelist_senders_files}}) {
        if(open(SENDERS, $f)) {
            while(<SENDERS>) {
                s/#.*$//; s/^\s+//; s/\s+$//; next if $_ eq '';
                my ($user, $domain) = split(/\@/, $_, 2);
                if(/^\/(\S+)\/$/) {
                    # regular expression
                    push @whitelist_senders, qr{$1}i;
                }
                elsif(!/^\S+$/) {
                    warn "$f line $.: doesn't look like an address\n";
                }
                # postfix access(5) syntax:
                elsif(defined $domain and $domain ne '') {
                    # user@domain (match also user+extension@domain)
                    push @whitelist_senders, qr{^\Q$user\E(?:\+[^@]+)?\@\Q$domain\E$}i;
                }
                elsif(defined $domain) {
                    # user@
                    push @whitelist_senders, qr{^\Q$user\E(?:\+[^@]+)?\@}i;
                }
                else {
                    # domain ($user is the domain)
                    push @whitelist_senders, qr{(?:\@|\.)\Q$user\E$}i;
                }
            }
        }
        else {
            # do not warn about .local file: maybe the user just doesn't have one
            warn "can't open $f: $!\n" unless $f =~ /\.local$/;
        }
        close(SENDERS);
    }
    $self->{postgate}{whitelist_senders} = \@whitelist_senders;
}


sub read_sender_blacklists($)
{
    my ($self) = @_;

    my @blacklist_senders = ();
    for my $f (@{$self->{postgate}{blacklist_senders_files}}) {
        if(open(SENDERS, $f)) {
            while(<SENDERS>) {
                s/#.*$//; s/^\s+//; s/\s+$//; next if $_ eq '';
                my ($user, $domain) = split(/\@/, $_, 2);
                if(/^\/(\S+)\/$/) {
                    # regular expression
                    push @blacklist_senders, qr{$1}i;
                }
                elsif(!/^\S+$/) {
                    warn "$f line $.: doesn't look like an address\n";
                }
                # postfix access(5) syntax:
                elsif(defined $domain and $domain ne '') {
                    # user@domain (match also user+extension@domain)
                    push @blacklist_senders, qr{^\Q$user\E(?:\+[^@]+)?\@\Q$domain\E$}i;
                }
                elsif(defined $domain) {
                    # user@
                    push @blacklist_senders, qr{^\Q$user\E(?:\+[^@]+)?\@}i;
                }
                else {
                    # domain ($user is the domain)
                    push @blacklist_senders, qr{(?:\@|\.)\Q$user\E$}i;
                }
            }
        }
        else {
            # do not warn about .local file: maybe the user just doesn't have one
            warn "can't open $f: $!\n" unless $f =~ /\.local$/;
        }
        close(SENDERS);
    }

    $self->{postgate}{blacklist_senders} = \@blacklist_senders;
}

sub mylog($$$)
{
    my ($self, $level, $string) = @_;
    $string =~ s/\%/%%/g; # for Net::Server <= 0.87
    if(!defined $Sys::Syslog::VERSION or $Sys::Syslog::VERSION lt '0.15'
    or !defined $Net::Server::VERSION or $Net::Server::VERSION lt '0.94') {
        # Workaround for a crash when syslog daemon is temporarily not
        # present (for example on syslog rotation).
        # Note that this is not necessary with Sys::Syslog >= 0.15 and
        # Net::Server >= 0.94 thanks to the nofatal Option.
        eval {
            local $SIG{"__DIE__"} = sub { };
            $self->log($level, $string);
        };
    }
    else {
        $self->log($level, $string);
    }
}

sub mylog_action($$$;$$)
{
    my ($self, $attr, $action, $reason, $additional_info) = @_;

    my @info = ("action=$action");
    push @info, "reason=$reason" if defined $reason;
    push @info, $additional_info if defined $additional_info;
    for my $a (qw(client_address sender recipient)) {
        push @info, "$a=$attr->{$a}" if $attr->{$a};
    }

    my $str = join(', ', @info);
    $self->mylog(2, $str);
}

sub do_maintenance($$)
{
    my ($self, $now) = @_;
    my $db     = $self->{postgate}{db};
    my $db_env = $self->{postgate}{db_env};

    my $total = 0;

    my $sth = $dbh->prepare("INSERT INTO $table_quota (email, ts, n) VALUES(?,?,?)");

    foreach my $x (keys %COUNTER) {
       if($x ne "" && $COUNTER{$x} > 0) {
          $sth->execute($x, $now, $COUNTER{$x});
          $total += $COUNTER{$x};
       }
    }

    $sth->finish;

    if($total > 0) {
       my $sth = $dbh->prepare("INSERT INTO $table_stat (ts, n) VALUES(?,?)");
       $sth->execute($now, $total);
       $sth->finish;
    }

    %COUNTER = ();

    $self->mylog(1, "doing maintenance...");
}

sub is_new_instance($$)
{
    my ($self, $inst) = @_;
    return 1 if not defined $inst; # in case the 'instance' parameter
                                   # was not supplied by the client (Exim)

    # we keep a list of the last 20 "instances", which identify unique messages
    # so that for example we only put one X-Greylist header per message.
    $self->{postgate}{instances} = [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ]
        unless defined $self->{postgate}{instances};

    my $i = $self->{postgate}{instances};
    return 0 if scalar grep { $_ eq $inst } @$i;

    # put new value into the array
    unshift @$i, $inst;
    pop @$i;

    return 1;
}


# main routine: based on attributes specified as argument, return policy decision
sub smtpd_access_policy($$)
{
    my ($self, $now, $attr) = @_;
    my $db = $self->{postgate}{db};
    my $sender = '';

    if($attr->{sasl_sender} ne "") {
       $sender = $attr->{sasl_sender};
    } elsif($attr->{sasl_username} ne "") {
       $sender = $attr->{sasl_username};
    } else {
       $sender = $attr->{sender};
    }

    $COUNTER{$sender}++;

    for my $w (@{$self->{postgate}{whitelist_senders}}) {
        if($attr->{sender} =~ $w) {
            $self->mylog_action($attr, 'passed', 'sender whitelist, user/limit=' . $COUNTER{$sender} . "/" . $self->{postgate}{hourly_limit});
            return 'DUNNO';
        }
    }

    for my $w (@{$self->{postgate}{blacklist_senders}}) {
        if($attr->{sender} =~ $w) {
            $self->mylog_action($attr, 'discard', 'sender blacklist, user/limit=' . $COUNTER{$sender} . "/" . $self->{postgate}{hourly_limit});
            return 'DISCARD';
        }
    }


    if($COUNTER{$sender} > $self->{postgate}{hourly_limit}) {
       $self->mylog_action($attr, 'ALERT', $COUNTER{$sender} . "/" . $self->{postgate}{hourly_limit});
       return 'DISCARD';
    }

    $self->mylog_action($attr, 'pass', $COUNTER{$sender} . "/" . $self->{postgate}{hourly_limit});

    return 'DUNNO';
}

sub main()
{
    # save arguments for Net:Server HUP restart
    my @ARGV_saved = @ARGV;

    # do not output any localized texts!
    setlocale(LC_ALL, 'C');

    # parse options
    my %opt = ();
    GetOptions(\%opt, 'help|h', 'man', 'version', 'noaction|no-action|n',
        'verbose|v', 'quiet|q', 'daemonize|d', 'unix|u=s', 'inet|i=s',
        'user=s', 'group=s', 'dbdir=s', 'pidfile=s', 'delay=i', 'max-age=i',
        'lookup-by-subnet', 'lookup-by-host', 'auto-whitelist-clients:s',
        'whitelist-clients=s@', 'whitelist-senders=s@',
        'syslogfacility|syslog-facility|facility=s',
        'retry-window=s', 'greylist-action=s', 'greylist-text=s', 'privacy',
        'hostname=s', 'exim', 'listen-queue-size=i', 'x-greylist-header=s',
    ) or exit(1);
    # note: lookup-by-subnet can be given for compatibility, but it is default
    # so do not do nothing with it...
    # note: auto-whitelist-clients:s and not auto-whitelist-clients:n so that
    # we can differentiate between --auto-whitelist-clients=0 and
    # auto-whitelist-clients

    if($opt{help})     { pod2usage(1) }
    if($opt{man})      { pod2usage(-exitstatus => 0, -verbose => 2) }
    if($opt{version})  { print "postgate $VERSION\n"; exit(0) }
    if($opt{noaction}) { die "ERROR: don't know how to \"no-action\".\n" }

    defined $opt{unix} or defined $opt{inet} or
        die "ERROR: --unix or --inet must be specified\n";

    # bind only localhost if no host is specified
    if(defined $opt{inet} and $opt{inet}=~/^\d+$/) {
        $opt{inet} = "localhost:$opt{inet}";
    }

    # retry window
    my $retry_window = 24*3600*2; # default: 2 days
    if(defined $opt{'retry-window'}) {
        if($opt{'retry-window'} =~ /^(\d+)h$/i) {
            $retry_window = $1 * 3600;
        }
        elsif($opt{'retry-window'} =~ /^\d+$/) {
            $retry_window = $opt{'retry-window'} * 24 * 3600;
        }
        else {
            die "ERROR: --retry-window must be either a number of days or a number\n",
                "       followed by 'h' for hours ('6h' for example).\n";
        }
    }

    # untaint what is given on --dbdir. It is not security sensitive since
    # it is provided by the admin
    if($opt{dbdir}) {
        $opt{dbdir} =~ /^(.*)$/; $opt{dbdir} = $1;
    }

    # determine proper "logsock" for Sys::Syslog
    my $syslog_logsock;
    if(defined $Sys::Syslog::VERSION and $Sys::Syslog::VERSION ge '0.15'
    and defined $Net::Server::VERSION and $Net::Server::VERSION ge '0.97') {
        # use 'native' when Sys::Syslog >= 0.15
        $syslog_logsock = 'native';
    }
    elsif($^O eq 'solaris') {
        # 'stream' is broken and 'unix' doesn't work on Solaris: only 'inet'
        # seems to be useable with Sys::Syslog < 0.15
        $syslog_logsock = 'inet';
    }
    else {
        $syslog_logsock = 'unix';
    }

    # Workaround: Net::Server doesn't allow for a value of 'listen' higher than 999
    if(defined $opt{'listen-queue-size'} and $opt{'listen-queue-size'} > 999) {
        $opt{'listen-queue-size'} = 999;
    }

    # create Net::Server object and run it
    my $server = bless {
        server => {
            commandline      => [ $0, @ARGV_saved ],
            port             => [ $opt{inet} ? $opt{inet} : $opt{unix}."|unix" ],
            proto            => $opt{inet} ? 'tcp' : 'unix',
            user             => $opt{user} || 'postgate',
            group            => $opt{group} || 'postgate',
            dbdir            => $opt{dbdir} || $DEFAULT_DBDIR,
            setsid           => $opt{daemonize} ? 1 : undef,
            pid_file         => $opt{daemonize} ? $opt{pidfile} : undef,
            log_level        => $opt{quiet} ? 1 : ($opt{verbose} ? 3 : 2),
            log_file         => $opt{daemonize} ? 'Sys::Syslog' : undef,
            syslog_logsock   => $syslog_logsock,
            syslog_facility  => $opt{syslogfacility} || 'mail',
            syslog_ident     => 'postgate',
            listen           => $opt{'listen-queue-size'} ? $opt{'listen-queue-size'} : undef,
        },
        postgate => {
            delay            => $opt{delay}     || 300,
            last_maint       => time,
            last_maint_keys  => 0, # do it on the first night
            lookup_by_host   => $opt{'lookup-by-host'},
            awl_clients      => defined $opt{'auto-whitelist-clients'} ?
                ($opt{'auto-whitelist-clients'} ne '' ?
                    $opt{'auto-whitelist-clients'} : 5) : 5,
            retry_window     => $retry_window,
            greylist_action  => $opt{'greylist-action'} || 'DEFER_IF_PERMIT',
            whitelist_clients_files    => $opt{'whitelist-clients'} ||
                [ "$CONFIG_DIR/postgate_whitelist_clients" ,
                  "$CONFIG_DIR/postgate_whitelist_clients.local" ],
            whitelist_senders_files => $opt{'whitelist-senders'} ||
                [ "$CONFIG_DIR/postgate_whitelist_senders" ],
            blacklist_senders_files => $opt{'blacklist-senders'} ||
                [ "$CONFIG_DIR/postgate_blacklist_senders" ],
            privacy => defined $opt{'privacy'},
            hostname => defined $opt{hostname} ? $opt{hostname} : hostname,
            hourly_limit => $opt{hourly_limit} || 1000,
            exim => defined $opt{'exim'},
        },
    }, 'postgate';

    # read black/whitelist
    $server->read_sender_whitelists();
    $server->read_sender_blacklists();

    # --privacy requires Digest::SHA
    if($opt{'privacy'}) {
        require Digest::SHA;
    }

    $0 = join(' ', @{$server->{server}{commandline}});
    $server->run;

    # shouldn't get here
    $server->mylog(1, "Exiting!");

    $dbh->disconnect();

    exit 1;
}

##### Net::Server::Multiplex methods:

# reload whitelists on HUP
sub sig_hup {
    my $self = shift;
    $self->mylog(1, "HUP received: reloading black/whitelists...");

    $self->read_sender_whitelists();
    $self->read_sender_blacklists();
}

sub post_bind_hook()
{
    my ($self) = @_;

    # unix socket permissions should be 666
    if($self->{server}{port}[0] =~ /^(.*)\|unix$/) {
        chmod 0666, $1;
    }
}

sub pre_loop_hook()
{
    my ($self) = @_;

    # be sure to put in syslog any warnings / fatal errors
    if($self->{server}{log_file} eq 'Sys::Syslog') {
        $SIG{__WARN__} = sub { Sys::Syslog::syslog('warning', '%s', "WARNING: $_[0]") };
        $SIG{__DIE__}  = sub { Sys::Syslog::syslog('crit', '%s', "FATAL: $_[0]"); die @_; };
    }

    # write files with mode 600
    umask 0077;

    # ensure that only one instance of postgate is running
    my $lock = "$self->{server}{dbdir}/postgate.lock";
    open(LOCK, ">>$lock") or die "ERROR: can't open lock file: $lock\n";
    flock(LOCK, LOCK_EX|LOCK_NB) or die "ERROR: locked: $lock\n";


    # open database

    $dbh = DBI->connect("DBI:SQLite:database=" . $self->{server}{dbdir} . "/postgate.sdb", '', '') || die "cannot open database: " . $self->{server}{dbdir} . "/postgate.sdb";

    $dbh->do("CREATE TABLE IF NOT EXISTS $table_quota (email char(128) not null, ts int default 0, n int default 0)");
    $dbh->do("CREATE TABLE IF NOT EXISTS $table_stat (ts int default 0, n int default 0)");
}

sub mux_input()
{
    my ($self, $mux, $fh, $in_ref) = @_;
    defined $self->{postgate_attr} or $self->{postgate_attr} = {};
    my $attr = $self->{postgate_attr};


    # consume entire lines
    while ($$in_ref =~ s/^([^\r\n]*)\r?\n//) {
        next unless defined $1;
        my $in = $1;
        if($in =~ /([^=]+)=(.*)/) {
            # read attributes
            $attr->{substr($1, 0, 512)} = substr($2, 0, 512);
        }
        elsif($in eq '') {
            defined $attr->{request} or $attr->{request}='';
            if($attr->{request} ne 'smtpd_access_policy') {
                $self->{net_server}->mylog(1, "unrecognized request type: '$attr->{request}'");
            }
            else {
                my $now = time;

                # decide
                my $action = $self->{net_server}->smtpd_access_policy($now, $attr);

                # give answer
                print $fh "action=$action\n\n";

                # attempt maintenance if one hour has passed since the last one
                my $server = $self->{net_server};
                if($server->{postgate}{last_maint} &&
                    $now-$server->{postgate}{last_maint} >= 3600)
                {
                    $server->{postgate}{last_maint} = $now;
                    $server->do_maintenance($now);
                }

                # close the filehandle if --exim is set
                if ($self->{net_server}->{postgate}{exim}) {
                    close($fh);
                    last;
                }
            }
            $self->{postgate_attr} = {};
        }
        else {
            $self->{net_server}->mylog(1, "ignoring garbage: <".substr($in, 0, 100).">");
        }
    }
}

sub fatal_hook()
{
    my ($self, $error, $package, $file, $line) = @_;
    # Net::Server calls $self->server_close but, unfortunately,
    # it does exit(0) (with Net::Server 0.97)...
    # It is however useful for init-script to detect non-zero exit codes
    die('ERROR: ' . $error);
}

main;

__END__