# HG changeset patch
# User Heiko Schlittermann <hs@schlittermann.de>
# Date 1497997606 -7200
# Node ID e2559ee78cb36de009a7a86d652ad7ec7bb0041e
# Parent  f095f28db247c15976232d80e806aefa135fe679
[snapshot] working?

diff -r f095f28db247 -r e2559ee78cb3 lib/Exim/Grey.pm
--- 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__
diff -r f095f28db247 -r e2559ee78cb3 t/00-basic.t
--- 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)';
-};
diff -r f095f28db247 -r e2559ee78cb3 t/10-interface.tt
--- /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)';
+};