| # <@LICENSE> |
| # Licensed to the Apache Software Foundation (ASF) under one or more |
| # contributor license agreements. See the NOTICE file distributed with |
| # this work for additional information regarding copyright ownership. |
| # The ASF licenses this file to you under the Apache License, Version 2.0 |
| # (the "License"); you may not use this file except in compliance with |
| # the License. You may obtain a copy of the License at: |
| # |
| # http://www.apache.org/licenses/LICENSE-2.0 |
| # |
| # Unless required by applicable law or agreed to in writing, software |
| # distributed under the License is distributed on an "AS IS" BASIS, |
| # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
| # See the License for the specific language governing permissions and |
| # limitations under the License. |
| # </@LICENSE> |
| |
| =head1 NAME |
| |
| Mail::SpamAssassin::DnsResolver - DNS resolution engine |
| |
| =head1 DESCRIPTION |
| |
| This is a DNS resolution engine for SpamAssassin, implemented in order to |
| reduce file descriptor usage by Net::DNS and avoid a response collision bug in |
| that module. |
| |
| =head1 METHODS |
| |
| =over 4 |
| |
| =cut |
| |
| # TODO: caching in this layer instead of in callers. |
| |
| package Mail::SpamAssassin::DnsResolver; |
| |
| use strict; |
| use warnings; |
| use bytes; |
| use re 'taint'; |
| |
| use Mail::SpamAssassin; |
| use Mail::SpamAssassin::Logger; |
| use Mail::SpamAssassin::Constants qw(:ip); |
| use Mail::SpamAssassin::Util qw(untaint_var fmt_dns_question_entry); |
| |
| use Socket; |
| use Errno qw(EADDRINUSE EACCES); |
| use Time::HiRes qw(time); |
| |
| our @ISA = qw(); |
| |
| use vars qw($io_socket_module_name); |
| BEGIN { |
| if (eval { require IO::Socket::IP }) { |
| $io_socket_module_name = 'IO::Socket::IP'; |
| } elsif (eval { require IO::Socket::INET6 }) { |
| $io_socket_module_name = 'IO::Socket::INET6'; |
| } elsif (eval { require IO::Socket::INET }) { |
| $io_socket_module_name = 'IO::Socket::INET'; |
| } |
| } |
| |
| ########################################################################### |
| |
| sub new { |
| my $class = shift; |
| $class = ref($class) || $class; |
| |
| my ($main) = @_; |
| my $self = { |
| 'main' => $main, |
| 'conf' => $main->{conf}, |
| 'id_to_callback' => { }, |
| }; |
| bless ($self, $class); |
| |
| $self->load_resolver(); |
| $self; |
| } |
| |
| ########################################################################### |
| |
| =item $res->load_resolver() |
| |
| Load the C<Net::DNS::Resolver> object. Returns 0 if Net::DNS cannot be used, |
| 1 if it is available. |
| |
| =cut |
| |
| sub load_resolver { |
| my ($self) = @_; |
| |
| if ($self->{res}) { return 1; } |
| $self->{no_resolver} = 1; |
| |
| # force only ipv4 if no IO::Socket::INET6 or ipv6 doesn't work |
| my $force_ipv4 = $self->{main}->{force_ipv4}; |
| my $force_ipv6 = $self->{main}->{force_ipv6}; |
| |
| if (!$force_ipv4 && $io_socket_module_name eq 'IO::Socket::INET') { |
| dbg("dns: socket module for IPv6 support not available"); |
| die "Use of IPv6 requested, but not available\n" if $force_ipv6; |
| $force_ipv4 = 1; $force_ipv6 = 0; |
| } |
| if (!$force_ipv4) { # test drive IPv6 |
| eval { |
| my $sock6; |
| if ($io_socket_module_name) { |
| $sock6 = $io_socket_module_name->new(LocalAddr=>'::', Proto=>'udp'); |
| } |
| if ($sock6) { $sock6->close() or warn "error closing socket: $!" } |
| $sock6; |
| } or do { |
| dbg("dns: socket module %s is available, but no host support for IPv6", |
| $io_socket_module_name); |
| die "Use of IPv6 requested, but not available\n" if $force_ipv6; |
| $force_ipv4 = 1; $force_ipv6 = 0; |
| } |
| } |
| |
| eval { |
| require Net::DNS; |
| # force_v4 is set in new() to avoid error in older versions of Net::DNS |
| # that don't have it; other options are set by function calls so a typo |
| # or API change will cause an error here |
| my $res = $self->{res} = Net::DNS::Resolver->new(force_v4 => $force_ipv4); |
| if ($res) { |
| $self->{no_resolver} = 0; |
| $self->{force_ipv4} = $force_ipv4; |
| $self->{force_ipv6} = $force_ipv6; |
| $self->{retry} = 1; # retries for non-backgrounded query |
| $self->{retrans} = 3; # initial timeout for "non-backgrounded" |
| # query run in background |
| |
| $res->retry(1); # If it fails, it fails |
| $res->retrans(0); # If it fails, it fails |
| $res->dnsrch(0); # ignore domain search-list |
| $res->defnames(0); # don't append stuff to end of query |
| $res->tcp_timeout(3); # timeout of 3 seconds only |
| $res->udp_timeout(3); # timeout of 3 seconds only |
| $res->persistent_tcp(0); # bug 3997 |
| $res->persistent_udp(0); # bug 3997 |
| |
| # RFC 2671 bis - EDNS0, value is a requestor's UDP payload size |
| my $edns = $self->{conf}->{dns_options}->{edns}; |
| if ($edns && $edns > 512) { |
| $res->udppacketsize($edns); |
| dbg("dns: EDNS, UDP payload size %d", $edns); |
| } |
| |
| # set $res->nameservers for the benefit of plugins which don't use |
| # our send/bgsend infrastructure but rely on Net::DNS::Resolver entirely |
| my @ns_addr_port = $self->available_nameservers(); |
| local($1,$2); |
| # drop port numbers, Net::DNS::Resolver can't take them |
| @ns_addr_port = map(/^\[(.*)\]:(\d+)\z/ ? $1 : $_, @ns_addr_port); |
| dbg("dns: nameservers set to %s", join(', ', @ns_addr_port)); |
| $res->nameservers(@ns_addr_port); |
| } |
| 1; |
| } or do { |
| my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; |
| dbg("dns: eval failed: $eval_stat"); |
| }; |
| |
| dbg("dns: using socket module: %s%s", $io_socket_module_name, |
| $self->{force_ipv4} ? ', forced IPv4' : |
| $self->{force_ipv6} ? ', forced IPv6' : ''); |
| dbg("dns: is Net::DNS::Resolver available? %s", |
| $self->{no_resolver} ? "no" : "yes" ); |
| if (!$self->{no_resolver} && defined $Net::DNS::VERSION) { |
| dbg("dns: Net::DNS version: %s", $Net::DNS::VERSION); |
| } |
| |
| return (!$self->{no_resolver}); |
| } |
| |
| =item $resolver = $res->get_resolver() |
| |
| Return the C<Net::DNS::Resolver> object. |
| |
| =cut |
| |
| sub get_resolver { |
| my ($self) = @_; |
| return $self->{res}; |
| } |
| |
| =item $res->configured_nameservers() |
| |
| Get a list of nameservers as configured by dns_server directives |
| or as provided by Net::DNS, typically from /etc/resolv.conf |
| |
| =cut |
| |
| sub configured_nameservers { |
| my $self = shift; |
| |
| my $res = $self->{res}; |
| my @ns_addr_port; # list of name servers: [addr]:port entries |
| if ($self->{conf}->{dns_servers}) { # specified in a config file |
| @ns_addr_port = @{$self->{conf}->{dns_servers}}; |
| dbg("dns: servers set by config to: %s", join(', ',@ns_addr_port)); |
| } elsif ($res) { # default as provided by Net::DNS, e.g. /etc/resolv.conf |
| @ns_addr_port = map(untaint_var("[$_]:" . $res->{port}), |
| @{$res->{nameservers}}); |
| dbg("dns: servers obtained from Net::DNS : %s", join(', ',@ns_addr_port)); |
| } |
| return @ns_addr_port; |
| } |
| |
| =item $res->available_nameservers() |
| |
| Get or set a list of currently available nameservers, |
| which is typically a known-to-be-good subset of configured nameservers |
| |
| =cut |
| |
| sub available_nameservers { |
| my $self = shift; |
| |
| if (@_) { |
| $self->{available_dns_servers} = [ @_ ]; # copy |
| dbg("dns: servers set by a caller to: %s", |
| join(', ',@{$self->{available_dns_servers}})); |
| } elsif (!$self->{available_dns_servers}) { |
| # a list of configured name servers: [addr]:port entries |
| $self->{available_dns_servers} = [ $self->configured_nameservers() ]; |
| } |
| if ($self->{force_ipv4} || $self->{force_ipv6}) { |
| # filter the list according to a chosen protocol family |
| my $ip4_re = IPV4_ADDRESS; |
| my(@filtered_addr_port); |
| for (@{$self->{available_dns_servers}}) { |
| local($1,$2); |
| /^ \[ (.*) \] : (\d+) \z/xs or next; |
| my($addr,$port) = ($1,$2); |
| if ($addr =~ /^${ip4_re}\z/o) { |
| push(@filtered_addr_port, $_) unless $self->{force_ipv6}; |
| } elsif ($addr =~ /:.*:/) { |
| push(@filtered_addr_port, $_) unless $self->{force_ipv4}; |
| } else { |
| warn "Unrecognized DNS server specification: $_"; |
| } |
| } |
| if (@filtered_addr_port < @{$self->{available_dns_servers}}) { |
| dbg("dns: filtered DNS servers according to protocol family: %s", |
| join(", ",@filtered_addr_port)); |
| } |
| @{$self->{available_dns_servers}} = @filtered_addr_port; |
| } |
| die "available_nameservers: No DNS servers available!\n" |
| if !@{$self->{available_dns_servers}}; |
| return @{$self->{available_dns_servers}}; |
| } |
| |
| sub disable_available_port { |
| my($self, $lport) = @_; |
| if ($lport >= 0 && $lport <= 65535) { |
| my $conf = $self->{conf}; |
| if (!defined $conf->{dns_available_portscount}) { |
| $self->pick_random_available_port(); # initialize |
| } |
| if (vec($conf->{dns_available_ports_bitset}, $lport, 1)) { |
| dbg("dns: disabling local port %d", $lport); |
| vec($conf->{dns_available_ports_bitset}, $lport, 1) = 0; |
| $conf->{dns_available_portscount_buckets}->[$lport >> 8] --; |
| $conf->{dns_available_portscount} --; |
| } |
| } |
| } |
| |
| sub pick_random_available_port { |
| my $self = shift; |
| my $port_number; # resulting port number, or undef if none available |
| |
| my $conf = $self->{conf}; |
| my $available_portscount = $conf->{dns_available_portscount}; |
| |
| # initialize when called for the first time or after a config change |
| if (!defined $available_portscount) { |
| my $ports_bitset = $conf->{dns_available_ports_bitset}; |
| if (!defined $ports_bitset) { # ensure it is initialized |
| Mail::SpamAssassin::Conf::set_ports_range(\$ports_bitset, 0, 0, 0); |
| $conf->{dns_available_ports_bitset} = $ports_bitset; |
| } |
| # prepare auxilliary data structure to speed up further free-port lookups; |
| # 256 buckets, each accounting for 256 ports: 8+8 = 16 bit port numbers; |
| # each bucket holds a count of available ports in its range |
| my @bucket_counts = (0) x 256; |
| my $all_zeroes = "\000" x 32; # one bucket's worth (256) of zeroes |
| my $all_ones = "\377" x 32; # one bucket's worth (256) of ones |
| my $ind = 0; |
| $available_portscount = 0; # number of all available ports |
| foreach my $bucket (0..255) { |
| my $cnt = 0; |
| my $b = substr($ports_bitset, $bucket*32, 32); # one bucket: 256 bits |
| if ($b eq $all_zeroes) { $ind += 256 } |
| elsif ($b eq $all_ones) { $ind += 256; $cnt += 256 } |
| else { # count nontrivial cases the slow way |
| foreach (0..255) { if (vec($ports_bitset, $ind++, 1)) { $cnt++ } } |
| } |
| $available_portscount += $cnt; |
| $bucket_counts[$bucket] = $cnt; |
| } |
| $conf->{dns_available_portscount} = $available_portscount; |
| if ($available_portscount) { |
| $conf->{dns_available_portscount_buckets} = \@bucket_counts; |
| } else { # save some storage |
| $conf->{dns_available_portscount_buckets} = undef; |
| $conf->{dns_available_ports_bitset} = ''; |
| } |
| } |
| |
| # find the n-th port number from the ordered set of available port numbers |
| dbg("dns: %d configured local ports for DNS queries", $available_portscount); |
| if ($available_portscount > 0) { |
| my $ports_bitset = $conf->{dns_available_ports_bitset}; |
| my $n = int(rand($available_portscount)); |
| my $bucket_counts_ref = $conf->{dns_available_portscount_buckets}; |
| my $ind = 0; |
| foreach my $bucket (0..255) { |
| # find the bucket containing n-th turned-on bit |
| my $cnt = $bucket_counts_ref->[$bucket]; |
| if ($cnt > $n) { last } else { $n -= $cnt; $ind += 256 } |
| } |
| while ($ind <= 65535) { # scans one bucket, runs at most 256 iterations |
| # find the n-th turned-on bit within the corresponding bucket |
| if (vec($ports_bitset, $ind, 1)) { |
| if ($n <= 0) { $port_number = $ind; last } else { $n-- } |
| } |
| $ind++; |
| } |
| } |
| return $port_number; |
| } |
| |
| =item $res->connect_sock() |
| |
| Re-connect to the first nameserver listed in C</etc/resolv.conf> or similar |
| platform-dependent source, as provided by C<Net::DNS>. |
| |
| =cut |
| |
| sub connect_sock { |
| my ($self) = @_; |
| |
| dbg("dns: connect_sock, resolver: %s", $self->{no_resolver} ? "no" : "yes"); |
| return if $self->{no_resolver}; |
| |
| $io_socket_module_name |
| or die "No Perl modules for network socket available"; |
| |
| if ($self->{sock}) { |
| $self->{sock}->close() |
| or info("connect_sock: error closing socket %s: %s", $self->{sock}, $!); |
| $self->{sock} = undef; |
| } |
| my $sock; |
| my $errno; |
| |
| # list of name servers: [addr]:port entries |
| my @ns_addr_port = $self->available_nameservers(); |
| # use the first name server in a list |
| my($ns_addr,$ns_port); local($1,$2); |
| ($ns_addr,$ns_port) = ($1,$2) if $ns_addr_port[0] =~ /^\[(.*)\]:(\d+)\z/; |
| |
| # Ensure families of src and dest addresses match (bug 4412 comment 29). |
| # Older IO::Socket::INET6 may choose a wrong LocalAddr if protocol family |
| # is unspecified, causing EINVAL failure when automatically assigned local |
| # IP address and a remote address do not belong to the same address family. |
| # Let's choose a suitable source address if possible. |
| my $ip4_re = IPV4_ADDRESS; |
| my $srcaddr; |
| if ($self->{force_ipv4}) { |
| $srcaddr = "0.0.0.0"; |
| } elsif ($self->{force_ipv6}) { |
| $srcaddr = "::"; |
| } elsif ($ns_addr =~ /^${ip4_re}\z/o) { |
| $srcaddr = "0.0.0.0"; |
| } elsif ($ns_addr =~ /:.*:/) { |
| $srcaddr = "::"; |
| } else { # unrecognized |
| # unspecified address, unspecified protocol family |
| } |
| dbg("dns: LocalAddr: %s, name server(s): %s", |
| $srcaddr||'', join(', ',@ns_addr_port)); |
| |
| # find a free local random port from a set of declared-to-be-available ports |
| my $lport; |
| my $attempts = 0; |
| for (;;) { |
| $attempts++; |
| $lport = $self->pick_random_available_port(); |
| if (!defined $lport) { |
| $lport = 0; |
| dbg("no configured local ports for DNS queries, letting OS choose"); |
| } |
| if ($attempts+1 > 50) { # sanity check |
| warn "could not create a DNS resolver socket in $attempts attempts\n"; |
| $errno = 0; |
| last; |
| } |
| my %args = ( |
| PeerAddr => $ns_addr, |
| PeerPort => $ns_port, |
| LocalAddr => $srcaddr, |
| LocalPort => $lport, |
| Type => SOCK_DGRAM, |
| Proto => 'udp', |
| ); |
| $sock = $io_socket_module_name->new(%args); |
| |
| last if $sock; # ok, got it |
| |
| # IO::Socket::IP constructor provides full error messages in $@ |
| $errno = $io_socket_module_name eq 'IO::Socket::IP' ? $@ : $!; |
| |
| if ($! == EADDRINUSE || $! == EACCES) { |
| # in use, let's try another source port |
| dbg("dns: UDP port $lport already in use, trying another port"); |
| if ($self->{conf}->{dns_available_portscount} > 100) { # still abundant |
| $self->disable_available_port($lport); |
| } |
| } else { |
| warn "error creating a DNS resolver socket: $errno"; |
| goto no_sock; |
| } |
| } |
| if (!$sock) { |
| warn "could not create a DNS resolver socket in $attempts attempts: $errno"; |
| goto no_sock; |
| } |
| |
| eval { |
| my($bufsiz,$newbufsiz); |
| $bufsiz = $sock->sockopt(Socket::SO_RCVBUF) |
| or die "cannot get a resolver socket rx buffer size: $!"; |
| if ($bufsiz >= 32*1024) { |
| dbg("dns: resolver socket rx buffer size is %d bytes, local port %d", |
| $bufsiz, $lport); |
| } else { |
| $sock->sockopt(Socket::SO_RCVBUF, 32*1024) |
| or die "cannot set a resolver socket rx buffer size: $!"; |
| $newbufsiz = $sock->sockopt(Socket::SO_RCVBUF) |
| or die "cannot get a resolver socket rx buffer size: $!"; |
| dbg("dns: resolver socket rx buffer size changed from %d to %d bytes, ". |
| "local port %d", $bufsiz, $newbufsiz, $lport); |
| } |
| 1; |
| } or do { |
| my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; |
| info("dns: socket buffer size error: $eval_stat"); |
| }; |
| |
| $self->{sock} = $sock; |
| $self->{sock_as_vec} = $self->fhs_to_vec($self->{sock}); |
| return; |
| |
| no_sock: |
| undef $self->{sock}; |
| undef $self->{sock_as_vec}; |
| } |
| |
| sub connect_sock_if_reqd { |
| my ($self) = @_; |
| $self->connect_sock() if !$self->{sock}; |
| } |
| |
| =item $res->get_sock() |
| |
| Return the C<IO::Socket::INET> object used to communicate with |
| the nameserver. |
| |
| =cut |
| |
| sub get_sock { |
| my ($self) = @_; |
| $self->connect_sock_if_reqd(); |
| return $self->{sock}; |
| } |
| |
| ########################################################################### |
| |
| =item $packet = new_dns_packet ($domain, $type, $class) |
| |
| A wrapper for C<Net::DNS::Packet::new()> which traps a die thrown by it. |
| |
| To use this, change calls to C<Net::DNS::Resolver::bgsend> from: |
| |
| $res->bgsend($domain, $type); |
| |
| to: |
| |
| $res->bgsend(Mail::SpamAssassin::DnsResolver::new_dns_packet($domain, $type, $class)); |
| |
| =cut |
| |
| # implements draft-vixie-dnsext-dns0x20-00 |
| # |
| sub dnsext_dns0x20 { |
| my ($string) = @_; |
| my $rnd; |
| my $have_rnd_bits = 0; |
| my $result = ''; |
| for my $ic (unpack("C*",$string)) { |
| if (chr($ic) =~ /^[A-Za-z]\z/) { |
| if ($have_rnd_bits < 1) { |
| # only reveal few bits at a time, hiding most of the accumulator |
| $rnd = int(rand(0x7fffffff)) & 0xff; $have_rnd_bits = 8; |
| } |
| $ic ^= 0x20 if $rnd & 1; # flip the 0x20 bit in name if dice says so |
| $rnd = $rnd >> 1; $have_rnd_bits--; |
| } |
| $result .= chr($ic); |
| } |
| return $result; |
| } |
| |
| # this subroutine mimics the Net::DNS::Resolver::Base::make_query_packet() |
| # |
| sub new_dns_packet { |
| my ($self, $domain, $type, $class) = @_; |
| |
| return if $self->{no_resolver}; |
| |
| # construct a PTR query if it looks like an IPv4 address |
| if (!defined($type) || $type eq 'PTR') { |
| local($1,$2,$3,$4); |
| if ($domain =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { |
| $domain = "$4.$3.$2.$1.in-addr.arpa."; |
| $type = 'PTR'; |
| } |
| } |
| $type = 'A' if !defined $type; # a Net::DNS::Packet default |
| $class = 'IN' if !defined $class; # a Net::DNS::Packet default |
| |
| my $packet; |
| eval { |
| $domain =~ s/\.*\z/./s; |
| if (length($domain) > 255) { |
| die "domain name longer than 255 bytes\n"; |
| } elsif ($domain !~ /^ (?: [^.]{1,63} \. )+ \z/sx) { |
| if ($domain !~ /^ (?: [^.]+ \. )+ \z/sx) { |
| die "a domain name contains a null label\n"; |
| } else { |
| die "a label in a domain name is longer than 63 bytes\n"; |
| } |
| } |
| |
| if ($self->{conf}->{dns_options}->{dns0x20}) { |
| $domain = dnsext_dns0x20($domain); |
| } else { |
| $domain =~ tr/A-Z/a-z/; # lowercase, limited to plain ASCII |
| } |
| |
| # Net::DNS expects RFC 1035 zone format encoding even in its API, silly! |
| # Since 0.68 it also assumes that domain names containing characters |
| # with codes above 0177 imply that IDN translation is to be performed. |
| # Protect also nonprintable characters just in case, ensuring transparency. |
| $domain =~ s{ ( [\000-\037\177-\377\\] ) } |
| { $1 eq '\\' ? "\\$1" : sprintf("\\%03d",ord($1)) }xgse; |
| |
| $packet = Net::DNS::Packet->new($domain, $type, $class); |
| |
| # a bit noisy, so commented by default... |
| #dbg("dns: new DNS packet time=%.3f domain=%s type=%s id=%s", |
| # time, $domain, $type, $packet->id); |
| 1; |
| } or do { |
| # this can if a domain name in a query is invalid, or if a timeout signal |
| # happened to be trapped by this eval, or if Net::DNS signalled an error |
| my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; |
| # resignal if alarm went off |
| die "dns: (1) $eval_stat\n" if $eval_stat =~ /__alarm__ignore__\(.*\)/s; |
| warn sprintf( |
| "dns: new_dns_packet (domain=%s type=%s class=%s) failed: %s\n", |
| $domain, $type, $class, $eval_stat); |
| }; |
| |
| if ($packet) { |
| # my $udp_payload_size = $self->{res}->udppacketsize; |
| my $udp_payload_size = $self->{conf}->{dns_options}->{edns}; |
| if ($udp_payload_size && $udp_payload_size > 512) { |
| # dbg("dns: adding EDNS ext, UDP payload size %d", $udp_payload_size); |
| if ($packet->UNIVERSAL::can('edns')) { # available since Net::DNS 0.69 |
| $packet->edns->size($udp_payload_size); |
| } else { # legacy mechanism |
| my $optrr = Net::DNS::RR->new(Type => 'OPT', Name => '', TTL => 0, |
| Class => $udp_payload_size); |
| $packet->push('additional', $optrr); |
| } |
| } |
| } |
| |
| return $packet; |
| } |
| |
| # Internal function used only in this file |
| ## compute a unique ID for a packet to match the query to the reply |
| ## It must use only data that is returned unchanged by the nameserver. |
| ## Argument is a Net::DNS::Packet that has a non-empty question section, |
| ## return is an (opaque) string that can be used as a hash key |
| sub _packet_id { |
| my ($self, $packet) = @_; |
| my $header = $packet->header; |
| my $id = $header->id; |
| my @questions = $packet->question; |
| |
| @questions <= 1 |
| or warn "dns: packet has multiple questions: " . $packet->string . "\n"; |
| |
| if ($questions[0]) { |
| # Bug 6232: Net::DNS::Packet::new is not consistent in keeping data in |
| # sections of a packet either as original bytes or presentation-encoded: |
| # creating a query packet as above in new_dns_packet() keeps label in |
| # non-encoded form, yet on parsing an answer packet, its query section |
| # is converted to presentation form by Net::DNS::Question::parse calling |
| # Net::DNS::Packet::dn_expand and Net::DNS::wire2presentation in turn. |
| # Let's undo the effect of the wire2presentation routine here to make |
| # sure the query section of an answer packet matches the query section |
| # in our packet as formed by new_dns_packet(): |
| # |
| my($class,$type,$qname) = fmt_dns_question_entry($questions[0]); |
| $qname =~ tr/A-Z/a-z/ if !$self->{conf}->{dns_options}->{dns0x20}; |
| return join('/', $id, $class, $type, $qname); |
| |
| } else { |
| # Odd, this should not happen, a DNS servers is supposed to retain |
| # a question section in its reply. There is a bug in Net::DNS 0.72 |
| # and earlier where a signal (e.g. a timeout alarm) during decoding |
| # of a reply packet produces a seemingly valid packet object, but |
| # with missing sections - see [rt.cpan.org #83451] . |
| # |
| # Better support it; just return the (safe) ID part, along with |
| # a text token indicating that the packet had no question part. |
| # |
| return $id . "/NO_QUESTION_IN_PACKET"; |
| } |
| } |
| |
| ########################################################################### |
| |
| =item $id = $res->bgsend($domain, $type, $class, $cb) |
| |
| Quite similar to C<Net::DNS::Resolver::bgsend>, except that when a reply |
| packet eventually arrives, and C<poll_responses> is called, the callback |
| sub reference C<$cb> will be called. |
| |
| Note that C<$type> and C<$class> may be C<undef>, in which case they |
| will default to C<A> and C<IN>, respectively. |
| |
| The callback sub will be called with three arguments -- the packet that was |
| delivered, and an id string that fingerprints the query packet and the expected |
| reply. The third argument is a timestamp (Unix time, floating point), captured |
| at the time the packet was collected. It is expected that a closure callback |
| be used, like so: |
| |
| my $id = $self->{resolver}->bgsend($domain, $type, undef, sub { |
| my ($reply, $reply_id, $timestamp) = @_; |
| $self->got_a_reply ($reply, $reply_id); |
| }); |
| |
| The callback can ignore the reply as an invalid packet sent to the listening |
| port if the reply id does not match the return value from bgsend. |
| |
| =cut |
| |
| sub bgsend { |
| my ($self, $domain, $type, $class, $cb) = @_; |
| return if $self->{no_resolver}; |
| |
| $self->{send_timed_out} = 0; |
| |
| my $pkt = $self->new_dns_packet($domain, $type, $class); |
| return if !$pkt; # just bail out, new_dns_packet already reported a failure |
| |
| my @ns_addr_port = $self->available_nameservers(); |
| dbg("dns: bgsend, DNS servers: %s", join(', ',@ns_addr_port)); |
| my $n_servers = scalar @ns_addr_port; |
| |
| my $ok; |
| for (my $attempts=1; $attempts <= $n_servers; $attempts++) { |
| dbg("dns: attempt %d/%d, trying connect/sendto to %s", |
| $attempts, $n_servers, $ns_addr_port[0]); |
| $self->connect_sock_if_reqd(); |
| if ($self->{sock} && defined($self->{sock}->send($pkt->data, 0))) { |
| $ok = 1; last; |
| } else { # any other DNS servers in a list to try? |
| my $msg = !$self->{sock} ? "unable to connect to $ns_addr_port[0]" |
| : "sendto() to $ns_addr_port[0] failed: $!"; |
| $self->finish_socket(); |
| if ($attempts >= $n_servers) { |
| warn "dns: $msg, no more alternatives\n"; |
| last; |
| } |
| # try with a next DNS server, rotate the list left |
| warn "dns: $msg, failing over to $ns_addr_port[1]\n"; |
| push(@ns_addr_port, shift(@ns_addr_port)); |
| $self->available_nameservers(@ns_addr_port); |
| } |
| } |
| return if !$ok; |
| my $id = $self->_packet_id($pkt); |
| dbg("dns: providing a callback for id: $id"); |
| $self->{id_to_callback}->{$id} = $cb; |
| return $id; |
| } |
| |
| ########################################################################### |
| |
| =item $nfound = $res->poll_responses() |
| |
| See if there are any C<bgsend> reply packets ready, and return |
| the number of such packets delivered to their callbacks. |
| |
| =cut |
| |
| sub poll_responses { |
| my ($self, $timeout) = @_; |
| return if $self->{no_resolver}; |
| return if !$self->{sock}; |
| my $cnt = 0; |
| |
| my $rin = $self->{sock_as_vec}; |
| my $rout; |
| |
| for (;;) { |
| my ($nfound, $timeleft, $eval_stat); |
| eval { # use eval to catch alarm signal |
| my $timer; # collects timestamp when variable goes out of scope |
| if (!defined($timeout) || $timeout > 0) |
| { $timer = $self->{main}->time_method("poll_dns_idle") } |
| $! = 0; |
| ($nfound, $timeleft) = select($rout=$rin, undef, undef, $timeout); |
| 1; |
| } or do { |
| $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat; |
| }; |
| if (defined $eval_stat) { |
| # most likely due to an alarm signal, resignal if so |
| die "dns: (2) $eval_stat\n" if $eval_stat =~ /__alarm__ignore__\(.*\)/s; |
| warn "dns: select aborted: $eval_stat\n"; |
| return; |
| } elsif (!defined $nfound || $nfound < 0) { |
| if ($!) { warn "dns: select failed: $!\n" } |
| else { info("dns: select interrupted") } # shouldn't happen |
| return; |
| } elsif (!$nfound) { |
| if (!defined $timeout) { warn("dns: select returned empty-handed\n") } |
| elsif ($timeout > 0) { dbg("dns: select timed out %.3f s", $timeout) } |
| return; |
| } |
| |
| my $now = time; |
| $timeout = 0; # next time around collect whatever is available, then exit |
| last if $nfound == 0; |
| |
| my $packet = $self->{res}->bgread($self->{sock}); |
| |
| if (!$packet) { |
| my $dns_err = $self->{res}->errorstring; |
| # resignal if alarm went off |
| die "dns (3) $dns_err\n" if $dns_err =~ /__alarm__ignore__\(.*\)/s; |
| info("dns: bad dns reply: $dns_err"); |
| } else { |
| my $header = $packet->header; |
| if (!$header) { |
| info("dns: dns reply is missing a header section"); |
| } else { |
| my $rcode = $header->rcode; |
| my $packet_id = $header->id; |
| my $id = $self->_packet_id($packet); |
| |
| if ($rcode eq 'NOERROR') { # success |
| # NOERROR, may or may not have answer records |
| dbg("dns: dns reply %s is OK, %d answer records", |
| $packet_id, $header->ancount); |
| if ($header->tc) { # truncation flag turned on |
| my $edns = $self->{conf}->{dns_options}->{edns} || 512; |
| info("dns: reply to %s truncated (%s), %d answer records", $id, |
| $edns == 512 ? "EDNS off" : "EDNS $edns bytes", |
| $header->ancount); |
| } |
| } else { |
| # some failure, e.g. NXDOMAIN, SERVFAIL, FORMERR, REFUSED, ... |
| # btw, one reason for SERVFAIL is an RR signature failure in DNSSEC |
| # NOTE: qname is encoded in RFC 1035 zone format, decode it |
| dbg("dns: dns reply to %s: %s", $id, $rcode); |
| } |
| |
| # A hash lookup: the id must match exactly (case-sensitively). |
| # The domain name part of the id was lowercased if dns0x20 is off, |
| # and case-randomized when dns0x20 option is on. |
| # |
| my $cb = delete $self->{id_to_callback}->{$id}; |
| |
| if ($cb) { |
| $cb->($packet, $id, $now); |
| $cnt++; |
| } else { # no match, report the problem |
| info("dns: no callback for id %s, ignored; packet: %s", |
| $id, $packet ? $packet->string : "undef" ); |
| # report a likely matching query for diagnostic purposes |
| local $1; |
| if ($id =~ m{^(\d+)/}) { |
| my $dnsid = $1; # the raw DNS packet id |
| my @matches = |
| grep(m{^\Q$dnsid\E/}, keys %{$self->{id_to_callback}}); |
| if (!@matches) { |
| info("dns: no likely matching queries for id %s", $dnsid); |
| } else { |
| info("dns: a likely matching query: %s", join(', ', @matches)); |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| return $cnt; |
| } |
| |
| ########################################################################### |
| |
| =item $res->bgabort() |
| |
| Call this to release pending requests from memory, when aborting backgrounded |
| requests, or when the scan is complete. |
| C<Mail::SpamAssassin::PerMsgStatus::check> calls this before returning. |
| |
| =cut |
| |
| sub bgabort { |
| my ($self) = @_; |
| $self->{id_to_callback} = {}; |
| } |
| |
| ########################################################################### |
| |
| =item $packet = $res->send($name, $type, $class) |
| |
| Emulates C<Net::DNS::Resolver::send()>. |
| |
| This subroutine is a simple synchronous leftover from SpamAssassin version |
| 3.3 and does not participate in packet query caching and callback grouping |
| as implemented by AsyncLoop::bgsend_and_start_lookup(). As such it should |
| be avoided for mainstream usage. |
| |
| =cut |
| |
| sub send { |
| my ($self, $name, $type, $class) = @_; |
| return if $self->{no_resolver}; |
| |
| my $retrans = $self->{retrans}; |
| my $retries = $self->{retry}; |
| my $timeout = $retrans; |
| my $answerpkt; |
| my $answerpkt_avail = 0; |
| for (my $i = 0; |
| (($i < $retries) && !defined($answerpkt)); |
| ++$i, $retrans *= 2, $timeout = $retrans) { |
| |
| $timeout = 1 if ($timeout < 1); |
| # note nifty use of a closure here. I love closures ;) |
| my $id = $self->bgsend($name, $type, $class, sub { |
| my ($reply, $reply_id, $timestamp) = @_; |
| $answerpkt = $reply; $answerpkt_avail = 1; |
| }); |
| |
| last if !defined $id; # perhaps a restricted zone or a serious failure |
| |
| my $now = time; |
| my $deadline = $now + $timeout; |
| |
| while (!$answerpkt_avail) { |
| if ($now >= $deadline) { $self->{send_timed_out} = 1; last } |
| $self->poll_responses(1); |
| $now = time; |
| } |
| } |
| return $answerpkt; |
| } |
| |
| ########################################################################### |
| |
| =item $res->errorstring() |
| |
| Little more than a stub for callers expecting this from C<Net::DNS::Resolver>. |
| |
| If called immediately after a call to $res->send this will return |
| C<query timed out> if the $res->send DNS query timed out. Otherwise |
| C<unknown error or no error> will be returned. |
| |
| No other errors are reported. |
| |
| =cut |
| |
| sub errorstring { |
| my ($self) = @_; |
| return 'query timed out' if $self->{send_timed_out}; |
| return 'unknown error or no error'; |
| } |
| |
| ########################################################################### |
| |
| =item $res->finish_socket() |
| |
| Reset socket when done with it. |
| |
| =cut |
| |
| sub finish_socket { |
| my ($self) = @_; |
| if ($self->{sock}) { |
| $self->{sock}->close() |
| or warn "finish_socket: error closing socket $self->{sock}: $!"; |
| undef $self->{sock}; |
| } |
| } |
| |
| ########################################################################### |
| |
| =item $res->finish() |
| |
| Clean up for destruction. |
| |
| =cut |
| |
| sub finish { |
| my ($self) = @_; |
| $self->finish_socket(); |
| %{$self} = (); |
| } |
| |
| ########################################################################### |
| # non-public methods. |
| |
| # should move to Util.pm (TODO) |
| sub fhs_to_vec { |
| my ($self, @fhlist) = @_; |
| my $rin = ''; |
| foreach my $sock (@fhlist) { |
| my $fno = fileno($sock); |
| if (!defined $fno) { |
| warn "dns: oops! fileno now undef for $sock"; |
| } else { |
| vec ($rin, $fno, 1) = 1; |
| } |
| } |
| return $rin; |
| } |
| |
| # call Mail::SA::init() instead |
| sub reinit_post_fork { |
| my ($self) = @_; |
| # release parent's socket, don't want all spamds sharing the same socket |
| $self->finish_socket(); |
| } |
| |
| 1; |
| |
| =back |
| |
| =cut |