lib/Exim/Grey.pm
author heiko
Wed, 01 Jun 2016 11:18:48 +0200
changeset 66 16b4815a6a15
parent 63 8525154c1389
child 67 da29842506b4
permissions -rw-r--r--
Do not include the "autokey" in the "greykey"
package Exim::Grey;

use strict;
use warnings;
use base 'Exporter';
use Carp;

our @EXPORT_OK   = qw(unseen getDBDir connectDB getDefault);
our %EXPORT_TAGS = (all => \@EXPORT_OK,);
our $VERSION     = '2.0';

# You may choose, but DB_File's footprint is smaller.
# perl -MDB_File -e 'tie %h, ...':	real    0m0.063s
# perl -MBerkeleyDB -e 'tie %h, ...':	real	0m0.112s
# And DB_File is part of the Perl core distribution (?)
# use BerkeleyDB;
# use DB_File;
# But we need locking! DB_File::Lock isn't part of the corelist.
use DB_File::Lock;

my %DEFAULT = (
    delay => 600,
    db    => "seen",
);

sub unseen;

# some helper functions
sub getDBDir();
sub findExim(;$);
sub connectDB($$);
sub getDefault() { %DEFAULT }

# Usage:
# 	${perl{unseen}{KEY}}
# 	${perl{unseen}{KEY}{600}}
# 	${perl{unseen}{KEY}{600}{seen}}
# 	${perl{unseen}{KEY}{600}{$spool_directory/grey/seen}}
#
# With KEY being something to identify the second delivery attempt
# I recommend using <$sender_address>:<$local_part@$domain>
#
# If KEY has a /... suffix, this suffix is used for auto-whitelisting.
# I recommend using $sender_host_address.
#
# defer  condition = ${perl{unseen}{<$sender_address>:<$local_part@$domain>/$sender_host_address}}
#
# record structure: key:   item\0
#                   value: timestamp(creation) timestamp(usage)[ auto]\0
# (This way we're compatible with ${lookup{...}dbm{...}})
#
# dbm file is relativ to $spool_directory/grey, EXCEPT its name
# starts with "./" or "/".

sub unseen {
    my $item   = shift;
    my $delay  = shift // $DEFAULT{delay};
    my $db     = shift // $DEFAULT{db};
    my $now    = time();
    my ($auto) = $item =~ /.*?\/(.+?)$/ # remove the /<autokey> from the item
        and $item =~ s/\/.*?$//;
    my $rc;

    connectDB(\my %h, $db);

    return 'no'    # not unseen, ergo known
      if defined $auto and is_whitelisted($auto, \%h);

    my $key = "$item\0";

    # we do not know anything about the client -> unknown
    if (not exists $h{$key}) {
        $h{$key} = "$now $now 0\0";
        return 'yes';
    }

    my ($created, undef, $count) = split /[ \0]/, $h{$key};

    # we know the client, but last contact was recently (too fast)
    if ($now - $created < $delay) {
        return 'yes';
    }

    # we know the client, was patiently enough
    ++$count;
    $h{$key} = "$created $now $count\0";
    whitelist($auto, \%h) if defined $auto;
    return 'no';
}

# According to a thought from "David Woodhouse <dwmw2@infradead.org>"
# on exim-users@exim.org (Thu, 08 May 2008 13:10:21 +0100,
# Message-Id: <1210248621.25560.1088.camel@pmac.infradead.org>) we
# should have the ability to "auto whitelist" hosts which are known
# for retries, because there is no benefit in greylisting them.
#
# Most safe approach would be something based on message id.
# If we see the message id a second time it indicates successful retry.
# But we do not see the message id the first time we reject the message.

# This function has to be called twice per message delivery attempt
# <KEY> <$sender_host_address> <$sender_helo_name>
# (Where <KEY> is something like <$sender_address>+<$local_part@$domain>
# If we see the same message a second time (same message means here:
# same greylist criteria

sub whitelist {
    my ($item, $h) = @_;
    my $now = time;
    $h->{"$item\0"} = "$now $now 1 auto\0";
}

sub is_whitelisted {
    my ($item, $h) = @_;
    my $key = "$item\0";

    return 0 if not exists $h->{$key};

    my ($t0, undef, $cnt, $flag) = split /[ \0]/, $h->{$key};
    $h->{$key} = join(' ' => $t0, time, ++$cnt, $flag ? $flag : ()) . "\0";

    return 1;
}

# Get the directory where we could store the database file(s)
# If we're running under exim it's easy, otherwise we've to find exim
# and then ask...
sub getDBDir() {
    my ($spooldir, $dbdir);
    eval { $spooldir = Exim::expand_string('$spool_directory') };
    if (not defined $spooldir) {
        my $exim = findExim();
        chomp($spooldir = `$exim -be '\$spool_directory'`);
        die "Can't find spooldir" if not defined $spooldir;
    }
    -d ($dbdir = "$spooldir/grey") and return $dbdir;

    my ($mode, $owner, $group) = (stat $spooldir)[2, 4, 5];
    {
        local $) = $group;
        local $> = $owner;
        $mode &= 0777;
        mkdir $dbdir, $mode or die "Can't create $dbdir: $!";
    }
    return $dbdir;
}

sub findExim(;$) {
    my $path = shift || $ENV{PATH};
    my $exim;
    foreach (split /:/, $ENV{PATH}) {
        -x ($exim = "$_/exim")  and return $exim;
        -x ($exim = "$_/exim4") and return $exim;
    }
    die "Can't find exim binary (missing .../sbin dirs in PATH?";
}

sub connectDB($$) {
    my ($h, $db) = @_;
    $db = getDBDir() . "/$db" unless $db =~ m(^\.?/);

    # Creation of DB-File if it doesn't exist
    # to avoid races we change our own uid/gid for creation of
    # this file.
    if (!-f $db) {
        (my $dir = $db) =~ s/^(.*)\/.*?$/$1/;

        # copy mode, uid, gid from the directory
        my ($mode, $user, $group) = (stat $dir)[2, 4, 5]
          or die "Can't stat $dir: $!";
        my $umask = umask(($mode & 0777) ^ 0777);
        local $) = $group;
        local $> = $user;
        open(X, ">>$db") or die "Can't create $db: $!";
        close(X);
        umask $umask;
    }

    # now test which of the DB-Modules has been loaded

    if (exists &BerkeleyDB::Hash::TIEHASH) {
        no strict;
        my $umask = umask 077;
        tie %$h, "BerkeleyDB::Hash", -Filename => $db
          or die "$0: $db: $!";
        return $db;
    }

    if (exists &DB_File::Lock::TIEHASH) {
        tie %$h, 'DB_File::Lock', [$db], 'write'
          or die "$0: $db: $!";
        return $db;
    }

    if (exists &DB_File::TIEHASH) {
        tie %$h, 'DB_File', $db or die "$0: $db: $!";
        warn "$0: using DB_File, no locking is possible!\n";
        return $db;
    }

    die "Can't connect to database driver";
}

1;

# vim:aw et sw=4 ts=4: