--- 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 <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 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: