Merge pull request #176 from jaredj/redis

Qpsmtpd::DB::Redis

.gitignore

@@ -17,6 +17,8 @@ denysoft_greylist.dbm
 denysoft_greylist.dbm.lock
 greylist.dbm
 greylist.dbm.lock
+greylisting.dbm
+greylisting.dbm.lock
 
 /cover_db/
 .last_cover_stats

lib/Qpsmtpd/DB.pm

@@ -1,16 +1,34 @@
 package Qpsmtpd::DB;
 use strict;
 use warnings;
-use Qpsmtpd::DB::File::DBM;
+
+our @child_classes = qw(
+    Qpsmtpd::DB::Redis
+    Qpsmtpd::DB::File::DBM
+);
 
 sub new {
     my ( $class, %arg ) = @_;
-    # The only supported class just now
-    return bless { %arg }, 'Qpsmtpd::DB::File::DBM';
+    my @try_classes = @child_classes;
+    if ( my $manual_class = delete $arg{class} ) {
+        @try_classes = ( $manual_class );
+    }
+    my ( $child, @errors );
+    for my $child_class ( @try_classes ) {
+        eval "use $child_class";
+        eval {
+            $child = $child_class->new(%arg);
+        };
+        last if ! $@;
+        push @errors, "Couldn't load $child_class: $@";
+    }
+    return $child if $child;
+    die join( "\n", "Couldn't load any storage modules", @errors );
 }
 
 # noop default method for plugins that don't require locking
-sub get_lock { 1 }
+sub lock   { 1 }
+sub unlock { 1 }
 
 sub name {
     my ( $self, $name ) = @_;

lib/Qpsmtpd/DB/File/DBM.pm

@@ -8,6 +8,11 @@ BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
 use AnyDBM_File;
 use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
 
+sub new {
+    my ( $class, %arg ) = @_;
+    return bless {%arg}, $class;
+}
+
 sub file_extension {
     my ( $self, $extension ) = @_;
     return $self->{file_extension} ||= '.dbm';
@@ -152,4 +157,14 @@ sub delete {
     delete $tied->{$key};
 }
 
+sub flush {
+    my ( $self ) = @_;
+    my $tied = $self->{tied};
+    if ( ! $tied ) {
+        warn "DBM db not yet set up, flush() failed\n";
+        return;
+    }
+    delete $tied->{$_} for keys %$tied;
+}
+
 1;

lib/Qpsmtpd/DB/Redis.pm

@@ -0,0 +1,119 @@
+package Qpsmtpd::DB::Redis;
+use strict;
+use warnings;
+
+use parent 'Qpsmtpd::DB';
+
+sub new {
+    my ( $class, %args ) = @_;
+    my $self = bless {}, $class;
+    $self->name( delete $args{name} ) if defined $args{name};
+    $self->{redis_args} = {%args};
+    $self->init_db();
+    return $self;
+}
+
+sub init_redis {
+    my ( $self ) = @_;
+    # Stringy eval needed to allow 'use Qpmstpd::DB::Redis' to succeed
+    # even when Redis module is unavailable; mainly for testing
+    eval 'use Redis';
+    die $@ if $@;
+    my $redis = $self->{redis} = MyRedis->new( %{ $self->{redis_args} } );
+    $redis->selected(0);
+    return $redis;
+}
+
+sub init_db {
+    my ( $self ) = @_;
+    my $redis = $self->init_redis;
+    return if $redis->get('___smtpd_reserved___');
+    die "Redis DB at index 0 is already populated!" if $redis->dbsize;
+    $redis->set( ___smtpd_reserved___ => 1 );
+}
+
+sub redis {
+    my ( $self, $index ) = @_;
+    my $redis = $self->{redis} or die "redis(): redis was not initialized";
+    $index = $self->index if ! defined $index;
+    $redis->select( $index );
+    return $redis;
+}
+
+sub index {
+    # Get index of database where the current plugin's data should be stored
+    my ( $self ) = @_;
+    return $self->{index} if $self->{index};
+    my $redis   = $self->redis(0);
+    my %stores  = $redis->hgetall('smtpd_stores');
+    return $self->{index} = $stores{ $self->name } if $stores{ $self->name };
+    my %rstores = reverse %stores;
+    for my $index ( 1 .. 255 ) {
+        $redis->select($index);
+
+        # This index is earmarked for something else
+        next if exists $rstores{$index};
+
+        # This index is populated by something else
+        next if $redis->dbsize;
+
+        # We can populate this empty store
+        $self->redis(0)->hset( 'smtpd_stores', $self->name => $index );
+        return $self->{index} = $index;
+    }
+}
+
+sub get {
+    my ( $self, $key ) = @_;
+    if ( ! $key ) {
+        warn "No key provided, get() failed\n";
+        return;
+    }
+    return $self->redis->get($key);
+}
+
+sub set {
+    my ( $self, $key, $val ) = @_;
+    if ( ! $key ) {
+        warn "No key provided, set() failed\n";
+        return;
+    }
+    return $self->redis->set( $key, $val );
+}
+
+sub delete {
+    my ( $self, $key ) = @_;
+    if ( ! $key ) {
+        warn "No key provided, delete() failed\n";
+        return;
+    }
+    return $self->redis->del($key);
+}
+
+sub get_keys { shift->redis->keys('*') }
+sub size     { shift->redis->dbsize    }
+sub flush    { shift->redis->flushdb   }
+
+package MyRedis;
+eval "use parent 'Redis'";
+
+# With all the (necessary) redundant select() going on, let's track the
+# currently selected db and avoid the round trip when select() is a noop
+
+sub select {
+    my $self  = shift;
+    my ( $index ) = @_;
+    return if $index == $self->selected;
+    my $r = $self->SUPER::select(@_);
+    $self->selected( $index );
+    return $r;
+}
+
+sub selected {
+    my ( $self, $index ) = @_;
+    $self->{selected} = $index if defined $index;
+    return $self->{selected} if defined $self->{selected};
+    return -1;
+}
+
+1;

lib/Qpsmtpd/Plugin.pm

@@ -349,6 +349,7 @@ sub _register_standard_hooks {
 
 sub db {
     my ( $self, %arg ) = @_;
+    $arg{name} ||= $self->plugin_name;
     return $self->{db} ||= Qpsmtpd::DB->new(%arg);
 }
 

t/plugin_tests/greylisting

@@ -8,11 +8,6 @@ use Qpsmtpd::Constants;
 
 my $test_email = 'user@example.com';
 
-my @greydbs = qw( denysoft_greylist.dbm denysoft_greylist.dbm.lock );
-foreach ( @greydbs ) {
-    unlink $_ if -f $_;
-}
-
 sub register_tests {
     my $self = shift;
 
@@ -238,24 +233,38 @@ sub test_greylist {
     $self->connection->remote_ip('1.2.3.4');
     my $sender = Qpsmtpd::Address->new( "<$test_email>" );
     my $rcpt   = Qpsmtpd::Address->new( "<$test_email>" );
-    my $start = time() - 40 * 3600 * 24; # 40 days ago
-    $mocktime = $start;
-    is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
-        'DENYSOFT: This mail is temporarily denied',
-        'Initial connection attempt greylisted' );
-    $mocktime = $start + 60 * 49;
-    is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
-        'DENYSOFT: This mail is temporarily denied',
-        'Greylisted 49 minutes later' );
-    $mocktime = $start + 60 * 51;
-    is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
-        'DECLINED',
-        'Allowed 51 minutes later' );
-    $mocktime = $start + 60 * 52 + 36 * 3600 * 24;
-    $self->prune_db;
-    is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
-        'DENYSOFT: This mail is temporarily denied',
-        're-greylisted 36 days later' );
+    for my $test_class (@Qpsmtpd::DB::child_classes) {
+        delete $self->{db};
+        eval { $self->db( class => $test_class ) };
+        if ( $@ ) {
+            warn "Unable to test greylisting against $test_class: $@";
+            next;
+        }
+        $self->db->lock;
+        $self->db->flush;
+        $self->db->unlock;
+        my $start = time() - 40 * 3600 * 24; # 40 days ago
+        $mocktime = $start;
+        is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
+            'DENYSOFT: This mail is temporarily denied',
+            'Initial connection attempt greylisted' );
+        $mocktime = $start + 60 * 49;
+        is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
+            'DENYSOFT: This mail is temporarily denied',
+            'Greylisted 49 minutes later' );
+        $mocktime = $start + 60 * 51;
+        is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
+            'DECLINED',
+            'Allowed 51 minutes later' );
+        $mocktime = $start + 60 * 52 + 36 * 3600 * 24;
+        $self->prune_db;
+        is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
+            'DENYSOFT: This mail is temporarily denied',
+            're-greylisted 36 days later' );
+        $self->db->lock;
+        $self->db->flush;
+        $self->db->unlock;
+    }
 }
 
 {

t/qpsmtpd-db-file.t

@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 'lib';    # test lib/Qpsmtpd (vs site_perl)
+use lib 't';
+
+use_ok('Qpsmtpd::DB::File');
+
+__qphome();
+__validate_dir();
+__dir();
+
+done_testing();
+
+sub __qphome {
+    my $db = FakeDB->new;
+    is( $db->qphome, 't', 'qphome()' );
+}
+
+sub __validate_dir {
+    my $db = FakeDB->new;
+    is( $db->validate_dir(),      0, 'validate_dir(): false on no input' );
+    is( $db->validate_dir(undef), 0, 'validate_dir(): false on undef' );
+    is( $db->validate_dir('invalid'), 0,
+        'validate_dir(): false for non-existent directory' );
+    is( $db->validate_dir('t/config'), 1,
+        'validate_dir(): true for real directory' );
+}
+
+sub __dir {
+    my $db = FakeDB->new;
+    is( $db->dir(), 't/config', 'default directory' );
+    is( $db->dir('_invalid','t/Test'), 't/Test', 'skip invalid candidate dirs' );
+    $db->{dir} = '_cached';
+    is( $db->dir(), '_cached', 'cached directory' );
+    is( $db->dir('t/Test'), 't/Test', 'passing candidate dirs resets cache' );
+    is( $db->dir('_invalid'), 't/config', 'invalid candidate dirs reverts to default' );
+}
+
+package FakeDB;
+use parent 'Qpsmtpd::DB::File';
+sub new {
+    my $class = shift;
+    return bless {@_}, $class;
+}

t/qpsmtpd-db-redis.t

@@ -0,0 +1,179 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 'lib';    # test lib/Qpsmtpd (vs site_perl)
+use lib 't';
+
+use_ok('Qpsmtpd::DB::Redis');
+
+my $db;
+eval 'use Redis; Redis->new';
+if ( $@ ) {
+    warn "Could not connect to redis to test; using mock redis";
+    $db = bless { name => 'testing', redis => FakeRedis->new }, 'Qpsmtpd::DB::Redis';
+}
+else {
+    Redis->new->flushall;
+    $db = Qpsmtpd::DB::Redis->new( name => 'testing' );
+
+    __new();
+
+}
+
+__index();
+__redis();
+__get();
+__set();
+__delete();
+__get_keys();
+__size();
+__flush();
+
+done_testing();
+
+sub __new {
+    is( ref $db->{redis}, 'MyRedis', 'Redis object populated' );
+    my $redis = $db->{redis};
+    $redis->select(0);
+    is( $redis->get('___smtpd_reserved___'), 1, 'DB properly initialized' );
+    is( join( '|', $redis->keys('*') ), '___smtpd_reserved___',
+        'Nothing else has happened to DB yet' );
+}
+
+sub __redis {
+    $db->{redis}->flushall;
+    $db->{redis}->select(0);
+    delete $db->{index};
+    my $redis = $db->redis;
+    is( $redis->selected, 1, 'redis() selects the correct index' );
+}
+
+sub __index {
+    my $redis = $db->{redis};
+    $redis->flushall;
+    is( stores($db),  '',          'stores unpopulated initially' );
+    is( $db->{index}, undef,       'index cache unpopulated initially' );
+    is( $db->index,   1,           'get first index given an empty db' );
+    is( stores($db), 'testing=1',  'stores populated correctly for index=1' );
+    is( $db->{index}, 1,           'index is cached' );
+    $db->{index} = 999;
+    is( $db->index,   999,         'index cache is honored' );
+    delete $db->{index};
+    $redis->flushall;
+    $redis->select(0);
+    $redis->hset( 'smtpd_stores', testing => 99 );
+    is( $db->index,   99,          'redis zero table is honored' );
+    delete $db->{index};
+    $redis->flushall;
+    $redis->select(1);
+    $redis->set( bugus => 1 );
+    is( $db->index,   2,           'index() skips already-populated db' );
+    is( stores($db),  'testing=2', 'stores populated correclty for index=2' );
+    delete $db->{index};
+    $redis->flushall;
+    $redis->select(0);
+    $redis->hset( 'smtpd_stores', foo => 1 );
+    $redis->hset( 'smtpd_stores', bar => 2 );
+    is( $db->index,   3,           'index() skips already-earmarked db' );
+}
+
+sub stores {
+    my $redis = $db->{redis};
+    $redis->select(0);
+    my %store = $redis->hgetall('smtpd_stores');
+    return join ';', map { "$_=$store{$_}" } keys %store;
+}
+
+sub __get {
+    my $redis = $db->redis;
+    $redis->flushdb;
+    $redis->set( moo => 'oooo' );
+    is( $db->get('moo'), 'oooo', 'get() retrieves key' );
+}
+
+sub __set {
+    my $redis = $db->redis;
+    $redis->flushdb;
+    $db->set( mee => 'ow' );
+    is( $redis->get('mee'), 'ow', 'set() stores key' );
+}
+
+sub __delete {
+    my $redis = $db->redis;
+    $redis->flushdb;
+    $redis->set( oink  => 1 );
+    $redis->set( quack => 1 );
+    $db->delete('quack');
+    is( join( '|', $redis->keys('*') ), 'oink', 'delete() removes key' );
+}
+
+sub __get_keys {
+    my $redis = $db->redis;
+    $redis->flushdb;
+    $redis->set( asdf   => 1 );
+    $redis->set( qwerty => 1 );
+    is( join( '|', sort $db->get_keys ), 'asdf|qwerty',
+        'get_keys() lists all keys in the db' );
+}
+
+sub __size {
+    my $redis = $db->redis;
+    $redis->flushdb;
+    $redis->set( baz  => 1 );
+    $redis->set( blah => 1 );
+    is( $db->size, 2, 'size() shows key count for db' );
+}
+
+sub __flush {
+    $db->redis->flushall;
+    my $redis = $db->redis;
+    $redis->flushdb;
+    $redis->set( bogus => 1 );
+    is( join( '|', $redis->keys('*') ), 'bogus', 'redis db populated' );
+    $db->flush;
+    is( join( '|', $redis->keys('*') ), '', 'flush() empties db' );
+}
+
+package FakeRedis;
+sub new {
+    my $class = shift;
+    return bless {@_}, $class;
+}
+
+sub flushall { delete $_[0]->{fakestore} }
+sub selected { $_[0]->{selected}         }
+sub select   { $_[0]->{selected} = $_[1] }
+sub dbsize   { scalar keys %{ $_[0]->fakestore }   }
+sub get      { $_[0]->fakestore->{ $_[1] }         }
+sub set      { $_[0]->fakestore->{ $_[1] } = $_[2] }
+sub del      { delete $_[0]->fakestore->{ $_[1] }  }
+
+sub hgetall  {
+    my ( $self, $h ) = @_;
+    return %{ $self->fakestore->{ $h } || {} };
+}
+
+sub hset {
+    my ( $self, $h, $key, $value ) = @_;
+    $self->fakestore->{ $h }{ $key } = $value;
+}
+
+sub keys {
+    my ( $self, $pattern ) = @_;
+    die "invalid pattern '$pattern': Mock Redis only understands '*'"
+        if $pattern ne '*';
+    return keys %{ $self->fakestore };
+}
+
+sub flushdb {
+    my ( $self ) = @_;
+    delete $self->{fakestore}{ $self->selected };
+}
+
+sub fakestore {
+    my ( $self ) = @_;
+    return $self->{fakestore}{ $self->selected } ||= {};
+}
+

t/qpsmtpd-db.t

@@ -0,0 +1,69 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 'lib';    # test lib/Qpsmtpd (vs site_perl)
+use lib 't';
+
+use_ok('Qpsmtpd::DB');
+use_ok('Qpsmtpd');
+
+__new();
+__lock();
+__unlock();
+__name();
+
+done_testing();
+
+sub __new {
+    @Qpsmtpd::DB::child_classes = qw(
+        BrokenClassOne
+        BrokenClassTwo
+    );
+    my $db;
+    eval { $db = Qpsmtpd::DB->new };
+    is( $@, "Couldn't load any storage modules\n"
+          . "Couldn't load BrokenClassOne: fool me once, shame on me\n\n"
+          . "Couldn't load BrokenClassTwo: fool me can't get fooled again\n",
+        'Detect failure to load all child DB classes' );
+    eval { $db = Qpsmtpd::DB->new( class => 'BrokenClassOne' ) };
+    is( $@, "Couldn't load any storage modules\n"
+          . "Couldn't load BrokenClassOne: fool me once, shame on me\n",
+        'Failure to load manual class' );
+    @Qpsmtpd::DB::child_classes = qw( EmptyClass );
+    eval { $db = Qpsmtpd::DB->new };
+    is( ref $db, 'EmptyClass',
+        'Load object with manual (bogus) class: Qpsmtpd object is returned' );
+}
+
+sub __lock {
+    @Qpsmtpd::DB::child_classes = qw( EmptyClass );
+    is( Qpsmtpd::DB->new->lock, 1, 'Default lock() method just returns true' );
+}
+
+sub __unlock {
+    @Qpsmtpd::DB::child_classes = qw( EmptyClass );
+    is( Qpsmtpd::DB->new->unlock, 1, 'Default lock() method just returns true' );
+}
+
+sub __name {
+    @Qpsmtpd::DB::child_classes = qw( EmptyClass );
+    my $db = Qpsmtpd::DB->new;
+    is( $db->name,          undef, 'no name set yet' );
+    is( $db->name('test'), 'test', 'set name' );
+    is( $db->name,         'test', 'get name' );
+}
+
+package BrokenClassOne;
+sub new { die "fool me once, shame on me\n" }
+
+package BrokenClassTwo;
+sub new { die "fool me can't get fooled again\n" }
+
+package EmptyClass;
+use parent 'Qpsmtpd::DB';
+sub new {
+    my $class = shift;
+    return bless {@_}, $class;
+}

t/qpsmtpd-plugin.t

@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 'lib';    # test lib/Qpsmtpd (vs site_perl)
+use lib 't';
+
+use_ok('Qpsmtpd::Plugin');
+
+__db();
+
+done_testing();
+
+sub __db {
+    my $plugin = FakePlugin->new;
+    my $db = $plugin->db( class => 'FakeDB', name => 'testfoo' );
+    is( ref $db, 'FakeDB', 'Qpsmtpd::Plugin::db(): Returns DB object' );
+    is( ref $plugin->{db}, 'FakeDB', 'DB object is cached' );
+    is( $db->{name}, 'testfoo', 'accepts name argument' );
+    delete $plugin->{db};
+    $db = $plugin->db( class => 'FakeDB' );
+    is( $db->{name}, 'testbar', 'name argument defaults to plugin name' );
+}
+
+package FakePlugin;
+use parent 'Qpsmtpd::Plugin';
+sub plugin_name { 'testbar' }
+
+package FakeDB;
+sub new {
+    my $class = shift;
+    return bless {@_}, $class;
+}