diff -r 9db6f9fdba12 -r 27440e1334b7 lib/Exim/Grey.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/Exim/Grey.pm Tue May 31 23:20:08 2016 +0200 @@ -0,0 +1,207 @@ +package Exim::Grey; + +use strict; +use warnings; +use base 'Exporter'; +use Carp; + +our @EXPORT_OK = qw(unseen getDBDir getDBs connectDB); +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 =~ /.*?\/(.+?)$/; + 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 ' ', $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 " +# 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 +# <$sender_host_address> <$sender_helo_name> +# (Where 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 ' ', $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: