[ViewVC] Diff of: cvs/AnyEvent/lib/AnyEvent/DNS.pm

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.45 by root, Thu May 29 06:40:06 2008 UTC vs.
Revision 1.55 by root, Fri May 30 10:37:34 2008 UTC

 =head1 DESCRIPTION
 This module offers both a number of DNS convenience functions as well
 as a fully asynchronous and high-performance pure-perl stub resolver.
-The stub resolver supports DNS over UDP, optional EDNS0 support for up to
+The stub resolver supports DNS over IPv4 and IPv6, UDP and TCP, optional
-4kiB datagrams and automatically falls back to virtual circuit mode for
+EDNS0 support for up to 4kiB datagrams and automatically falls back to
-large responses.
+virtual circuit mode for large responses.
 =head2 CONVENIENCE FUNCTIONS
 =over 4
 of service records.
 Each srv_rr is an array reference with the following contents:
 C<[$priority, $weight, $transport, $target]>.
-They will be sorted with lowest priority, highest weight first (TODO:
+They will be sorted with lowest priority first, then randomly
-should use the RFC algorithm to reorder same-priority records for weight).
+distributed by weight as per RFC 2782.
 Example:
    AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
    # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
-=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
+=item AnyEvent::DNS::ptr $domain, $cb->(@hostnames)
+Tries to make a PTR lookup on the given domain. See C<reverse_lookup>
+and C<reverse_verify> if you want to resolve an IP address to a hostname
+instead.
+=item AnyEvent::DNS::any $domain, $cb->(@rrs)
+Tries to resolve the given domain and passes all resource records found to
+the callback.
+=item AnyEvent::DNS::reverse_lookup $ipv4_or_6, $cb->(@hostnames)
 Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
-into it's hostname(s).
+into it's hostname(s). Handles V4MAPPED and V4COMPAT IPv6 addresses
+transparently.
+=item AnyEvent::DNS::reverse_verify $ipv4_or_6, $cb->(@hostnames)
+The same as C<reverse_lookup>, but does forward-lookups to verify that
+the resolved hostnames indeed point to the address, which makes spoofing
+harder.
+If you want to resolve an address into a hostname, this is the preferred
+method: The DNS records could still change, but at least this function
+verified that the hostname, at one point in the past, pointed at the IP
+address you originally resolved.
 Example:
    AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
    # => f.root-servers.net
-=item AnyEvent::DNS::any $domain, $cb->(@rrs)
-Tries to resolve the given domain and passes all resource records found to
-the callback.
 =cut
 sub MAX_PKT() { 4096 } # max packet size we advertise and accept
 sub srv($$$$) {
    my ($service, $proto, $domain, $cb) = @_;
    # todo, ask for any and check glue records
    resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
-      $cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] || $b->[4] <=> $a->[4] } @_);
+      my @res;
+      # classify by priority
+      my %pri;
+      push @{ $pri{$_->[3]} }, [ @$_[3,4,5,6] ]
+         for @_;
+      # order by priority
+      for my $pri (sort { $a->[0] <=> $b->[0] } keys %pri) {
+         # order by weight
+         my @rr = sort { $a->[1] <=> $b->[1] } @{ delete $pri{$pri} };
+         my $sum; $sum += $_->[1] for @rr;
+         while (@rr) {
+            my $w = int rand $sum + 1;
+            for (0 .. $#rr) {
+               if (($w -= $rr[$_][1]) <= 0) {
+                  $sum -= $rr[$_][1];
+                  push @res, splice @rr, $_, 1, ();
+                  last;
+               }
+            }
+         }
+      }
+      $cb->(@res);
    });
 }
 sub ptr($$) {
+   my ($domain, $cb) = @_;
+   resolver->resolve ($domain => "ptr", sub {
+      $cb->(map $_->[3], @_);
+   });
+}
+sub any($$) {
+   my ($domain, $cb) = @_;
+   resolver->resolve ($domain => "*", $cb);
+}
+# convert textual ip address into reverse lookup form
+sub _munge_ptr($) {
+   my $ipn = $_[0]
+      or return;
+   my $ptr;
+   my $af = AnyEvent::Socket::address_family ($ipn);
+   if ($af == AF_INET6) {
+      $ipn = substr $ipn, 0, 16; # anticipate future expansion
+      # handle v4mapped and v4compat
+      if ($ipn =~ s/^\x00{10}(?:\xff\xff|\x00\x00)//) {
+         $af = AF_INET;
+      } else {
+         $ptr = join ".", (reverse split //, unpack "H32", $ipn), "ip6.arpa.";
+      }
+   }
+   if ($af == AF_INET) {
+      $ptr = join ".", (reverse unpack "C4", $ipn), "in-addr.arpa.";
+   }
+   $ptr
+}
+sub reverse_lookup($$) {
    my ($ip, $cb) = @_;
-   $ip = AnyEvent::Socket::parse_address ($ip)
+   $ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
       or return $cb->();
-   my $af = AnyEvent::Socket::address_family ($ip);
-   if ($af == AF_INET) {
-      $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
-   } elsif ($af == AF_INET6) {
-      $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
-   } else {
-      return $cb->();
-   }
    resolver->resolve ($ip => "ptr", sub {
       $cb->(map $_->[3], @_);
    });
 }
-sub any($$) {
+sub reverse_verify($$) {
-   my ($domain, $cb) = @_;
+   my ($ip, $cb) = @_;
+   my $ipn = AnyEvent::Socket::parse_address ($ip)
+      or return $cb->();
-   resolver->resolve ($domain => "*", $cb);
+   my $af = AnyEvent::Socket::address_family ($ipn);
+   my @res;
+   my $cnt;
+   my $ptr = _munge_ptr $ipn
+      or return $cb->();
+   $ip = AnyEvent::Socket::format_address ($ipn); # normalise into the same form
+   ptr $ptr, sub {
+      for my $name (@_) {
+         ++$cnt;
+         # () around AF_INET to work around bug in 5.8
+         resolver->resolve ("$name." => ($af == (AF_INET) ? "a" : "aaaa"), sub {
+            for (@_) {
+               push @res, $name
+                  if $_->[3] eq $ip;
+            }
+            $cb->(@res) unless --$cnt;
+         });
+      }
+      $cb->() unless $cnt;
+   };
 }
 #################################################################################
 =back
    minfo =>  14,
    mx    =>  15,
    txt   =>  16,
    aaaa  =>  28,
    srv   =>  33,
+   naptr =>  35, # rfc2915
    opt   =>  41,
    spf   =>  99,
    tkey  => 249,
    tsig  => 250,
    ixfr  => 251,
    die "encoding of resource records is not supported";
 }
 =item $pkt = AnyEvent::DNS::dns_pack $dns
-Packs a perl data structure into a DNS packet. Reading RFC1034 is strongly
+Packs a perl data structure into a DNS packet. Reading RFC 1035 is strongly
 recommended, then everything will be totally clear. Or maybe not.
 Resource records are not yet encodable.
 Examples:
     13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
     15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
     16 => sub { unpack "(C/a*)*", $_ }, # txt
     28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
     33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
+    35 => sub { # naptr
+       my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_;
+       local $ofs = $ofs + $offset - length;
+       ($order, $preference, $flags, $service, $regexp, _dec_name)
+    },
     99 => sub { unpack "(C/a*)*", $_ }, # spf
 );
 sub _dec_rr {
    my $name = _dec_name;
 been resolved.
 =item reuse => $seconds
 The number of seconds (default: C<300>) that a query id cannot be re-used
-after a timeout. If there as no time-out then query id's can be reused
+after a timeout. If there was no time-out then query ids can be reused
 immediately.
 =back
 =cut
       server  => [],
       timeout => [2, 5, 5],
       search  => [],
       ndots   => 1,
       max_outstanding => 10,
-      reuse   => 300, # reuse id's after 5 minutes only, if possible
+      reuse   => 300,
       %arg,
       reuse_q => [],
    }, $class;
    # search should default to gethostname's domain
       # - the registry thing needs separate code on win32 native vs. cygwin
       # - the registry layout differs between windows versions
       # - calling windows api functions doesn't work on cygwin
       # - ipconfig uses locale-specific messages
-      # we use ipconfig parsing because, despite all it's brokenness,
+      # we use ipconfig parsing because, despite all its brokenness,
       # it seems most stable in practise.
       # for good measure, we append a fallback nameserver to our list.
       if (open my $fh, "ipconfig /all |") {
          # parsing strategy: we go through the output and look for
             } elsif (/^\S/ || /^\s[^:]{16,}: /) {
                $dns = 0;
             }
             if ($dns && /^\s*(\S+)\s*$/) {
                my $s = $1;
-               $s =~ s/%\d+(?!\S)//; # get rid of scope id
+               $s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
                if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
                   push @{ $self->{server} }, $ipn;
                } else {
                   push @{ $self->{search} }, $s;
                }
       if (open my $fh, "</etc/resolv.conf") {
          local $/;
          $self->parse_resolv_conf (<$fh>);
       }
    }
+}
+=item $resolver->timeout ($timeout, ...)
+Sets the timeout values. See the C<timeout> constructor argument (and note
+that this method uses the values itself, not an array-reference).
+=cut
+sub timeout {
+   my ($self, @timeout) = @_;
+   $self->{timeout} = \@timeout;
+   $self->_compile;
+}
+=item $resolver->max_outstanding ($nrequests)
+Sets the maximum number of outstanding requests to C<$nrequests>. See the
+C<max_outstanding> constructor argument.
+=cut
+sub max_outstanding {
+   my ($self, $max) = @_;
+   $self->{max_outstanding} = $max;
+   $self->_scheduler;
 }
 sub _compile {
    my $self = shift;
          my ($res) = @_;
          if ($res->{tc}) {
             # success, but truncated, so use tcp
             AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
+               return unless $do_retry; # some other request could have invalidated us already
                my ($fh) = @_
                   or return &$do_retry;
-               my $handle = new AnyEvent::Handle
+               my $handle; $handle = new AnyEvent::Handle
                   fh       => $fh,
+                  timeout  => $timeout,
                   on_error => sub {
+                     undef $handle;
+                     return unless $do_retry; # some other request could have invalidated us already
                      # failure, try next
                      &$do_retry;
                   };
                $handle->push_write (pack "n/a", $req->[0]);
                $handle->push_read (chunk => 2, sub {
                   $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
+                     undef $handle;
                      $self->_feed ($_[1]);
                   });
                });
-               shutdown $fh, 1;
             }, sub { $timeout });
          } else {
             # success
 }
 sub _scheduler {
    my ($self) = @_;
+   no strict 'refs';
    $NOW = time;
    # first clear id reuse queue
    delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
       while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
             $self->_scheduler;
          });
          last;
       }
-      my $req = shift @{ $self->{queue} }
+      if (my $req = shift @{ $self->{queue} }) {
-         or last;
+         # found a request in the queue, execute it
-      while () {
+         while () {
-         $req->[2] = int rand 65536;
+            $req->[2] = int rand 65536;
-         last unless exists $self->{id}{$req->[2]};
+            last unless exists $self->{id}{$req->[2]};
+         }
+         ++$self->{outstanding};
+         $self->{id}{$req->[2]} = 1;
+         substr $req->[0], 0, 2, pack "n", $req->[2];
+         $self->_exec ($req);
+      } elsif (my $cb = shift @{ $self->{wait} }) {
+         # found a wait_for_slot callback, call that one first
+         $cb->($self);
+      } else {
+         # nothing to do, just exit
+         last;
       }
-      ++$self->{outstanding};
-      $self->{id}{$req->[2]} = 1;
-      substr $req->[0], 0, 2, pack "n", $req->[2];
-      $self->_exec ($req);
    }
 }
 =item $resolver->request ($req, $cb->($res))
+This is the main low-level workhorse for sending DNS requests.
-Sends a single request (a hash-ref formated as specified for
+This function sends a single request (a hash-ref formated as specified
-C<dns_pack>) to the configured nameservers including
+for C<dns_pack>) to the configured nameservers in turn until it gets a
+response. It handles timeouts, retries and automatically falls back to
+virtual circuit mode (TCP) when it receives a truncated reply.
-retries. Calls the callback with the decoded response packet if a reply
+Calls the callback with the decoded response packet if a reply was
-was received, or no arguments on timeout.
+received, or no arguments in case none of the servers answered.
 =cut
 sub request($$) {
    my ($self, $req, $cb) = @_;
 =item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
 Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
-A C<$qtype> is either a numerical query type (e.g. C<1> for A recods) or
+A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
 a lowercase name (you have to look at the source to see which aliases are
-supported, but all types from RFC 1034, C<aaaa>, C<srv>, C<spf> and a few
+supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
-more are known to this module). A qtype of "*" is supported and means
+more are known to this module). A C<$qtype> of "*" is supported and means
 "any" record type.
 The callback will be invoked with a list of matching result records or
 none on any error or if the name could not be found.
 the domain name, C<$type> a type string or number, C<$class> a class name
 and @data is resource-record-dependent data. For C<a> records, this will
 be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
 a domain name, for C<txt> records these are all the strings and so on.
-All types mentioned in RFC 1034, C<aaaa>, C<srv> and C<spf> are
+All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
-decoded. All resource records not known to this module will just return
+decoded. All resource records not known to this module will have
 the raw C<rdata> field as fourth entry.
 Note that this resolver is just a stub resolver: it requires a name server
 supporting recursive queries, will not do any recursive queries itself and
 is not secure when used against an untrusted name server.
 =item search => [$suffix...]
 Use the given search list (which might be empty), by appending each one
 in turn to the C<$qname>. If this option is missing then the configured
-C<ndots> and C<search> define its value. If the C<$qname> ends in a dot,
+C<ndots> and C<search> values define its value (depending on C<ndots>, the
-then the searchlist will be ignored.
+empty suffix will be prepended or appended to that C<search> value). If
+the C<$qname> ends in a dot, then the searchlist will be ignored.
 =item accept => [$type...]
 Lists the acceptable result types: only result types in this set will be
 accepted and returned. The default includes the C<$qtype> and nothing
 =back
 Examples:
-   # full example, you can paste this into perl
+   # full example, you can paste this into perl:
    use Data::Dumper;
    use AnyEvent::DNS;
    AnyEvent::DNS::resolver->resolve (
       "google.com", "*", my $cv = AnyEvent->condvar);
    warn Dumper [$cv->recv];
    };
    $do_search->();
 }
+=item $resolver->wait_for_slot ($cb->($resolver))
+Wait until a free request slot is available and call the callback with the
+resolver object.
+A request slot is used each time a request is actually sent to the
+nameservers: There are never more than C<max_outstanding> of them.
+Although you can submit more requests (they will simply be queued until
+a request slot becomes available), sometimes, usually for rate-limiting
+purposes, it is useful to instead wait for a slot before generating the
+request (or simply to know when the request load is low enough so one can
+submit requests again).
+This is what this method does: The callback will be called when submitting
+a DNS request will not result in that request being queued. The callback
+may or may not generate any requests in response.
+Note that the callback will only be invoked when the request queue is
+empty, so this does not play well if somebody else keeps the request queue
+full at all times.
+=cut
+sub wait_for_slot {
+   my ($self, $cb) = @_;
+   push @{ $self->{wait} }, $cb;
+   $self->_scheduler;
+}
 use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
 1;
 =back

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.45 by root, Thu May 29 06:40:06 2008 UTC vs. Revision 1.55 by root, Fri May 30 10:37:34 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.45 by root, Thu May 29 06:40:06 2008 UTC vs.
Revision 1.55 by root, Fri May 30 10:37:34 2008 UTC