Merge pull request #160 from jaredj/abstract-dbm

Move DBM functions to Qpsmtpd::DB

lib/Qpsmtpd/DB.pm

@@ -0,0 +1,21 @@
+package Qpsmtpd::DB;
+use strict;
+use warnings;
+use Qpsmtpd::DB::File::DBM;
+
+sub new {
+    my ( $class, %arg ) = @_;
+    # The only supported class just now
+    return bless { %arg }, 'Qpsmtpd::DB::File::DBM';
+}
+
+# noop default method for plugins that don't require locking
+sub get_lock { 1 }
+
+sub name {
+    my ( $self, $name ) = @_;
+    return $self->{name} = $name if $name;
+    return $self->{name};
+}
+
+1;

lib/Qpsmtpd/DB/File.pm

@@ -0,0 +1,34 @@
+package Qpsmtpd::DB::File;
+use strict;
+use warnings;
+use parent 'Qpsmtpd::DB';
+
+sub dir {
+    my ( $self, @candidate_dirs ) = @_;
+    return $self->{dir} if $self->{dir} and ! @candidate_dirs;
+    push @candidate_dirs, ( $self->qphome . '/var/db', $self->qphome . '/config' );
+    for my $d ( @candidate_dirs ) {
+        next if ! $self->validate_dir($d);
+        return $self->{dir} = $d; # first match wins
+    }
+}
+
+sub validate_dir {
+    my ( $self, $d ) = @_;
+    return 0 if ! $d;
+    return 0 if ! -d $d;
+    return 1;
+}
+
+sub qphome {
+    my ( $self ) = @_;
+    my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
+    return $QPHOME;
+}
+
+sub path {
+    my ( $self ) = @_;
+    return $self->dir . '/' . $self->name . $self->file_extension;
+}
+
+1;

lib/Qpsmtpd/DB/File/DBM.pm

@@ -0,0 +1,155 @@
+package Qpsmtpd::DB::File::DBM;
+use strict;
+use warnings;
+
+use parent 'Qpsmtpd::DB::File';
+
+BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
+use AnyDBM_File;
+use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
+
+sub file_extension {
+    my ( $self, $extension ) = @_;
+    return $self->{file_extension} ||= '.dbm';
+}
+
+sub lock {
+    my ( $self ) = @_;
+    if ( $self->nfs_locking ) {
+        $self->nfs_file_lock or return;
+    } else {
+        $self->file_lock or return;
+    }
+    return $self->tie_dbm;
+}
+
+sub file_lock {
+    my ( $self ) = @_;
+    my $path = $self->path;
+    open(my $lock, '>', "$path.lock") or do {
+        warn "opening lockfile failed: $!\n";
+        return;
+    };
+
+    flock($lock, LOCK_EX) or do {
+        warn "flock of lockfile failed: $!\n";
+        close $lock;
+        return;
+    };
+    $self->{lock} = $lock;
+}
+
+sub nfs_file_lock {
+    my ( $self ) = @_;
+    my $path = $self->path;
+
+    require File::NFSLock;
+
+    ### set up a lock - lasts until object looses scope
+    my $nfslock = new File::NFSLock {
+                             file               => "$path.lock",
+                             lock_type          => LOCK_EX | LOCK_NB,
+                             blocking_timeout   => 10,                  # 10 sec
+                             stale_lock_timeout => 30 * 60,             # 30 min
+                                    }
+      or do {
+        warn "nfs lockfile failed: $!\n";
+        return;
+      };
+
+    open(my $lock, '+<', "$path.lock") or do {
+        warn "opening nfs lockfile failed: $!\n";
+        return;
+    };
+
+    $self->{lock} = $lock;
+}
+
+sub tie_dbm {
+    my ( $self ) = @_;
+    my $path = $self->path;
+
+    tie(my %db, 'AnyDBM_File', $path, O_CREAT | O_RDWR, oct('0600')) or do {
+        warn "tie to database $path failed: $!\n";
+        $self->unlock;
+        return;
+    };
+    $self->{tied} = \%db;
+    return 1;
+}
+
+sub nfs_locking {
+    my $self = shift;
+    return $self->{nfs_locking} if ! @_;
+    return $self->{nfs_locking} = shift;
+}
+
+sub unlock {
+    my ( $self ) = @_;
+    close $self->{lock};
+    untie $self->{tied};
+}
+
+sub get {
+    my ( $self, $key ) = @_;
+    if ( ! $key ) {
+        warn "No key provided, set() failed\n";
+        return;
+    }
+    my $tied = $self->{tied};
+    if ( ! $tied ) {
+        warn "DBM db not yet set up, get() failed\n";
+        return;
+    }
+    return $tied->{$key};
+}
+
+sub set {
+    my ( $self, $key, $val ) = @_;
+    my $tied = $self->{tied};
+    if ( ! $tied ) {
+        warn "DBM db not yet set up, set() failed\n";
+        return;
+    }
+    if ( ! $key ) {
+        warn "No key provided, set() failed\n";
+        return;
+    }
+    return $tied->{$key} = $val;
+}
+
+sub get_keys {
+    my ( $self ) = @_;
+    my $tied = $self->{tied};
+    if ( ! $tied ) {
+        warn "DBM db not yet set up, keys() failed\n";
+        return;
+    }
+    return keys %$tied;
+}
+
+sub size {
+    my ( $self ) = @_;
+    my $tied = $self->{tied};
+    if ( ! $tied ) {
+        warn "DBM db not yet set up, size() failed\n";
+        return;
+    }
+    return scalar keys %$tied;
+}
+
+sub delete {
+    my ( $self, $key ) = @_;
+    my $tied = $self->{tied};
+    if ( ! $tied ) {
+        warn "DBM db not yet set up, delete() failed\n";
+        return;
+    }
+    if ( ! $key ) {
+        warn "No key provided, delete() failed\n";
+        return;
+    }
+    delete $tied->{$key};
+}
+
+1;

lib/Qpsmtpd/Plugin.pm

@@ -4,6 +4,7 @@ use warnings;
 
 use lib 'lib';
 use parent 'Qpsmtpd::Base';
+use Qpsmtpd::DB;
 use Qpsmtpd::Constants;
 
 # more or less in the order they will fire
@@ -346,4 +347,9 @@ sub _register_standard_hooks {
     }
 }
 
+sub db {
+    my ( $self, %arg ) = @_;
+    return $self->{db} ||= Qpsmtpd::DB->new(%arg);
+}
+
 1;

plugins/greylisting

@@ -178,13 +178,7 @@ use Qpsmtpd::Constants;
 
 my $VERSION = '0.12';
 
-BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
-use AnyDBM_File;
-use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
-
 my $DENYMSG        = "This mail is temporarily denied";
-my ($QPHOME)       = ($0 =~ m!(.*?)/([^/]+)$!);
-my $DB             = "greylist.dbm";
 my %PERMITTED_ARGS = map { $_ => 1 } qw(per_recipient remote_ip sender
   recipient black_timeout grey_timeout white_timeout deny_late db_dir
   nfslock p0f reject loglevel geoip upgrade );
@@ -224,6 +218,7 @@ sub register {
     else {
         $self->register_hook('rcpt', 'rcpt_handler');
     }
+    $self->init_db();
     $self->prune_db();
     if ($self->{_args}{upgrade}) {
         $self->convert_db();
@@ -231,6 +226,25 @@ sub register {
     $self->load_exclude_files();
 }
 
+sub init_db {
+    my ( $self ) = @_;
+    $self->db( name => 'greylist' );
+    return if ! $self->db->can('path');
+    my $cdir = $self->{_args}{db_dir};
+    $cdir = $1 if $cdir and $cdir =~ m{^([-a-zA-Z0-9./_]+)$};
+    # greylisting-specific hints for where to store the greylist DB
+    my $db_dir = $self->db->dir( $cdir, '/var/lib/qpsmtpd/greylisting' );
+
+    return if $self->db->file_extension ne '.dbm';
+    $self->db->nfs_locking( $self->{_args}{nfslock} );
+    
+    # Work around old DBM filename
+    return if -f "$db_dir/greylist.dbm";
+    my $oldname = 'denysoft_greylist';
+    return if ! -f "$db_dir/$oldname.dbm";
+    $self->db->name($oldname);
+}
+
 sub load_exclude_files {
     my ( $self ) = @_;
     $self->load_exclude_file($_) for $self->qp->config('greylist_exclude_files');
@@ -337,30 +351,30 @@ sub greylist {
 
     return DECLINED if $self->exclude();
 
-    my $db   = $self->get_dbm_location();
+
-    my $lock = $self->get_dbm_lock($db) or return DECLINED;
-    my $tied = $self->get_dbm_tie($db, $lock) or return DECLINED;
     my $key  = $self->get_greylist_key($sender, $rcpt) or return DECLINED;
 
     my $fmt = "%s:%d:%d:%d";
 
+    $self->db->lock or return DECLINED;
+    my $value = $self->db->get($key);
+    if ( ! $value ) {
         # new IP or entry timed out - record new
-    if (!$tied->{$key}) {
+        $self->db->set( $key, sprintf $fmt, time, 1, 0, 0 );
-        $tied->{$key} = sprintf $fmt, time, 1, 0, 0;
         $self->log(LOGWARN, "fail: initial DENYSOFT, unknown");
-        return $self->cleanup_and_return($tied, $lock);
+        return $self->cleanup_and_return();
     }
 
-    my ($ts, $new, $black, $white) = split /:/, $tied->{$key};
+    my ( $ts, $new, $black, $white ) = split /:/, $value;
     $self->log(LOGDEBUG, "ts: " . localtime($ts) . ", now: " . localtime);
 
     if ($white) {
 
         # white IP - accept unless timed out
         if (time - $ts < $config->{white_timeout}) {
-            $tied->{$key} = sprintf $fmt, time, $new, $black, ++$white;
+            $self->db->set( $key, sprintf $fmt, time, $new, $black, ++$white );
             $self->log(LOGINFO, "pass: white, $white deliveries");
-            return $self->cleanup_and_return($tied, $lock, DECLINED);
+            return $self->cleanup_and_return(DECLINED);
         }
         else {
             $self->log(LOGINFO, "key $key has timed out (white)");
@@ -369,28 +383,27 @@ sub greylist {
 
     # Black IP - deny, but don't update timestamp
     if (time - $ts < $config->{black_timeout}) {
-        $tied->{$key} = sprintf $fmt, $ts, $new, ++$black, 0;
+        $self->db->set( $key, sprintf $fmt, $ts, $new, ++$black, 0 );
         $self->log(LOGWARN,
                    "fail: black DENYSOFT - $black deferred connections");
-        return $self->cleanup_and_return($tied, $lock);
+        return $self->cleanup_and_return();
     }
 
     # Grey IP - accept unless timed out
     elsif (time - $ts < $config->{grey_timeout}) {
-        $tied->{$key} = sprintf $fmt, time, $new, $black, 1;
+        $self->db->set( $key, sprintf $fmt, time, $new, $black, 1 );
         $self->log(LOGWARN, "pass: updated grey->white");
-        return $self->cleanup_and_return($tied, $lock, DECLINED);
+        return $self->cleanup_and_return(DECLINED);
     }
 
     $self->log(LOGWARN, "pass: timed out (grey)");
-    return $self->cleanup_and_return($tied, $lock, DECLINED);
+    return $self->cleanup_and_return(DECLINED);
 }
 
 sub cleanup_and_return {
-    my ($self, $tied, $lock, $return_val) = @_;
+    my ($self, $return_val) = @_;
 
-    untie $tied;
+    $self->db->unlock;
-    close $lock;
     return $return_val if defined $return_val;    # explicit override
     return DECLINED
       if defined $self->{_args}{reject} && !$self->{_args}{reject};
@@ -417,137 +430,45 @@ sub get_greylist_key {
     return join ':', @key;
 }
 
-sub get_dbm_tie {
-    my ($self, $db, $lock) = @_;
-
-    tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, oct('0600')) or do {
-        $self->log(LOGCRIT, "tie to database $db failed: $!");
-        close $lock;
-        return;
-    };
-    return \%db;
-}
-
-sub get_dbm_location {
-    my $self = shift;
-
-    my $transaction = $self->qp->transaction;
-    my $config      = $self->{_args};
-
-    if ($config->{db_dir} && $config->{db_dir} =~ m{^([-a-zA-Z0-9./_]+)$}) {
-        $config->{db_dir} = $1;
-    }
-
-    my @candidate_dirs = (
-                          $config->{db_dir},
-                          "/var/lib/qpsmtpd/greylisting",
-                          "$QPHOME/var/db", "$QPHOME/config", '.'
-                         );
-
-    my $dbdir;
-    for my $d (@candidate_dirs) {
-        next if !$d || !-d $d;    # impossible
-        $dbdir = $d;
-        last;                     # first match wins
-    }
-    my $db = "$dbdir/$DB";
-    if (!-f $db && -f "$dbdir/denysoft_greylist.dbm") {
-        $db = "$dbdir/denysoft_greylist.dbm";    # old DB name
-    }
-    $self->log(LOGDEBUG, "using $db as greylisting database");
-    return $db;
-}
-
-sub get_dbm_lock {
-    my ($self, $db) = @_;
-
-    return $self->get_dbm_lock_nfs($db) if $self->{_args}{nfslock};
-
-    # Check denysoft db
-    open(my $lock, '>', "$db.lock") or do {
-        $self->log(LOGCRIT, "opening lockfile failed: $!");
-        return;
-    };
-
-    flock($lock, LOCK_EX) or do {
-        $self->log(LOGCRIT, "flock of lockfile failed: $!");
-        close $lock;
-        return;
-    };
-
-    return $lock;
-}
-
-sub get_dbm_lock_nfs {
-    my ($self, $db) = @_;
-
-    require File::NFSLock;
-
-    ### set up a lock - lasts until object looses scope
-    my $nfslock = new File::NFSLock {
-                             file               => "$db.lock",
-                             lock_type          => LOCK_EX | LOCK_NB,
-                             blocking_timeout   => 10,                  # 10 sec
-                             stale_lock_timeout => 30 * 60,             # 30 min
-                                    }
-      or do {
-        $self->log(LOGCRIT, "nfs lockfile failed: $!");
-        return;
-      };
-
-    open(my $lock, '+<', "$db.lock") or do {
-        $self->log(LOGCRIT, "opening nfs lockfile failed: $!");
-        return;
-    };
-
-    return $lock;
-}
-
 sub convert_db {
     my $self = shift;
 
-    my $db    = $self->get_dbm_location();
+    $self->db->lock or return DECLINED;
-    my $lock  = $self->get_dbm_lock($db) or return DECLINED;
+    my $count = $self->db->size;
-    my $tied  = $self->get_dbm_tie($db, $lock) or return DECLINED;
-    my $count = keys %$tied;
 
     my $converted = 0;
-    foreach my $key (keys %$tied) {
+    foreach my $key ( $self->db->get_keys ) {
         my (@parts) = split /:/, $key;
         next if $parts[0] =~ /^[\d]+$/;    # already converted
         $converted++;
         my $nip = Net::IP->new($parts[0]);
         $parts[0] = $nip->intip;           # convert IP to integer
         my $new_key = join ':', @parts;
-        $tied->{$new_key} = $tied->{$key};
+        $self->db->set( $new_key, $self->db->get($key) );
-        delete $tied->{$key};
+        $self->db->delete( $key );
     }
-    untie $tied;
+    $self->db->unlock;
-    close $lock;
     $self->log(LOGINFO, "converted $converted of $count DB entries");
-    return $self->cleanup_and_return($tied, $lock, DECLINED);
+    return $self->cleanup_and_return(DECLINED);
 }
 
 sub prune_db {
     my $self = shift;
 
-    my $db    = $self->get_dbm_location();
+    $self->db->lock or return DECLINED;
-    my $lock  = $self->get_dbm_lock($db) or return DECLINED;
+    my $count = $self->db->size;
-    my $tied  = $self->get_dbm_tie($db, $lock) or return DECLINED;
-    my $count = keys %$tied;
 
     my $pruned = 0;
-    foreach my $key (keys %$tied) {
+    foreach my $key ( $self->db->get_keys ) {
-        my ($ts, $new, $black, $white) = split /:/, $tied->{$key};
+        my ($ts, $new, $black, $white) = split /:/, $self->db->get($key);
         my $age = time - $ts;
         next if $age < $self->{_args}{white_timeout};
         $pruned++;
-        delete $tied->{$key};
+        $self->db->delete($key);
     }
-    untie $tied;
+    $self->db->unlock;
-    close $lock;
     $self->log(LOGINFO, "pruned $pruned of $count DB entries");
-    return $self->cleanup_and_return($tied, $lock, DECLINED);
+    return $self->cleanup_and_return(DECLINED);
 }
 
 sub exclude {

plugins/karma

@@ -231,9 +231,6 @@ use warnings;
 
 use Qpsmtpd::Constants;
 
-BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
-use AnyDBM_File;
-use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
 use Net::IP;
 
 sub register {
@@ -248,6 +245,7 @@ sub register {
         $self->{_args}{reject} = 'naughty';
     }
 
+    $self->init_db();
     #$self->prune_db();    # keep the DB compact
     $self->register_hook('connect',       'connect_handler');
     $self->register_hook('mail',          'from_handler');
@@ -257,6 +255,18 @@ sub register {
     $self->register_hook('disconnect',    'disconnect_handler');
 }
 
+sub init_db {
+    my ( $self ) = @_;
+    $self->db( name => 'karma' );
+    return if ! $self->db->can('path');
+    my $cdir = $self->{_args}{db_dir};
+    # karma-specific hints for where to store the DB
+    $self->db->dir( $cdir, '/var/lib/qpsmtpd/karma' );
+
+    return if $self->db->file_extension ne '.dbm';
+    $self->db->nfs_locking( $self->{_args}{nfslock} );
+}
+
 sub hook_pre_connection {
     my ($self, $transaction, %args) = @_;
 
@@ -264,23 +274,22 @@ sub hook_pre_connection {
 
     my $remote_ip = $args{remote_ip};
 
-    my $db   = $self->get_dbm_location();
+    $self->db->lock or return DECLINED;
-    my $lock = $self->get_dbm_lock($db) or return DECLINED;
-    my $tied = $self->get_dbm_tie($db, $lock) or return DECLINED;
     my $key  = $self->get_karma_key($remote_ip) or do {
         $self->log(LOGINFO, "skip, unable to get DB key");
         return DECLINED;
     };
 
-    if (!$tied->{$key}) {
+    my $value = $self->db->get($key);
+    if ( ! $value ) {
         $self->log(LOGDEBUG, "pass, no record");
-        return $self->cleanup_and_return($tied, $lock);
+        return $self->cleanup_and_return();
     }
 
     my ($penalty_start_ts, $naughty, $nice, $connects) =
-      $self->parse_db_record($tied->{$key});
+      $self->parse_db_record($value);
     $self->calc_karma($naughty, $nice);
-    return $self->cleanup_and_return($tied, $lock);
+    return $self->cleanup_and_return();
 }
 
 sub connect_handler {
@@ -290,37 +299,36 @@ sub connect_handler {
 
     return DECLINED if $self->is_immune();
 
-    my $db   = $self->get_dbm_location();
+    $self->db->lock or return DECLINED;
-    my $lock = $self->get_dbm_lock($db) or return DECLINED;
-    my $tied = $self->get_dbm_tie($db, $lock) or return DECLINED;
     my $key  = $self->get_karma_key() or do {
         $self->log(LOGINFO, "skip, unable to get DB key");
         return DECLINED;
     };
 
-    if (!$tied->{$key}) {
+    my $value = $self->db->get($key);
+    if ( ! $value) {
         $self->log(LOGINFO, "pass, no record");
-        return $self->cleanup_and_return($tied, $lock);
+        return $self->cleanup_and_return();
     }
 
     my ($penalty_start_ts, $naughty, $nice, $connects) =
-      $self->parse_db_record($tied->{$key});
+      $self->parse_db_record($value);
     my $summary = "$naughty naughty, $nice nice, $connects connects";
     my $karma = $self->calc_karma($naughty, $nice);
 
     if (!$penalty_start_ts) {
         $self->log(LOGINFO, "pass, no penalty ($summary)");
-        return $self->cleanup_and_return($tied, $lock);
+        return $self->cleanup_and_return();
     }
 
     my $days_old = (time - $penalty_start_ts) / 86400;
     if ($days_old >= $self->{_args}{penalty_days}) {
         $self->log(LOGINFO, "pass, penalty expired ($summary)");
-        return $self->cleanup_and_return($tied, $lock);
+        return $self->cleanup_and_return();
     }
 
-    $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
+    $self->db->set( $key, join(':', $penalty_start_ts, $naughty, $nice, ++$connects) );
-    $self->cleanup_and_return($tied, $lock);
+    $self->cleanup_and_return();
 
     my $left = sprintf "%.2f", $self->{_args}{penalty_days} - $days_old;
     my $mess = "You were naughty. You cannot connect for $left more days.";
@@ -414,13 +422,11 @@ sub disconnect_handler {
         return DECLINED;
     };
 
-    my $db   = $self->get_dbm_location();
+    $self->db->lock or return DECLINED;
-    my $lock = $self->get_dbm_lock($db) or return DECLINED;
-    my $tied = $self->get_dbm_tie($db, $lock) or return DECLINED;
     my $key  = $self->get_karma_key();
 
     my ($penalty_start_ts, $naughty, $nice, $connects) =
-      $self->parse_db_record($tied->{$key});
+      $self->parse_db_record( $self->db->get($key) );
     my $history = ($nice || 0) - $naughty;
     my $log_mess = '';
 
@@ -450,8 +456,8 @@ sub disconnect_handler {
     }
     $self->log(LOGINFO, $log_mess . ", (msg: $karma, his: $history)");
 
-    $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
+    $self->db->set( $key, join(':', $penalty_start_ts, $naughty, $nice, ++$connects) );
-    return $self->cleanup_and_return($tied, $lock);
+    return $self->cleanup_and_return();
 }
 
 sub illegal_envelope_format {
@@ -489,10 +495,9 @@ sub calc_karma {
 }
 
 sub cleanup_and_return {
-    my ($self, $tied, $lock, $return_val) = @_;
+    my ( $self, $return_val ) = @_;
 
-    untie $tied;
+    $self->db->unlock;
-    close $lock;
     return $return_val if defined $return_val;    # explicit override
     return DECLINED;
 }
@@ -507,103 +512,21 @@ sub get_karma_key {
     return $nip->intip;                             # convert IP to an int
 }
 
-sub get_dbm_tie {
-    my ($self, $db, $lock) = @_;
-
-    tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do {
-        $self->log(LOGCRIT, "error, tie to database $db failed: $!");
-        close $lock;
-        return;
-    };
-    return \%db;
-}
-
-sub get_dbm_location {
-    my $self = shift;
-
-    # Setup database location
-    my ($QPHOME) = ($0 =~ m!(.*?)/([^/]+)$!);
-    my @candidate_dirs = (
-                          $self->{args}{db_dir},
-                          "/var/lib/qpsmtpd/karma", "$QPHOME/var/db",
-                          "$QPHOME/config", '.'
-                         );
-
-    my $dbdir;
-    for my $d (@candidate_dirs) {
-        next if !$d || !-d $d;    # impossible
-        $dbdir = $d;
-        last;                     # first match wins
-    }
-    my $db = "$dbdir/karma.dbm";
-    $self->log(LOGDEBUG, "using $db as karma database");
-    return $db;
-}
-
-sub get_dbm_lock {
-    my ($self, $db) = @_;
-
-    return $self->get_dbm_lock_nfs($db) if $self->{_args}{nfslock};
-
-    # Check denysoft db
-    open(my $lock, ">$db.lock") or do {
-        $self->log(LOGCRIT, "error, opening lockfile failed: $!");
-        return;
-    };
-
-    flock($lock, LOCK_EX) or do {
-        $self->log(LOGCRIT, "error, flock of lockfile failed: $!");
-        close $lock;
-        return;
-    };
-
-    return $lock;
-}
-
-sub get_dbm_lock_nfs {
-    my ($self, $db) = @_;
-
-    require File::NFSLock;
-
-    ### set up a lock - lasts until object looses scope
-    my $nfslock = new File::NFSLock {
-                             file               => "$db.lock",
-                             lock_type          => LOCK_EX | LOCK_NB,
-                             blocking_timeout   => 10,                  # 10 sec
-                             stale_lock_timeout => 30 * 60,             # 30 min
-                                    }
-      or do {
-        $self->log(LOGCRIT, "error, nfs lockfile failed: $!");
-        return;
-      };
-
-    open(my $lock, "+<$db.lock") or do {
-        $self->log(LOGCRIT, "error, opening nfs lockfile failed: $!");
-        return;
-    };
-
-    return $lock;
-}
-
 sub prune_db {
     my $self = shift;
 
-    my $db    = $self->get_dbm_location();
+    $self->db->lock or return DECLINED;
-    my $lock  = $self->get_dbm_lock($db) or return DECLINED;
+    my $count = $self->db->size;
-    my $tied  = $self->get_dbm_tie($db, $lock) or return DECLINED;
-    my $count = keys %$tied;
 
     my $pruned = 0;
-    foreach my $key (keys %$tied) {
+    foreach my $key ( $self->db->get_keys ) {
-        my $ts       = $tied->{$key};
+        my $ts       = $self->db->get($key);
         my $days_old = (time - $ts) / 86400;
         next if $days_old < $self->{_args}{penalty_days} * 2;
-        delete $tied->{$key};
+        $self->delete($key);
         $pruned++;
     }
-    untie $tied;
-    close $lock;
     $self->log(LOGINFO, "pruned $pruned of $count DB entries");
-    return $self->cleanup_and_return($tied, $lock, DECLINED);
+    return $self->cleanup_and_return(DECLINED);
 }
 

plugins/karma_tool

@@ -4,13 +4,13 @@ package Karma;
 use strict;
 use warnings;
 
-BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
-use AnyDBM_File;
 use Data::Dumper;
-use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
 use Net::IP qw(:PROC);
 use POSIX qw(strftime);
 
+use lib 'lib';
+use Qpsmtpd::DB;
+
 my $self = bless({args => {db_dir => 'config'},}, 'Karma');
 my $command = $ARGV[0];
 
@@ -57,6 +57,18 @@ EO_HELP
       ;
 }
 
+sub db {
+    my ( $self ) = @_;
+    return $self->{db} if $self->{db};
+    $self->{db} = Qpsmtpd::DB->new( name => 'karma' );
+    $self->{db}->dir(
+        $self->{args}{db_dir},
+        qw( /var/lib/qpsmtpd/karma ./var/db ./config . ) );
+    my $path = $self->{db}->path;
+    print "using karma db at $path\n";
+    return $self->{db};
+}
+
 sub capture {
     my $self = shift;
     my $ip = shift or return;
@@ -65,16 +77,14 @@ sub capture {
         return;
     };
 
-    my $db   = $self->get_dbm_location();
+    $self->db->lock;
-    my $lock = $self->get_dbm_lock($db) or return;
-    my $tied = $self->get_dbm_tie($db, $lock) or return;
     my $key  = $self->get_karma_key($ip);
 
     my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
-      $tied->{$key};
+      $self->db->get( $key );
 
-    $tied->{$key} = join(':', time, $naughty + 1, $nice, $connects);
+    $self->db->set( $key, join(':', time, $naughty + 1, $nice, $connects) );
-    return $self->cleanup_and_return($tied, $lock);
+    $self->db->unlock;
 }
 
 sub release {
@@ -82,28 +92,26 @@ sub release {
     my $ip = shift or return;
     is_ip($ip) or do { warn "not an IP: $ip\n"; return; };
 
-    my $db   = $self->get_dbm_location();
+    $self->db->lock;
-    my $lock = $self->get_dbm_lock($db) or return;
-    my $tied = $self->get_dbm_tie($db, $lock) or return;
     my $key  = $self->get_karma_key($ip);
 
     my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
-      $tied->{$key};
+      $self->db->get( $key );
 
-    $tied->{$key} = join(':', 0, 0, $nice, $connects);
+    $self->db->set( $key, join(':', 0, 0, $nice, $connects) );
-    return $self->cleanup_and_return($tied, $lock);
+    $self->db->unlock;
 }
 
 sub show_ip {
     my $self = shift;
     my $ip   = shift or return;
-    my $db   = $self->get_dbm_location();
+    $self->db->lock;
-    my $lock = $self->get_dbm_lock($db) or return;
+
-    my $tied = $self->get_dbm_tie($db, $lock) or return;
     my $key  = $self->get_karma_key($ip);
 
     my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
-      $tied->{$key};
+      $self->db->get( $key );
+    $self->db->unlock;
     $naughty  ||= 0;
     $nice     ||= 0;
     $connects ||= 0;
@@ -122,17 +130,15 @@ sub show_ip {
 sub main {
     my $self = shift;
 
-    my $db   = $self->get_dbm_location();
+    $self->db->lock;
-    my $lock = $self->get_dbm_lock($db) or return;
-    my $tied = $self->get_dbm_tie($db, $lock) or return;
     my %totals;
 
     print
 "      IP Address                 Penalty        Naughty  Nice  Connects  Hostname\n";
-    foreach my $r (sort keys %$tied) {
+    foreach my $r ( $self->db->get_keys ) {
         my $ip = ip_bintoip(ip_inttobin($r, 4), 4);
         my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/,
-          $tied->{$r};
+          $self->db->get( $r );
         $naughty  ||= '';
         $nice     ||= '';
         $connects ||= '';
@@ -167,6 +173,7 @@ sub main {
         $totals{nice}     += $nice     if $nice;
         $totals{connects} += $connects if $connects;
     }
+    $self->db->unlock;
     print Dumper(\%totals);
 }
 
@@ -176,114 +183,28 @@ sub is_ip {
     return 1;
 }
 
-sub cleanup_and_return {
-    my ($self, $tied, $lock) = @_;
-    untie $tied;
-    close $lock;
-}
-
 sub get_karma_key {
     my $self = shift;
     my $nip = Net::IP->new(shift) or return;
     return $nip->intip;    # convert IP to an int
 }
 
-sub get_dbm_tie {
-    my ($self, $db, $lock) = @_;
-
-    tie(my %db, 'AnyDBM_File', $db, O_CREAT | O_RDWR, 0600) or do {
-        warn "tie to database $db failed: $!";
-        close $lock;
-        return;
-    };
-    return \%db;
-}
-
-sub get_dbm_location {
-    my $self = shift;
-
-    # Setup database location
-    my @candidate_dirs = (
-                          $self->{args}{db_dir},
-                          "/var/lib/qpsmtpd/karma", "./var/db", "./config", '.'
-                         );
-
-    my $dbdir;
-    for my $d (@candidate_dirs) {
-        next if !$d || !-d $d;    # impossible
-        $dbdir = $d;
-        last;                     # first match wins
-    }
-    my $db = "$dbdir/karma.dbm";
-    print "using karma db at $db\n";
-    return $db;
-}
-
-sub get_dbm_lock {
-    my ($self, $db) = @_;
-
-    return $self->get_dbm_lock_nfs($db) if $self->{_args}{nfslock};
-
-    # Check denysoft db
-    open(my $lock, ">$db.lock") or do {
-        warn "opening lockfile failed: $!";
-        return;
-    };
-
-    flock($lock, LOCK_EX) or do {
-        warn "flock of lockfile failed: $!";
-        close $lock;
-        return;
-    };
-
-    return $lock;
-}
-
-sub get_dbm_lock_nfs {
-    my ($self, $db) = @_;
-
-    require File::NFSLock;
-
-    ### set up a lock - lasts until object looses scope
-    my $nfslock = new File::NFSLock {
-                             file               => "$db.lock",
-                             lock_type          => LOCK_EX | LOCK_NB,
-                             blocking_timeout   => 10,                  # 10 sec
-                             stale_lock_timeout => 30 * 60,             # 30 min
-                                    }
-      or do {
-        warn "nfs lockfile failed: $!";
-        return;
-      };
-
-    open(my $lock, "+<$db.lock") or do {
-        warn "opening nfs lockfile failed: $!";
-        return;
-    };
-
-    return $lock;
-}
-
 sub prune_db {
     my $self       = shift;
     my $prune_days = shift;
 
-    my $db    = $self->get_dbm_location();
+    $self->db->lock;
-    my $lock  = $self->get_dbm_lock($db) or return;
+    my $count = $self->db->size;
-    my $tied  = $self->get_dbm_tie($db, $lock) or return;
-    my $count = keys %$tied;
 
     my $pruned = 0;
-    foreach my $key (keys %$tied) {
+    foreach my $key ( $self->db->get_keys ) {
-        my ($ts, $naughty, $nice, $connects) = split /:/, $tied->{$key};
+        my ($ts, $naughty, $nice, $connects) = split /:/, $self->db->get( $key );
         my $days_old = (time - $ts) / 86400;
         next if $days_old < $prune_days;
-        delete $tied->{$key};
+        $self->db->delete( $key );
         $pruned++;
     }
-    untie $tied;
+    $self->db->unlock;
-    close $lock;
     warn "pruned $pruned of $count DB entries";
-    return $self->cleanup_and_return($tied, $lock);
 }
 

t/plugin_tests/greylisting

@@ -19,7 +19,6 @@ sub register_tests {
     $self->register_test("test_load_exclude_files");
     $self->register_test('test_hook_data');
     $self->register_test('test_get_greylist_key');
-    $self->register_test('test_get_dbm_location');
     $self->register_test('test_exclude');
     $self->register_test("test_greylist_geoip");
     $self->register_test("test_greylist_p0f_genre");
@@ -130,13 +129,6 @@ sub test_get_greylist_key {
     cmp_ok( $key, 'eq', "3232235777:$test_email:$test_email", "db key: $key");
 }
 
-sub test_get_dbm_location {
-    my $self = shift;
-
-    my $db = $self->get_dbm_location();
-    ok( $db, "db location: $db");
-}
-
 sub test_exclude {
     my ( $self ) = @_;