exigrey: comparison lib/Exim/Grey.pm

equal deleted inserted replaced

-:f095f28db247
+:e2559ee78cb3
 use Carp;
 our @EXPORT_OK   = qw(unseen seen getDBDir connectDB getDefault);
 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;
 my %DEFAULT = (
 delay => 600,
 sub getDBDir();
 sub findExim(;$);
 sub connectDB($$);
 sub getDefault() { %DEFAULT }
 # dbm file is relativ to $spool_directory/grey, EXCEPT its name
-# starts with "./" or "/".
+# starts with "/".
-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
+my ($auto) = $item =~ /.*?\/(.+?)$/ # remember the /<autokey> from the item
-and $item =~ s/\/.*?$//;
+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"
+$h{$key} = serialize(t0 => $now, t1 => $now, count => 0, auto => [defined $auto ? $auto : ()]);
-. (defined $auto ? " auto=$auto" : '')
-. "\0";
+verbose "unseen: $item" if $verbose;
-return 'yes';
+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) {
+# should we add it to our list auto entries too?
-return 'yes';
+if ($now - $entry{t0} < $delay) {
+return 1;
 }
 # we know the client, was patiently enough
-++$count;
+whitelist(\%h, uniq($auto, $entry{auto})) if defined $auto;
-$h{$key} = "$created $now $count\0";
+$entry{count}++;
-whitelist(\%h, $auto, $flags =~ /auto=(\S+)/) if defined $auto;
+$h{$key} = $_ = serialize(%entry);
-return 'no';
+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,
 # Message-Id: <1210248621.25560.1088.camel@pmac.infradead.org>) we
 # should have the ability to "auto whitelist" hosts which are known
 # (Where <KEY> is something like <$sender_address>+<$local_part@$domain>
 # If we see the same message a second time (same message means here:
 # 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);
 }
 sub uniq {
 sub is_whitelisted {
 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;
 }
 # Get the directory where we could store the database file(s)
 die "Can't find exim binary (missing .../sbin dirs in PATH?";
 }
 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
 # this file.
 if (!-f $db) {
 }
 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__
 =head1 NAME

changeset 73	e2559ee78cb3
parent 72	f095f28db247