--- AnyEvent/lib/AnyEvent/DNS.pm 2008/05/23 06:42:53 1.13 +++ AnyEvent/lib/AnyEvent/DNS.pm 2009/06/22 11:57:05 1.93 @@ -4,16 +4,21 @@ =head1 SYNOPSIS - use AnyEvent::DNS; + use AnyEvent::DNS; + + my $cv = AnyEvent->condvar; + AnyEvent::DNS::a "www.google.de", $cv; + # ... later + my @addrs = $cv->recv; =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. +The stub resolver supports DNS over IPv4 and IPv6, UDP and TCP, optional +EDNS0 support for up to 4kiB datagrams and automatically falls back to +virtual circuit mode for large responses. =head2 CONVENIENCE FUNCTIONS @@ -26,26 +31,24 @@ no warnings; use strict; -use AnyEvent::Util (); -use AnyEvent::Handle (); - -=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs) - -NOT YET IMPLEMENTED +use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM); -Tries to resolve the given nodename and service name into sockaddr -structures usable to connect to this node and service in a -protocol-independent way. It works similarly to the getaddrinfo posix -function. +use AnyEvent (); +use AnyEvent::Handle (); +use AnyEvent::Util qw(AF_INET6); -Example: +our $VERSION = 4.411; - AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... }; +our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222); =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 @@ -64,35 +67,55 @@ Tries to resolve the given service, protocol and domain name into a list of service records. -Each srv_rr is an arrayref with the following contents: +Each C<$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: -should use the rfc algorithm to reorder same-priority records for weight). +They will be sorted with lowest priority first, then randomly +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 +and C 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) -Requires the Socket6 module for IPv6 support. +The same as C, 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) +=cut -Tries to resolve the given domain and passes all resource records found to -the callback. +sub MAX_PKT() { 4096 } # max packet size we advertise and accept -=cut +sub DOMAIN_PORT() { 53 } # if this changes drop me a note sub resolver; @@ -104,6 +127,14 @@ }); } +sub aaaa($$) { + my ($domain, $cb) = @_; + + resolver->resolve ($domain => "aaaa", sub { + $cb->(map $_->[3], @_); + }); +} + sub mx($$) { my ($domain, $cb) = @_; @@ -133,26 +164,40 @@ # 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 <=> $b } 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 ($ip, $cb) = @_; - - my $name; - - if (AnyEvent::Util::dotted_quad $ip) { - $name = join ".", (reverse split /\./, $ip), "in-addr.arpa."; - } else { - require Socket6; - $name = join ".", - (reverse split //, - unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)), - "ip6.arpa."; - } + my ($domain, $cb) = @_; - resolver->resolve ($name => "ptr", sub { + resolver->resolve ($domain => "ptr", sub { $cb->(map $_->[3], @_); }); } @@ -163,6 +208,82 @@ 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 = _munge_ptr AnyEvent::Socket::parse_address ($ip) + or return $cb->(); + + resolver->resolve ($ip => "ptr", sub { + $cb->(map $_->[3], @_); + }); +} + +sub reverse_verify($$) { + my ($ip, $cb) = @_; + + my $ipn = AnyEvent::Socket::parse_address ($ip) + or return $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 + =head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS =over 4 @@ -170,12 +291,13 @@ =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. +support. By default, this is disabled (C<0>), unless overridden by +C<$ENV{PERL_ANYEVENT_EDNS0}>, 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 $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0}*1; # set to 1 to enable (partial) edns0 our %opcode_id = ( query => 0, @@ -231,6 +353,8 @@ txt => 16, aaaa => 28, srv => 33, + naptr => 35, # rfc2915 + dname => 39, # rfc2672 opt => 41, spf => 99, tkey => 249, @@ -253,13 +377,12 @@ our %class_str = reverse %class_id; -# names MUST have a trailing dot -sub _enc_qname($) { - pack "(C/a)*", (split /\./, shift), "" +sub _enc_name($) { + pack "(C/a*)*", (split /\./, shift), "" } sub _enc_qd() { - (_enc_qname $_->[0]) . pack "nn", + (_enc_name $_->[0]) . pack "nn", ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}), ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"}) } @@ -270,37 +393,37 @@ =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: - # very simple request, using lots of default values: - { rd => 1, qd => [ [ "host.domain", "a"] ] } - - # more complex example, showing how flags etc. are named: - - { - id => 10000, - op => "query", - rc => "nxdomain", - - # flags - qr => 1, - aa => 0, - tc => 0, - rd => 0, - ra => 0, - ad => 0, - cd => 0, - - qd => [@rr], # query section - an => [@rr], # answer section - ns => [@rr], # authority section - ar => [@rr], # additional records section - } + # very simple request, using lots of default values: + { rd => 1, qd => [ [ "host.domain", "a"] ] } + + # more complex example, showing how flags etc. are named: + + { + id => 10000, + op => "query", + rc => "nxdomain", + + # flags + qr => 1, + aa => 0, + tc => 0, + rd => 0, + ra => 0, + ad => 0, + cd => 0, + + qd => [@rr], # query section + an => [@rr], # answer section + ns => [@rr], # authority section + ar => [@rr], # additional records section + } =cut @@ -323,21 +446,21 @@ scalar @{ $req->{qd} || [] }, scalar @{ $req->{an} || [] }, scalar @{ $req->{ns} || [] }, - $EDNS0 + scalar @{ $req->{ar} || [] }, # include EDNS0 option here + $EDNS0 + scalar @{ $req->{ar} || [] }, # EDNS0 option included 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} || [] }), - ($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size + ($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option } our $ofs; our $pkt; # bitches -sub _dec_qname { +sub _dec_name { my @res; my $redir; my $ptr = $ofs; @@ -348,7 +471,7 @@ my $len = ord substr $pkt, $ptr++, 1; - if ($len & 0xc0) { + if ($len >= 0xc0) { $ptr++; $ofs = $ptr if $ptr > $ofs; $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff; @@ -363,39 +486,46 @@ } sub _dec_qd { - my $qname = _dec_qname; + my $qname = _dec_name; 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 - 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns - 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname + 1 => sub { join ".", unpack "C4", $_ }, # a + 2 => sub { local $ofs = $ofs - length; _dec_name }, # ns + 5 => sub { local $ofs = $ofs - length; _dec_name }, # cname 6 => sub { local $ofs = $ofs - length; - my $mname = _dec_qname; - my $rname = _dec_qname; + my $mname = _dec_name; + my $rname = _dec_name; ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) }, # soa - 11 => sub { ((Socket::inet_aton substr $_, 0, 4), 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 - 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv - 99 => sub { unpack "(C/a)*", $_ }, # spf + 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks + 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr + 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 + # requires perl 5.10, sorry + 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) + }, + 39 => sub { local $ofs = $ofs - length; _dec_name }, # dname + 99 => sub { unpack "(C/a*)*", $_ }, # spf ); sub _dec_rr { - my $qname = _dec_qname; + my $name = _dec_name; my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10; local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen; [ - $qname, + $name, $type_str{$rt} || $rt, $class_str{$rc} || $rc, ($dec_rr{$rt} || sub { $_ })->(), @@ -408,61 +538,61 @@ Examples: - # an unsuccessful reply - { - 'qd' => [ - [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] - ], - 'rc' => 'nxdomain', - 'ar' => [], - 'ns' => [ - [ - 'uni-karlsruhe.de', - 'soa', - 'in', - 'netserv.rz.uni-karlsruhe.de', - 'hostmaster.rz.uni-karlsruhe.de', - 2008052201, 10800, 1800, 2592000, 86400 - ] - ], - 'tc' => '', - 'ra' => 1, - 'qr' => 1, - 'id' => 45915, - 'aa' => '', - 'an' => [], - 'rd' => 1, - 'op' => 'query' - } - - # a successful reply - - { - 'qd' => [ [ 'www.google.de', 'a', 'in' ] ], - 'rc' => 0, - 'ar' => [ - [ 'a.l.google.com', 'a', 'in', '209.85.139.9' ], - [ 'b.l.google.com', 'a', 'in', '64.233.179.9' ], - [ 'c.l.google.com', 'a', 'in', '64.233.161.9' ], - ], - 'ns' => [ - [ 'l.google.com', 'ns', 'in', 'a.l.google.com' ], - [ 'l.google.com', 'ns', 'in', 'b.l.google.com' ], - ], - 'tc' => '', - 'ra' => 1, - 'qr' => 1, - 'id' => 64265, - 'aa' => '', - 'an' => [ - [ 'www.google.de', 'cname', 'in', 'www.google.com' ], - [ 'www.google.com', 'cname', 'in', 'www.l.google.com' ], - [ 'www.l.google.com', 'a', 'in', '66.249.93.104' ], - [ 'www.l.google.com', 'a', 'in', '66.249.93.147' ], - ], - 'rd' => 1, - 'op' => 0 - } + # an unsuccessful reply + { + 'qd' => [ + [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] + ], + 'rc' => 'nxdomain', + 'ar' => [], + 'ns' => [ + [ + 'uni-karlsruhe.de', + 'soa', + 'in', + 'netserv.rz.uni-karlsruhe.de', + 'hostmaster.rz.uni-karlsruhe.de', + 2008052201, 10800, 1800, 2592000, 86400 + ] + ], + 'tc' => '', + 'ra' => 1, + 'qr' => 1, + 'id' => 45915, + 'aa' => '', + 'an' => [], + 'rd' => 1, + 'op' => 'query' + } + + # a successful reply + + { + 'qd' => [ [ 'www.google.de', 'a', 'in' ] ], + 'rc' => 0, + 'ar' => [ + [ 'a.l.google.com', 'a', 'in', '209.85.139.9' ], + [ 'b.l.google.com', 'a', 'in', '64.233.179.9' ], + [ 'c.l.google.com', 'a', 'in', '64.233.161.9' ], + ], + 'ns' => [ + [ 'l.google.com', 'ns', 'in', 'a.l.google.com' ], + [ 'l.google.com', 'ns', 'in', 'b.l.google.com' ], + ], + 'tc' => '', + 'ra' => 1, + 'qr' => 1, + 'id' => 64265, + 'aa' => '', + 'an' => [ + [ 'www.google.de', 'cname', 'in', 'www.google.com' ], + [ 'www.google.com', 'cname', 'in', 'www.l.google.com' ], + [ 'www.l.google.com', 'a', 'in', '66.249.93.104' ], + [ 'www.l.google.com', 'a', 'in', '66.249.93.147' ], + ], + 'rd' => 1, + 'op' => 0 + } =cut @@ -527,8 +657,8 @@ sub resolver() { $RESOLVER || do { - $RESOLVER = new AnyEvent::DNS; - $RESOLVER->load_resolv_conf; + $RESOLVER = new AnyEvent::DNS untaint => 1; + $RESOLVER->os_config; $RESOLVER } } @@ -543,8 +673,9 @@ =item server => [...] -A list of server addressses (default: C) in network format (4 -octets for IPv4, 16 octets for IPv6 - not yet supported). +A list of server addresses (default: C) in network format +(i.e. as returned by C - both IPv4 and +IPv6 are supported). =item timeout => [...] @@ -563,17 +694,22 @@ =item max_outstanding => $integer -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. +Most name servers do not handle many parallel requests very well. This +option limits the number of outstanding requests to C<$integer> +(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). +The number of seconds (default: C<300>) that a query id cannot be re-used +after a timeout. If there was no time-out then query ids can be reused +immediately. + +=item untaint => $boolean + +When true, then the resolver will automatically untaint results, and might +also ignore certain environment variables. =back @@ -582,28 +718,52 @@ sub new { my ($class, %arg) = @_; - socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0 - or Carp::croak "socket: $!"; - - AnyEvent::Util::fh_nonblocking $fh, 1; - my $self = bless { - server => [v127.0.0.1], + server => [], timeout => [2, 5, 5], search => [], ndots => 1, max_outstanding => 10, - reuse => 60, # reuse id's after 5 minutes only, if possible + reuse => 300, %arg, - fh => $fh, reuse_q => [], }, $class; # search should default to gethostname's domain # but perl lacks a good posix module + # try to create an ipv4 and an ipv6 socket + # only fail when we cannot create either + my $got_socket; + Scalar::Util::weaken (my $wself = $self); - $self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv }); + + if (socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0) { + ++$got_socket; + + AnyEvent::Util::fh_nonblocking $fh4, 1; + $self->{fh4} = $fh4; + $self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub { + if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) { + $wself->_recv ($pkt, $peer); + } + }); + } + + if (AF_INET6 && socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0) { + ++$got_socket; + + $self->{fh6} = $fh6; + AnyEvent::Util::fh_nonblocking $fh6, 1; + $self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub { + if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) { + $wself->_recv ($pkt, $peer); + } + }); + } + + $got_socket + or Carp::croak "unable to create either an IPv4 or an IPv6 socket"; $self->_compile; @@ -612,8 +772,8 @@ =item $resolver->parse_resolv_conv ($string) -Parses the given string a sif it were a F file. The following -directives are supported: +Parses the given string as if it were a F file. The following +directives are supported (but not necessarily implemented). C<#>-style comments, C, C, C, C, C (C, C, C). @@ -635,8 +795,8 @@ # comment } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { my $ip = $1; - if (AnyEvent::Util::dotted_quad $ip) { - push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; + if (my $ipn = AnyEvent::Socket::parse_address ($ip)) { + push @{ $self->{server} }, $ipn; } else { warn "nameserver $ip invalid and ignored\n"; } @@ -667,26 +827,112 @@ $self->_compile; } -=item $resolver->load_resolv_conf +=item $resolver->os_config -Tries to load and parse F. If there will ever be windows -support, then this function will do the right thing under windows, too. +Tries so load and parse F on portable operating +systems. Tries various egregious hacks on windows to force the DNS servers +and searchlist out of the system. =cut -sub load_resolv_conf { +sub os_config { my ($self) = @_; - open my $fh, "{server} = []; + $self->{search} = []; + + if (AnyEvent::WIN32 || $^O =~ /cygwin/i) { + no strict 'refs'; - local $/; - $self->parse_resolv_conf (<$fh>); + # there are many options to find the current nameservers etc. on windows + # all of them don't work consistently: + # - 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 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 + # :-lines with DNS in them. everything in those is regarded as + # either a nameserver (if it parses as an ip address), or a suffix + # (all else). + + my $dns; + while (<$fh>) { + if (s/^\s.*\bdns\b.*://i) { + $dns = 1; + } elsif (/^\S/ || /^\s[^:]{16,}: /) { + $dns = 0; + } + if ($dns && /^\s*(\S+)\s*$/) { + my $s = $1; + $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; + } + } + } + + # always add one fallback server + push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK]; + + $self->_compile; + } + } else { + # try resolv.conf everywhere + + if (open my $fh, "parse_resolv_conf (<$fh>); + } + } +} + +=item $resolver->timeout ($timeout, ...) + +Sets the timeout values. See the C 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 constructor argument. + +=cut + +sub max_outstanding { + my ($self, $max) = @_; + + $self->{max_outstanding} = $max; + $self->_scheduler; } sub _compile { my $self = shift; + my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }]; + my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }]; + + unless (@{ $self->{server} }) { + # use 127.0.0.1 by default, and one opendns nameserver as fallback + $self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]]; + } + my @retry; for my $timeout (@{ $self->{timeout} }) { @@ -701,6 +947,9 @@ sub _feed { my ($self, $res) = @_; + ($res) = $res =~ /^(.*)$/s + if AnyEvent::TAINT && $self->{untaint}; + $res = dns_unpack $res or return; @@ -713,80 +962,111 @@ } sub _recv { - my ($self) = @_; + my ($self, $pkt, $peer) = @_; + + # we ignore errors (often one gets port unreachable, but there is + # no good way to take advantage of that. - while (my $peer = recv $self->{fh}, my $res, 4096, 0) { - my ($port, $host) = Socket::unpack_sockaddr_in $peer; + my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer); - return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; + return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; - $self->_feed ($res); + $self->_feed ($pkt); +} + +sub _free_id { + my ($self, $id, $timeout) = @_; + + if ($timeout) { + # we need to block the id for a while + $self->{id}{$id} = 1; + push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id]; + } else { + # we can quickly recycle the id + delete $self->{id}{$id}; } + + --$self->{outstanding}; + $self->_scheduler; } +# execute a single request, involves sending it with timeouts to multiple servers sub _exec { - my ($self, $req, $retry) = @_; + my ($self, $req) = @_; + + my $retry; # of retries + my $do_retry; + + $do_retry = sub { + my $retry_cfg = $self->{retry}[$retry++] + or do { + # failure + $self->_free_id ($req->[2], $retry > 1); + undef $do_retry; return $req->[1]->(); + }; - if (my $retry_cfg = $self->{retry}[$retry]) { my ($server, $timeout) = @$retry_cfg; $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { $NOW = time; # timeout, try next - $self->_exec ($req, $retry + 1); + &$do_retry if $do_retry; }), 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 (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub { + return unless $do_retry; # some other request could have invalidated us already + my ($fh) = @_ - or return $self->_exec ($req, $retry + 1); + 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 - $self->_exec ($req, $retry + 1); + &$do_retry; }; $handle->push_write (pack "n/a", $req->[0]); - $handle->push_read_chunk (2, sub { - $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { + $handle->push_read (chunk => 2, sub { + $handle->unshift_read (chunk => (unpack "n", $_[1]), sub { + undef $handle; $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]]; - --$self->{outstanding}; - $self->_scheduler; - - $req->[1]->($res); + $self->_free_id ($req->[2], $retry > 1); + undef $do_retry; return $req->[1]->($res); } }]; + + my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server); - send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; - } else { - # failure - $self->{id}{$req->[2]} = 1; - push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; - --$self->{outstanding}; - $self->_scheduler; + my $fh = AF_INET == Socket::sockaddr_family ($sa) + ? $self->{fh4} : $self->{fh6} + or return &$do_retry; - $req->[1]->(); - } + send $fh, $req->[0], 0, $sa; + }; + + &$do_retry; } sub _scheduler { my ($self) = @_; + no strict 'refs'; + $NOW = time; # first clear id reuse queue @@ -804,28 +1084,41 @@ last; } - my $req = shift @{ $self->{queue} } - or last; - - while () { - $req->[2] = int rand 65536; - last unless exists $self->{id}{$req->[2]}; - } + if (my $req = shift @{ $self->{queue} }) { + # found a request in the queue, execute it + while () { + $req->[2] = int rand 65536; + last unless exists $self->{id}{$req->[2]}; + } - $self->{id}{$req->[2]} = 1; - substr $req->[0], 0, 2, pack "n", $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); - ++$self->{outstanding}; - $self->_exec ($req, 0); + } else { + # nothing to do, just exit + last; + } } } =item $resolver->request ($req, $cb->($res)) -Sends a single request (a hash-ref formated as specified for -C) to the configured nameservers including -retries. Calls the callback with the decoded response packet if a reply -was received, or no arguments on timeout. +This is the main low-level workhorse for sending DNS requests. + +This function sends a single request (a hash-ref formated as specified +for C) 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. + +Calls the callback with the decoded response packet if a reply was +received, or no arguments in case none of the servers answered. =cut @@ -836,17 +1129,33 @@ $self->_scheduler; } -=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr)) +=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr)) + +Queries the DNS for the given domain name C<$qname> of type C<$qtype>. -Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a -qtype of "*" is supported and means "any"). +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 1035, C, C, C and a few +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. -CNAME chains (although illegal) are followed up to a length of 8. +CNAME chains (although illegal) are followed up to a length of 10. -Note that this resolver is just a stub resolver: it requires a nameserver +The callback will be invoked with arraryefs of the form C<[$name, $type, +$class, @data>], where C<$name> is the domain name, C<$type> a type string +or number, C<$class> a class name and @data is resource-record-dependent +data. For C records, this will be the textual IPv4 addresses, for C +or C records this will be a domain name, for C records these +are all the strings and so on. + +All types mentioned in RFC 1035, C, C, C and C are +decoded. All resource records not known to this module will have +the raw C 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. @@ -858,14 +1167,16 @@ 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 and C define its value. If the C<$qname> ends in a dot, -then the searchlist will be ignored. +C and C values define its value (depending on C, the +empty suffix will be prepended or appended to that C 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 -else. +else. If this list includes C, then CNAME-chains will not be +followed (because you asked for the CNAME record). =item class => "class" @@ -876,19 +1187,35 @@ Examples: - $res->resolve ("ruth.plan9.de", "a", sub { - warn Dumper [@_]; - }); - - [ - [ - 'ruth.schmorp.de', - 'a', - 'in', - '129.13.162.95' - ] - ] + # 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]; + + # shortened result: + # [ + # [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com', + # 2008052701, 7200, 1800, 1209600, 300 ], + # [ + # 'google.com', 'txt', 'in', + # 'v=spf1 include:_netblocks.google.com ~all' + # ], + # [ 'google.com', 'a', 'in', '64.233.187.99' ], + # [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ], + # [ 'google.com', 'ns', 'in', 'ns2.google.com' ], + # ] + + # resolve a records: + $res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] }); + + # result: + # [ + # [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ] + # ] + # resolve any records, but return only a and aaaa records: $res->resolve ("test1.laendle", "*", accept => ["a", "aaaa"], sub { @@ -896,20 +1223,11 @@ } ); - [ - [ - 'test1.laendle', - 'a', - 'in', - '10.0.0.255' - ], - [ - 'test1.laendle', - 'aaaa', - 'in', - '3ffe:1900:4545:0002:0240:0000:0000:f7e1' - ] - ] + # result: + # [ + # [ 'test1.laendle', 'a', 'in', '10.0.0.255' ], + # [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ] + # ] =cut @@ -932,15 +1250,17 @@ : ($qtype => 1); # advance in searchlist - my $do_search; $do_search = sub { + my ($do_search, $do_req); + + $do_search = sub { @search - or return $cb->(); + or (undef $do_search), (undef $do_req), return $cb->(); (my $name = lc "$qname." . shift @search) =~ s/\.$//; - my $depth = 2; + my $depth = 10; # advance in cname-chain - my $do_req; $do_req = sub { + $do_req = sub { $self->request ({ rd => 1, qd => [[$name, $qtype, $class]], @@ -954,7 +1274,7 @@ # results found? my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; - return $cb->(@rr) + (undef $do_search), (undef $do_req), return $cb->(@rr) if @rr; # see if there is a cname we can follow @@ -985,14 +1305,47 @@ $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 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 =head1 AUTHOR - Marc Lehmann - http://home.schmorp.de/ + Marc Lehmann + http://home.schmorp.de/ =cut