lib/Exim/Grey.pm
author Heiko Schlittermann <hs@schlittermann.de>
Sat, 04 Jun 2016 22:07:56 +0200
changeset 70 bb6af74ba8b2
parent 69 0f66e8a1364a
child 72 f095f28db247
permissions -rw-r--r--
Documentation
package Exim::Grey;
# for usage please see at the end

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

our @EXPORT_OK   = qw(unseen seen 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',
);

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


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

sub seen {
    return(unseen(@_) eq 'yes' ? 'no' : 'yes');
}

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

__END__
=head1 NAME

 Exim::Grey

=head1 SYNOPSIS

 perl_startup use Exim::Grey qw(unseen);
 ...
 acl rcpt
    defer condition = ${perl{unseen}{<$sender_address>:<$local_part@$domain>}}

=head1 DESCRIPTION

This is a module to be loade by Exim, the MTA. On request it exports
a single function C<unseen()>. This function may be used in the ACL section
to support greylisting.

=head1 FUNCTIONS

=over

=item scalar B<unseen>(I<key>, I<delay>, I<db>)

This function returns I<true> if the key is already known in the I<db> database
for the minimum I<delay> time. (Note: The database may be cleaned regularly by
the compangion L<exigrey> tool.)

The I<key> is mandotory, the default I<delay> is 600 seconds and the default I<db>
is called F<seen>.

I<Key> may contain a suffix, separated by "/". This suffix is used for
automatic whitelisting.

=item scalar B<seen>(I<key>, I<delay>, I<db>)

The same as C<unseen()>, but with reversed result.

=back

=head1 EXAMPLES

=head2 Greylisting

First you have to include B<Exim::Grey> into your Exim. If Exim is built with Perl
support, the configuration syntax allows for C<perl_startup>:

    perl_startup = use Exim::Grey qw(unseen);

In the ACL section of the configuration can check if a given key (sender, or combination
of sender and recipient, or whatever) is new (unseen):

    defer condition = ${perl{unseen}{<$sender_address>:$<local_part@$domain>}}

If the same condition is checked more then I<delay> later, the C<unseen> function returns
false.

=head2 Greylisting + automatic whitelisting

Greylisting gets annoying if you do it for senders that are already known to retry. Thus it might be
good to maintain a whitelist. You may use a suffix to your key, separated by "/". Once the greylist
filter is passed, the used suffixes are registered with the whitelist.

  t
  |
  0  a->b/x  # a->b never seen, suffix never seen: greylist
  1  a->b/y  # a->b again: accept AND put x and y to the whitelist,
  |          # as they are known to retry
  2  c->b/x  # c->b unknown, but x is already whitelisted: accept
  3  d->b/y  # d->b unknown, but y is already whitelisted: accept
  |
  v

This can be implemented in your ACL as:

    defer condition = ${perl{unseen}{<$sender_address>:$<local_part@$domain>/$sender_host_address}}

But, if I<a> and I<b> are the sender and the recipient address, and the
subkey is the sender host address, a spammer might send a forged message
after t0, to get whitelisted.

=head1 INTERNALS

=head2 Format of the database

The record structure is

 key:   item\0
 value: timestamp(creation) timestamp(usage) counter[ flags]\0

This way we are compatible with ${lookup{...}dbm{...}}

=head1 FILES

The database files are placed in C<$spool_directory/grey/>.

=head1 SEE ALSO

The companion tool L<exigrey> should be used for inspection and manipulation
of the database.

=cut

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