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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.8 by root, Fri May 23 05:34:32 2008 UTC vs.
Revision 1.19 by root, Fri May 23 23:37:13 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
+4kiB datagrams and automatically falls back to virtual circuit mode for
+large responses.
 =head2 CONVENIENCE FUNCTIONS
 =over 4
 =cut
 package AnyEvent::DNS;
 no warnings;
 use strict;
-use AnyEvent::Util ();
 use AnyEvent::Handle ();
-=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)
+=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
 NOT YET IMPLEMENTED
-Tries to resolve the given nodename and service name into sockaddr
+Tries to resolve the given nodename and service name into protocol families
-structures usable to connect to this node and service in a
+and sockaddr structures usable to connect to this node and service in a
-protocol-independent way. It works similarly to the getaddrinfo posix
+protocol-independent way. It works remotely similar to the getaddrinfo
-function.
+posix function.
+C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
+either a service name (port name from F</etc/services>) or a numerical
+port number. If both C<$node> and C<$service> are names, then SRV records
+will be consulted to find the real service, otherwise they will be
+used as-is. If you know that the service name is not in your services
+database, then you cna specify the service in the format C<name=port>
+(e.g. C<http=80>).
+C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
+C<sctp>. The default is C<tcp>.
+C<$family> must be either C<0> (meaning any protocol is ok), C<4> (use
+only IPv4) or C<6> (use only IPv6).
+C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
+C<undef> in which case it gets automatically chosen).
+The callback will receive zero or more array references that contain
+C<$family, $type, $proto> for use in C<socket> and a binary
+C<$sockaddr> for use in C<connect> (or C<bind>).
+The application should try these in the order given.
 Example:
-   AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
+   AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
 =item AnyEvent::DNS::a $domain, $cb->(@addrs)
 Tries to resolve the given domain to IPv4 address(es).
+=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
+Tries to resolve the given domain to IPv6 address(es).
 =item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
 Tries to resolve the given domain into a sorted (lower preference value
 first) list of domain names.
 =item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
 Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
 into it's hostname(s).
-Requires the Socket6 module for IPv6 support.
 Example:
    AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
    # => f.root-servers.net
 sub a($$) {
    my ($domain, $cb) = @_;
    resolver->resolve ($domain => "a", sub {
+      $cb->(map $_->[3], @_);
+   });
+}
+sub aaaa($$) {
+   my ($domain, $cb) = @_;
+   resolver->resolve ($domain => "aaaa", sub {
       $cb->(map $_->[3], @_);
    });
 }
 sub mx($$) {
 }
 sub ptr($$) {
    my ($ip, $cb) = @_;
-   my $name;
+   $ip = AnyEvent::Socket::parse_ip ($ip)
+      or return $cb->();
-   if (AnyEvent::Util::dotted_quad $ip) {
+   if (4 == length $ip) {
-      $name = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
+      $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
    } else {
-      require Socket6;
+      $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
-      $name = join ".",
-                (reverse split //,
-                   unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
-                "ip6.arpa.";
    }
-   resolver->resolve ($name => "ptr", sub {
+   resolver->resolve ($ip => "ptr", sub {
       $cb->(map $_->[3], @_);
    });
 }
 sub any($$) {
    my ($domain, $cb) = @_;
    resolver->resolve ($domain => "*", $cb);
 }
+#############################################################################
+#AnyEvent::DNS::addr $node, $service, $family, $type, $proto, $cb->([$family, $type, $protocol, $sockaddr], ...)
+# $port, $host
+sub pack_sockaddr_in6($$) {
+   pack "nnN a16 N",
+      Socket::AF_INET6,
+      $_[0], # port
+      0,     # flowinfo
+      $_[1], # addr
+      0      # scope id
+}
+sub addr($$$$$$) {
+   my ($node, $service, $proto, $family, $type, $cb) = @_;
+   unless (eval { &Socket::AF_INET6 }) {
+      $family != 6
+         or return $cb->();
+      $family ||= 4;
+   }
+   $proto ||= "tcp";
+   $type  ||= $proto eq "udp" ? Socket::SOCK_DGRAM : Socket::SOCK_STREAM;
+   my $proton = (getprotobyname $proto)[2]
+      or Carp::croak "$proto: protocol unknown";
+   my $port;
+   if ($service =~ /^(\S+)=(\d+)$/) {
+      ($service, $port) = ($1, $2);
+   } elsif ($service =~ /^\d+$/) {
+      ($service, $port) = (undef, $service);
+   } else {
+      $port = (getservbyname $service, $proto)[2]
+            or Carp::croak "$service/$proto: service unknown";
+   }
+   my @target = [$node, $port];
+   # resolve a records / provide sockaddr structures
+   my $resolve = sub {
+      my @res;
+      my $cv = AnyEvent->condvar (cb => sub {
+         $cb->(map $_->[1], sort { $a->[0] <=> $b->[0] } @res)
+      });
+      $cv->begin;
+      for my $idx (0 .. $#target) {
+         my ($node, $port) = @{ $target[$idx] };
+         if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
+            if (4 == length $noden && $family != 6) {
+               push @res, [$idx, [Socket::AF_INET, $type, $proton,
+                           Socket::pack_sockaddr_in $port, $noden]]
+            }
+            if (16 == length $noden && $family != 4) {
+               push @res, [$idx, [Socket::AF_INET6, $type, $proton,
+                           pack_sockaddr_in6 $port, $noden]]
+            }
+         } else {
+            # ipv4
+            if ($family != 6) {
+               $cv->begin;
+               a $node, sub {
+                  push @res, [$idx, [Socket::AF_INET, $type, $proton,
+                              Socket::pack_sockaddr_in $port, AnyEvent::Socket::parse_ipv4 ($_)]]
+                     for @_;
+                  $cv->end;
+               };
+            }
+            my $idx = $idx + 0.5; # prefer ipv4 for now
+            # ipv6
+            if ($family != 4) {
+               $cv->begin;
+               aaaa $node, sub {
+                  push @res, [$idx, [Socket::AF_INET6, $type, $proton,
+                              pack_sockaddr_in6 $port, AnyEvent::Socket::parse_ipv6 ($_)]]
+                     for @_;
+                  $cv->end;
+               };
+            }
+         }
+      }
+      $cv->end;
+   };
+   # try srv records, if applicable
+   if (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
+      srv $service, $proto, $node, sub {
+         my (@srv) = @_;
+         # no srv records, continue traditionally
+         @srv
+            or return &$resolve;
+         # only srv record has "." => abort
+         $srv[0][2] ne "." || $#srv
+            or return $cb->();
+         # use srv records then
+         @target = map [$_->[3], $_->[2]],
+                      grep $_->[3] ne ".",
+                         @srv;
+         &$resolve;
+      };
+   } else {
+      &$resolve;
+   }
+}
+#############################################################################
+=back
-=head2 DNS EN-/DECODING FUNCTIONS
+=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
 =over 4
+=item $AnyEvent::DNS::EDNS0
+This variable decides whether dns_pack automatically enables EDNS0
+support. By default, this is disabled (C<0>), but when set to C<1>,
+AnyEvent::DNS will use EDNS0 in all requests.
 =cut
+our $EDNS0 = 0; # set to 1 to enable (partial) edns0
 our %opcode_id = (
    query  => 0,
    iquery => 1,
    status => 2,
       + $rcode_id{$req->{rc}} * 0x0001,
       scalar @{ $req->{qd} || [] },
       scalar @{ $req->{an} || [] },
       scalar @{ $req->{ns} || [] },
-      scalar @{ $req->{ar} || [] }, # include EDNS0 option here
+      $EDNS0 + scalar @{ $req->{ar} || [] }, # include EDNS0 option here
       (join "", map _enc_qd, @{ $req->{qd} || [] }),
       (join "", map _enc_rr, @{ $req->{an} || [] }),
       (join "", map _enc_rr, @{ $req->{ns} || [] }),
       (join "", map _enc_rr, @{ $req->{ar} || [] }),
-      # (pack "C nnNn", 0, 41, 4000, 0, 0) # EDNS0, 4k udp payload size
+      ($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size
 }
 our $ofs;
 our $pkt;
    my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
    [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
 }
 our %dec_rr = (
-     1 => sub { Socket::inet_ntoa $_ }, # a
+     1 => sub { join ".", unpack "C4" }, # a
      2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
      5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
      6 => sub {
              local $ofs = $ofs - length;
              my $mname = _dec_qname;
              my $rname = _dec_qname;
              ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
           }, # soa
-    11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks
+    11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks
     12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
     13 => sub { unpack "C/a C/a", $_ }, # hinfo
     15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
     16 => sub { unpack "(C/a)*", $_ }, # txt
-    28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa
+    28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
     33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
     99 => sub { unpack "(C/a)*", $_ }, # spf
 );
 sub _dec_rr {
 Unpacks a DNS packet into a perl data structure.
 Examples:
-  # a non-successful reply
+  # an unsuccessful reply
   {
     'qd' => [
               [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
             ],
     'rc' => 'nxdomain',
                 'uni-karlsruhe.de',
                 'soa',
                 'in',
                 'netserv.rz.uni-karlsruhe.de',
                 'hostmaster.rz.uni-karlsruhe.de',
-                2008052201,
+                2008052201, 10800, 1800, 2592000, 86400
-                10800,
-                1800,
-                2592000,
-                86400
               ]
             ],
     'tc' => '',
     'ra' => 1,
     'qr' => 1,
 =back
 =head2 THE AnyEvent::DNS RESOLVER CLASS
-This is the class which deos the actual protocol work.
+This is the class which does the actual protocol work.
 =over 4
 =cut
 our $RESOLVER;
 sub resolver() {
    $RESOLVER || do {
       $RESOLVER = new AnyEvent::DNS;
-      $RESOLVER->load_resolv_conf;
+      $RESOLVER->os_config;
       $RESOLVER
    }
 }
 =item $resolver = new AnyEvent::DNS key => value...
 =over 4
 =item server => [...]
-A list of server addressses (default C<v127.0.0.1>) in network format (4
+A list of server addressses (default: C<v127.0.0.1>) in network format (4
 octets for IPv4, 16 octets for IPv6 - not yet supported).
 =item timeout => [...]
 A list of timeouts to use (also determines the number of retries). To make
 Most name servers do not handle many parallel requests very well. This option
 limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means
 if you request more than this many requests, then the additional requests will be queued
 until some other requests have been resolved.
+=item reuse => $seconds
+The number of seconds (default: C<60>) that a query id cannot be re-used
+after a request. Since AnyEvent::DNS will only allocate up to 30000 ID's
+at the same time, the long-term maximum number of requests per second is
+C<30000 / $seconds> (and thus C<500> requests/s by default).
 =back
 =cut
       server  => [v127.0.0.1],
       timeout => [2, 5, 5],
       search  => [],
       ndots   => 1,
       max_outstanding => 10,
-      reuse   => 300, # reuse id's after 5 minutes only, if possible
+      reuse   => 60, # reuse id's after 5 minutes only, if possible
       %arg,
       fh      => $fh,
       reuse_q => [],
    }, $class;
 }
 =item $resolver->parse_resolv_conv ($string)
 Parses the given string a sif it were a F<resolv.conf> file. The following
-directives are supported:
+directives are supported (but not neecssarily implemented).
 C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
 C<options> (C<timeout>, C<attempts>, C<ndots>).
 Everything else is silently ignored.
       if $attempts;
    $self->_compile;
 }
-=item $resolver->load_resolv_conf
+=item $resolver->os_config
-Tries to load and parse F</etc/resolv.conf>. If there will ever be windows
+Tries so load and parse F</etc/resolv.conf> on portable opertaing systems. Tries various
-support, then this function will do the right thing under windows, too.
+egregious hacks on windows to force the dns servers and searchlist out of the config.
 =cut
-sub load_resolv_conf {
+sub os_config {
    my ($self) = @_;
+   if ($^O =~ /mswin32|cygwin/i) {
+      # yeah, it suxx... lets hope DNS is DNS in all locales
+      if (open my $fh, "ipconfig /all |") {
+         delete $self->{server};
+         delete $self->{search};
+         while (<$fh>) {
+            # first DNS.* is suffix list
+            if (/^\s*DNS/) {
+               while (/\s+([[:alnum:].\-]+)\s*$/) {
+                  push @{ $self->{search} }, $1;
+                  $_ = <$fh>;
+               }
+               last;
+            }
+         }
+         while (<$fh>) {
+            # second DNS.* is server address list
+            if (/^\s*DNS/) {
+               while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
+                  my $ip = $1;
+                  push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip
+                     if AnyEvent::Util::dotted_quad $ip;
+                  $_ = <$fh>;
+               }
+               last;
+            }
+         }
+         $self->_compile;
+      }
+   } else {
+      # try resolv.conf everywhere
-   open my $fh, "</etc/resolv.conf"
+      if (open my $fh, "</etc/resolv.conf") {
-      or return;
-   local $/;
+         local $/;
-   $self->parse_resolv_conf (<$fh>);
+         $self->parse_resolv_conf (<$fh>);
+      }
+   }
 }
 sub _compile {
    my $self = shift;
 }
 sub _recv {
    my ($self) = @_;
-   while (my $peer = recv $self->{fh}, my $res, 4000, 0) {
+   while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
       my ($port, $host) = Socket::unpack_sockaddr_in $peer;
       return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
       $self->_feed ($res);
       }), sub {
          my ($res) = @_;
          if ($res->{tc}) {
             # success, but truncated, so use tcp
-            AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub {
+            AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
                my ($fh) = @_
                   or return $self->_exec ($req, $retry + 1);
                my $handle = new AnyEvent::Handle
                   fh       => $fh,
                      $self->_feed ($_[1]);
                   });
                });
                shutdown $fh, 1;
-            }, sub { $timeout };
+            }, sub { $timeout });
          } else {
             # success
             $self->{id}{$req->[2]} = 1;
             push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
    $NOW = time;
    # first clear id reuse queue
    delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
-      while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;
+      while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
    while ($self->{outstanding} < $self->{max_outstanding}) {
+      if (@{ $self->{reuse_q} } >= 30000) {
+         # we ran out of ID's, wait a bit
+         $self->{reuse_to} ||= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
+            delete $self->{reuse_to};
+            $self->_scheduler;
+         });
+         last;
+      }
       my $req = shift @{ $self->{queue} }
          or last;
       while () {
          $req->[2] = int rand 65536;
    };
    $do_search->();
 }
+use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
 1;
 =back
 =head1 AUTHOR

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.8 by root, Fri May 23 05:34:32 2008 UTC vs. Revision 1.19 by root, Fri May 23 23:37:13 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.8 by root, Fri May 23 05:34:32 2008 UTC vs.
Revision 1.19 by root, Fri May 23 23:37:13 2008 UTC