--- a/lib/Exim/Grey.pm Sat Jun 04 23:05:29 2016 +0200
+++ b/lib/Exim/Grey.pm Wed Jun 21 00:26:46 2017 +0200
@@ -10,12 +10,22 @@
our %EXPORT_TAGS = (all => \@EXPORT_OK,);
our $VERSION = '2.0';
+our $verbose;
+
+sub verbose {
+ return if not $verbose;
+ print STDERR __PACKAGE__ . ': ' . map { s/\0//gr } @_, "\n";
+}
+
+sub exim_bool { $_[0] ? 'yes' : 'no' }
+
# 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;
@@ -30,51 +40,52 @@
sub connectDB($$);
sub getDefault() { %DEFAULT }
+# dbm file is relativ to $spool_directory/grey, EXCEPT its name
+# starts with "/".
-# dbm file is relativ to $spool_directory/grey, EXCEPT its name
-# starts with "./" or "/".
-
-sub unseen {
+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 ($auto) = $item =~ /.*?\/(.+?)$/ # remember the /<autokey> from the item
+ and $item =~ s/\/.*?$//; # and remove it from the item
my $rc;
connectDB(\my %h, $db);
- return 'no' # not unseen, ergo known
+ return 1 # not unseen, ergo known
if defined $auto and is_whitelisted($auto, \%h);
- my $key = "$item\0";
+ my $key = "$item\0"; # for compatibility with Exim's dbm functions
- # we do not know anything about the client -> unknown
+ # We do not know anything about the client -> unknown.
+ # But remember that key with the associated "auto" subkey
if (not exists $h{$key}) {
- $h{$key} = "$now $now 0"
- . (defined $auto ? " auto=$auto" : '')
- . "\0";
- return 'yes';
+ $h{$key} = serialize(t0 => $now, t1 => $now, count => 0, auto => [defined $auto ? $auto : ()]);
+
+ verbose "unseen: $item" if $verbose;
+ return 1;
}
- my ($created, undef, $count, $flags) = split /[ \0]/, $h{$key};
+ my %entry = deserialize($h{$key});
# we know the client, but last contact was recently (too fast)
- if ($now - $created < $delay) {
- return 'yes';
+ # should we add it to our list auto entries too?
+ if ($now - $entry{t0} < $delay) {
+ return 1;
}
# we know the client, was patiently enough
- ++$count;
- $h{$key} = "$created $now $count\0";
- whitelist(\%h, $auto, $flags =~ /auto=(\S+)/) if defined $auto;
- return 'no';
+ whitelist(\%h, uniq($auto, $entry{auto})) if defined $auto;
+ $entry{count}++;
+ $h{$key} = $_ = serialize(%entry);
+ verbose "seen: $_" if $verbose;
+ return 0;
}
-sub seen {
- return(unseen(@_) eq 'yes' ? 'no' : 'yes');
-}
+sub unseen { exim_bool unseen_ @_ }
+sub seen { exim_bool !unseen_ @_ }
# According to a thought from "David Woodhouse <dwmw2@infradead.org>"
# on exim-users@exim.org (Thu, 08 May 2008 13:10:21 +0100,
@@ -93,8 +104,10 @@
# same greylist criteria
sub whitelist {
- my ($h, @items) = @_;
+ my ($h, @items) = (shift, uniq(@_));
my $now = time;
+ warn __PACKAGE__ . ": whitelist: @items\n"
+ if $verbose;
$h->{"$_\0"} = "$now $now 1 auto\0"
foreach uniq(@items);
}
@@ -108,11 +121,16 @@
my ($item, $h) = @_;
my $key = "$item\0";
+ warn __PACKAGE__ . 'is '
+ . (exists $h->{$key} ? '' : 'not')
+ . "whitelisted: $item\n" if $verbose;
+
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;
}
@@ -151,7 +169,7 @@
sub connectDB($$) {
my ($h, $db) = @_;
- $db = getDBDir() . "/$db" unless $db =~ m(^\.?/);
+ $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
@@ -195,6 +213,31 @@
die "Can't connect to database driver";
}
+# These two functions do not truly serialize/de-serialize the data
+# passed. They're specialiased to a fixed data format:
+# serialized: <t0> <t1> <count> [auto=<item>[,<item>]...]
+# structured: (
+# t0 => <t0>,
+# t1 => <t1>,
+# count => <count>,
+# auto => [item, item, …],
+# )
+sub serialize {
+ my %data = @_;
+ my $auto = (ref $data{auto} && @{$data{auto}}) ? join ',', @{$data{auto}} : '';
+ return "$data{t0} $data{t1} $data{count} auto=$auto\0";
+}
+
+sub deserialize {
+ my @data = split / /, $_[0] =~ s/\0$//r;
+ my %data;
+ ($data{t0}, $data{t1}, $data{count}) = splice @data, 0, 3;
+ if ($data[0] =~ /^auto=(.*)/) {
+ $data{auto} = [split /,/, $1];
+ }
+ return %data;
+}
+
1;
__END__
--- a/t/00-basic.t Sat Jun 04 23:05:29 2016 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,38 +0,0 @@
-use strict;
-use warnings;
-
-use Test::More qw(no_plan);
-use File::Temp;
-
-use_ok 'Exim::Grey' => qw(unseen seen) or BAIL_OUT;
-
-subtest 'simple' => sub {
- my $db = File::Temp->new();
- is seen('a->x', 0, "$db"), 'no' => 'not seen a->x';
- is unseen('a->b', 0, "$db"), 'yes' => 'unseen a->b';
- is unseen('a->b', 600, "$db"), 'yes' => 'unseen a->b with 600s delay';
- is unseen('a->b', 0, "$db"), 'no' => 'not unseen a->b';
- is seen('a->b', 600, "$db"), 'no' => 'not seen a->b with 600s delay';
-};
-
-subtest 'whitelist' => sub {
- my $db = File::Temp->new();
- is unseen('x->y/1.1.1.1', 1, "$db"), 'yes' => 'unseen x->y/1.1.1.1';
- is unseen('x->y/1.1.1.1', 1, "$db"), 'yes' => 'unseen x->y/1.1.1.1';
-
- is unseen('x->y/1.1.1.1', 0, "$db"), 'no' => 'not unseen x->y/1.1.1.1';
- is unseen('x->z/1.1.1.1', 0, "$db"), 'no' => 'not unseen x->z/1.1.1.1';
- is seen('x->z/1.1.1.1', 0, "$db"), 'yes' => 'seen x->z/1.1.1.1';
-
-};
-
-subtest 'whitelist multiple subkeys' => sub {
- my $db = File::Temp->new();
-
- is unseen('x->y/1.1.1.1', 0, "$db"), 'yes' => 'unseen x->y/1.1.1.1';
- is unseen('x->y/2.2.2.2', 0, "$db"), 'no' => 'not unseen x->y/2.2.2.2';
-
- is unseen('a->b/1.1.1.1', 0, "$db"), 'no' => 'not unseen (whitelisted source)';
- is unseen('a->c/2.2.2.2', 0, "$db"), 'no' => 'not unseen (whitelisted source)';
- is unseen('x->y/3.3.3.3', 0, "$db"), 'no' => 'not unseen x->y/3.3.3.3 (known key)';
-};
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/t/10-interface.tt Wed Jun 21 00:26:46 2017 +0200
@@ -0,0 +1,40 @@
+use strict;
+use warnings;
+
+use Test::More qw(no_plan);
+use File::Temp;
+
+use_ok 'Exim::Grey' => qw(unseen seen) or BAIL_OUT;
+
+subtest 'simple' => sub {
+ my $db = File::Temp->new();
+ is seen('a->x', 0, "$db"), 'no' => 'not seen a->x';
+ is unseen('a->b', 0, "$db"), 'yes' => 'unseen a->b';
+ is unseen('a->b', 600, "$db"), 'yes' => 'unseen a->b with 600s delay';
+ is unseen('a->b', 0, "$db"), 'no' => 'not unseen a->b';
+ is seen('a->b', 600, "$db"), 'no' => 'not seen a->b with 600s delay';
+};
+
+subtest 'whitelist' => sub {
+ my $db = File::Temp->new();
+ is unseen('x->y/1.1.1.1', 1, "$db"), 'yes' => 'unseen x->y/1.1.1.1';
+ is unseen('x->y/1.1.1.1', 1, "$db"), 'yes' => 'unseen x->y/1.1.1.1';
+
+ is seen('x->y/1.1.1.1', 0, "$db"), 'yes' => 'seen x->y/1.1.1.1';
+ is seen('x->z/1.1.1.1', 0, "$db"), 'yes' => 'seen x->z/1.1.1.1 (subkey known)';
+ is seen('1.1.1.1', 0, "$db"), 'yes' => 'seen 1.1.1.1';
+
+};
+__END__
+
+subtest 'whitelist multiple subkeys' => sub {
+ my $db = File::Temp->new();
+
+ is unseen('x->y/1.1.1.1', 0, "$db"), 'yes' => 'unseen x->y/1.1.1.1';
+ is unseen('x->y/2.2.2.2', 3, "$db"), 'yes' => 'unseen x->y/3.3.3.3';
+ is unseen('x->y/3.3.3.3', 0, "$db"), 'no' => 'not unseen x->y/2.2.2.2';
+
+ is unseen('a->b/1.1.1.1', 0, "$db"), 'no' => 'not unseen (whitelisted source)';
+ is unseen('a->c/2.2.2.2', 0, "$db"), 'no' => 'not unseen (whitelisted source)';
+ is unseen('x->y/3.3.3.3', 0, "$db"), 'no' => 'not unseen x->y/3.3.3.3 (known key)';
+};