Merge pull request #34 from msimerson/master

apply pending commits from my fork

MANIFEST

@@ -78,8 +78,7 @@ plugins/check_bogus_bounce
 plugins/check_basicheaders
 plugins/check_earlytalker
 plugins/check_loop
-plugins/check_norelay
+plugins/relay
-plugins/check_relay
 plugins/check_spamhelo
 plugins/connection_time
 plugins/content_log
@@ -114,7 +113,6 @@ plugins/quit_fortune
 plugins/random_error
 plugins/rcpt_ok
 plugins/rcpt_regexp
-plugins/relay_only
 plugins/require_resolvable_fromhost
 plugins/rhsbl
 plugins/sender_permitted_from

config.sample/flat_auth_pw

@@ -1,2 +1,4 @@
+# used by plugins/auth/auth_flat_file
+# example entries
 good@example.com:good_pass
 bad@example.com:bad_pass

config.sample/norelayclients

@@ -0,0 +1,6 @@
+# used by plugins/relay
+# test entries - http://tools.ietf.org/html/rfc5737
+192.0.99.5
+192.0.99.6
+192.0.98.
+# add your own entries below...

config.sample/plugins

@@ -32,7 +32,7 @@ quit_fortune
 #tls
 check_earlytalker
 count_unrecognized_commands 4
-check_relay
+relay
 
 require_resolvable_fromhost
 
@@ -45,6 +45,10 @@ check_spamhelo
 # sender_permitted_from
 # greylisting p0f genre,windows
 
+#auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true
+#auth/auth_vpopmail
+#auth/auth_vpopmaild
+#auth/auth_vpopmail_sql
 auth/auth_flat_file
 auth/authdeny
 
@@ -85,6 +89,6 @@ dspam learn_from_sa 7 reject 1
 
 # If you need to run the same plugin multiple times, you can do
 # something like the following
-#    check_relay
+#    relay
-#    check_relay:0 somearg
+#    relay:0 somearg
-#    check_relay:1 someotherarg
+#    relay:1 someotherarg

config.sample/relayclients

@@ -1,5 +1,6 @@
+# used by plugins/relay
 # Format is IP, or IP part with trailing dot
 # e.g. "127.0.0.1", or "192.168."
 127.0.0.1 
 # leading/trailing whitespace is ignored
- 192.168. 
+ 192.0. 

config.sample/smtpauth-checkpassword

@@ -0,0 +1 @@
+/usr/local/vpopmail/bin/vchkpw /bin/true

lib/Qpsmtpd/Plugin.pm

@@ -210,6 +210,37 @@ sub compile {
     die "eval $@" if $@;
 }
 
+sub is_immune {
+    my $self = shift;
+
+    if ( $self->qp->connection->relay_client() ) {
+        # set by plugins/relay, or Qpsmtpd::Auth
+        $self->log(LOGINFO, "skip, relay client");
+        return 1;
+    };
+    if ( $self->qp->connection->notes('whitelisthost') ) {
+        # set by plugins/dns_whitelist_soft or plugins/whitelist
+        $self->log(LOGINFO, "skip, whitelisted host");
+        return 1;
+    };
+    if ( $self->qp->transaction->notes('whitelistsender') ) {
+        # set by plugins/whitelist
+        $self->log(LOGINFO, "skip, whitelisted sender");
+        return 1;
+    };
+    if ( $self->connection->notes('naughty') ) {
+        # see plugins/naughty
+        $self->log(LOGINFO, "skip, naughty");
+        return 1;
+    };
+    if ( $self->connection->notes('rejected') ) {
+        # http://www.steve.org.uk/Software/ms-lite/
+        $self->log(LOGINFO, "skip, already rejected");
+        return 1;
+    };
+    return;
+};
+
 sub _register_standard_hooks {
   my ($plugin, $qp) = @_;
 

lib/Qpsmtpd/Transaction.pm

@@ -358,7 +358,7 @@ the C<DATA> command. If you need the size that will be queued, use
    + $transaction->body_length;
 
 The line above is of course only valid in I<hook_queue( )>, as other plugins
-may add headers and qpsmtpd will add it's I<Received:> header.
+may add headers and qpsmtpd will add its I<Received:> header.
 
 =head2 body_length( )
 

plugins/auth/auth_checkpassword

@@ -124,6 +124,7 @@ sub auth_checkpassword {
 
     my $binary = $self->connection->notes('auth_checkpassword_bin');
     my $true = $self->connection->notes('auth_checkpassword_true');
+    chomp ($binary, $true);
 
     my $sudo = get_sudo($binary);
 

plugins/auth/auth_vpopmail

@@ -45,7 +45,7 @@ use warnings;
 use Qpsmtpd::Auth;
 use Qpsmtpd::Constants;
 
-#use vpopmail;    # we eval this in $test_vpopmail
+#use vpopmail;    # we eval this in $test_vpopmail_module
 
 sub register {
     my ($self, $qp) = @_;
@@ -86,7 +86,7 @@ sub test_vpopmail_module {
     my $self = shift;
 # vpopmail will not allow vauth_getpw to succeed unless the requesting user is vpopmail or root.
 # by default, qpsmtpd runs as the user 'qpsmtpd' and does not have permission.
-    eval "use vpopmail";
+    eval 'use vpopmail';
     if ( $@ ) {
         $self->log(LOGERROR, "skip: is vpopmail perl module installed?");
         return;

plugins/auth/auth_vpopmail_sql

@@ -69,11 +69,18 @@ use warnings;
 use Qpsmtpd::Auth;
 use Qpsmtpd::Constants;
 
-use DBI;
+#use DBI;  # done in ->register
 
 sub register {
     my ( $self, $qp ) = @_;
 
+    eval 'use DBI';
+    if ( $@ ) {
+        warn "plugin disabled. is DBI installed?\n";
+        $self->log(LOGERROR, "skip: plugin disabled. is DBI installed?\n");
+        return;
+    };
+
     $self->register_hook('auth-plain',    'auth_vmysql');
     $self->register_hook('auth-login',    'auth_vmysql');
     $self->register_hook('auth-cram-md5', 'auth_vmysql');

plugins/check_basicheaders

@@ -35,7 +35,7 @@ I would be surprised if a valid message ever had a date header older than a week
 
 Determine if the connection is denied. Use the I<reject 0> option when first enabling the plugin, and then watch your logs to see what would have been rejected. When you are no longer concerned that valid messages will be rejected, enable with I<reject 1>.
 
-  check_basicheaders [ reject 0 | 1 ]
+  check_basicheaders reject [ 0 | 1 ]
 
 Default policy is to reject.
 
@@ -116,7 +116,7 @@ sub hook_data_post {
 
     if ( ! $header->get('From') ) {
         $self->log(LOGINFO, "fail: no from");
-        return ($deny, "We require a valid From header")
+        return ($deny, "We require a valid From header");
     };
 
     my $date = $header->get('Date') or do {

plugins/check_norelay

@@ -1,58 +0,0 @@
-#!perl -w
-=pod
-
-=head1 SYNOPSIS
-
-This plugin checks the norelayclients config file to see if 
-relaying is denied.
-
-This allows specific clients, such as the gateway, to be denied 
-relaying, even though they would be allowed relaying by the 
-relayclients file.
-
-=head1 CONFIG
-
-config/norelayclients
-
-Each line is:
-- a full IP address
-- partial IP address terminated by a dot for matching whole networks
-  e.g. 192.168.42.
-
-=head1 BUGS AND LIMITATIONS
-
-This plugin does not have a more_norelayclients map equivalent
-of the more_relayclients map of the check_relay plugin.
-
-=head1 AUTHOR
-
-Based on check_relay plugin from the qpsmtpd distribution.
-
-Copyright 2005 Gordon Rowell <gordonr@gormand.com.au>
-
-This software is free software and may be distributed under the same
-terms as qpsmtpd itself.
-
-=cut
-
-sub hook_connect {
-  my ($self, $transaction) = @_;
-  my $connection = $self->qp->connection;
-
-  # Check if this IP is not allowed to relay
-  my @no_relay_clients = $self->qp->config("norelayclients");
-  my %no_relay_clients = map { $_ => 1 } @no_relay_clients;
-  my $client_ip = $self->qp->connection->remote_ip;
-  while ($client_ip) {
-    if ( exists($no_relay_clients{$client_ip}) )
-    {
-      $connection->relay_client(0);
-      delete $ENV{RELAYCLIENT};
-      $self->log(LOGNOTICE, "check_norelay: $client_ip denied relaying");
-      last;
-    }
-    $client_ip =~ s/\d+\.?$//; # strip off another 8 bits
-  }
-  
-  return (DECLINED);
-}

plugins/check_relay

@@ -1,83 +0,0 @@
-#!perl -w
-
-=head1 NAME
-
-check_relay
-
-=head1 SYNOPSIS
-
-Checks the relayclients config file and $ENV{RELAYCLIENT} to see if relaying is allowed.
-
-=cut
-
-use strict;
-use warnings;
-
-use Qpsmtpd::Constants;
-use Net::IP qw(:PROC);
-
-sub hook_connect {
-  my ($self, $transaction) = @_;
-  my $connection = $self->qp->connection;
-
-  # Check if this IP is allowed to relay
-  my $client_ip = $self->qp->connection->remote_ip;
-
-  # @crelay... for comparing, @srelay... for stripping
-  my (@crelay_clients, @srelay_clients);
-
-  my @relay_clients = $self->qp->config("relayclients");
-  for (@relay_clients) {
-    my ($range_ip, $range_prefix) = ip_splitprefix($_);
-    if($range_prefix){
-      # has a prefix, so due for comparing
-      push @crelay_clients, $_;
-    }
-    else {
-      # has no prefix, so due for splitting
-      push @srelay_clients, $_;
-    }
-  }
-  
-  if (@crelay_clients){
-    my ($range_ip, $range_prefix, $rversion, $begin, $end, $bin_client_ip);
-    my $cversion = ip_get_version($client_ip);
-    for (@crelay_clients) {
-      # Get just the IP from the CIDR range, to get the IP version, so we can
-      # get the start and end of the range
-      ($range_ip, $range_prefix) = ip_splitprefix($_);
-      $rversion = ip_get_version($range_ip);
-      ($begin, $end) = ip_normalize($_, $rversion);
-
-      # expand the client address (zero pad it) before converting to binary
-      $bin_client_ip = ip_iptobin(ip_expand_address($client_ip, $cversion), $cversion);
-
-      if (ip_bincomp($bin_client_ip, 'gt', ip_iptobin($begin, $rversion)) 
-        && ip_bincomp($bin_client_ip, 'lt', ip_iptobin($end, $rversion)))
-      {
-        $connection->relay_client(1);
-        last;
-      }
-    }
-  }
-
-  # If relay_client is already set, no point checking again
-  if (@srelay_clients && !$connection->relay_client) {
-    my $more_relay_clients = $self->qp->config("morerelayclients", "map");
-    my %srelay_clients = map { $_ => 1 } @srelay_clients;
-    $client_ip =~ s/::/:/;
-	($connection->relay_client(1) && undef($client_ip)) if $client_ip eq ":1";
-
-    while ($client_ip) {
-      if (exists($ENV{RELAYCLIENT}) or
-          exists($srelay_clients{$client_ip}) or
-          exists($more_relay_clients->{$client_ip}))
-      {
-        $connection->relay_client(1);
-        last;
-      }
-      $client_ip =~ s/(\d|\w)+(:|\.)?$//; # strip off another 8 bits
-    }
-  }
-  return (DECLINED);
-}

plugins/ident/p0f

@@ -11,9 +11,9 @@ implement more sophisticated anti-spam policies.
 
 =head1 DESCRIPTION
 
-This p0f module inserts a 'p0f' note that other qpsmtpd plugins can inspect.
+This p0f module inserts a I<p0f> connection note with information deduced
-It includes the following information about the TCP fingerprint (link,
+from the TCP fingerprint. The note typically includes at least the link,
-detail, distance, uptime, genre). Here's an example connection note:
+detail, distance, uptime, genre. Here's a p0f v2 example:
 
  genre    => FreeBSD
  detail   => 6.x (1)
@@ -26,20 +26,29 @@ Which was parsed from this p0f fingerprint:
   24.18.227.2:39435 - FreeBSD 6.x (1) (up: 1390 hrs)
     -> 208.75.177.101:25 (distance 17, link: ethernet/modem)
 
+When using p0f v3, the following additional values may also be available in
+the I<p0f> connection note:
+
+=over 4
+
+magic, status, first_seen, last_seen, total_conn, uptime_min, up_mod_days, last_nat, last_chg, distance, bad_sw, os_match_q, os_name, os_flavor, http_name, http_flavor, link_type, and language.
+
+=back
+
 =head1 MOTIVATION
 
 This p0f plugin provides a way to make sophisticated policies for email
 messages. For example, the vast majority of email connections to my server
-from Windows computers are spam (>99%). But, I have a few clients that use
+from Windows computers are spam (>99%). But, I have clients with
-Exchange servers so I can't just block email from all Windows computers.
+Exchange servers so I can't block email from all Windows computers.
 
-Same goes for greylisting. Finance companies (AmEx, BoA, etc) just love to
+Same goes for greylisting. Finance companies (AmEx, BoA, etc) send notices
-send notices that they won't queue and retry. Either they deliver at that
+that they don't queue and retry. They deliver immediately or never. Enabling
-instant or never. When I enable greylisting, I lose valid messages. Grrr.
+greylisting means maintaining manual whitelists or losing valid messages.
 
-So, while I'm not willing to use greylisting, and I'm not willing to block
+While I'm not willing to use greylisting for every connection, and I'm not
-connections from Windows computers, I am quite willing to greylist all email
+willing to block connections from Windows computers, I am willing to greylist
-from Windows computers.
+all email from Windows computers.
 
 =head1 CONFIGURATION
 
@@ -47,7 +56,7 @@ Configuration consists of two steps: starting p0f and configuring this plugin.
 
 =head2 start p0f
 
-Create a startup script for PF that creates a communication socket when your
+Create a startup script for p0f that creates a communication socket when your
 server starts up.
 
 p0f v2 example:
@@ -73,10 +82,9 @@ It's even possible to run both versions of p0f simultaneously:
 
 =head2 local_ip
 
-Use the local_ip option to override the IP address of your mail server. This
+Use I<local_ip> to override the IP address of your mail server. This is useful
-is useful if your mail server has a private IP because it is running behind
+if your mail server runs on a private IP behind a firewall. My mail server has
-a firewall. For example, my mail server has the IP 127.0.0.6, but the world
+the IP 127.0.0.6, but the world knows my mail server as 208.75.177.101.
-knows my mail server as 208.75.177.101.
 
 Example config/plugins entry with local_ip override:
 
@@ -107,15 +115,11 @@ Version 2 code heavily based upon the p0fq.pl included with the p0f distribution
 
 =head1 AUTHORS
 
-Robert Spier ( original author )
+2004 - Robert Spier ( original author )
 
-Matt Simerson
+2010 - Matt Simerson - added local_ip option
 
-=head1 CHANGES
+2012 - Matt Simerson - refactored, v3 support
-
-Added local_ip option - Matt Simerson (5/2010)
-
-Refactored and added p0f v3 support - Matt Simerson (4/2012)
 
 =cut
 

plugins/karma

@@ -0,0 +1,455 @@
+#!perl -w
+
+=head1 NAME
+
+karma - reward nice and penalize naughty mail senders
+
+=head1 SYNOPSIS
+
+Karma tracks sender history, providing the ability to deliver differing levels
+of service to naughty, nice, and unknown senders.
+
+=head1 DESCRIPTION
+
+Karma records the number of nice, naughty, and total connections from mail
+senders. After sending a naughty message, if a sender has more naughty than
+nice connections, they are penalized for I<penalty_days>. Connections
+from senders in the penalty box are tersely disconnected.
+
+Karma provides other plugins with a karma value they can use to be more
+lenient, strict, or skip processing entirely.
+
+Karma is small, fast, and ruthlessly efficient. Karma can be used to craft
+custom connection policies such as these two examples: 
+
+=over 4 
+
+Hi there, well behaved sender. Please help yourself to TLS, AUTH, greater
+concurrency, multiple recipients, no delays, and other privileges.
+
+Hi there, naughty sender. Enjoy this poke in the eye with a sharp stick. Bye.
+
+=back 
+
+=head1 CONFIG
+
+=head2 negative <integer>
+
+How negative a senders karma can get before we penalize them for sending a
+naughty message. Karma is the number of nice - naughty connections. 
+
+Default: 1
+
+Examples:
+
+ negative 1:  0 nice - 1 naughty = karma -1, penalize
+ negative 1:  1 nice - 1 naughty = karma  0, okay
+ negative 2:  1 nice - 2 naughty = karma -1, okay
+ negative 2:  1 nice - 3 naughty = karma -2, penalize
+
+With the default negative limit of one, there's a very small chance you could
+penalize a "mostly good" sender. Raising it to 2 reduces that possibility to
+improbable.
+
+=head2 penalty_days <days>
+
+The number of days a naughty sender is refused connections. Use a decimal
+value to penalize for portions of days.
+
+  karma penalty_days 1
+
+Default: 1
+
+=head2 reject
+
+  karma reject [ 0 | 1 | connect | zombie ]
+
+I<0> will not reject any connections.
+
+I<1> will reject naughty senders.
+
+I<connect> is the most efficient setting. 
+
+To reject at any other connection hook, use the I<zombie> setting and the
+B<reaper> plugin.
+
+=head2 db_dir <path>
+
+Path to a directory in which the DB will be stored. This directory must be
+writable by the qpsmtpd user. If unset, the first usable directory from the
+following list will be used:
+
+=over 4
+
+=item /var/lib/qpsmtpd/karma
+
+=item I<BINDIR>/var/db (where BINDIR is the location of the qpsmtpd binary)
+
+=item I<BINDIR>/config
+
+=back
+
+=head2 loglevel
+
+Adjust the quantity of logging for this plugin. See docs/logging.pod
+
+=head1 BENEFITS
+
+Karma reduces the resources wasted by naughty mailers. 
+When used with the 
+I<reject connect> setting, naughty senders are disconnected in about 0.1 seconds.
+
+The biggest gains to be had are by having heavy plugins (spamassassin, dspam,
+virus filters) set the B<karma> transaction note (see KARMA) when they encounter
+naughty senders. Reasons to send servers to the penalty box could include
+sending a virus, early talking, or sending messages with a very high spam
+score.
+
+This plugin does not penalize connections with transaction notes I<relayclient>
+or I<whitelisthost> set. These notes would have been set by the B<relay>, 
+B<whitelist>, and B<dns_whitelist_soft> plugins. Obviously, those plugins must
+run before B<karma> for that to work.
+
+=head1 KARMA
+
+No attempt is made by this plugin to determine what karma is. It is up to
+other plugins to make that determination and communicate it to this plugin by
+incrementing or decrementing the transaction note B<karma>. Raise it for good
+karma and lower it for bad karma. This is best done like so:
+
+ # only if karma plugin loaded
+ if ( defined $connection->notes('karma') ) {   
+   $connection->notes('karma', $connection->notes('karma') - 1); # bad
+   $connection->notes('karma', $connection->notes('karma') + 1); # good 
+ };
+
+After the connection ends, B<karma> will record the result. Mail servers whose
+naughty connections exceed nice ones are sent to the penalty box. Servers in
+the penalty box will be tersely disconnected for I<penalty_days>. Here is
+an example connection from an IP in the penalty box:
+
+ 73122 Connection from smtp.midsetmediacorp.com [64.185.226.65]
+ 73122 (connect) ident::geoip: US, United States
+ 73122 (connect) ident::p0f: Windows 7 or 8
+ 73122 (connect) earlytalker: pass: 64.185.226.65 said nothing spontaneous
+ 73122 (connect) relay: skip: no match
+ 73122 (connect) karma: fail
+ 73122 550 You were naughty. You are penalized for 0.99 more days.
+ 73122 click, disconnecting
+ 73122 (post-connection) connection_time: 1.048 s.
+
+If we only sets negative karma, we will almost certainly penalize servers we
+want to receive mail from. For example, a Yahoo user sends an egregious spam
+to a user on our server. Now nobody on our server can receive email from that
+Yahoo server for I<penalty_days>. This should happen approximately 0% of
+the time if we are careful to also set positive karma.
+
+=head1 USING KARMA
+
+To get rid of naughty connections as fast as possible, run karma before other
+connection plugins. Plugins that trigger DNS lookups or impose time delays
+should run after B<karma>. In this example, karma runs before all but the
+ident plugins.
+
+ 89011 Connection from Unknown [69.61.27.204]
+ 89011 (connect) ident::geoip: US, United States
+ 89011 (connect) ident::p0f: Linux 3.x
+ 89011 (connect) karma: fail, 1 naughty, 0 nice, 1 connects
+ 89011 550 You were naughty. You are penalized for 0.99 more days.
+ 89011 click, disconnecting
+ 89011 (post-connection) connection_time: 0.118 s.
+ 88798 cleaning up after 89011
+
+Unlike RBLs, B<karma> only penalizes IPs that have sent us spam, and only when
+those senders haven't sent us any ham. As such, it's much safer to use.
+
+=head1 USING KARMA IN OTHER PLUGINS
+
+This plugin sets the connection note I<karma_history>. Your plugin can
+use the senders karma to be more gracious or rude to senders. The value of
+I<karma_history> is the number the nice connections minus naughty
+ones. The higher the number, the better you should treat the sender.
+
+When I<reject zombie> is set and a naughty sender is encountered, most
+plugins should skip processing. However, if you wish to toy with spammers by
+teergrubing, extending banner delays, limiting connections, limiting
+recipients, random disconnects, handoffs to rblsmtpd, and other fun tricks, 
+then connections with the I<zombie> note set are for you!
+
+=head1 EFFECTIVENESS
+
+In the first 24 hours, B<karma> rejected 8% of all connections. After one
+week of running with I<penalty_days 1>, karma has rejected 15% of all
+connections.
+
+This plugins effectiveness results from the propensity of naughty senders
+to be repeat offenders. Limiting them to a single offense per day(s) greatly
+reduces the number of useless tokens miscreants add to our Bayes databases.
+
+Of the connections that had previously passed all other checks and were caught
+only by spamassassin and/or dspam, B<karma> rejected 31 percent. Since
+spamassassin and dspam consume more resources than others plugins, this plugin
+seems to be a very big win.
+
+=head1 DATABASE
+
+Connection summaries are stored in a database. The database key is the int
+form of the remote IP. The value is a : delimited list containing a penalty
+box start time (if the server is/was on timeout) and the count of naughty,
+nice, and total connections. The database can be listed and searched with the
+karma_dump.pl script.
+
+=head1 BUGS & LIMITATIONS
+
+This plugin is reactionary. Like the FBI, it doesn't punish until
+after a crime has been committed. It an "abuse me once, shame on you,
+abuse me twice, shame on me" policy.
+
+There is little to be gained by listing servers that are already on DNS
+blacklists, send to non-existent users, earlytalkers, etc. Those already have
+very lightweight tests.
+
+=head1 AUTHOR
+
+ 2012 - Matt Simerson - msimerson@cpan.org
+
+=head1 ACKNOWLEDGEMENTS
+
+Gavin Carr's DB implementation in the greylisting plugin.
+
+=cut
+
+use strict;
+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 {
+    my ($self, $qp ) = shift, shift;
+    $self->log(LOGERROR, "Bad arguments") if @_ % 2;
+    $self->{_args} = { @_ };
+    $self->{_args}{negative}     ||= 1;
+    $self->{_args}{penalty_days} ||= 1;
+    $self->{_args}{reject_type}  ||= 'disconnect';
+
+    if ( ! defined $self->{_args}{reject} ) {
+        $self->{_args}{reject} = 'zombie';
+    };
+    #$self->prune_db();    # keep the DB compact
+    $self->register_hook('connect',           'connect_handler');
+    $self->register_hook('disconnect',        'disconnect_handler');
+}
+
+sub connect_handler {
+    my $self = shift;
+
+    $self->connection->notes('karma', 0);  # default
+
+    return DECLINED if $self->is_immune();
+
+    my $db   = $self->get_db_location();
+    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $key  = $self->get_db_key();
+
+    if ( ! $tied->{$key} ) {
+        $self->log(LOGINFO, "pass, no record");
+        return $self->cleanup_and_return($tied, $lock );
+    };
+
+    my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
+    my $summary = "$naughty naughty, $nice nice, $connects connects";
+    my $karma = 0;
+    if ( $naughty || $nice ) {
+        $karma = $nice || 0 - $naughty || 0;
+        $self->connection->notes('karma_history', $karma );
+    };
+
+    my $happy_return = $karma > 3 ? DONE : DECLINED;  # skip other connection tests?
+    if ( ! $penalty_start_ts ) {
+        $self->log(LOGINFO, "pass, no penalty ($summary)");
+        return $self->cleanup_and_return($tied, $lock, $happy_return );
+        return $self->cleanup_and_return($tied, $lock );
+    };
+
+    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 );
+    };
+
+    $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
+    $self->cleanup_and_return($tied, $lock );
+
+    my $left = sprintf "%.2f", $self->{_args}{penalty_days} - $days_old;
+    my $mess = "You were naughty. You are penalized for $left more days.";
+
+    return $self->get_reject( $mess );
+}
+
+sub disconnect_handler {
+    my $self = shift;
+
+    my $karma = $self->connection->notes('karma') or do {
+        $self->log(LOGDEBUG, "no karma");
+        return DECLINED;
+    };
+
+    my $db   = $self->get_db_location();
+    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $key  = $self->get_db_key();
+
+    my ($penalty_start_ts, $naughty, $nice, $connects) = $self->parse_value( $tied->{$key} );
+
+    if ( $karma < 0 ) {
+        $naughty++;
+        my $negative_limit = 0 - $self->{_args}{negative};
+        my $karma_history  = ($nice || 0) - $naughty;
+        if ( $karma_history <= $negative_limit ) {
+            $self->log(LOGINFO, "negative, sent to penalty box");
+            $penalty_start_ts = sprintf "%s", time;
+        }
+        else {
+            $self->log(LOGINFO, "negative");
+        };
+    }
+    elsif ($karma > 1) {
+        $nice++;
+        $self->log(LOGINFO, "positive");
+    }
+
+    $tied->{$key} = join(':', $penalty_start_ts, $naughty, $nice, ++$connects);
+    return $self->cleanup_and_return($tied, $lock );
+}
+
+sub parse_value {
+    my ($self, $value) = @_;
+
+    my $penalty_start_ts = my $naughty = my $nice = my $connects = 0;
+    if ( $value  ) {
+        ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $value;
+        $penalty_start_ts ||= 0;
+        $nice    ||= 0;
+        $naughty ||= 0;
+        $connects ||= 0;
+    };
+    return ($penalty_start_ts, $naughty, $nice, $connects );
+};
+
+sub cleanup_and_return {
+    my ($self, $tied, $lock, $return_val ) = @_;
+
+    untie $tied;
+    close $lock;
+    return ($return_val) if defined $return_val;  # explicit override
+    return (DECLINED);
+};
+
+sub get_db_key {
+    my $self = shift;
+    my $nip = Net::IP->new( $self->qp->connection->remote_ip );
+    return $nip->intip;   # convert IP to an int
+};
+
+sub get_db_tie {
+    my ( $self, $db, $lock ) = @_;
+
+    tie( my %db, 'AnyDBM_File', $db, O_CREAT|O_RDWR, 0600) or do {
+        $self->log(LOGCRIT, "tie to database $db failed: $!");
+        close $lock;
+        return;
+    };
+    return \%db;
+};
+
+sub get_db_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_db_lock {
+    my ($self, $db) = @_;
+
+    return $self->get_db_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_db_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 prune_db {
+    my $self = shift;
+
+    my $db   = $self->get_db_location();
+    my $lock = $self->get_db_lock( $db ) or return DECLINED;
+    my $tied = $self->get_db_tie( $db, $lock ) or return DECLINED;
+    my $count = keys %$tied;
+
+    my $pruned = 0;
+    foreach my $key ( keys %$tied ) {
+        my $ts = $tied->{$key};
+        my $days_old = ( time - $ts ) / 86400;
+        next if $days_old < $self->{_args}{penalty_days} * 2;
+        delete $tied->{$key};
+        $pruned++;
+    };
+    untie $tied;
+    close $lock;
+    $self->log( LOGINFO, "pruned $pruned of $count DB entries" );
+    return $self->cleanup_and_return( $tied, $lock, DECLINED );
+};
+

plugins/karma_tool

@@ -0,0 +1,250 @@
+#!/usr/bin/perl
+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);
+
+my $self = bless( { args => { db_dir => 'config' }, }, 'Karma' );
+my $command = $ARGV[0];
+
+if ( ! $command ) {
+    $self->usage();
+}
+elsif ( $command eq 'capture' ) {
+    $self->capture( $ARGV[1] );
+}
+elsif ( $command eq 'release' ) {
+    $self->capture( $ARGV[1] );
+}
+elsif ( $command eq 'prune' ) {
+    $self->prune_db( $ARGV[1] || 7 );
+}
+elsif ( $command eq 'list' ) {
+    $self->main();
+};
+
+exit(0);
+
+sub usage {
+    print <<EO_HELP
+ karma_tool [ list search prune capture release ]
+
+list takes no arguments.
+
+search [ naughty nice both ]
+  and returns a list of matching IPs
+
+capture [ IP ]
+  sends an IP to the penalty box
+
+release [ IP ]
+  remove an IP from the penalty box
+
+prune takes no arguments.
+  prunes database of entries older than 7 days
+
+EO_HELP
+;
+};
+
+sub capture {
+    my $self = shift;
+    my $ip = shift or return;
+    is_ip( $ip ) or do {
+        warn "not an IP: $ip\n";
+        return;
+    };
+
+    my $db   = $self->get_db_location();
+    my $lock = $self->get_db_lock( $db ) or return;
+    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $key  = $self->get_db_key( $ip );
+
+    $tied->{$key} = join(':', time, 1, 0, 1);
+    return $self->cleanup_and_return( $tied, $lock );
+};
+
+sub release {
+    my $self = shift;
+    my $ip = shift or return;
+    is_ip( $ip ) or do {
+        warn "not an IP: $ip\n";
+        return;
+    };
+
+    my $db   = $self->get_db_location();
+    my $lock = $self->get_db_lock( $db ) or return;
+    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $key  = $self->get_db_key( $ip );
+
+    $tied->{$key} = join(':', 0, 1, 0, 1);
+    return $self->cleanup_and_return( $tied, $lock );
+};
+
+sub main {
+    my $self = shift;
+
+    my $db   = $self->get_db_location();
+    my $lock = $self->get_db_lock( $db ) or return;
+    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my %totals;
+
+    print "      IP Address                 Penalty        Naughty  Nice  Connects  Hostname\n";
+    foreach my $r ( sort keys %$tied ) {
+        my $ip = ip_bintoip( ip_inttobin( $r, 4 ), 4);
+        my ($penalty_start_ts, $naughty, $nice, $connects) = split /:/, $tied->{$r};
+        $naughty ||= '';
+        $nice    ||= '';
+        $connects ||= '';
+        my $time_human = '';
+        if ( $command eq 'search' ) {
+            my $search = $ARGV[1];
+            if ( $search eq 'nice' ) {
+                next if ! $nice;
+            }
+            elsif ( $search eq 'naughty' ) {
+                next if ! $naughty;
+            }
+            elsif ( $search eq 'both' ) {
+                next if ! $naughty || ! $nice;
+            }
+            elsif ( is_ip() && $search ne $ip ) {
+                next;
+            }
+        };
+        if ( $penalty_start_ts ) {
+            $time_human = strftime "%a %b %e %H:%M", localtime $penalty_start_ts;
+        };
+        my $hostname = '';
+        if ( $naughty && $nice ) {
+            $hostname = `dig +short -x $ip`; chomp $hostname;
+        };
+        printf(" %-18s  %24s    %3s     %3s     %3s    %30s\n", $ip, $time_human, $naughty, $nice, $connects, $hostname);
+        $totals{naughty}  += $naughty  if $naughty;
+        $totals{nice}     += $nice     if $nice;
+        $totals{connects} += $connects if $connects;
+    };
+    print Dumper(\%totals);
+}
+
+sub is_ip {
+    my $ip = shift || $ARGV[0];
+    return 1 if $ip =~ /^(\d{1,3}\.){3}\d{1,3}$/;
+    return;
+};
+
+sub cleanup_and_return {
+    my ($self, $tied, $lock ) = @_;
+    untie $tied;
+    close $lock;
+};
+
+sub get_db_key {
+    my $self = shift;
+    my $nip = Net::IP->new( shift );
+    return $nip->intip;   # convert IP to an int
+};
+
+sub get_db_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_db_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_db_lock {
+    my ($self, $db) = @_;
+
+    return $self->get_db_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_db_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_db_location();
+    my $lock = $self->get_db_lock( $db ) or return;
+    my $tied = $self->get_db_tie( $db, $lock ) or return;
+    my $count = keys %$tied;
+
+    my $pruned = 0;
+    foreach my $key ( keys %$tied ) {
+        my ($ts, $naughty, $nice, $connects) = split /:/, $tied->{$key};
+        my $days_old = ( time - $ts ) / 86400;
+        next if $days_old < $prune_days;
+        delete $tied->{$key};
+        $pruned++;
+    };
+    untie $tied;
+    close $lock;
+    warn "pruned $pruned of $count DB entries";
+    return $self->cleanup_and_return( $tied, $lock );
+};
+

plugins/relay

@@ -0,0 +1,237 @@
+#!perl -w
+
+=head1 SYNOPSIS
+
+relay - control whether relaying is permitted
+
+=head1 DESCRIPTION
+
+relay - check the following places to see if relaying is allowed:
+
+I<$ENV{RELAYCLIENT}>
+
+I<config/norelayclients>, I<config/relayclients>, I<config/morerelayclients>
+
+The search order is as shown and cascades until a match is found or the list
+is exhausted.
+
+Note that I<norelayclients> is the first file checked. A match there will
+override matches in the subsequent files.
+
+=head1 CONFIG
+
+Enable this plugin by adding it to config/plugins above the rcpt_* plugins
+
+ # other plugins...
+
+ relay
+
+ # rcpt_* go here
+
+=head2 relayclients
+
+A list of IP addresses that are permitted to relay mail through this server.
+
+Each line in I<relayclients> is one of:
+ - a full IP address
+
+ - partial IP address terminated by a dot or colon for matching whole networks
+     192.168.42.
+     fdda:b13d:e431:ae06:
+     ...
+
+ - a network/mask, aka a CIDR block
+     10.1.0.0/24
+     fdda:b13d:e431:ae06::/64
+     ...
+
+=head2 morerelayclients
+
+Additional IP addresses that are permitted to relay. The syntax of the config
+file is identical to I<relayclients> except that CIDR (net/mask) entries are
+not supported. If you have many (>50) IPs allowed to relay, most should likely
+be listed in I<morerelayclients> where lookups are faster.
+
+
+=head2 norelayclients
+
+I<norelayclients> allows specific clients, such as a mail gateway, to be denied
+relaying, even though they would be allowed by I<relayclients>. This is most
+useful when a block of IPs is allowed in relayclients, but several IPs need to
+be excluded.
+
+The file format is the same as morerelayclients.
+
+=head2 RELAY ONLY
+
+The relay only option restricts connections to only clients that have relay
+permission. All other connections are denied during the RCPT phase of the
+SMTP conversation.
+
+This option is useful when a server is used as the smart relay host for
+internal users and external/authenticated users, but should not be considered
+a normal inbound MX server.
+
+It should be configured to be run before other RCPT hooks! Only clients that
+have authenticated or are listed in the relayclient file will be allowed to
+send mail.
+
+To enable relay only mode, set the B<only> option to any true value in
+I<config/plugins> as shown:
+
+  relay only 1
+
+=head1 AUTHOR
+
+2012 - Matt Simerson - Merged check_relay, check_norelay, and relayonly
+
+2006 - relay_only  - John Peackock
+
+2005 - check_norelay - Copyright Gordon Rowell <gordonr@gormand.com.au>
+
+2002 - check_relay - Ask Bjorn Hansen
+
+=head1 LICENSE
+
+This software is free software and may be distributed under the same
+terms as qpsmtpd itself.
+
+=cut
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+use Net::IP qw(:PROC);
+
+sub register {
+    my ($self, $qp) = shift, shift;
+    $self->log(LOGERROR, "Bad arguments") if @_ % 2;
+    $self->{_args} = { @_ };
+
+    if ( $self->{_args}{only} ) {
+        $self->register_hook('rcpt', 'relay_only');
+    };
+};
+
+sub is_in_norelayclients {
+    my $self = shift;
+
+    my %no_relay_clients = map { $_ => 1 } $self->qp->config('norelayclients');
+
+    my $ip = $self->qp->connection->remote_ip;
+
+    while ( $ip ) {
+        if ( exists $no_relay_clients{$ip} ) {
+            $self->log(LOGNOTICE, "$ip in norelayclients");
+            return 1;
+        }
+        $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another octet
+    };
+
+    $self->log(LOGDEBUG, "no match in norelayclients");
+    return;
+};
+
+sub populate_relayclients {
+    my $self = shift;
+
+    foreach ( $self->qp->config('relayclients') ) {
+        my ($network, $netmask) = ip_splitprefix($_);
+        if ( $netmask ) {
+            push @{ $self->{_cidr_blocks} }, $_;
+            next;
+        }
+        $self->{_octets}{$_} = 1;   # no prefix, split
+    }
+};
+
+sub is_in_cidr_block {
+    my $self = shift;
+
+    my $ip = $self->qp->connection->remote_ip;
+    my $cversion = ip_get_version($ip);
+    for ( @{ $self->{_cidr_blocks} } ) {
+        my ($network, $mask) = ip_splitprefix($_); # split IP & CIDR range
+        my $rversion = ip_get_version($network);   # get IP version (4 vs 6)
+        my ($begin, $end) = ip_normalize($_, $rversion); # get pool start/end
+
+# expand the client address (zero pad it) before converting to binary
+        my $bin_ip = ip_iptobin(ip_expand_address($ip, $cversion), $cversion);
+
+        if (    ip_bincomp($bin_ip, 'gt', ip_iptobin($begin, $rversion))
+             && ip_bincomp($bin_ip, 'lt', ip_iptobin($end,   $rversion))
+           ) {
+            $self->log(LOGINFO, "pass: cidr match ($ip)");
+            return 1;
+        }
+    }
+
+    $self->log(LOGDEBUG, "no cidr match");
+    return;
+};
+
+sub is_octet_match {
+    my $self = shift;
+
+    my $ip = $self->qp->connection->remote_ip;
+    $ip =~ s/::/:/;
+
+    if ( $ip eq ':1' ) {
+        $self->log(LOGINFO, "pass: octet matched localhost ($ip)");
+        return 1;
+    };
+
+    my $more_relay_clients = $self->qp->config('morerelayclients', 'map');
+
+    while ($ip) {
+        if ( exists $self->{_octets}{$ip} ) {
+            $self->log(LOGINFO, "pass: octet match in relayclients ($ip)");
+            return 1;
+        };
+
+        if ( exists $more_relay_clients->{$ip} ) {
+            $self->log(LOGINFO, "pass: octet match in morerelayclients ($ip)");
+            return 1;
+        };
+        $ip =~ s/(\d|\w)+(:|\.)?$// or last; # strip off another 8 bits
+    }
+
+    $self->log(LOGDEBUG, "no octet match" );
+    return;
+}
+
+sub hook_connect {
+    my ($self, $transaction) = @_;
+
+    if ( $self->is_in_norelayclients() ) {
+        $self->qp->connection->relay_client(0);
+        delete $ENV{RELAYCLIENT};
+        return (DECLINED);
+    }
+
+    if ( $ENV{RELAYCLIENT} ) {
+        $self->qp->connection->relay_client(1);
+        $self->log(LOGINFO, "pass: enabled by env");
+        return (DECLINED);
+    };
+
+    $self->populate_relayclients();
+
+    if ( $self->is_in_cidr_block() || $self->is_octet_match() ) {
+        $self->qp->connection->relay_client(1);
+        return (DECLINED);
+    };
+
+    $self->log(LOGINFO, "skip: no match");
+    return (DECLINED);
+}
+
+sub relay_only {
+    my $self = shift;
+    if ( $self->qp->connection->relay_client ) {
+        return (OK);
+    };
+    return (DENY);
+}
+

plugins/relay_only

@@ -1,36 +0,0 @@
-#!perl -w
-
-=head1 NAME
-
-relay_only - this plugin only permits relaying
-
-=head1 SYNOPSIS
-
-# in config/plugins
-
-check_relay
-
-relay_only
-
-# other rcpt hooks go here
-
-=head1 DESCRIPTION
-
-This plugin can be used for the case where a server is used as the smart
-relay host for internal users and external/authenticated users, but should
-not be considered a normal inbound MX server
-
-It should be configured to be run _AFTER_ check_relay and before other
-RCPT hooks!  Only clients that have authenticated or are listed in the
-relayclient file will be allowed to send mail.
-
-=cut
-
-sub hook_rcpt {
-  if ( shift->qp->connection->relay_client ) {
-    return (OK);
-  }
-  else {
-    return (DENY);
-  }
-}

plugins/sender_permitted_from

@@ -167,7 +167,7 @@ sub hook_rcpt {
     }
     elsif ( $code eq 'permerror' ) {
         return (DENY, "SPF - $code: $why") if $reject >= 6;
-        return (DENYSOFT, "SPF - $code: $why") if $reject >= 2;
+        return (DENYSOFT, "SPF - $code: $why") if $reject >= 3;
     }
     elsif ( $code eq 'temperror' ) {
         return (DENYSOFT, "SPF - $code: $why") if $reject >= 2;

t/Test/Qpsmtpd.pm

@@ -69,6 +69,7 @@ sub input {
 }
 
 sub config_dir {
+    return './t/config' if $ENV{QPSMTPD_DEVELOPER};
     './config.sample';
 }
 

t/Test/Qpsmtpd/Plugin.pm

@@ -5,8 +5,10 @@ package Test::Qpsmtpd::Plugin;
 package Qpsmtpd::Plugin;
 
 use strict;
-use Test::More;
+use warnings;
+
 use Qpsmtpd::Constants;
+use Test::More;
 
 sub register_tests {
     # Virtual base method - implement in plugin

t/config.t

@@ -5,12 +5,17 @@ use strict;
 use lib 't';
 use_ok('Test::Qpsmtpd');
 
+my @mes;
+
 BEGIN { # need this to happen before anything else
     my $cwd = `pwd`;
     chomp($cwd);
-    open my $me_config, '>', "./config.sample/me";
+    @mes = qw{ ./config.sample/me ./t/config/me };
-    print $me_config "some.host.example.org";
+    foreach my $f ( @mes ) {
-    close $me_config;
+        open my $me_config, '>', $f;
+        print $me_config "some.host.example.org";
+        close $me_config;
+    };
 }
 
 ok(my ($smtpd, $conn) = Test::Qpsmtpd->new_conn(), "get new connection");
@@ -20,8 +25,10 @@ is($smtpd->config('me'), 'some.host.example.org', 'config("me")');
 # test for ignoring leading/trailing whitespace (relayclients has a
 # line with both)
 my $relayclients = join ",", sort $smtpd->config('relayclients');
-is($relayclients, '127.0.0.1,192.168.', 'config("relayclients") are trimmed');
+is($relayclients, '127.0.0.1,192.0.', 'config("relayclients") are trimmed');
 
-unlink "./config.sample/me";
+foreach my $f ( @mes ) {
+    unlink $f if -f $f;
+};
 
 

t/config/badhelo

@@ -0,0 +1,4 @@
+# these domains never uses their domain when greeting us, so reject transactions
+aol.com
+yahoo.com
+

t/config/badrcptto

@@ -0,0 +1,9 @@
+######## entries used for testing ###
+bad@example.com
+@bad.example.com
+########    Example patterns   #######
+# Format is pattern\s+Response
+# Don't forget to anchor the pattern if required
+!       Sorry, bang paths not accepted here
+@.*@    Sorry, multiple at signs not accepted here
+%       Sorry, percent hack not accepted here 

t/config/dnsbl_zones

@@ -0,0 +1 @@
+zen.spamhaus.org

t/config/flat_auth_pw

@@ -0,0 +1,2 @@
+good@example.com:good_pass
+bad@example.com:bad_pass

t/config/plugins

@@ -0,0 +1,94 @@
+#
+#  Example configuration file for plugins
+#
+
+# enable this to get configuration via http; see perldoc
+# plugins/http_config for details.
+#   http_config http://localhost/~smtpd/config/  http://www.example.com/smtp.pl?config=
+
+# hosts_allow does not work with the tcpserver deployment model!
+#   perldoc plugins/hosts_allow for an alternative.
+#
+# The hosts_allow module must be loaded if you want the -m / --max-from-ip /
+# my $MAXCONNIP = 5; # max simultaneous connections from one IP
+# settings... without this it will NOT refuse more than $MAXCONNIP connections
+# from one IP!
+hosts_allow
+
+# information plugins
+ident/geoip
+#ident/p0f /tmp/.p0f_socket version 3
+connection_time
+
+# enable to accept MAIL FROM:/RCPT TO: addresses without surrounding <>
+dont_require_anglebrackets
+
+# enable to reject MAIL FROM:/RCPT TO: parameters if client helo was HELO
+# (strict RFC 821)... this is not used in EHLO ...
+parse_addr_withhelo
+
+quit_fortune
+# tls should load before count_unrecognized_commands
+#tls
+check_earlytalker
+count_unrecognized_commands 4
+check_relay
+
+require_resolvable_fromhost
+
+rhsbl
+dnsbl
+check_badmailfrom
+check_badrcptto
+check_spamhelo
+
+sender_permitted_from
+greylisting p0f genre,windows
+
+auth/auth_checkpassword checkpw /usr/local/vpopmail/bin/vchkpw true /usr/bin/true
+auth/auth_vpopmail
+auth/auth_vpopmaild
+auth/auth_vpopmail_sql
+auth/auth_flat_file
+auth/authdeny
+
+# this plugin needs to run after all other "rcpt" plugins
+rcpt_ok
+
+check_basicheaders days 5 reject_type temp
+domainkeys
+
+# content filters
+virus/klez_filter
+
+
+# You can run the spamassassin plugin with options.  See perldoc
+# plugins/spamassassin for details.
+#
+spamassassin
+
+# rejects mails with a SA score higher than 20 and munges the subject
+# of the score is higher than 10.
+#
+#   spamassassin reject_threshold 20 munge_subject_threshold 10
+
+# dspam must run after spamassassin for the learn_from_sa feature to work
+dspam learn_from_sa 7 reject 1
+
+# run the clamav virus checking plugin
+virus/clamav
+
+# You must enable a queue plugin - see the options in plugins/queue/ - for example:
+
+# queue to a maildir
+# queue/maildir /home/spamtrap/mail
+
+# queue the mail with qmail-queue
+queue/qmail-queue
+
+
+# If you need to run the same plugin multiple times, you can do
+# something like the following
+#    check_relay
+#    check_relay:0 somearg
+#    check_relay:1 someotherarg

t/config/rcpthosts

@@ -0,0 +1 @@
+localhost

t/config/relayclients

@@ -0,0 +1,5 @@
+# Format is IP, or IP part with trailing dot
+# e.g. "127.0.0.1", or "192.168."
+127.0.0.1 
+# leading/trailing whitespace is ignored
+ 192.168. 

t/plugin_tests.t

@@ -7,3 +7,11 @@ my $qp = Test::Qpsmtpd->new();
 
 $qp->run_plugin_tests();
 
+foreach my $file ( 
+        "./t/config/greylist.dbm",
+        "./t/config/greylist.dbm.lock"
+        ) {
+    next if ! -f $file;
+    unlink $file;
+};
+

t/plugin_tests/auth/auth_vpopmail

@@ -23,7 +23,7 @@ sub test_auth_vpopmail {
 
     if ( ! $self->test_vpopmail_module ) {
         warn "vpopmail plugin not configured\n";
-        foreach ( 0..2) { ok( 1, "test_auth_vpopmail, skipped") };
+        foreach ( 0..2) { ok( 1, "skipped") };
         return;
     };
 

t/plugin_tests/auth/auth_vpopmail_sql

@@ -6,6 +6,11 @@ use warnings;
 sub register_tests {
     my $self = shift;
 
+    eval 'use DBI';
+    if ( $@ ) {
+        warn "skipping auth_vpopmail_sql tests, is DBI installed?\n";
+        return;
+    };
     $self->register_test("auth_vpopmail_sql", 3);
 }
 
@@ -15,7 +20,7 @@ sub auth_vpopmail_sql {
 
     my $dbh = $self->get_db_handle() or do {
             foreach ( 0..2 ) {
-                ok( 1, "auth_vpopmail_sql, skipped (no DB)" );
+                ok( 1, "skipped (no DB)" );
             };
             return;
         };
@@ -24,11 +29,11 @@ sub auth_vpopmail_sql {
     my $vuser = $self->get_vpopmail_user( $dbh, 'postmaster@example.com' );
     if ( ! $vuser || ! $vuser->{pw_passwd} ) {
         foreach ( 0..1 ) {
-            ok( 1, "auth_vpopmail_sql, no example.com domain" );
+            ok( 1, "no example.com domain" );
         };
         return;
     };
-    ok( ref $vuser, "auth_vpopmail_sql, found example.com domain" );
+    ok( ref $vuser, "found example.com domain" );
 
     ok( $self->auth_vmysql(
             $self->qp->transaction,
@@ -38,6 +43,6 @@ sub auth_vpopmail_sql {
             $vuser->{pw_passwd},
             $ticket,
         ),
-        "auth_vpopmail_sql, postmaster"
+        "postmaster"
     );
 }

t/plugin_tests/relay

@@ -0,0 +1,81 @@
+#!perl -w
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
+
+sub register_tests {
+    my $self = shift;
+
+    $self->register_test('test_relay_only', 2);
+    $self->register_test('test_is_octet_match', 3);
+    $self->register_test('test_is_in_cidr_block', 4);
+    $self->register_test('test_is_in_norelayclients', 5);
+}
+
+sub test_relay_only {
+    my $self = shift;
+
+    $self->qp->connection->relay_client(0);
+    my $r = $self->relay_only();
+    cmp_ok( $r, '==', DENY, "relay_only -");
+
+    $self->qp->connection->relay_client(1);
+    $r = $self->relay_only();
+    cmp_ok( $r, '==', OK, "relay_only +");
+
+    $self->qp->connection->relay_client(0);
+};
+
+sub test_is_octet_match {
+    my $self = shift;
+
+    $self->populate_relayclients();
+
+    $self->qp->connection->remote_ip('192.0.1.1');
+    ok( $self->is_octet_match(), "match, +");
+
+    $self->qp->connection->remote_ip('192.51.1.1');
+    ok( ! $self->is_octet_match(), "nope, -");
+
+    $self->qp->connection->remote_ip('203.0.113.0');
+    ok( ! $self->is_octet_match(), "nope, -");
+};
+
+sub test_is_in_cidr_block {
+    my $self = shift;
+
+    $self->qp->connection->remote_ip('192.0.1.1');
+    $self->{_cidr_blocks} = [ '192.0.1.0/24' ];
+    ok( $self->is_in_cidr_block(), "match, +" );
+
+    $self->{_cidr_blocks} = [ '192.0.0.0/24' ];
+    ok( ! $self->is_in_cidr_block(), "nope, -" );
+
+
+    $self->qp->connection->remote_ip('fdda:b13d:e431:ae06:00a1::');
+    $self->{_cidr_blocks} = [ 'fdda:b13d:e431:ae06::/64' ];
+    ok( $self->is_in_cidr_block(), "match, +" );
+
+    $self->{_cidr_blocks} = [ 'fdda:b13d:e431:be17::' ];
+    ok( ! $self->is_in_cidr_block(), "nope, -" );
+};
+
+sub test_is_in_norelayclients {
+    my $self = shift;
+
+    my @matches = qw/ 192.0.99.5 192.0.98.1 192.0.98.255 /;
+    my @false = qw/ 192.0.99.7 192.0.109.7 /;
+
+    foreach ( @matches ) {
+        $self->qp->connection->remote_ip($_);
+        ok( $self->is_in_norelayclients(), "match, + ($_)");
+    };
+
+    foreach ( @false ) {
+        $self->qp->connection->remote_ip($_);
+        ok( ! $self->is_in_norelayclients(), "match, + ($_)");
+    };
+};
+