home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / Mail / SpamAssassin / DnsResolver.pm < prev    next >
Text File  |  2006-11-29  |  16KB  |  616 lines
  1. # <@LICENSE>
  2. # Licensed to the Apache Software Foundation (ASF) under one or more
  3. # contributor license agreements.  See the NOTICE file distributed with
  4. # this work for additional information regarding copyright ownership.
  5. # The ASF licenses this file to you under the Apache License, Version 2.0
  6. # (the "License"); you may not use this file except in compliance with
  7. # the License.  You may obtain a copy of the License at:
  8. # 
  9. #     http://www.apache.org/licenses/LICENSE-2.0
  10. # 
  11. # Unless required by applicable law or agreed to in writing, software
  12. # distributed under the License is distributed on an "AS IS" BASIS,
  13. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  14. # See the License for the specific language governing permissions and
  15. # limitations under the License.
  16. # </@LICENSE>
  17.  
  18. =head1 NAME
  19.  
  20. Mail::SpamAssassin::DnsResolver - DNS resolution engine
  21.  
  22. =head1 DESCRIPTION
  23.  
  24. This is a DNS resolution engine for SpamAssassin, implemented in order to
  25. reduce file descriptor usage by Net::DNS and avoid a response collision bug in
  26. that module.
  27.  
  28. =head1 METHODS
  29.  
  30. =over 4
  31.  
  32. =cut
  33.  
  34. # TODO: caching in this layer instead of in callers.
  35.  
  36. package Mail::SpamAssassin::DnsResolver;
  37.  
  38. use strict;
  39. use warnings;
  40. use bytes;
  41.  
  42. use Mail::SpamAssassin;
  43. use Mail::SpamAssassin::Logger;
  44.  
  45. use IO::Socket::INET;
  46. use Errno qw(EINVAL EADDRINUSE);
  47.  
  48. use constant HAS_SOCKET_INET6 => eval { require IO::Socket::INET6 };
  49.  
  50. our @ISA = qw();
  51.  
  52. # TODO: would be nice to have this in Conf.pm, but resolver is loaded
  53. # before configs are read! :(
  54. #=item dns_cache_items n
  55. #
  56. #Number of RBL responses to store in a query cache. Default 2000
  57. #
  58. #=cut
  59. #
  60. #  push (@cmds, {
  61. #    setting => 'dns_cache_items',
  62. #    default => 2000,
  63. #    type => $CONF_TYPE_NUMERIC
  64. #  });
  65. #
  66. #=item dns_cache_timeout n
  67. #
  68. #Default time to keep RBL responses in query cache. Default 120, but
  69. #overridden by the TTL value of each response.
  70. #
  71. #=cut
  72. #
  73. #  push (@cmds, {
  74. #    setting => 'dns_cache_timeout',
  75. #    default => 120,
  76. #    type => $CONF_TYPE_NUMERIC
  77. #  });
  78. #
  79. #=back
  80.  
  81. my $dns_cache_items = 2000;
  82. my $dns_cache_timeout = 255;
  83.  
  84. ###########################################################################
  85.  
  86. sub new {
  87.   my $class = shift;
  88.   $class = ref($class) || $class;
  89.  
  90.   my ($main) = @_;
  91.   my $self = {
  92.     'main'              => $main,
  93.     'conf'        => $main->{conf},
  94.     'id_to_callback'    => { },
  95.   };
  96.   bless ($self, $class);
  97.  
  98.   $self->load_resolver();
  99.   $self;
  100. }
  101.  
  102. ###########################################################################
  103.  
  104. =item $res->load_resolver()
  105.  
  106. Load the C<Net::DNS::Resolver> object.  Returns 0 if Net::DNS cannot be used,
  107. 1 if it is available.
  108.  
  109. =cut
  110.  
  111. use FS::Cache;
  112. sub load_resolver {
  113.   my ($self) = @_;
  114.  
  115.   if (defined $self->{res}) { return 1; }
  116.   $self->{no_resolver} = 1;
  117.  
  118.   eval {
  119.     require Net::DNS;
  120.     $self->{res} = Net::DNS::Resolver->new;
  121.     if (defined $self->{res}) {
  122.       $self->{no_resolver} = 0;
  123.       $self->{dns_cache} = new FS::Cache(
  124.         $dns_cache_items,
  125.         $dns_cache_timeout
  126.       );
  127.       $self->{retry} = 1;               # retries for non-nackgrounded query
  128.       $self->{retrans} = 3;   # initial timeout for "non-backgrounded" query run in background
  129.       $self->{res}->retry(1);           # If it fails, it fails
  130.       $self->{res}->retrans(0);         # If it fails, it fails
  131.       $self->{res}->dnsrch(0);          # ignore domain search-list
  132.       $self->{res}->defnames(0);        # don't append stuff to end of query
  133.       $self->{res}->tcp_timeout(3);     # timeout of 3 seconds only
  134.       $self->{res}->udp_timeout(3);     # timeout of 3 seconds only
  135.       $self->{res}->persistent_tcp(0);  # bug 3997
  136.       $self->{res}->persistent_udp(0);  # bug 3997
  137.     }
  138.     1;
  139.   };   #  or warn "dns: eval failed: $@ $!\n";
  140.  
  141.   dbg("dns: is Net::DNS::Resolver available? " .
  142.        ($self->{no_resolver} ? "no" : "yes"));
  143.   if (!$self->{no_resolver} && defined $Net::DNS::VERSION) {
  144.     dbg("dns: Net::DNS version: ".$Net::DNS::VERSION);
  145.   }
  146.  
  147.   return (!$self->{no_resolver});
  148. }
  149.  
  150. =item $resolver = $res->get_resolver()
  151.  
  152. Return the C<Net::DNS::Resolver> object.
  153.  
  154. =cut
  155.  
  156. sub get_resolver {
  157.   my ($self) = @_;
  158.   return $self->{res};
  159. }
  160.  
  161. =item $res->nameservers()
  162.  
  163. Wrapper for Net::DNS::Reslolver->nameservers to get or set list of nameservers
  164.  
  165. =cut
  166.  
  167. sub nameservers {
  168.   my $self = shift;
  169.   my $res = $self->{res};
  170.   $self->connect_sock_if_reqd();
  171.   return $res->nameservers(@_) if $res;
  172. }
  173.  
  174. =item $res->connect_sock()
  175.  
  176. Re-connect to the first nameserver listed in C</etc/resolv.conf> or similar
  177. platform-dependent source, as provided by C<Net::DNS>.
  178.  
  179. =cut
  180.  
  181. sub connect_sock {
  182.   my ($self) = @_;
  183.  
  184.   return if $self->{no_resolver};
  185.  
  186.   $self->{sock}->close() if $self->{sock};
  187.   my $sock;
  188.   my $errno;
  189.  
  190.   # IO::Socket::INET6 may choose wrong LocalAddr if family is unspecified,
  191.   # causing EINVAL failure when automatically assigned local IP address
  192.   # and remote address do not belong to the same address family:
  193.   use Mail::SpamAssassin::Constants qw(:ip);
  194.   my $ip64 = IP_ADDRESS;
  195.   my $ip4 = IPV4_ADDRESS;
  196.   my $ns = $self->{res}->{nameservers}[0];
  197.   my $ipv6 = 0;
  198.  
  199.   # now, attempt to set the family to AF_INET6 if we can.  Some
  200.   # platforms don't have it (bug 4412 comment 29)...
  201.   # also, only set $ipv6 to true if that succeeds.
  202.   my $family;
  203.   if (HAS_SOCKET_INET6 && $ns=~/^${ip64}$/o && $ns!~/^${ip4}$/o) {
  204.     eval '$family = AF_INET6; $ipv6 = 1;';
  205.   }
  206.   if (!defined $family) {
  207.     $family = AF_INET;       # that didn't work ;)
  208.   }
  209.  
  210.   dbg("dns: discovered name servers: " .
  211.     join(", ", @{$self->{res}->{nameservers}})
  212.   );
  213.   dbg("dns: name server: $ns, family: $family, ipv6: $ipv6");
  214.  
  215.   # find next available unprivileged port (1024 - 65535)
  216.   # starting at a random value to spread out use of ports
  217.   my $port_offset = int(rand(64511));  # 65535 - 1024
  218.   for (my $i = 0; $i<64511; $i++) {
  219.     my $lport = 1024 + (($port_offset + $i) % 64511);
  220.  
  221.     my %args = (
  222.         PeerAddr => $ns,
  223.         PeerPort => $self->{res}->{port},
  224.         Proto => 'udp',
  225.         LocalPort => $lport,
  226.         Type => SOCK_DGRAM,
  227.         Domain => $family,
  228.     );
  229.  
  230.     if (HAS_SOCKET_INET6) {
  231.       $sock = IO::Socket::INET6->new(%args);
  232.     } else {
  233.       $sock = IO::Socket::INET->new(%args);
  234.     }
  235.     $errno = $!;
  236.     if (defined $sock) {  # ok, got it
  237.       last;
  238.     } elsif ($! == EADDRINUSE) {  # in use, let's try another source port
  239.       dbg("dns: UDP port $lport already in use, trying another port");
  240.     } else {
  241.       # did we fail due to the attempted use of an IPv6 nameserver?
  242.       $self->_ipv6_ns_warning()  if (!$ipv6 && $errno==EINVAL);
  243.       warn "Error creating a DNS resolver socket: $errno";
  244.       goto no_sock;
  245.     }
  246.   }
  247.   if (!defined $sock) {
  248.     warn "Can't create a DNS resolver socket: $errno";
  249.     goto no_sock;
  250.   }
  251.  
  252.   $self->{sock} = $sock;
  253.   $self->{sock_as_vec} = $self->fhs_to_vec($self->{sock});
  254.   return;
  255.  
  256. no_sock:
  257.   $self->{no_resolver} = 1;
  258. }
  259.  
  260. sub connect_sock_if_reqd {
  261.   my ($self) = @_;
  262.   $self->connect_sock() if !$self->{sock};
  263. }
  264.  
  265. =item $res->get_sock()
  266.  
  267. Return the C<IO::Socket::INET> object used to communicate with
  268. the nameserver.
  269.  
  270. =cut
  271.  
  272. sub get_sock {
  273.   my ($self) = @_;
  274.   $self->connect_sock_if_reqd();
  275.   return $self->{sock};
  276. }
  277.  
  278. ###########################################################################
  279.  
  280. =item $packet = new_dns_packet ($host, $type, $class)
  281.  
  282. A wrapper for C<Net::DNS::Packet::new()> which traps a die thrown by it.
  283.  
  284. To use this, change calls to C<Net::DNS::Resolver::bgsend> from:
  285.  
  286.     $res->bgsend($hostname, $type);
  287.  
  288. to:
  289.  
  290.     $res->bgsend(Mail::SpamAssassin::DnsResolver::new_dns_packet($hostname, $type, $class));
  291.  
  292. =cut
  293.  
  294. sub new_dns_packet {
  295.   my ($self, $host, $type, $class) = @_;
  296.  
  297.   return if $self->{no_resolver};
  298.  
  299.   # construct a PTR query if it looks like an IPv4 address
  300.   if ((!defined($type) || $type eq 'PTR') && $host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
  301.     $host = "$4.$3.$2.$1.in-addr.arpa.";
  302.     $type = 'PTR';
  303.   }
  304.  
  305.   $self->connect_sock_if_reqd();
  306.   my $packet;
  307.   eval {
  308.     $packet = Net::DNS::Packet->new($host, $type, $class);
  309.  
  310.     # a bit noisy, so commented by default...
  311.     #dbg("dns: new DNS packet time=".time()." host=$host type=$type id=".$packet->id);
  312.   };
  313.  
  314.   if ($@) {
  315.     # this can happen if Net::DNS isn't available -- but in this
  316.     # case this function should never be called!
  317.     warn "dns: cannot create Net::DNS::Packet, but new_dns_packet() was called: $@ $!";
  318.   }
  319.   return $packet;
  320. }
  321.  
  322. # Internal function used only in this file
  323. ## compute an unique ID for a packet to match the query to the reply
  324. ## It must use only data that is returned unchanged by the nameserver.
  325. ## Argument is a Net::DNS::Packet that has a non-empty question section
  326. ## return is an object that can be used as a hash key
  327. sub _packet_id {
  328.   my ($self, $packet) = @_;
  329.   my $header = $packet->header;
  330.   my $id = $header->id;
  331.   my @questions = $packet->question;
  332.   my $ques = $questions[0];
  333.  
  334.   if (defined $ques) {
  335.     return $id . $ques->qname . $ques->qtype . $ques->qclass;
  336.   } else {
  337.     # odd.  this should not happen, but clearly some DNS servers
  338.     # can return something that Net::DNS interprets as having no
  339.     # question section.  Better support it; just return the
  340.     # (safe) ID part, along with a text token indicating that
  341.     # the packet had no question part.
  342.     return $id . "NO_QUESTION_IN_PACKET";
  343.   }
  344. }
  345.  
  346. ###########################################################################
  347.  
  348. =item $id = $res->bgsend($host, $type, $class, $cb)
  349.  
  350. Quite similar to C<Net::DNS::Resolver::bgsend>, except that when a response
  351. packet eventually arrives, and C<poll_responses> is called, the callback
  352. sub reference C<$cb> will be called.
  353.  
  354. Note that C<$type> and C<$class> may be C<undef>, in which case they
  355. will default to C<A> and C<IN>, respectively.
  356.  
  357. The callback sub will be called with two arguments -- the packet that was
  358. delivered and an id string that fingerprints the query packet and the expected reply.
  359. It is expected that a closure callback be used, like so:
  360.  
  361.   my $id = $self->{resolver}->bgsend($host, $type, undef, sub {
  362.         my $reply = shift;
  363.         my $reply_id = shift;
  364.         $self->got_a_reply ($reply, $reply_id);
  365.       });
  366.  
  367. The callback can ignore the reply as an invalid packet sent to the listening port
  368. if the reply id does not match the return value from bgsend.
  369.  
  370. =cut
  371.  
  372. sub cache_key {
  373.   my ($packet) = @_;
  374.   my @questions = $packet->question;
  375.   my $ques = $questions[0];
  376.  
  377.   return join("|", $ques->qname, $ques->qtype, $ques->qclass);
  378. }
  379.  
  380. sub bgsend {
  381.   my ($self, $host, $type, $class, $cb) = @_;
  382.   return if $self->{no_resolver};
  383.  
  384.   my $pkt = $self->new_dns_packet($host, $type, $class);
  385.  
  386.   # check if a cached reply exists
  387.   my $key = cache_key($pkt);
  388.   if (my $packet = $self->{dns_cache}->get($key)) {
  389.     $cb->($packet, $key);
  390.  
  391.     my ($hit, $miss) = $self->{dns_cache}->stats();
  392.     dbg(sprintf "dnscache: hit %d/%d %.1f%% %s",
  393.       $hit, $miss, 100.0 * $hit / ($hit + $miss), $key
  394.     );
  395.  
  396.     return $key;
  397.   }
  398.  
  399.   $self->connect_sock_if_reqd();
  400.   if (!defined($self->{sock}->send($pkt->data, 0))) {
  401.     warn "dns: sendto() failed: $!";
  402.     return;
  403.   }
  404.   my ($hit, $miss) = $self->{dns_cache}->stats();
  405.   dbg(sprintf "dnscache: miss %d/%d %.1f%% %s",
  406.     $hit, $miss, 100.0 * $hit / ($hit + $miss), $key
  407.   );
  408.  
  409.   my $id = $self->_packet_id($pkt);
  410.   $self->{id_to_callback}->{$id} = $cb;
  411.   return $id;
  412. }
  413.  
  414. sub min {
  415.   my $min = $_[0];
  416.   for (@_) {
  417.     $min = $_ if $min > $_
  418.   }
  419.   return $min;
  420. }
  421.  
  422. ###########################################################################
  423.  
  424. =item $nfound = $res->poll_responses()
  425.  
  426. See if there are any C<bgsend> response packets ready, and return
  427. the number of such packets delivered to their callbacks.
  428.  
  429. =cut
  430.  
  431. sub poll_responses {
  432.   my ($self, $timeout) = @_;
  433.   return if $self->{no_resolver};
  434.   return if !$self->{sock};
  435.  
  436.   my $rin = $self->{sock_as_vec};
  437.   my $rout;
  438.   my ($nfound, $timeleft) = select($rout=$rin, undef, undef, $timeout);
  439.  
  440.   if (!defined $nfound || $nfound < 0) {
  441.     warn "dns: select failed: $!";
  442.     return;
  443.   }
  444.  
  445.   if ($nfound == 0) {
  446.     return 0;           # nothing's ready yet
  447.   }
  448.  
  449.   my $packet = $self->{res}->bgread($self->{sock});
  450.   my $err = $self->{res}->errorstring;
  451.  
  452.   if (defined $packet &&
  453.       defined $packet->header &&
  454.       defined $packet->question &&
  455.       defined $packet->answer)
  456.   {
  457.     my $id = $self->_packet_id($packet);
  458.  
  459.     my $cb = delete $self->{id_to_callback}->{$id};
  460.     if (!$cb) {
  461.       dbg("dns: no callback for id: $id, ignored; packet: ".
  462.                     ($packet ? $packet->string : "undef"));
  463.       return 0;
  464.     }
  465.  
  466.     # cache result
  467.     my $ttl = min(map {$_->ttl} $packet->answer);
  468.     unless (defined $ttl) {
  469.       $ttl = min(map {$_->minimum} $packet->authority) || 0;
  470.       dbg("dnscache: no answer, setting ttl by SOA to $ttl");
  471.     }
  472.     $self->{dns_cache}->set(cache_key($packet), $packet, $ttl);
  473.  
  474.     $cb->($packet, $id);
  475.     return 1;
  476.   }
  477.   else {
  478.     dbg("dns: no packet! err=$err packet=".
  479.                     ($packet ? $packet->string : "undef"));
  480.   }
  481.  
  482.   return 0;
  483. }
  484.  
  485. ###########################################################################
  486.  
  487. =item $res->bgabort()
  488.  
  489. Call this to release pending requests from memory when aborting backgrounded requests
  490.  
  491. =cut
  492.  
  493. sub bgabort {
  494.   my ($self) = @_;
  495.   $self->{id_to_callback} = {};
  496. }
  497.  
  498. ###########################################################################
  499.  
  500. =item $packet = $res->send($name, $type, $class)
  501.  
  502. Emulates C<Net::DNS::Resolver::send()>.
  503.  
  504. =cut
  505.  
  506. sub send {
  507.   my ($self, $name, $type, $class) = @_;
  508.   return if $self->{no_resolver};
  509.  
  510.   my $retrans = $self->{retrans};
  511.   my $retries = $self->{retry};
  512.   my $timeout = $retrans;
  513.   my $answerpkt;
  514.   for (my $i = 0;
  515.        (($i < $retries) && !defined($answerpkt));
  516.        ++$i, $retrans *= 2, $timeout = $retrans) {
  517.  
  518.     $timeout = 1 if ($timeout < 1);
  519.     # note nifty use of a closure here.  I love closures ;)
  520.     $self->bgsend($name, $type, $class, sub {
  521.       $answerpkt = shift;
  522.     });
  523.  
  524.     my $now = time;
  525.     my $deadline = $now + $timeout;
  526.  
  527.     while (($now < $deadline) && (!defined($answerpkt))) {
  528.       $self->poll_responses(1);
  529.       $now = time;
  530.     }
  531.   }
  532.   return $answerpkt;
  533. }
  534.  
  535. ###########################################################################
  536.  
  537. =item $res->finish_socket()
  538.  
  539. Reset socket when done with it.
  540.  
  541. =cut
  542.  
  543. sub finish_socket {
  544.   my ($self) = @_;
  545.   if ($self->{sock}) {
  546.     $self->{sock}->close();
  547.     delete $self->{sock};
  548.   }
  549. }
  550.  
  551. ###########################################################################
  552.  
  553. =item $res->finish()
  554.  
  555. Clean up for destruction.
  556.  
  557. =cut
  558.  
  559. sub finish {
  560.   my ($self) = @_;
  561.   $self->finish_socket();
  562.   if (!$self->{no_resolver}) {
  563.     delete $self->{res};
  564.   }
  565.   delete $self->{main};
  566. }
  567.  
  568. ###########################################################################
  569. # non-public methods.
  570.  
  571. # should move to Util.pm (TODO)
  572. sub fhs_to_vec {
  573.   my ($self, @fhlist) = @_;
  574.   my $rin = '';
  575.   foreach my $sock (@fhlist) {
  576.     my $fno = fileno($sock);
  577.     warn "dns: oops! fileno now undef for $sock" unless defined($fno);
  578.     vec ($rin, $fno, 1) = 1;
  579.   }
  580.   return $rin;
  581. }
  582.  
  583. # call Mail::SA::init() instead
  584. sub reinit_post_fork {
  585.   my ($self) = @_;
  586.   # and a new socket, so we don't have 5 spamds sharing the same
  587.   # socket
  588.   $self->connect_sock();
  589. }
  590.  
  591. sub _ipv6_ns_warning {
  592.   my ($self) = @_;
  593.  
  594.   # warn about the attempted use of an IPv6 nameserver without
  595.   # IO::Socket::INET6 installed (bug 4412)
  596.   my $firstns = $self->{res}->{nameservers}[0];
  597.  
  598.   use Mail::SpamAssassin::Constants qw(:ip);
  599.   my $ip64 = IP_ADDRESS;
  600.   my $ip4 = IPV4_ADDRESS;
  601.  
  602.   # was the nameserver in IPv6 format?
  603.   if ($firstns =~ /^${ip64}$/o && $firstns !~ /^${ip4}$/o) {
  604.     my $addr = inet_aton($firstns);
  605.     if (!defined $addr) {
  606.       die "IO::Socket::INET6 module is required to use IPv6 nameservers such as '$firstns': $@\n";
  607.     }
  608.   }
  609. }
  610.  
  611. 1;
  612.  
  613. =back
  614.  
  615. =cut
  616.