--- AnyEvent/lib/AnyEvent/DNS.pm 2008/05/29 06:17:52 1.42 +++ AnyEvent/lib/AnyEvent/DNS.pm 2008/05/30 05:56:20 1.51 @@ -16,9 +16,9 @@ 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 @@ -70,29 +70,47 @@ 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: -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) + +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) - -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 @@ -146,35 +164,120 @@ # 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 ($ip, $cb) = @_; + my ($domain, $cb) = @_; - $ip = AnyEvent::Socket::parse_address ($ip) - or return $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 ($ip); + 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) { - $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa."; - } elsif ($af == AF_INET6) { - $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa."; - } else { - return $cb->(); + $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 any($$) { - my ($domain, $cb) = @_; +sub reverse_verify($$) { + 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; + }; } ################################################################################# @@ -250,6 +353,7 @@ txt => 16, aaaa => 28, srv => 33, + naptr => 35, # rfc2915 opt => 41, spf => 99, tkey => 249, @@ -272,7 +376,6 @@ our %class_str = reverse %class_id; -# names MUST have a trailing dot sub _enc_name($) { pack "(C/a*)*", (split /\./, shift), "" } @@ -289,7 +392,7 @@ =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. @@ -342,14 +445,14 @@ 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, MAX_PKT, 0, 0 : "") # EDNS0, 4kiB udp payload size + ($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option } our $ofs; @@ -404,6 +507,11 @@ 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 ); @@ -583,10 +691,11 @@ =item max_outstanding => $integer -Most name servers do not handle many parallel requests very well. This option -limits the number of 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 @@ -909,6 +1018,8 @@ sub _scheduler { my ($self) = @_; + no strict 'refs'; + $NOW = time; # first clear id reuse queue @@ -926,19 +1037,27 @@ 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->{outstanding}; - $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->_exec ($req); + } else { + # nothing to do, just exit + last; + } } } @@ -960,14 +1079,32 @@ =item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr)) -Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a -qtype of "*" is supported and means "any"). +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 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 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. +The callback will be invoked with an result code in string form (noerror, +formerr, servfail, nxdomain, notimp, refused and so on), or numerical +form if the result code is not supported. The remaining arguments are +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 and C are +decoded. All resource records not known to this module will just return +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. @@ -987,7 +1124,8 @@ 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" @@ -998,19 +1136,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 { @@ -1018,20 +1172,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 @@ -1109,6 +1254,37 @@ $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;