Allow autowhitelists
authorheiko
Tue, 24 May 2016 16:32:56 +0200
changeset 55 ab282b335eb5
parent 54 cd04db2a79cc
child 56 6e6a5c3567f2
Allow autowhitelists
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);
 
-    if (not exists $h{$item}) {
-        $h{$item} = "$now $now 0\0";
-        $rc = "yes";
+    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';
     }
-    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 <dwmw2@infradead.org>"
@@ -92,17 +100,22 @@
 # If we see the same message a second time (same message means here:
 # same greylist criteria
 
-sub autowhite {
+sub whitelist {
+    my ($item, $h) = @_;
+    my $now = time;
+    $h->{"$item\0"} = "$now $now 1\0";
 }
 
-sub known {
-}
-
+sub is_whitelisted {
+    my ($item, $h) = @_;
+    my $key = "$item\0";
 
+    return 0 if not exists $h->{$key};
+    
+    my ($t0, undef, $cnt) = split ' ', $h->{$key};
+    $h->{$key} = join(' ' => $t0, time, ++$cnt) . "\0";
 
-sub white($;$) {
-    unseen($_[0], 0, defined $_[1] ? $_[1] : $DEFAULT{white});
-    return "yes";
+    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(^\.?/);
-
-        # 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/;
+sub connectDB($$) {
+    my ($h, $db) = @_;
+    $db = getDBDir() . "/$db" unless $db =~ m(^\.?/);
 
-            # 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: $!";
+    # 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/;
 
-        # 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: