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