--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,5 @@
+_build/
+blib/
+pm_to_blib
+MYMETA.json
+MYMETA.yml
--- a/Makefile Tue May 24 17:24:04 2016 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,36 +0,0 @@
-# $Id$
-# $URL$
-#
-PERL = $(shell which perl)
-
-exim = exim
-prefix = /usr/local
-sbindir = ${prefix}/sbin
-libdir = ${prefix}/share/${exim}
-
-SCRIPTS = exigrey
-
-.PHONY: all clean install
-
-all: $(SCRIPTS)
-
-clean:
- -rm -f $(SCRIPTS)
-
-install: all
- install -m 0755 -d $(DESTDIR)${sbindir}
- install -m 0755 $(SCRIPTS) $(DESTDIR)${sbindir}/
-
- install -m 0755 -d $(DESTDIR)$(libdir)
- install -m 0644 exim-exigrey.pl $(DESTDIR)$(libdir)/exigrey.pl
-
-%: .%.pl
- @test -e $@ && { test -w $@ || chmod +w $@; } || true
- @cat $< >$@
- @chmod a-w,a+x $@
-
-.%.pl: %.pl
- @sed -e 's,@LIBDIR@,$(libdir),g' \
- -e 's,@PERL@,$(PERL),g' \
- <$< >$@
- @perl -c $@
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile.PL Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,13 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Exim::Grey',
+ AUTHOR => ['Heiko Schlittermann <hs@schlittermann.de>'],
+ VERSION_FROM => 'lib/Exim/Grey.pm',
+ EXE_FILES => ['bin/exigrey'],
+ PREREQ_PM => {
+ 'DB_File::Lock' => '0.05',
+ },
+ NO_META => 1,
+ NO_MYMETA => 1,
+);
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/bin/exigrey Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,208 @@
+#!perl
+# © 2006,2007,2016 Heiko Schlittermann <hs@schlittermann.de>
+# Quick and dirty. Absolutly no warranty. Not even for spelling ;-)
+
+use constant USAGE => <<'#';
+
+Usage: !ME! --insert item [delay [db]] # insert an item
+ !ME! --remove item # remove an item
+ !ME! --list [db] # list all items
+ !ME! --stat [db* ...] # print short statistic
+ !ME! --clean [days [db* ...]] # remove items not used since <days> days
+ !ME! --purge [days [db* ...]] # remove items older than <days> days
+ !ME! --dbs [db* ...] # list data base(s)
+
+ db -- single name of database
+ db* -- glob pattern of database
+
+ If the data base name doesn't doesn't start with "./" or "/"
+ it is considered to be realtiv to exim_spool_dir/grey/.
+
+#
+
+use strict;
+use warnings;
+use Getopt::Long;
+use File::Basename;
+use File::Temp qw/tmpfile/;
+use constant ME => basename $0;
+use FindBin qw/$Bin/;
+use POSIX qw/strftime mktime/;
+
+use Exim::Grey qw(:all);
+
+my $VERSION = '$Id$';
+
+my $opt_list;
+my $opt_stats;
+my $opt_insert;
+my $opt_help;
+my $opt_clean;
+my $opt_purge;
+my $opt_dbs;
+my $opt_remove;
+
+sub getDBs(@);
+sub iterate(\%$);
+
+MAIN: {
+
+ GetOptions(
+ "list!" => \$opt_list,
+ "insert!" => \$opt_insert,
+ "remove!" => \$opt_remove,
+ "stats!" => \$opt_stats,
+ "clean!" => \$opt_clean,
+ "purge!" => \$opt_purge,
+ "dbs!" => \$opt_dbs,
+ "help!" => \$opt_help,
+ ) or die ME . ": Bad usage, try " . ME . " --help.\n";
+
+ if ($opt_help) {
+ ($_ = USAGE) =~ s/!(.*?)!/eval $1/eg;
+ print;
+ exit 0;
+ }
+
+ if ($opt_list) {
+ foreach (@ARGV = getDBs(@ARGV)) {
+ my %h;
+ my $db = connectDB(\%h, $_);
+ print "# $db\n";
+ iterate(
+ %h,
+ sub {
+ my ($item, $v0, $v1, $c, $flag) = @_;
+ printf "$item: $v0 $v1 $c (%s %s)%s\n",
+ strftime("%FT%T", localtime($v0)),
+ strftime("%FT%T", localtime($v1)),
+ $flag ? " $flag" : "";
+ }
+ );
+ print "\n" if @ARGV;
+ }
+ exit 0;
+ }
+
+ if ($opt_stats) {
+ foreach (@ARGV = getDBs(@ARGV)) {
+ my %h;
+ my $db = connectDB(\%h, $_);
+
+ my ($seen, $returned, $oldest_c, $oldest_u, $auto);
+ $seen = $returned = 0;
+ $oldest_c = $oldest_u = time();
+ iterate(
+ %h,
+ sub {
+ my ($item, $v0, $v1, $c, $flags) = @_;
+ if ($flags//'' eq 'auto') {
+ ++$auto;
+ return;
+ }
+ ++$seen;
+ ++$returned if $v0 != $v1; # soon it can be $c
+ $oldest_c = $v0 if $v0 < $oldest_c;
+ $oldest_u = $v1 if $v1 < $oldest_u;
+ return;
+ }
+ );
+
+ $_ = <<__;
+ date: %s
+ db: $db (ls: %.1f MB / du: %.1f MB)
+ total: $seen (100%%)
+ returned: %*d (%3d%%)
+ not returned: %*d (%3d%%)
+auto white listed: %*d
+ oldest (created): %.1f days (%s)
+ oldest (used): %.1f days (%s)
+__
+ printf $_, scalar(localtime), (-s $db) / (1024 * 1024),
+ ((stat $db)[12] * 512) / (1024 * 1024),
+ length($seen), $returned, int(0.5 + 100 * ($returned / $seen)), # returned
+ length($seen), $seen - $returned, int(0.5 + 100 * ($seen - $returned) / $seen), # not returned
+ length($seen), $auto, # auto white
+ ((time - $oldest_c) / 86400), scalar(localtime $oldest_c),
+ ((time - $oldest_u) / 86400), scalar(localtime $oldest_u);
+ print "\n" if @ARGV;
+
+ }
+ exit 0;
+ }
+
+ if ($opt_clean or $opt_purge) {
+
+ my $cut = time() - (86400 * (@ARGV ? shift: 7));
+ foreach (getDBs(@ARGV)) {
+ my %h;
+ my $tmp = tmpfile();
+ my $db = connectDB(\%h, $_);
+ iterate(
+ %h,
+ sub {
+ my ($item, $v0, $v1, $c) = @_;
+ my $rv = defined $opt_purge ? \$v0 : \$v1;
+ print $tmp "$item\0" if $$rv <= $cut;
+ }
+ );
+
+ seek($tmp, 0, 0) or die "Can't seek tmpfile";
+
+ $/ = "\0";
+ delete $h{$_} while <$tmp>;
+ printf "$. items %s from $db\n", $opt_purge ? "purged" : "deleted";
+
+ close($tmp);
+
+ }
+ exit 0;
+ }
+
+ if ($opt_dbs) {
+ print join("\n", getDBs(@ARGV)), "\n";
+ exit 0;
+ }
+
+ if ($opt_insert) {
+ print unseen(@ARGV);
+ exit 0;
+ }
+
+ if ($opt_remove) {
+ my %default = getDefault();
+ my $item = shift;
+ my $db = shift // $default{db};
+
+ my $key = "$item\0";
+
+ connectDB(\my %h, $db);
+ if (not exists $h{$key}) {
+ warn "$0: not found\n";
+ }
+ else {
+ $_ = $h{$key};
+ s/\0$/\n/;
+ delete $h{$key};
+ print;
+ }
+ exit 0;
+ }
+}
+
+sub getDBs(@) {
+ grep { !/\.lock$/ } grep { -f -s }
+ map { m(^\.?/) ? glob($_) : glob(getDBDir() . "/$_") } @_ ? @_ : "*";
+}
+
+# Helper to iterate over our hash and call the passed
+# "callback" function (item, v0, v1, count, flags)
+sub iterate(\%$) {
+ my ($hash, $sub) = @_;
+ while (my ($k, $v) = each %$hash) {
+ chop($k, $v);
+ &$sub($k, (split(' ', $v), 0, 0)[ 0 .. 3 ]); # 0 for filling
+ }
+}
+
+# vim:ft=perl aw sts=4 sw=4:
--- a/exigrey.pl Tue May 24 17:24:04 2016 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,212 +0,0 @@
-#! @PERL@
-# © 2006,2007 Heiko Schlittermann <hs@schlittermann.de>
-# Quick and dirty. Absolutly no warranty. Not even for spelling ;-)
-# $Id$
-# $URL$
-
-use constant USAGE => <<'#';
-
-Usage: !ME! --insert item [delay [db]] # insert an item
- !ME! --remove item # remove an item
- !ME! --list [db] # list all items
- !ME! --stat [db* ...] # print short statistic
- !ME! --clean [days [db* ...]] # remove items not used since <days> days
- !ME! --purge [days [db* ...]] # remove items older than <days> days
- !ME! --dbs [db* ...] # list data base(s)
-
- db -- single name of database
- db* -- glob pattern of database
-
- If the data base name doesn't doesn't start with "./" or "/"
- it is considered to be realtiv to exim_spool_dir/grey/.
-
-#
-
-use strict;
-use warnings;
-use Getopt::Long;
-use File::Basename;
-use File::Temp qw/tmpfile/;
-use constant ME => basename $0;
-use FindBin qw/$Bin/;
-use POSIX qw/strftime mktime/;
-
-do './exim-exigrey.pl'
- or do '@LIBDIR@/exigrey.pl'
- or die $!;
-
-my $VERSION = '$Id$';
-
-my $opt_list;
-my $opt_stats;
-my $opt_insert;
-my $opt_help;
-my $opt_clean;
-my $opt_purge;
-my $opt_dbs;
-my $opt_remove;
-
-sub getDBs(@);
-sub iterate(\%$);
-
-MAIN: {
-
- GetOptions(
- "list!" => \$opt_list,
- "insert!" => \$opt_insert,
- "remove!" => \$opt_remove,
- "stats!" => \$opt_stats,
- "clean!" => \$opt_clean,
- "purge!" => \$opt_purge,
- "dbs!" => \$opt_dbs,
- "help!" => \$opt_help,
- ) or die ME . ": Bad usage, try " . ME . " --help.\n";
-
- if ($opt_help) {
- ($_ = USAGE) =~ s/!(.*?)!/eval $1/eg;
- print;
- exit 0;
- }
-
- if ($opt_list) {
- foreach (@ARGV = getDBs(@ARGV)) {
- my %h;
- my $db = connectDB(\%h, $_);
- print "# $db\n";
- iterate(
- %h,
- sub {
- my ($item, $v0, $v1, $c, $flag) = @_;
- printf "$item: $v0 $v1 $c (%s %s)%s\n",
- strftime("%FT%T", localtime($v0)),
- strftime("%FT%T", localtime($v1)),
- $flag ? " $flag" : "";
- }
- );
- print "\n" if @ARGV;
- }
- exit 0;
- }
-
- if ($opt_stats) {
- foreach (@ARGV = getDBs(@ARGV)) {
- my %h;
- my $db = connectDB(\%h, $_);
-
- my ($seen, $returned, $oldest_c, $oldest_u, $auto);
- $seen = $returned = 0;
- $oldest_c = $oldest_u = time();
- iterate(
- %h,
- sub {
- my ($item, $v0, $v1, $c, $flags) = @_;
- if ($flags//'' eq 'auto') {
- ++$auto;
- return;
- }
- ++$seen;
- ++$returned if $v0 != $v1; # soon it can be $c
- $oldest_c = $v0 if $v0 < $oldest_c;
- $oldest_u = $v1 if $v1 < $oldest_u;
- return;
- }
- );
-
- $_ = <<__;
- date: %s
- db: $db (ls: %.1f MB / du: %.1f MB)
- total: $seen (100%%)
- returned: %*d (%3d%%)
- not returned: %*d (%3d%%)
-auto white listed: %*d
- oldest (created): %.1f days (%s)
- oldest (used): %.1f days (%s)
-__
- printf $_, scalar(localtime), (-s $db) / (1024 * 1024),
- ((stat $db)[12] * 512) / (1024 * 1024),
- length($seen), $returned, int(0.5 + 100 * ($returned / $seen)), # returned
- length($seen), $seen - $returned, int(0.5 + 100 * ($seen - $returned) / $seen), # not returned
- length($seen), $auto, # auto white
- ((time - $oldest_c) / 86400), scalar(localtime $oldest_c),
- ((time - $oldest_u) / 86400), scalar(localtime $oldest_u);
- print "\n" if @ARGV;
-
- }
- exit 0;
- }
-
- if ($opt_clean or $opt_purge) {
-
- my $cut = time() - (86400 * (@ARGV ? shift: 7));
- foreach (getDBs(@ARGV)) {
- my %h;
- my $tmp = tmpfile();
- my $db = connectDB(\%h, $_);
- iterate(
- %h,
- sub {
- my ($item, $v0, $v1, $c) = @_;
- my $rv = defined $opt_purge ? \$v0 : \$v1;
- print $tmp "$item\0" if $$rv <= $cut;
- }
- );
-
- seek($tmp, 0, 0) or die "Can't seek tmpfile";
-
- $/ = "\0";
- delete $h{$_} while <$tmp>;
- printf "$. items %s from $db\n", $opt_purge ? "purged" : "deleted";
-
- close($tmp);
-
- }
- exit 0;
- }
-
- if ($opt_dbs) {
- print join("\n", getDBs(@ARGV)), "\n";
- exit 0;
- }
-
- if ($opt_insert) {
- print unseen(@ARGV);
- exit 0;
- }
-
- if ($opt_remove) {
- my %default = getDefault();
- my $item = shift;
- my $db = shift // $default{db};
-
- my $key = "$item\0";
-
- connectDB(\my %h, $db);
- if (not exists $h{$key}) {
- warn "$0: not found\n";
- }
- else {
- $_ = $h{$key};
- s/\0$/\n/;
- delete $h{$key};
- print;
- }
- exit 0;
- }
-}
-
-sub getDBs(@) {
- grep { !/\.lock$/ } grep { -f -s }
- map { m(^\.?/) ? glob($_) : glob(getDBDir() . "/$_") } @_ ? @_ : "*";
-}
-
-# Helper to iterate over our hash and call the passed
-# "callback" function (item, v0, v1, count, flags)
-sub iterate(\%$) {
- my ($hash, $sub) = @_;
- while (my ($k, $v) = each %$hash) {
- chop($k, $v);
- &$sub($k, (split(' ', $v), 0, 0)[ 0 .. 3 ]); # 0 for filling
- }
-}
-
-# vim:ft=perl aw sts=4 sw=4:
--- a/exim-exigrey.pl Tue May 24 17:24:04 2016 +0200
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,202 +0,0 @@
-# © 2006,2007,2008 Heiko Schlittermann <hs@schlittermann.de>
-# $Id$
-# $URL$
-
-use strict;
-use warnings;
-use Carp;
-
-# 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,
- db => "seen",
-);
-
-sub unseen;
-
-# some helper functions
-sub getDBDir();
-sub findExim(;$);
-sub connectDB($$);
-sub getDefault() { %DEFAULT }
-
-# Usage:
-# ${perl{unseen}{KEY}}
-# ${perl{unseen}{KEY}{600}}
-# ${perl{unseen}{KEY}{600}{seen}}
-# ${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>
-#
-# 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)[ auto]\0
-# (This way we're compatible with ${lookup{...}dbm{...}})
-#
-# dbm file is relativ to $spool_directory/grey, EXCEPT its name
-# starts with "./" or "/".
-
-sub unseen {
- my $item = shift;
- my $delay = shift // $DEFAULT{delay};
- my $db = shift // $DEFAULT{db};
- my $now = time();
- my ($auto) = $item =~ /.*?\/(.+?)$/;
- my $rc;
-
- connectDB(\my %h, $db);
-
- 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';
- }
-
- my ($created, undef, $count) = split ' ', $h{$key};
-
- # we know the client, but last contact was recently (too fast)
- if ($now - $created < $delay) {
- return 'yes';
- }
-
- # 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>"
-# 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
-# for retries, because there is no benefit in greylisting them.
-#
-# Most safe approach would be something based on message id.
-# If we see the message id a second time it indicates successful retry.
-# But we do not see the message id the first time we reject the message.
-
-# This function has to be called twice per message delivery attempt
-# <KEY> <$sender_host_address> <$sender_helo_name>
-# (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 ($item, $h) = @_;
- my $now = time;
- $h->{"$item\0"} = "$now $now 1 auto\0";
-}
-
-sub is_whitelisted {
- my ($item, $h) = @_;
- my $key = "$item\0";
-
- return 0 if not exists $h->{$key};
-
- my ($t0, undef, $cnt, $flag) = split ' ', $h->{$key};
- $h->{$key} = join(' ' => $t0, time, ++$cnt, $flag ? $flag : ()) . "\0";
-
- return 1;
-}
-
-# Get the directory where we could store the database file(s)
-# If we're running under exim it's easy, otherwise we've to find exim
-# and then ask...
-sub getDBDir() {
- my ($spooldir, $dbdir);
- eval { $spooldir = Exim::expand_string('$spool_directory') };
- if (not defined $spooldir) {
- my $exim = findExim();
- chomp($spooldir = `$exim -be '\$spool_directory'`);
- die "Can't find spooldir" if not defined $spooldir;
- }
- -d ($dbdir = "$spooldir/grey") and return $dbdir;
-
- my ($mode, $owner, $group) = (stat $spooldir)[ 2, 4, 5 ];
- {
- local $) = $group;
- local $> = $owner;
- $mode &= 0777;
- mkdir $dbdir, $mode or die "Can't create $dbdir: $!";
- }
- return $dbdir;
-}
-
-sub findExim(;$) {
- my $path = shift || $ENV{PATH};
- my $exim;
- foreach (split /:/, $ENV{PATH}) {
- -x ($exim = "$_/exim") and return $exim;
- -x ($exim = "$_/exim4") and return $exim;
- }
- die "Can't find exim binary (missing .../sbin dirs in PATH?";
-}
-
-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/;
-
- # 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;
- }
-
- # 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 et sw=4 ts=4:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/Exim/Grey.pm Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,207 @@
+package Exim::Grey;
+
+use strict;
+use warnings;
+use base 'Exporter';
+use Carp;
+
+our @EXPORT_OK = qw(unseen getDBDir getDBs connectDB);
+our %EXPORT_TAGS = (
+ all => \@EXPORT_OK,
+);
+our $VERSION = '2.0';
+
+# 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,
+ db => "seen",
+);
+
+sub unseen;
+
+# some helper functions
+sub getDBDir();
+sub findExim(;$);
+sub connectDB($$);
+sub getDefault() { %DEFAULT }
+
+# Usage:
+# ${perl{unseen}{KEY}}
+# ${perl{unseen}{KEY}{600}}
+# ${perl{unseen}{KEY}{600}{seen}}
+# ${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>
+#
+# 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)[ auto]\0
+# (This way we're compatible with ${lookup{...}dbm{...}})
+#
+# dbm file is relativ to $spool_directory/grey, EXCEPT its name
+# starts with "./" or "/".
+
+sub unseen {
+ my $item = shift;
+ my $delay = shift // $DEFAULT{delay};
+ my $db = shift // $DEFAULT{db};
+ my $now = time();
+ my ($auto) = $item =~ /.*?\/(.+?)$/;
+ my $rc;
+
+ connectDB(\my %h, $db);
+
+ 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';
+ }
+
+ my ($created, undef, $count) = split ' ', $h{$key};
+
+ # we know the client, but last contact was recently (too fast)
+ if ($now - $created < $delay) {
+ return 'yes';
+ }
+
+ # 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>"
+# 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
+# for retries, because there is no benefit in greylisting them.
+#
+# Most safe approach would be something based on message id.
+# If we see the message id a second time it indicates successful retry.
+# But we do not see the message id the first time we reject the message.
+
+# This function has to be called twice per message delivery attempt
+# <KEY> <$sender_host_address> <$sender_helo_name>
+# (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 ($item, $h) = @_;
+ my $now = time;
+ $h->{"$item\0"} = "$now $now 1 auto\0";
+}
+
+sub is_whitelisted {
+ my ($item, $h) = @_;
+ my $key = "$item\0";
+
+ return 0 if not exists $h->{$key};
+
+ my ($t0, undef, $cnt, $flag) = split ' ', $h->{$key};
+ $h->{$key} = join(' ' => $t0, time, ++$cnt, $flag ? $flag : ()) . "\0";
+
+ return 1;
+}
+
+# Get the directory where we could store the database file(s)
+# If we're running under exim it's easy, otherwise we've to find exim
+# and then ask...
+sub getDBDir() {
+ my ($spooldir, $dbdir);
+ eval { $spooldir = Exim::expand_string('$spool_directory') };
+ if (not defined $spooldir) {
+ my $exim = findExim();
+ chomp($spooldir = `$exim -be '\$spool_directory'`);
+ die "Can't find spooldir" if not defined $spooldir;
+ }
+ -d ($dbdir = "$spooldir/grey") and return $dbdir;
+
+ my ($mode, $owner, $group) = (stat $spooldir)[ 2, 4, 5 ];
+ {
+ local $) = $group;
+ local $> = $owner;
+ $mode &= 0777;
+ mkdir $dbdir, $mode or die "Can't create $dbdir: $!";
+ }
+ return $dbdir;
+}
+
+sub findExim(;$) {
+ my $path = shift || $ENV{PATH};
+ my $exim;
+ foreach (split /:/, $ENV{PATH}) {
+ -x ($exim = "$_/exim") and return $exim;
+ -x ($exim = "$_/exim4") and return $exim;
+ }
+ die "Can't find exim binary (missing .../sbin dirs in PATH?";
+}
+
+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/;
+
+ # 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;
+ }
+
+ # 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 et sw=4 ts=4:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/t/00-basic.t Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,3 @@
+use Test::More qw(no_plan);
+
+use_ok 'Exim::Grey' => qw(unseen);