# HG changeset patch # User heiko # Date 1464100376 -7200 # Node ID ab282b335eb581e1882e73cf837737572588dd18 # Parent cd04db2a79cc7911500607d2b59719ea0e5a6fa3 Allow autowhitelists diff -r cd04db2a79cc -r ab282b335eb5 exim-exigrey.pl --- a/exim-exigrey.pl Tue May 24 16:32:36 2016 +0200 +++ b/exim-exigrey.pl Tue May 24 16:32:56 2016 +0200 @@ -5,28 +5,27 @@ use strict; use warnings; use Carp; -use Fcntl qw(:flock); # 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; +# 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", - white => "white", ); -sub unseen($;$$); +sub unseen; # some helper functions sub getDBDir(); sub findExim(;$); sub connectDB($$); -sub disconnectDB(); sub getDefault() { %DEFAULT } # Usage: @@ -36,7 +35,12 @@ # ${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) +# 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)\0 @@ -44,36 +48,40 @@ # # dbm file is relativ to $spool_directory/grey, EXCEPT its name # starts with "./" or "/". -# -sub unseen($;$$) { - my ($item, $delay, $db) = @_; - $item .= "\0"; - $delay = $DEFAULT{delay} unless defined $delay; - $db = $DEFAULT{db} unless defined $db; +sub unseen { + my $item = shift; + my $delay = shift // $DEFAULT{delay}; + my $db = shift // $DEFAULT{db}; my $now = time(); + my ($auto) = $item =~ /.*?\/(.+?)$/; my $rc; - my %h; - $db = connectDB(\%h, $db); + connectDB(\my %h, $db); + + return 'no' # not unseen, ergo known + if defined $auto and is_whitelisted($auto, \%h); - if (not exists $h{$item}) { - $h{$item} = "$now $now 0\0"; - $rc = "yes"; + 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'; } - else { - ($_ = $h{$item}) =~ s/\0*$//; # we're \0 terminated - my ($created, $used, $count) = split; - if ($now - $created < $delay) { $rc = "yes" } - else { - $rc = "no"; - ++$count; - $h{$item} = "$created $now $count\0"; - } + + my ($created, undef, $count) = split ' ', $h{$key}; + + # we know the client, but last contact was recently (too fast) + if ($now - $created < $delay) { + return 'yes'; } - untie %h; - disconnectDB(); - return $rc; + + # 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 " @@ -92,17 +100,22 @@ # If we see the same message a second time (same message means here: # same greylist criteria -sub autowhite { -} - -sub known { +sub whitelist { + my ($item, $h) = @_; + my $now = time; + $h->{"$item\0"} = "$now $now 1\0"; } - +sub is_whitelisted { + my ($item, $h) = @_; + my $key = "$item\0"; -sub white($;$) { - unseen($_[0], 0, defined $_[1] ? $_[1] : $DEFAULT{white}); - return "yes"; + return 0 if not exists $h->{$key}; + + my ($t0, undef, $cnt) = split ' ', $h->{$key}; + $h->{$key} = join(' ' => $t0, time, ++$cnt) . "\0"; + + return 1; } # Get the directory where we could store the database file(s) @@ -138,58 +151,52 @@ die "Can't find exim binary (missing .../sbin dirs in PATH?"; } -{ - my $fh; +sub connectDB($$) { + my ($h, $db) = @_; + $db = getDBDir() . "/$db" unless $db =~ m(^\.?/); - 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/; + # 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; - } - - # We try to open and lock the database file to avoid - # a race. - open($fh, $db) or die "Can't open $db: $!"; - flock($fh, LOCK_EX) or die "Can't lock $db: $!"; - - # 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::TIEHASH) { - tie %$h, "DB_File", $db - or die "$0: $db: $!"; - return $db; - } - - die "Can't connect to database driver"; + # 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; } - sub disconnectDB() { - close($fh); + # 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: +# vim:aw et sw=4 ts=4: