Base: consistent DNS handling

Makefile.PL

@@ -13,8 +13,8 @@ WriteMakefile(
         'File::Temp'      => 0,
         'Mail::Header'    => 0,
         'MIME::Base64'    => 0,
-        'Net::DNS'        => 0.39,
+        'Net::DNS'        => 0.79,
-        'Net::IP'         => 0,
+        'Net::IP'         => 1.26,
         'Time::HiRes'     => 0,
         'IO::Socket::SSL' => 0,
         'ClamAV::Client'  => 0,      # virus/clamdscan
@@ -22,7 +22,7 @@ WriteMakefile(
         'Test::More'      => 0,
         'Test::Output'    => 0,
 # modules for specific features
-        'Mail::DKIM'         => 0,
+        'Mail::DKIM'         => 0.40,
         'File::Tail'         => 0,   # log/summarize, log/watch
         'Time::TAI64'        => 0,   # log2sql
 #       'DBI'                => 0,   # auth_vpopmail_sql and

lib/Qpsmtpd/Base.pm

@@ -1,6 +1,7 @@
 package Qpsmtpd::Base;
 use strict;
 
+use Net::DNS;
 use Net::IP;
 
 sub new {
@@ -45,4 +46,67 @@ sub is_ipv6 {
     return Net::IP::ip_is_ipv6($ip);
 };
 
+sub get_resolver {
+    my ($self, %args) = @_;
+    return $self->{_resolver} if $self->{_resolver};
+    my $timeout = 5;
+    if (defined $args{timeout}) {
+        $timeout = delete $args{timeout};
+    }
+    $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
+    $self->{_resolver}->tcp_timeout($timeout);
+    $self->{_resolver}->udp_timeout($timeout);
+    return $self->{_resolver};
+}
+
+sub get_async_resolver {
+    my ( $self, %args ) = @_;
+    return $self->{_async_resolver} if $self->{_async_resolver};
+
+    my $res = Net::DNS::Resolver->new(dnsrch => 0);
+    $res->tcp_timeout(0);  # Net::DNS::Async handles its own timeouts
+    $res->tcp_timeout(0);
+
+    my $async_res;
+    eval 'use Net::DNS::Async';
+    if ($@) {
+        warn "Net::DNS::Async failed to load";
+        return;
+    }
+
+    $self->{_async_resolver} = Net::DNS::Async->new( %args );
+    $self->{_async_resolver}{Resolver} = $res;
+    return $self->{_async_resolver};
+}
+
+sub resolve_a {
+    my ($self, $name) = @_;
+    my $q = $self->get_resolver->query($name, 'A') or return;
+    return map { $_->address } grep { $_->type eq 'A' } $q->answer;
+}
+
+sub resolve_aaaa {
+    my ($self, $name) = @_;
+    my $q = $self->get_resolver->query($name, 'AAAA') or return;
+    return map { $_->address } grep { $_->type eq 'AAAA' } $q->answer;
+}
+
+sub resolve_mx {
+    my ($self, $name) = @_;
+    my $q = $self->get_resolver->query($name, 'MX') or return;
+    return map { $_->exchange } grep { $_->type eq 'MX' } $q->answer;
+}
+
+sub resolve_ns {
+    my ($self, $name) = @_;
+    my $q = $self->get_resolver->query($name, 'NS') or return;
+    return map { $_->nsdname } grep { $_->type eq 'NS' } $q->answer;
+}
+
+sub resolve_ptr {
+    my ($self, $name) = @_;
+    my $q = $self->get_resolver->query($name, 'PTR') or return;
+    return map { $_->ptrdname } grep { $_->type eq 'PTR' } $q->answer;
+}
+
 1;

lib/Qpsmtpd/Plugin.pm

@@ -2,8 +2,8 @@ package Qpsmtpd::Plugin;
 use strict;
 use warnings;
 
-use Net::DNS;
+use lib 'lib';
-
+use parent 'Qpsmtpd::Base';
 use Qpsmtpd::Constants;
 
 # more or less in the order they will fire
@@ -278,17 +278,6 @@ sub store_auth_results {
     $self->qp->connection->notes('authentication_results', $ar );
 };
 
-sub init_resolver {
-    my $self = shift;
-    my $timeout = $self->{_args}{dns_timeout} || shift || 5;
-    return $self->{_resolver} if $self->{_resolver};
-    $self->log(LOGDEBUG, "initializing Net::DNS::Resolver");
-    $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
-    $self->{_resolver}->tcp_timeout($timeout);
-    $self->{_resolver}->udp_timeout($timeout);
-    return $self->{_resolver};
-}
-
 sub is_immune {
     my $self = shift;
 

lib/Qpsmtpd/SMTP.pm

@@ -8,7 +8,6 @@ use Carp;
 #use Data::Dumper;
 use POSIX qw(strftime);
 use Mail::Header;
-use Net::DNS;
 
 use Qpsmtpd;
 use Qpsmtpd::Connection;

plugins/dns_whitelist_soft

@@ -68,10 +68,10 @@ sub hook_connect {
 
     my $reversed_ip = join('.', reverse(split(/\./, $remote_ip)));
 
-    # we queue these lookups in the background and just fetch the
+    # queue lookups in the background and fetch the
     # results in the first rcpt handler
 
-    my $res = new Net::DNS::Resolver;
+    my $res = $self->get_resolver();
     my $sel = IO::Select->new();
 
     for my $dnsbl (keys %whitelist_zones) {
@@ -90,7 +90,7 @@ sub process_sockets {
 
     return $conn->notes('whitelisthost') if $conn->notes('whitelisthost');
 
-    my $res = new Net::DNS::Resolver;
+    my $res = $self->get_resolver();
     my $sel = $conn->notes('whitelist_sockets') or return '';
 
     $self->log(LOGDEBUG, "waiting for whitelist dns");

plugins/dnsbl

@@ -166,7 +166,9 @@ sub hook_connect {
     return DECLINED if $self->ip_whitelisted();
 
     my $dnsbl_zones = $self->get_dnsbl_zones() or return DECLINED;
-    my $resolv      = $self->get_resolver()    or return DECLINED;
+    my $timeout     = $self->{_args}{timeout} || 30;
+    my $resolv      = $self->{_resolver} = $self->get_resolver(timeout=>$timeout)
+        or return DECLINED;
 
     for my $dnsbl (keys %$dnsbl_zones) {
 
@@ -299,15 +301,3 @@ sub hook_rcpt {
 
     return DECLINED;
 }
-
-sub get_resolver {
-    my $self = shift;
-    return $self->{_resolver} if $self->{_resolver};
-    $self->log(LOGDEBUG, "initializing Net::DNS::Resolver");
-    $self->{_resolver} = Net::DNS::Resolver->new(dnsrch => 0);
-    my $timeout = $self->{_args}{timeout} || 30;
-    $self->{_resolver}->tcp_timeout($timeout);
-    $self->{_resolver}->udp_timeout($timeout);
-    return $self->{_resolver};
-}
-

plugins/fcrdns

@@ -141,8 +141,6 @@ sub register {
         $self->{_args}{reject} = 0;
     }
 
-    $self->init_resolver() or return;
-
     $self->register_hook('connect',   'connect_handler');
 }
 
@@ -205,7 +203,7 @@ sub is_not_fqdn {
 sub has_reverse_dns {
     my ($self) = @_;
 
-    my $res = $self->init_resolver();
+    my $res = $self->get_resolver();
     my $ip  = $self->qp->connection->remote_ip;
 
     my $query = $res->query($ip, 'PTR') or do {
@@ -252,7 +250,7 @@ sub has_reverse_dns {
 sub has_forward_dns {
     my ($self) = @_;
 
-    my $res = $self->init_resolver();
+    my $res = $self->get_resolver();
 
     foreach my $host (keys %{$self->{_args}{ptr_hosts}}) {
 

plugins/helo

@@ -244,7 +244,7 @@ sub register {
         $self->{_args}{reject} = 1;
     }
     $self->populate_tests();
-    $self->init_resolver() or return;
+    $self->get_resolver() or return;
 
     $self->register_hook('helo',      'helo_handler');
     $self->register_hook('ehlo',      'helo_handler');
@@ -402,7 +402,7 @@ sub no_forward_dns {
 
     return if $self->is_address_literal($host);
 
-    my $res = $self->init_resolver();
+    my $res = $self->get_resolver();
 
     $host = "$host." if $host !~ /\.$/;    # fully qualify name
     my $query = $res->query($host);
@@ -431,7 +431,7 @@ sub no_forward_dns {
 sub no_reverse_dns {
     my ($self, $host, $ip) = @_;
 
-    my $res = $self->init_resolver();
+    my $res = $self->get_resolver();
     $ip ||= $self->qp->connection->remote_ip;
 
     my $query = $res->query($ip) or do {

plugins/resolvable_fromhost

@@ -92,6 +92,8 @@ sub register {
         $self->{_args}{reject} = 1;
     }
     $self->{_args}{reject_type} ||= 'soft';
+
+    $self->{resolver} = $self->get_resolver(timeout => 30);
 }
 
 sub hook_mail {
@@ -158,16 +160,14 @@ sub check_dns {
         return 1;
     }
 
-    my $res = new Net::DNS::Resolver(dnsrch => 0);
+    my $res = $self->get_resolver(timeout => 30);
-    $res->tcp_timeout(30);
-    $res->udp_timeout(30);
 
-    my $has_mx = $self->get_and_validate_mx($res, $host, $transaction);
+    my $has_mx = $self->get_and_validate_mx($host, $transaction);
     return 1 if $has_mx == 1;     # success, has MX!
     return   if $has_mx == -1;    # has invalid MX records
                                   # at this point, no MX for fh is resolvable
 
-    my @host_answers = $self->get_host_records($res, $host, $transaction);
+    my @host_answers = $self->get_host_records($host, $transaction);
     foreach my $rr (@host_answers) {
         if ($rr->type eq 'A' || $rr->type eq 'AAAA') {
             $self->log(LOGINFO, "pass, found A for $host");
@@ -198,9 +198,9 @@ sub ip_is_valid {
 }
 
 sub get_and_validate_mx {
-    my ($self, $res, $host, $transaction) = @_;
+    my ($self, $host, $transaction) = @_;
 
-    my @mx = mx($res, $host);
+    my @mx = mx($self->{resolver}, $host);
     if (!scalar @mx) {    # no mx records
         $self->adjust_karma(-1);
         $self->log(LOGINFO, "$host has no MX");
@@ -225,9 +225,10 @@ sub get_and_validate_mx {
 }
 
 sub get_host_records {
-    my ($self, $res, $host, $transaction) = @_;
+    my ($self, $host, $transaction) = @_;
 
     my @answers;
+    my $res = $self->{resolver};
     my $query = $res->search($host);
 
     if ($query) {
@@ -259,38 +260,26 @@ sub mx_address_resolves {
     my ($self, $name, $fromhost) = @_;
 
     # IP in MX
-    return $self->ip_is_valid($name) if ip_is_ipv4($name) || ip_is_ipv6($name);
+    if (ip_is_ipv4($name) || ip_is_ipv6($name)) {
+        return $self->ip_is_valid($name);
+    };
+
+    my $res = $self->get_resolver();
+    my @mx_answers = $self->resolve_a($name);
 
-    my $res = new Net::DNS::Resolver(dnsrch => 0);
-    my @mx_answers;
-    my $query = $res->search($name, 'A');
-    if ($query) {
-        foreach my $rrA ($query->answer) {
-            push(@mx_answers, $rrA);
-        }
-    }
     if ($has_ipv6) {
-        my $query = $res->search($name, 'AAAA');
+        push @mx_answers, $self->resolve_aaaa($name);
-        if ($query) {
-            foreach my $rrAAAA ($query->answer) {
-                push(@mx_answers, $rrAAAA);
-            }
-        }
     }
+
     if (!@mx_answers) {
         if ($res->errorstring eq 'NXDOMAIN') {
-            $self->log(LOGWARN, "fail, query for $fromhost, ",
+            $self->log(LOGWARN, "fail, query for $fromhost, ", $res->errorstring);
-                       $res->errorstring);
         }
         return;
     }
 
-    foreach my $rr (@mx_answers) {
+    return if ! scalar @mx_answers;
-        next if ($rr->type ne 'A' && $rr->type ne 'AAAA');
+    return $self->ip_is_valid($mx_answers[0]);
-        return $self->ip_is_valid($rr->address);
-    }
-
-    return;
 }
 
 sub populate_invalid_networks {

plugins/rhsbl

@@ -67,7 +67,7 @@ sub hook_mail {
 
     my %rhsbl_zones = $self->populate_zones() or return DECLINED;
 
-    my $res = $self->init_resolver();
+    my $res = $self->get_resolver();
 
     my @hosts = $sender->host;
     for my $host (@hosts) {

plugins/stunnel

@@ -61,13 +61,8 @@ sub stunnel {
     $self->log(LOGINFO, "stunnel : $2:$4");
 
     # DNS reverse
-    my $res = $self->init_resolver();
+    my @ptrs = $self->resolve_ptr($self->connection->remote_ip);
-    if (my $query = $res->query($self->connection->remote_ip, 'PTR')) {
+    $self->connection->remote_host($ptrs[0]);
-        foreach my $rr ($query->answer) {
-            next if $rr->type ne 'PTR';
-            $self->connection->remote_host($rr->ptrdname);
-        }
-    }
     return DONE;
 }
 

plugins/uribl

@@ -92,9 +92,9 @@ may be used and redistributed under the same terms as qpsmtpd itself.
 use strict;
 use warnings;
 
+use lib 'lib';
 use Qpsmtpd::Constants;
 
-use Net::DNS::Resolver;
 use Time::HiRes qw(time);
 use IO::Select;
 
@@ -180,7 +180,7 @@ sub init {
     my @whitelist = $self->qp->config('uribl_whitelist_domains');
     $self->{whitelist_zones} = {(map { ($_ => 1) } @whitelist)};
 
-    $self->init_resolver;
+    $self->{resolver} = $self->get_resolver(timeout => $self->{timeout});
 }
 
 sub send_query {
@@ -533,8 +533,3 @@ sub hook_data {
     return DECLINED;
 }
 
-sub init_resolver {
-    my $self = shift;
-    $self->{resolver} = new Net::DNS::Resolver or return;
-    $self->{resolver}->udp_timeout($self->{timeout});
-}

t/plugin_tests/helo

@@ -8,7 +8,6 @@ use Qpsmtpd::Constants;
 sub register_tests {
     my $self = shift;
 
-    $self->register_test('test_init_resolver');
     $self->register_test('test_is_in_badhelo');
     $self->register_test('test_is_regex_match');
     $self->register_test('test_invalid_localhost');
@@ -24,17 +23,9 @@ sub register_tests {
 
 sub test_helo_handler {
     my $self = shift;
-
     cmp_ok( $self->helo_handler(undef, undef), '==', DECLINED, "empty host");
 };
 
-sub test_init_resolver {
-    my $self = shift;
-    my $net_dns = $self->init_resolver();
-    ok( $net_dns, "net::dns" );
-    cmp_ok( ref $net_dns, 'eq', 'Net::DNS::Resolver', "ref ok");
-};
-
 sub test_is_in_badhelo {
     my $self = shift;
 

t/plugin_tests/resolvable_fromhost

@@ -3,11 +3,9 @@
 use strict;
 use warnings;
 
-use Net::DNS;
 use Qpsmtpd::Address;
 use Qpsmtpd::Constants;
 
-my $res = new Net::DNS::Resolver(dnsrch => 0);
 my $test_email = 'user@example.com';
 
 sub register_tests {
@@ -60,17 +58,17 @@ sub test_get_and_validate_mx {
     my $self = shift;
     my $transaction = $self->qp->transaction;
 
-    ok( scalar $self->get_and_validate_mx( $res, 'perl.com', $transaction ) );
+    ok( scalar $self->get_and_validate_mx( 'perl.com', $transaction ) );
 
-    ok( ! scalar $self->get_host_records( $res, 'fake-domain-name-for-test.com', $transaction ) );
+    ok( ! scalar $self->get_host_records( 'fake-domain-name-for-test.com', $transaction ) );
 };
 
 sub test_get_host_records {
     my $self = shift;
     my $transaction = $self->qp->transaction;
 
-    ok( scalar $self->get_host_records( $res, 'perl.com', $transaction ) );
+    ok( scalar $self->get_host_records( 'perl.com', $transaction ) );
-    ok( ! scalar $self->get_host_records( $res, 'fake-domain-name-for-test.com', $transaction ) );
+    ok( ! scalar $self->get_host_records( 'fake-domain-name-for-test.com', $transaction ) );
 };
 
 sub test_mx_address_resolves {

t/qpsmtpd-base.t

@@ -16,6 +16,13 @@ my $base = Qpsmtpd::Base->new();
 __tildeexp();
 __is_localhost();
 __is_valid_ip();
+__get_resolver();
+__get_async_resolver();
+__resolve_a();
+__resolve_aaaa();
+__resolve_mx();
+__resolve_ns();
+__resolve_ptr();
 
 done_testing();
 
@@ -49,3 +56,43 @@ sub __tildeexp {
     $path = $base->tildeexp('no/tilde/in/path');
     cmp_ok( $path, 'eq', 'no/tilde/in/path', 'tildeexp, no expansion');
 };
+
+sub __get_resolver {
+    my $res = $base->get_resolver();
+    isa_ok( $res, 'Net::DNS::Resolver', "get_resolver returns a Net::DNS::Resolver");
+
+}
+
+sub __get_async_resolver {
+    my $res = $base->get_async_resolver() or return;
+    isa_ok( $res, 'Net::DNS::Async', "resolver object, $res");
+    isa_ok( $res->{Resolver}, 'Net::DNS::Resolver', "resolver object, $res");
+}
+
+sub __resolve_a {
+    my @r = $base->resolve_a('simerson.net');
+    ok(@r, "resolve_a: " . join(',', @r));
+}
+
+sub __resolve_aaaa {
+    my @r = $base->resolve_aaaa('ns2.cadillac.net');
+    ok(@r, "resolve_aaaa: " . join(',', @r));
+}
+
+sub __resolve_mx {
+    my @r = $base->resolve_mx('simerson.net');
+    ok(@r, "resolve_mx: " . join(',', @r));
+}
+
+sub __resolve_ns {
+    my @r = $base->resolve_ns('simerson.net');
+    ok(@r, "resolve_ns: " . join(', ', @r));
+}
+
+sub __resolve_ptr {
+    my @r = $base->resolve_ptr('163.51.128.66.in-addr.arpa.');
+    ok(@r, "resolve_ptr: FQDN: " . join(', ', @r));
+
+    @r = $base->resolve_ptr('66.128.51.163');
+    ok(@r, "resolve_ptr, IP: " . join(', ', @r));
+}