badrcptto: merged plugins, refactored, tests

merged badrcptto_pattern into badrcptto
refactored into smaller methods
added unit tests for each method

config.sample/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 

plugins/check_badrcptto

@@ -1,22 +1,126 @@
 #!perl -w
 
-# this plugin checks the badrcptto config (like badmailfrom, but for rcpt address
-# rather than sender address)
+=head1 SYNOPSIS
+
+deny connections to recipients in the I<badrcptto> file
+
+like badmailfrom, but for recipient address rather than sender
+
+=head1 CONFIG
+
+Recipients are matched against entries in I<config/badrcptto>. Entries can be
+a complete email address, a host entry that starts with an @ symbol, or a
+regular expression. For regexp pattern matches, see PATTERNS.
+
+=head1 PATTERNS
+
+This allows special patterns to be denied (e.g. percent hack, bangs,
+double ats).
+
+Patterns are stored in the format pattern\sresponse, where pattern
+is a Perl pattern expression. Don't forget to anchor the pattern if
+you want to restrict it from matching anywhere in the string.
+
+qpsmtpd already ensures that the address contains an @, with something
+to the left and right of the @.
+
+=head1 AUTHOR
+
+2002 - original badrcptto plugin - apparently Jim Winstead
+       https://github.com/smtpd/qpsmtpd/commits/master/plugins/check_badrcptto
+
+2005 - pattern feature, (c) Gordon Rowell <gordonr@gormand.com.au>
+
+2012 - merged the two, refactored, added tests - Matt Simerson
+
+=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 Qpsmtpd::DSN;
 
 sub hook_rcpt {
   my ($self, $transaction, $recipient, %param) = @_;
-  my @badrcptto = $self->qp->config("badrcptto") or return (DECLINED);
-  return (DECLINED) unless $recipient->host && $recipient->user;
-  my $host = lc $recipient->host;
-  my $to = lc($recipient->user) . '@' . $host;
-  for my $bad (@badrcptto) {
-    $bad = lc $bad;
-    $bad =~ s/^\s*(\S+)/$1/;
-    return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here")
-      if $bad eq $to;
-    return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here")
-      if substr($bad,0,1) eq '@' && $bad eq "\@$host";
-  }
-  return (DECLINED);
+
+    return (DECLINED) if $self->qp->connection->relay_client();
+
+    my ($host, $to) = $self->get_host_and_to( $recipient )
+        or return (DECLINED);
+
+    my @badrcptto = $self->qp->config("badrcptto") or return (DECLINED);
+
+    for my $line (@badrcptto) {
+        $line =~ s/^\s+//g; # trim leading whitespace
+        my ($bad, $reason) = split /\s+/, $line, 2;
+        next if ! $bad;
+        if ( $self->is_match( $to, lc($bad), $host ) ) {;
+            if ( $reason ) {
+                return (DENY, "mail to $bad not accepted here");
+            }
+            else {
+                return Qpsmtpd::DSN->no_such_user("mail to $bad not accepted here");
+            }
+        };
+    }
+    $self->log(LOGINFO, 'pass');
+    return (DECLINED);
 }
+
+sub is_match {
+    my ( $self, $to, $bad, $host ) = @_;
+
+    if ( $bad =~ /[\/\^\$\*\+\!\%]/ ) {  # it's a regexp
+        $self->log(LOGDEBUG, "badmailfrom pattern ($bad) match for $to");
+        if ( $to =~ /$bad/i ) {
+            $self->log(LOGINFO, 'fail: pattern match');
+            return 1;
+        };
+        return;
+    };
+
+    if ( $bad !~ m/\@/ ) {
+        $self->log(LOGERROR, "badrcptto: bad config: no \@ sign in $bad");
+        return;
+    };
+
+    $bad = lc $bad;
+    $to  = lc $to;
+
+    if ( substr($bad,0,1) eq '@' ) {
+        if ( $bad eq "\@$host" ) {
+            $self->log(LOGINFO, 'fail: host match');
+            return 1;
+        };
+        return;
+    };
+
+    if ( $bad eq $to ) {
+        $self->log(LOGINFO, 'fail: rcpt match');
+        return 1;
+    }
+    return;
+};
+
+sub get_host_and_to {
+    my ( $self, $recipient ) = @_;
+
+    if ( ! $recipient ) {
+        $self->log(LOGERROR, 'skip: no recipient!');
+        return;
+    };
+
+    if ( ! $recipient->host || ! $recipient->user ) {
+        $self->log(LOGINFO, 'skip: missing host or user');
+        return;
+    };
+
+    my $host = lc $recipient->host;
+    return ( $host, lc($recipient->user) . '@' . $host );
+};

t/plugin_tests/check_badrcptto

@@ -1,9 +1,92 @@
+#!perl -w
+
+use strict;
+use warnings;
+
+use Qpsmtpd::Constants;
 
 sub register_tests {
     my $self = shift;
-    $self->register_test("test_check_badrcptto_ok", 1);
+
+    $self->register_test("test_is_match", 10);
+    $self->register_test("test_hook_rcpt", 3);
+    $self->register_test("test_get_host_and_to", 8);
 }
 
-sub test_check_badrcptto_ok {
-    ok(1, 'badrcptto, ok');
-}
+sub test_is_match {
+    my $self = shift;
+
+# is_match receives ( $to, $bad, $host )
+
+    my $r = $self->is_match( 'matt@example.com', 'matt@example.com', 'example.com' );
+    ok($r, "match");
+
+    ok( $self->is_match( 'matt@exAmple.com', 'matt@example.com', 'tnpi.com' ),
+            "case insensitive match");
+
+    ok( $self->is_match( 'mAtt@example.com', 'matt@example.com', 'tnpi.com' ),
+            "case insensitive match +");
+
+    ok( ! $self->is_match( 'matt@exmple.com', 'matt@example.com', 'tnpi.com' ),
+            "non-match");
+
+    ok( ! $self->is_match( 'matt@example.com', 'matt@exAple.com', 'tnpi.com' ),
+            "case insensitive non-match");
+
+    ok( $self->is_match( 'matt@example.com', '@example.com', 'example.com' ),
+            "match host");
+
+    ok( ! $self->is_match( 'matt@example.com', '@example.not', 'example.com' ),
+            "non-match host");
+
+    ok( ! $self->is_match( 'matt@example.com', '@example.com', 'example.not' ),
+            "non-match host");
+
+    ok( $self->is_match( 'matt@example.com', 'example.com$', 'tnpi.com' ),
+            "pattern match");
+
+    ok( ! $self->is_match( 'matt@example.com', 'example.not$', 'tnpi.com' ),
+            "pattern non-match");
+};
+
+sub test_hook_rcpt {
+    my $self = shift;
+
+    my $transaction = $self->qp->transaction;
+    my $recipient = Qpsmtpd::Address->new( '<user@example.com>' );
+
+    my ($r, $mess) = $self->hook_rcpt( $transaction, $recipient );
+    cmp_ok( DECLINED, '==', $r, "valid +");
+
+    $recipient = Qpsmtpd::Address->new( '<bad@example.com>' );
+    ($r, $mess) = $self->hook_rcpt( $transaction, $recipient );
+    cmp_ok( DENY, '==', $r, "bad match, +");
+
+    $recipient = Qpsmtpd::Address->new( '<any@bad.example.com>' );
+    ($r, $mess) = $self->hook_rcpt( $transaction, $recipient );
+    cmp_ok( DENY, '==', $r, "bad host match, +");
+};
+
+sub test_get_host_and_to {
+    my $self = shift;
+
+    my $recipient = Qpsmtpd::Address->new( '<>' );
+    my ($host, $to) = $self->get_host_and_to( $recipient );
+    ok( ! $host, "null recipient -");
+
+    $recipient = Qpsmtpd::Address->new( '<user>' );
+    ($host, $to) = $self->get_host_and_to( $recipient );
+    ok( ! $host, "missing host -");
+    ok( ! $to, "unparseable to -");
+
+    $recipient = Qpsmtpd::Address->new( '<user@example.com>' );
+    ($host, $to) = $self->get_host_and_to( $recipient );
+    ok( $host, "valid host +");
+    ok( $to, "valid to +");
+    cmp_ok( $to, 'eq', 'user@example.com', "valid to +");
+
+    $recipient = Qpsmtpd::Address->new( '<uSer@exaMple.com>' );
+    ($host, $to) = $self->get_host_and_to( $recipient );
+    cmp_ok( $host, 'eq', 'example.com', "case normalized +");
+    cmp_ok( $to, 'eq', 'user@example.com', "case normalized +");
+};