Merge pull request #84 from jaredj/per-recip-config

Add hook_user_config

docs/hooks.pod

@@ -712,26 +712,55 @@ Allowed return codes are
 
 plugin didn't find the requested value
 
-=item OK
+=item OK, @values
 
 requested values as C<@list>, example:
 
-  return (OK, @{$config{$value}}) 
-    if exists $config{$value};
+  return (OK, @{$config{$key}})
+    if exists $config{$key};
   return (DECLINED);
 
 =back
 
 Arguments:
 
-  my ($self,$transaction,$value) = @_; 
-  # $value: the requested config item(s)
+  my ($self,$transaction,@keys) = @_;
+  # @keys: the requested config item(s)
 
 B<NOTE:> C<$transaction> may be C<undef>, depending when / where this hook
 is called. It's probably best not to try acessing it.
 
 Example plugin is F<http_config> from the qpsmtpd distribution.
 
+=head2 hook_user_config
+
+Called when a per-user configuration directive is requested, for example
+if someone calls C<my @cfg = $rcpt-E<gt>config($cfg_name);>. 
+Allowed return codes are
+
+=over 4
+
+=item DECLINED
+
+plugin didn't find the requested value
+
+=item OK, @values
+
+requested values as C<@list>, example:
+
+  return (OK, @{$config{$key}})
+    if exists $config{$key};
+  return (DECLINED);
+
+=back
+
+Arguments:
+
+  my ($self,$transaction,$user,@keys) = @_;
+  # @keys: the requested config item(s)
+
+Example plugin is F<user_config> from the qpsmtpd distribution.
+
 =head2 hook_unrecognized_command
 
 This is called if the client sent a command unknown to the core of qpsmtpd.

lib/Qpsmtpd.pm

@@ -5,6 +5,7 @@ use vars qw($TraceLevel $Spool_dir $Size_threshold);
 
 use Sys::Hostname;
 use Qpsmtpd::Constants;
+use Qpsmtpd::Address;
 
 our $VERSION = "0.94";
 
@@ -145,44 +146,26 @@ sub config {
 
     $self->log(LOGDEBUG, "in config($c)");
 
-    # first try the cache
-    # XXX - is this always the right thing to do? what if a config hook
-    # can return different values on subsequent calls?
-    if ($_config_cache->{$c}) {
-        $self->log(LOGDEBUG,
-                   "config($c) returning (@{$_config_cache->{$c}}) from cache");
-        return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
-    }
-
-    # then run the hooks
-    my ($rc, @config) = $self->run_hooks_no_respond("config", $c);
-    $self->log(LOGDEBUG, "config($c): hook returned ($rc, @config) ");
-    if ($rc == OK) {
-        $self->log(LOGDEBUG,
-"setting _config_cache for $c to [@config] from hooks and returning it"
-        );
-        $_config_cache->{$c} = \@config;
-        return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
-    }
+    # first run the hooks
+    my ($rc, @config);
+    ($rc, @config) = $self->run_hooks_no_respond('user_config',$type,$c)
+        if ref $type and $type->can('address');
+    return wantarray ? @config : $config[0]
+        if defined $rc and $rc == OK;
+    ($rc, @config) = $self->run_hooks_no_respond('config',$c);
+    $self->log(LOGDEBUG, "config($c): hook returned ("
+        . join( ',', map { defined $_ ? $_ : 'undef' } ($rc,@config) ) . ")");
+    return wantarray ? @config : $config[0]
+        if defined $rc and $rc == OK;
 
     # and then get_qmail_config
     @config = $self->get_qmail_config($c, $type);
-    if (@config) {
-        $self->log(LOGDEBUG,
-"setting _config_cache for $c to [@config] from get_qmail_config and returning it"
-        );
-        $_config_cache->{$c} = \@config;
-        return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
-    }
+    return wantarray ? @config : $config[0]
+        if @config;
 
     # finally we use the default if there is any:
-    if (exists($defaults{$c})) {
-        $self->log(LOGDEBUG,
-"setting _config_cache for $c to @{[$defaults{$c}]} from defaults and returning it"
-        );
-        $_config_cache->{$c} = [$defaults{$c}];
-        return wantarray ? @{$_config_cache->{$c}} : $_config_cache->{$c}->[0];
-    }
+    return wantarray ? ($defaults{$c}) : $defaults{$c}
+        if exists $defaults{$c};
     return;
 }
 
@@ -666,6 +649,13 @@ sub auth_mechanism {
     return (defined $self->{_auth_mechanism} ? $self->{_auth_mechanism} : "");
 }
 
+sub address {
+    my $self = shift;
+    my $addr = Qpsmtpd::Address->new(@_);
+    $addr->qp($self);
+    return $addr;
+}
+
 1;
 
 __END__

lib/Qpsmtpd/Address.pm

@@ -338,6 +338,25 @@ sub notes {
     return $self->{_notes}->{$key} = shift;
 }
 
+=head2 config($value)
+
+Looks up a configuration directive based on this recipient, using any plugins that utilize
+hook_user_config
+
+=cut
+
+sub qp {
+    my $self = shift;
+    $self->{qp} = $_[0] if @_;
+    return $self->{qp};
+}
+
+sub config {
+    my ($self,$key) = @_;
+    my $qp = $self->qp or return;
+    return $qp->config($key,$self);
+}
+
 sub _addr_cmp {
     require UNIVERSAL;
     my ($left, $right, $swap) = @_;

lib/Qpsmtpd/Plugin.pm

@@ -9,7 +9,7 @@ use Qpsmtpd::Constants;
 
 # more or less in the order they will fire
 our @hooks = qw(
-  logging config post-fork pre-connection connect ehlo_parse ehlo
+  logging config user_config post-fork pre-connection connect ehlo_parse ehlo
   helo_parse helo auth_parse auth auth-plain auth-login auth-cram-md5
   rcpt_parse rcpt_pre rcpt mail_parse mail mail_pre
   data data_headers_end data_post queue_pre queue queue_post vrfy noop

lib/Qpsmtpd/SMTP.pm

@@ -15,7 +15,6 @@ use Qpsmtpd::Transaction;
 use Qpsmtpd::Plugin;
 use Qpsmtpd::Constants;
 use Qpsmtpd::Auth;
-use Qpsmtpd::Address ();
 use Qpsmtpd::Command;
 
 my %auth_mechanisms = ();
@@ -389,10 +388,10 @@ sub mail_pre_respond {
       unless $from =~ /^<.*>$/;
 
     if ($from eq "<>" or $from =~ m/\[undefined\]/ or $from eq "<#@[]>") {
-        $from = Qpsmtpd::Address->new("<>");
+        $from = $self->address("<>");
     }
     else {
-        $from = (Qpsmtpd::Address->parse($from))[0];
+        $from = $self->address($from);
     }
     return $self->respond(501, "could not parse your mail from command")
       unless $from;
@@ -480,7 +479,7 @@ sub rcpt_pre_respond {
     return $self->respond(501, "could not parse recipient")
       unless $rcpt =~ /^<.*>$/;
 
-    $rcpt = (Qpsmtpd::Address->parse($rcpt))[0];
+    $rcpt = $self->address($rcpt);
 
     return $self->respond(501, "could not parse recipient")
       if (!$rcpt or ($rcpt->format eq '<>'));

plugins/user_config

@@ -0,0 +1,51 @@
+#!perl
+use strict;
+use warnings;
+
+=head1 NAME
+
+user_config - basic plugin for storing per-user configuration directives
+
+=head1 SYNOPSIS
+
+# in config/plugins
+
+user_config [B<filename pattern>]
+
+=over 4
+
+=item B<config file search pattern>
+
+Pattern to use when searching for user config directory
+Substitute %u for username, %h for host, or %a for full addressn.
+Default: I</home/%u/.qpsmtpd/>
+
+=head1 DESCRIPTION
+
+This plugin implements very basic support for storing user configuration
+in separate directories similar to the global qpsmtpd config directory.
+
+=cut
+
+sub init {
+    my ( $self, $qp, $pattern ) = @_;
+    $self->{pattern} = $pattern || '/home/%u/.qpsmtpd';
+}
+
+sub hook_user_config {
+    my ($self,$txn,$addr,$conf) = @_;
+    my $path = $self->{pattern} or return DECLINED;
+    my ( $user, $host, $address ) = ( $addr->user, $addr->host, $addr->address );
+    $path =~ s/%u/$user/g;
+    $path =~ s/%h/$host/g;
+    $path =~ s/%a/$address/g;
+    my $filename = "$path/$conf";
+    return DECLINED unless -f $filename;
+    my $fh;
+    unless (open $fh,$filename) {
+        $self->log(LOGNOTICE,"Couldn't open $filename:$!");
+        return DECLINED;
+    }
+    map {chomp} (my @return = (<$fh>));
+    return OK,@return;
+}

t/plugin_tests/user_config

@@ -0,0 +1,50 @@
+#!perl -w
+
+use strict;
+use warnings;
+use File::Path;
+use Qpsmtpd::Constants;
+
+BEGIN {    # need this to happen before anything else
+    my $cwd = `pwd`;
+    chomp($cwd);
+    open my $spooldir, '>', "./config.sample/spool_dir";
+    print $spooldir "$cwd/t/tmp";
+    close $spooldir;
+}
+
+sub register_tests {
+    my ($self) = @_;
+    $self->register_test('test_hook_user_config', 4);
+}
+
+sub test_hook_user_config {
+    my ( $self ) = @_;
+    my $dirname = $self->qp->temp_dir;
+    $self->{pattern} = $dirname . '/%u_%h_%a';
+    $dirname .= '/testuser_testhost_testaddress';
+    -d $dirname
+        or mkdir($dirname, 0700)
+        or die "Could not create $dirname: $!";
+    open my $fh, '>', "$dirname/testfield";
+    print $fh "testdata";
+    close $fh;
+    my $a = FakeAddress->new( user => 'testuser', host => 'testhost', address => 'testaddress' );
+    my ( $r, $value ) = $self->hook_user_config( $self->qp->transaction, $a, 'testfield' );
+    is( $r, OK, 'hook_user_config returned OK when config file present' );
+    is( $value, 'testdata', 'hook_user_config returned the correct value' );
+    ( $r, $value ) = $self->hook_user_config( $self->qp->transaction, $a, 'noconfig' );
+    is( $r, DECLINED, 'hook_user_config returned DECLINED when no config file present' );
+    is( $value, undef, 'hook_user_config returned no value when no config file present' );
+    rmtree($dirname);
+}
+
+package FakeAddress;
+
+sub new {
+   shift;
+   return bless {@_};
+}
+sub address { return shift->{address} }
+sub user { return shift->{user} }
+sub host { return shift->{host} }

t/qpsmtpd-address.t

@@ -6,9 +6,12 @@ use Test::More;
 
 use lib 'lib';
 
-BEGIN {
-    use_ok('Qpsmtpd::Address');
-}
+BEGIN { use_ok('Qpsmtpd::Constants'); }
+use_ok('Qpsmtpd::Address');
+use lib 't';
+use_ok('Test::Qpsmtpd');
+
+__config();
 
 __new();
 __parse();
@@ -118,3 +121,43 @@ sub __parse {
     is($ao && $ao->address, $as, "address $as");
     ok($ao eq $as, "overloaded 'cmp' operator");
 };
+
+sub __config {
+    ok( my ($qp,$cxn) = Test::Qpsmtpd->new_conn(), "get new connection" );
+    ok( $qp->command('HELO test') );
+    ok( $qp->command('MAIL FROM:<test@example.com>') );
+    my $sender = $qp->transaction->sender;
+    my @test_data = (
+        {
+            pref     => 'size_threshold',
+            result   => [], 
+            expected => 10000,
+            descr    => 'fall back to global config when user_config is absent',
+        },
+        {
+            pref     => 'test_config',
+            result   => [], 
+            expected => undef,
+            descr    => 'return nothing when no user_config plugins exist',
+        },
+        {
+            pref     => 'test_config',
+            result   => [DECLINED], 
+            expected => undef,
+            descr    => 'return nothing when user_config plugins return DECLINED',
+        },
+        {
+            pref     => 'test_config',
+            result   => [OK,'test value'], 
+            expected => 'test value',
+            descr    => 'return results when user_config plugin returns a value',
+        },
+    );
+    for (@test_data) {
+        $qp->hooks->{user_config}
+            = @{ $_->{result} }
+                ? [{ name => 'test hook', code => sub { return @{ $_->{result} }} }]
+                : undef;
+        is( $sender->config($_->{pref}), $_->{expected}, $_->{descr} );
+    }
+}

t/qpsmtpd.t

@@ -6,8 +6,13 @@ use Data::Dumper;
 use Test::More;
 
 use lib 'lib';      # test lib/Qpsmtpd (vs site_perl)
-BEGIN { use_ok('Qpsmtpd'); }
-BEGIN { use_ok('Qpsmtpd::Constants'); }
+BEGIN {
+    use_ok('Qpsmtpd');
+    use_ok('Qpsmtpd::Constants');
+}
+
+use lib 't';
+use_ok('Test::Qpsmtpd');
 
 my $qp = bless {}, 'Qpsmtpd';
 
@@ -23,11 +28,6 @@ __load_logging();
 
 done_testing();
 
-sub __config {
-    my @r = $qp->config('badhelo');
-    ok( $r[0], "config, badhelo, @r");
-};
-
 sub __get_qmail_config {
     ok( !$qp->get_qmail_config('me'), "get_qmail_config, me");
 
@@ -83,3 +83,103 @@ sub __authenticated {
     $qp->{_auth} = 0;
     ok( !$qp->authenticated(), "authenticated, false");
 };
+
+sub __config {
+    my @r = $qp->config('badhelo');
+    ok( $r[0], "config, badhelo, @r");
+    my $a = FakeAddress->new( test => 'test value' );
+    ok( my ($qp,$cxn) = Test::Qpsmtpd->new_conn(), "get new connection" );
+    my @test_data = (
+        {
+            pref     => 'size_threshold',
+            hooks    => {
+                user_config => [],
+                config      => [],
+            },
+            expected => {
+                user   => 10000,
+                global => 10000,
+            },
+            descr    => 'no user or global config hooks, fall back to config file',
+        },
+        {
+            pref     => 'timeout',
+            hooks    => {
+                user_config => [],
+                config      => [],
+            },
+            expected => {
+                user   => 1200,
+                global => 1200,
+            },
+            descr    => 'no user or global config hooks, fall back to defaults',
+        },
+        {
+            pref     => 'timeout',
+            hooks    => {
+                user_config => [DECLINED],
+                config      => [DECLINED],
+            },
+            expected => {
+                user   => 1200,
+                global => 1200,
+            },
+            descr    => 'user and global config hooks decline, fall back to defaults',
+        },
+        {
+            pref     => 'timeout',
+            hooks    => {
+                user_config => [DECLINED],
+                config      => [OK,1000],
+            },
+            expected => {
+                user   => 1000,
+                global => 1000,
+            },
+            descr    => 'user hook declines, global hook returns',
+        },
+        {
+            pref     => 'timeout',
+            hooks    => {
+                user_config => [OK,500],
+                config      => [OK,undef],
+            },
+            expected => {
+                user   => 500,
+                global => undef,
+            },
+            descr    => 'user hook returns int, global hook returns undef',
+        },
+        {
+            pref     => 'timeout',
+            hooks    => {
+                user_config => [OK,undef],
+                config      => [OK,1000],
+            },
+            expected => {
+                user   => undef,
+                global => 1000,
+            },
+            descr    => 'user hook returns undef, global hook returns int',
+        },
+    );
+    for my $t (@test_data) {
+        for my $hook (qw( config user_config )) {
+             $qp->hooks->{$hook}
+                = @{ $t->{hooks}{$hook} }
+                    ? [{ name => 'test hook', code => sub { return @{ $t->{hooks}{$hook} }} }]
+                    : undef;
+        }
+        is( $qp->config($t->{pref},$a), $t->{expected}{user},   "User config: $t->{descr}");
+        is( $qp->config($t->{pref}),    $t->{expected}{global}, "Global config: $t->{descr}");
+    }
+}
+
+package FakeAddress;
+
+sub new {
+   shift;
+   return bless {@_};
+}
+
+sub address { } # pass the can('address') conditional