Create async version of dns_whitelist_soft, rhsbl and uribl plugins.

git-svn-id: https://svn.perl.org/qpsmtpd/trunk@921 958fd67b-6ff1-0310-b445-bb7760255be9

Changes

@@ -1,3 +1,5 @@
+  Create async version of dns_whitelist_soft, rhsbl and uribl plugins.
+
   async: added pre- and post-connection hooks
 
   Qpsmtpd::Connection->notes are now reset on end of connection (currently

MANIFEST

@@ -29,6 +29,7 @@ lib/Qpsmtpd/Connection.pm
 lib/Qpsmtpd/Constants.pm
 lib/Qpsmtpd/DSN.pm
 lib/Qpsmtpd/Plugin.pm
+lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm
 lib/Qpsmtpd/PollServer.pm
 lib/Qpsmtpd/Postfix.pm
 lib/Qpsmtpd/Postfix/Constants.pm
@@ -47,9 +48,12 @@ MANIFEST			This list of files
 MANIFEST.SKIP
 META.yml			Module meta-data (added by MakeMaker)
 plugins/async/check_earlytalker
+plugins/async/dns_whitelist_soft
 plugins/async/dnsbl
 plugins/async/require_resolvable_fromhost
+plugins/async/rhsbl
 plugins/async/queue/smtp-forward
+plugins/async/uribl
 plugins/auth/auth_cvm_unix_local
 plugins/auth/auth_flat_file
 plugins/auth/auth_ldap_bind

lib/Qpsmtpd/Plugin/Async/DNSBLBase.pm

@@ -0,0 +1,87 @@
+package Qpsmtpd::Plugin::Async::DNSBLBase;
+
+# Class methods shared by the async plugins using DNS based blacklists or
+# whitelists.
+
+use strict;
+use Qpsmtpd::Constants;
+use ParaDNS;
+
+sub lookup {
+    my ($class, $qp, $A_lookups, $TXT_lookups) = @_;
+
+    my $total_zones = @$A_lookups + @$TXT_lookups;
+
+    my ($A_pdns, $TXT_pdns);
+
+    if (@$A_lookups) {
+        $qp->log(LOGDEBUG, "Checking ",
+                 join(", ", @$A_lookups),
+                 " for A record in the background");
+
+        $A_pdns = ParaDNS->new(
+            callback => sub {
+                my ($result, $query) = @_;
+                return if $result !~ /^\d+\.\d+\.\d+\.\d+$/;
+                $qp->log(LOGDEBUG, "Result for A $query: $result");
+                $class->process_a_result($qp, $result, $query);
+            },
+            finished => sub {
+                $total_zones -= @$A_lookups;
+                $class->finished($qp, $total_zones);
+            },
+            hosts  => [@$A_lookups],
+            type   => 'A',
+            client => $qp->input_sock,
+                              );
+
+        return unless defined $A_pdns;
+    }
+
+    if (@$TXT_lookups) {
+        $qp->log(LOGDEBUG, "Checking ",
+                 join(", ", @$TXT_lookups),
+                 " for TXT record in the background");
+
+        $TXT_pdns = ParaDNS->new(
+            callback => sub {
+                my ($result, $query) = @_;
+                return if $result !~ /[a-z]/;
+                $qp->log(LOGDEBUG, "Result for TXT $query: $result");
+                $class->process_txt_result($qp, $result, $query);
+            },
+            finished => sub {
+                $total_zones -= @$TXT_lookups;
+                $class->finished($qp, $total_zones);
+            },
+            hosts  => [@$TXT_lookups],
+            type   => 'TXT',
+            client => $qp->input_sock,
+                                );
+
+        unless (defined $TXT_pdns) {
+            undef $A_pdns;
+            return;
+        }
+    }
+
+    return 1;
+}
+
+sub finished {
+    my ($class, $qp, $total_zones) = @_;
+    $qp->log(LOGDEBUG, "Finished ($total_zones)");
+    $qp->run_continuation unless $total_zones;
+}
+
+# plugins should implement the following two methods to do something
+# useful with the results
+sub process_a_result {
+    my ($class, $qp, $result, $query) = @_;
+}
+
+sub process_txt_result {
+    my ($class, $qp, $result, $query) = @_;
+}
+
+1;

plugins/async/dns_whitelist_soft

@@ -0,0 +1,90 @@
+#!perl -w
+
+use Qpsmtpd::Plugin::Async::DNSBLBase;
+
+sub init {
+    my $self = shift;
+    my $class = ref $self;
+
+    no strict 'refs';
+    push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
+}
+
+sub hook_connect {
+    my ($self, $transaction) = @_;
+    my $class = ref $self;
+
+    my %whitelist_zones =
+      map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('whitelist_zones');
+
+    return DECLINED unless %whitelist_zones;
+
+    my $remote_ip = $self->connection->remote_ip;
+    my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
+
+    # type TXT lookup only
+    return DECLINED
+      unless $class->lookup($self->qp, [],
+                            [map { "$reversed_ip.$_" } keys %whitelist_zones],
+                           );
+
+    return YIELD;
+}
+
+sub process_txt_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $connection = $qp->connection;
+    $connection->notes('whitelisthost', $result)
+      unless $connection->notes('whitelisthost');
+}
+
+sub hook_rcpt {
+    my ($self, $transaction, $rcpt) = @_;
+    my $connection = $self->qp->connection;
+
+    if (my $note = $connection->notes('whitelisthost')) {
+        my $ip = $connection->remote_ip;
+        $self->log(LOGNOTICE, "Host $ip is whitelisted: $note");
+    }
+    return DECLINED;
+}
+
+1;
+
+=head1 NAME
+
+dns_whitelist_soft - dns-based whitelist override for other qpsmtpd plugins
+
+=head1 DESCRIPTION
+
+The dns_whitelist_soft plugin allows selected host to be whitelisted as
+exceptions to later plugin processing.  It is most suitable for multisite
+installations, so that the whitelist is stored in one location and available
+from all.
+
+=head1 CONFIGURATION
+
+To enable the plugin, add it to the ~qpsmtpd/config/plugins file as usual.
+It should precede any plugins whose rejections you wish to override.  You may
+have to alter those plugins to check the appropriate notes field.
+
+Several configuration files are supported, corresponding to different
+parts of the SMTP conversation:
+
+=over 4
+
+=item whitelist_zones
+
+Any IP address listed in the whitelist_zones file is queried using
+the connecting MTA's IP address.  Any A or TXT answer means that the
+remote HOST address can be selectively exempted at other stages by plugins
+testing for a 'whitelisthost' connection note.
+
+=back
+
+NOTE: in contrast to the non-async version, the other 'connect' hooks
+fired after the 'connect' hook of this plugin will see the 'whitelisthost'
+connection note, if set by this plugin.
+
+=cut

plugins/async/dnsbl

@@ -1,20 +1,27 @@
 #!/usr/bin/perl -w
 
-use ParaDNS;
+use Qpsmtpd::Plugin::Async::DNSBLBase;
 
 sub init {
     my ($self, $qp, $denial) = @_;
+    my $class = ref $self;
+
+    {
+        no strict 'refs';
+        push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
+    }
+
     if (defined $denial and $denial =~ /^disconnect$/i) {
         $self->{_dnsbl}->{DENY} = DENY_DISCONNECT;
     }
     else {
         $self->{_dnsbl}->{DENY} = DENY;
     }
-
 }
 
 sub hook_connect {
     my ($self, $transaction) = @_;
+    my $class = ref $self;
 
     my $remote_ip = $self->connection->remote_ip;
 
@@ -29,72 +36,47 @@ sub hook_connect {
 
     my $reversed_ip = join(".", reverse(split(/\./, $remote_ip)));
 
-    my $total_zones = keys %dnsbl_zones;
+    my @A_zones   = grep { defined($dnsbl_zones{$_}) } keys %dnsbl_zones;
-    my $qp          = $self->qp;
+    my @TXT_zones = grep { !defined($dnsbl_zones{$_}) } keys %dnsbl_zones;
-    for my $dnsbl (keys %dnsbl_zones) {
 
-# fix to find A records, if the dnsbl_zones line has a second field 20/1/04 ++msp
+    if (@A_zones) {
-        if (defined($dnsbl_zones{$dnsbl})) {
+
-            $self->log(LOGDEBUG,
+        # message templates for responding to the client
-                 "Checking $reversed_ip.$dnsbl for A record in the background");
+        $self->connection->notes(
-            ParaDNS->new(
+            dnsbl_templates => {
-                callback => sub {
+                map {
-                    process_a_result($qp, $dnsbl_zones{$dnsbl}, @_);
+                    +"$reversed_ip.$_" => $dnsbl_zones{$_}
-                },
+                  } @A_zones
-                finished => sub { $total_zones--; finished($qp, $total_zones) },
+            }
-                host   => "$reversed_ip.$dnsbl",
-                type   => 'A',
-                client => $self->qp->input_sock,
         );
     }
-        else {
+
-            $self->log(LOGDEBUG,
+    return DECLINED
-                 "Checking $reversed_ip.$dnsbl for TXT record in the background"
+      unless $class->lookup($self->qp,
+                            [map { "$reversed_ip.$_" } @A_zones],
+                            [map { "$reversed_ip.$_" } @TXT_zones],
                            );
-            ParaDNS->new(
-                callback => sub { process_txt_result($qp, @_) },
-                finished => sub { $total_zones--; finished($qp, $total_zones) },
-                host   => "$reversed_ip.$dnsbl",
-                type   => 'TXT',
-                client => $self->qp->input_sock,
-                        );
-        }
-    }
 
     return YIELD;
 }
 
-sub finished {
-    my ($qp, $total_zones) = @_;
-    $qp->log(LOGINFO, "Finished ($total_zones)");
-    $qp->run_continuation unless $total_zones;
-}
-
 sub process_a_result {
-    my ($qp, $template, $result, $query) = @_;
+    my ($class, $qp, $result, $query) = @_;
-
-    $qp->log(LOGINFO, "Result for A $query: $result");
-    if ($result !~ /^\d+\.\d+\.\d+\.\d+$/) {
-
-        # NXDOMAIN or ERROR possibly...
-        return;
-    }
 
     my $conn = $qp->connection;
+    return if $conn->notes('dnsbl');
+
+    my $templates = $conn->notes('dnsbl_templates');
     my $ip        = $conn->remote_ip;
+
+    my $template = $templates->{$query};
     $template =~ s/%IP%/$ip/g;
-    $conn->notes('dnsbl', $template) unless $conn->notes('dnsbl');
+
+    $conn->notes('dnsbl', $template);
 }
 
 sub process_txt_result {
-    my ($qp, $result, $query) = @_;
+    my ($class, $qp, $result, $query) = @_;
-
-    $qp->log(LOGINFO, "Result for TXT $query: $result");
-    if ($result !~ /[a-z]/) {
-
-        # NXDOMAIN or ERROR probably...
-        return;
-    }
 
     my $conn = $qp->connection;
     $conn->notes('dnsbl', $result) unless $conn->notes('dnsbl');

plugins/async/rhsbl

@@ -0,0 +1,94 @@
+#!perl -w
+
+use Qpsmtpd::Plugin::Async::DNSBLBase;
+
+sub init {
+    my $self = shift;
+    my $class = ref $self;
+
+    no strict 'refs';
+    push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
+}
+
+sub hook_mail {
+    my ($self, $transaction, $sender) = @_;
+    my $class = ref $self;
+
+    return DECLINED if $sender->format eq '<>';
+
+    my %rhsbl_zones =
+      map { (split /\s+/, $_, 2)[0, 1] } $self->qp->config('rhsbl_zones');
+    return DECLINED unless %rhsbl_zones;
+
+    my $sender_host = $sender->host;
+
+    my @A_zones   = grep { defined($rhsbl_zones{$_}) } keys %rhsbl_zones;
+    my @TXT_zones = grep { !defined($rhsbl_zones{$_}) } keys %rhsbl_zones;
+
+    if (@A_zones) {
+
+        # message templates for responding to the client
+        $transaction->notes(rhsbl_templates =>
+                     {map { +"$sender_host.$_" => $rhsbl_zones{$_} } @A_zones});
+    }
+
+    return DECLINED
+      unless $class->lookup($self->qp,
+                            [map { "$sender_host.$_" } @A_zones],
+                            [map { "$sender_host.$_" } @TXT_zones],
+                           );
+
+    return YIELD;
+}
+
+sub process_a_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $transaction = $qp->transaction;
+    $transaction->notes('rhsbl',
+                        $transaction->notes('rhsbl_templates')->{$query})
+      unless $transaction->notes('rhsbl');
+}
+
+sub process_txt_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $transaction = $qp->transaction;
+    $transaction->notes('rhsbl', $result) unless $transaction->notes('rhsbl');
+}
+
+sub hook_rcpt {
+    my ($self, $transaction, $rcpt) = @_;
+    my $host = $transaction->sender->host;
+
+    my $note = $transaction->notes('rhsbl');
+    return (DENY, "Mail from $host rejected because it $note") if $note;
+    return DECLINED;
+}
+
+1;
+
+=head1 NAME
+
+rhsbl - handle RHSBL lookups
+
+=head1 DESCRIPTION
+
+Pluging that checks the host part of the sender's address against a
+configurable set of RBL services.
+
+=head1 CONFIGURATION
+
+This plugin reads the lists to use from the rhsbl_zones configuration
+file. Normal domain based dns blocking lists ("RBLs") which contain TXT
+records are specified simply as:
+
+  dsn.rfc-ignorant.org
+
+To configure RBL services which do not contain TXT records in the DNS,
+but only A records, specify, after a whitespace, your own error message
+to return in the SMTP conversation e.g.
+
+  abuse.rfc-ignorant.org does not support abuse@domain
+
+=cut

plugins/async/uribl

@@ -0,0 +1,144 @@
+#!/usr/bin/perl -w
+
+use Qpsmtpd::Plugin::Async::DNSBLBase;
+
+use strict;
+use warnings;
+
+sub init {
+    my ($self, $qp, %args) = @_;
+    my $class = ref $self;
+
+    $self->isa_plugin("uribl");
+    {
+        no strict 'refs';
+        push @{"${class}::ISA"}, 'Qpsmtpd::Plugin::Async::DNSBLBase';
+    }
+
+    $self->SUPER::init($qp, %args);
+}
+
+sub register {
+    my $self = shift;
+
+    $self->register_hook('data_post', 'start_data_post');
+    $self->register_hook('data_post', 'finish_data_post');
+}
+
+sub start_data_post {
+    my ($self, $transaction) = @_;
+    my $class = ref $self;
+
+    my @names;
+
+    my $queries = $self->lookup_start($transaction, sub {
+        my ($self, $name) = @_;
+        push @names, $name;
+    });
+
+    my @hosts;
+    foreach my $z (keys %{$self->{uribl_zones}}) {
+        push @hosts, map { "$_.$z" } @names;
+    }
+
+    $transaction->notes(uribl_results => {});
+    $transaction->notes(uribl_zones => $self->{uribl_zones});
+
+    return DECLINED
+        unless @hosts && $class->lookup($self->qp, [ @hosts ], [ @hosts ]);
+
+    return YIELD;
+}
+
+sub finish_data_post {
+    my ($self, $transaction) = @_;
+
+    my $matches = $self->collect_results($transaction);
+    for (@$matches) {
+        $self->log(LOGWARN, $_->{desc});
+        if ($_->{action} eq 'add-header') {
+            $transaction->header->add('X-URIBL-Match', $_->{desc});
+        } elsif ($_->{action} eq 'deny') {
+            return (DENY, $_->{desc});
+        } elsif ($_->{action} eq 'denysoft') {
+            return (DENYSOFT, $_->{desc});
+        }
+    }
+    return DECLINED;
+}
+
+sub init_resolver { }
+
+sub process_a_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $transaction = $qp->transaction;
+    my $results = $transaction->notes('uribl_results');
+    my $zones = $transaction->notes('uribl_zones');
+
+    foreach my $z (keys %$zones) {
+        if ($query =~ /^(.*)\.$z$/) {
+            my $name = $1;
+            $results->{$z}->{$name}->{a} = $result;
+        }
+    }
+}
+
+sub process_txt_result {
+    my ($class, $qp, $result, $query) = @_;
+
+    my $transaction = $qp->transaction;
+    my $results = $transaction->notes('uribl_results');
+    my $zones = $transaction->notes('uribl_zones');
+
+    foreach my $z (keys %$zones) {
+        if ($query =~ /^(.*)\.$z$/) {
+            my $name = $1;
+            $results->{$z}->{$name}->{txt} = $result;
+        }
+    }
+}
+
+sub collect_results {
+    my ($self, $transaction) = @_;
+
+    my $results = $transaction->notes('uribl_results');
+
+    my @matches;
+    foreach my $z (keys %$results) {
+        foreach my $n (keys %{$results->{$z}}) {
+            if (exists $results->{$z}->{$n}->{a}) {
+                if ($self->evaluate($z, $results->{$z}->{$n}->{a})) {
+                    $self->log(LOGDEBUG, "match $n in $z");
+                    push @matches, {
+                        action => $self->{uribl_zones}->{$z}->{action},
+                        desc => "$n in $z: " .
+                            ($results->{$z}->{$n}->{txt} || $results->{$z}->{$n}->{a}),
+                    };
+                }
+            }
+        }
+    }
+
+    return \@matches;
+}
+
+1;
+
+=head1 NAME
+
+uribl - URIBL blocking plugin for qpsmtpd
+
+=head1 DESCRIPTION
+
+This plugin implements DNSBL lookups for URIs found in spam, such as that
+implemented by SURBL (see E<lt>http://surbl.org/E<gt>).  Incoming messages are
+scanned for URIs, which are then checked against one or more URIBLs in a
+fashion similar to DNSBL systems.
+
+=head1 CONFIGURATION
+
+See the documentation of the non-async version. The timeout config option is
+ignored, the ParaDNS timeout is used instead.
+
+=cut

plugins/dns_whitelist_soft

@@ -24,7 +24,7 @@ parts of the SMTP conversation:
 =item whitelist_zones
 
 Any IP address listed in the whitelist_zones file is queried using
-the connecting MTA's IP address.  Any A or TXT answer is means that the
+the connecting MTA's IP address.  Any A or TXT answer means that the
 remote HOST address can be selectively exempted at other stages by plugins
 testing for a 'whitelisthost' connection note.
 
@@ -34,6 +34,10 @@ NOTE: other 'connect' hooks will continue to fire (e.g. dnsbl), since the DNS
 queries happen in the background.  This plugin's 'rcpt_handler' retrieves
 the results of the query and sets the connection note if found.
 
+If you switch to qpsmtpd-async and to the async version of this plugin, then
+the 'whitelisthost' connection note will be available to the other 'connect'
+hooks, see the documentation of the async plugin.
+
 =head1 AUTHOR
 
 John Peacock <jpeacock@rowman.com>

plugins/uribl

@@ -137,7 +137,8 @@ my %strict_twolevel_cctlds = (
     'za' => 1,
 );
 
-sub register {
+# async version: OK
+sub init {
     my ($self, $qp, %args) = @_;
 
     $self->{action} = $args{action} || 'add-header';
@@ -181,11 +182,17 @@ sub register {
         ( map { ($_ => 1) } @whitelist )
     };
 
-    $self->{resolver} = new Net::DNS::Resolver or return undef;
+    $self->init_resolver;
-    $self->{resolver}->udp_timeout($self->{timeout});
+}
+
+# async version: not used
+sub register {
+    my $self = shift;
+
     $self->register_hook('data_post', 'data_handler');
 }
 
+# async version: not used
 sub send_query {
     my $self = shift;
     my $name = shift || return undef;
@@ -230,6 +237,7 @@ sub send_query {
     $count;
 }
 
+# async version: not used
 sub lookup_finish {
     my $self = shift;
     $self->{socket_idx} = {};
@@ -237,6 +245,7 @@ sub lookup_finish {
     undef $self->{socket_select};
 }
 
+# async version: OK
 sub evaluate {
     my $self = shift;
     my $zone = shift || return undef;
@@ -251,8 +260,10 @@ sub evaluate {
     return ($v & $mask);
 }
 
-sub data_handler {
+# async version: OK
-    my ($self, $transaction) = @_;
+sub lookup_start {
+    my ($self, $transaction, $start_query) = @_;
+
     my $l;
     my $queries = 0;
     my %pending;
@@ -297,7 +308,7 @@ sub data_handler {
             my $rev = join('.', reverse @octets);
             $self->log(LOGDEBUG, "uribl: matched pure-integer ipaddr $1 ($fwd)");
             unless (exists $pending{$rev}) {
-                $queries += $self->send_query($rev);
+                $queries += $start_query->($self, $rev);
                 $pending{$rev} = 1;
             }
         }
@@ -320,7 +331,7 @@ sub data_handler {
             my $rev = join('.', reverse @octets);
             $self->log(LOGDEBUG, "uribl: matched URI ipaddr $fwd");
             unless (exists $pending{$rev}) {
-                $queries += $self->send_query($rev);
+                $queries += $start_query->($self, $rev);
                 $pending{$rev} = 1;
             }
         }
@@ -348,7 +359,7 @@ sub data_handler {
                     my $subhost = join('.', @host_domains);
                     unless (exists $pending{$subhost}) {
                         $self->log(LOGINFO, "URIBL: checking sub-host $subhost");
-                        $queries += $self->send_query($subhost);
+                        $queries += $start_query->($self, $subhost);
                         $pending{$subhost} = 1;
                     }
                     shift @host_domains;
@@ -379,7 +390,7 @@ sub data_handler {
                     my $subhost = join('.', @host_domains);
                     unless (exists $pending{$subhost}) {
                         $self->log(LOGINFO, "URIBL: checking sub-host $subhost");
-                        $queries += $self->send_query($subhost);
+                        $queries += $start_query->($self, $subhost);
                         $pending{$subhost} = 1;
                     }
                     shift @host_domains;
@@ -389,11 +400,13 @@ sub data_handler {
     }
     $transaction->body_resetpos;
 
-    unless ($queries) {
+    return $queries;
-        $self->log(LOGINFO, "No URIs found in mail");
-        return DECLINED;
 }
 
+# async version: not used
+sub collect_results {
+    my ($self, $transaction) = @_;
+
     my $matches = 0;
     my $complete = 0;
     my $start_time = time;
@@ -454,7 +467,25 @@ sub data_handler {
 
     $self->lookup_finish;
 
-    for (@matches) {
+    return \@matches;
+}
+
+# async version: not used
+sub data_handler {
+    my ($self, $transaction) = @_;
+
+    my $queries = $self->lookup_start($transaction, sub {
+        my ($self, $name) = @_;
+        return $self->send_query($name);
+    });
+
+    unless ($queries) {
+        $self->log(LOGINFO, "No URIs found in mail");
+        return DECLINED;
+    }
+
+    my $matches = $self->collect_results($transaction);
+    for (@$matches) {
         $self->log(LOGWARN, $_->{desc});
         if ($_->{action} eq 'add-header') {
             $transaction->header->add('X-URIBL-Match', $_->{desc});
@@ -467,6 +498,14 @@ sub data_handler {
     return DECLINED;
 }
 
+# async version: not used
+sub init_resolver {
+    my $self = shift;
+
+    $self->{resolver} = new Net::DNS::Resolver or return undef;
+    $self->{resolver}->udp_timeout($self->{timeout});
+}
+
 1;
 
 # vi: ts=4 sw=4 expandtab syn=perl