--- AnyEvent/lib/AnyEvent/DNS.pm 2008/05/23 02:59:32 1.2 +++ AnyEvent/lib/AnyEvent/DNS.pm 2009/07/20 22:39:57 1.109 @@ -4,16 +4,23 @@ =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. -=head2 CONVENIENCE FUNCTIONS +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. -# none yet +=head2 CONVENIENCE FUNCTIONS =over 4 @@ -21,35 +28,305 @@ package AnyEvent::DNS; -use strict; +use Carp (); +use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM); + +use AnyEvent (); BEGIN { AnyEvent::common_sense } +use AnyEvent::Util qw(AF_INET6); + +our $VERSION = 4.86; + +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 +first) list of domain names. + +=item AnyEvent::DNS::ns $domain, $cb->(@hostnames) + +Tries to resolve the given domain name into a list of name servers. + +=item AnyEvent::DNS::txt $domain, $cb->(@hostnames) + +Tries to resolve the given domain name into a list of text records. + +=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) + +Tries to resolve the given service, protocol and domain name into a list +of service records. + +Each C<$srv_rr> is an array reference with the following contents: +C<[$priority, $weight, $transport, $target]>. + +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 $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). 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. -use AnyEvent::Util (); +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 + +=cut + +sub MAX_PKT() { 4096 } # max packet size we advertise and accept + +sub DOMAIN_PORT() { 53 } # if this changes drop me a note + +sub resolver; + +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($$) { + my ($domain, $cb) = @_; + + resolver->resolve ($domain => "mx", sub { + $cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_); + }); +} + +sub ns($$) { + my ($domain, $cb) = @_; + + resolver->resolve ($domain => "ns", sub { + $cb->(map $_->[3], @_); + }); +} + +sub txt($$) { + my ($domain, $cb) = @_; + + resolver->resolve ($domain => "txt", sub { + $cb->(map $_->[3], @_); + }); +} + +sub srv($$$$) { + my ($service, $proto, $domain, $cb) = @_; + + # todo, ask for any and check glue records + resolver->resolve ("_$service._$proto.$domain" => "srv", sub { + 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 ($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 = _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 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>), 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 = $ENV{PERL_ANYEVENT_EDNS0}*1; # set to 1 to enable (partial) edns0 + our %opcode_id = ( query => 0, iquery => 1, status => 2, - map +($_ => $_), 3..15 + notify => 4, + update => 5, + map +($_ => $_), 3, 6..15 ); our %opcode_str = reverse %opcode_id; our %rcode_id = ( - ok => 0, - formerr => 1, - servfail => 2, - nxdomain => 3, - notimp => 4, - refused => 5, - map +($_ => $_), 6..15 + noerror => 0, + formerr => 1, + servfail => 2, + nxdomain => 3, + notimp => 4, + refused => 5, + yxdomain => 6, # Name Exists when it should not [RFC 2136] + yxrrset => 7, # RR Set Exists when it should not [RFC 2136] + nxrrset => 8, # RR Set that should exist does not [RFC 2136] + notauth => 9, # Server Not Authoritative for zone [RFC 2136] + notzone => 10, # Name not contained in zone [RFC 2136] +# EDNS0 16 BADVERS Bad OPT Version [RFC 2671] +# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845] +# EDNS0 17 BADKEY Key not recognized [RFC 2845] +# EDNS0 18 BADTIME Signature out of time window [RFC 2845] +# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930] +# EDNS0 20 BADNAME Duplicate key name [RFC 2930] +# EDNS0 21 BADALG Algorithm not supported [RFC 2930] + map +($_ => $_), 11..15 ); our %rcode_str = reverse %rcode_id; @@ -73,6 +350,13 @@ txt => 16, aaaa => 28, srv => 33, + naptr => 35, # rfc2915 + dname => 39, # rfc2672 + opt => 41, + spf => 99, + tkey => 249, + tsig => 250, + ixfr => 251, axfr => 252, mailb => 253, "*" => 255, @@ -81,21 +365,28 @@ our %type_str = reverse %type_id; our %class_id = ( - in => 1, - ch => 3, - hs => 4, - "*" => 255, + in => 1, + ch => 3, + hs => 4, + none => 254, + "*" => 255, ); 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), "" +} + +if ($[ < 5.008) { + # special slower 5.6 version + *_enc_name = sub { + join "", map +(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"}) } @@ -106,42 +397,44 @@ =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, - - 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 sub dns_pack($) { my ($req) = @_; - pack "nn nnnn a* a* a* a*", + pack "nn nnnn a* a* a* a* a*", $req->{id}, ! !$req->{qr} * 0x8000 @@ -150,24 +443,28 @@ + ! !$req->{tc} * 0x0200 + ! !$req->{rd} * 0x0100 + ! !$req->{ra} * 0x0080 + + ! !$req->{ad} * 0x0020 + + ! !$req->{cd} * 0x0010 + $rcode_id{$req->{rc}} * 0x0001, scalar @{ $req->{qd} || [] }, scalar @{ $req->{an} || [] }, scalar @{ $req->{ns} || [] }, - scalar @{ $req->{ar} || [] }, + $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} || [] }); + (join "", map _enc_rr, @{ $req->{ar} || [] }), + + ($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; @@ -178,7 +475,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; @@ -193,38 +490,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", $_ }, - 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 + 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_ipv6 ($_) }, # 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 { $_ })->(), @@ -237,65 +542,61 @@ Examples: - # a non-successful 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 @@ -313,6 +614,8 @@ tc => ! ! ($flags & 0x0200), rd => ! ! ($flags & 0x0100), ra => ! ! ($flags & 0x0080), + ad => ! ! ($flags & 0x0020), + cd => ! ! ($flags & 0x0010), op => $opcode_str{($flags & 0x001e) >> 11}, rc => $rcode_str{($flags & 0x000f)}, @@ -329,7 +632,7 @@ =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 @@ -352,22 +655,38 @@ Unless you have special needs, prefer this function over creating your own resolver object. +The resolver is created with the following parameters: + + untaint enabled + max_outstanding $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS} + +C will be used for OS-specific configuration, unless +C<$ENV{PERL_ANYEVENT_RESOLV_CONF}> is specified, in which case that file +gets parsed. + =cut our $RESOLVER; sub resolver() { $RESOLVER || do { - $RESOLVER = new AnyEvent::DNS; - $RESOLVER->load_resolv_conf; + $RESOLVER = new AnyEvent::DNS + untaint => 1, + exists $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS} + ? (max_outstanding => $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}*1 || 1) : (), + ; + + exists $ENV{PERL_ANYEVENT_RESOLV_CONF} + ? length $ENV{PERL_ANYEVENT_RESOLV_CONF} && $RESOLVER->_parse_resolv_conf_file ($ENV{PERL_ANYEVENT_RESOLV_CONF}) + : $RESOLVER->os_config; + $RESOLVER } } =item $resolver = new AnyEvent::DNS key => value... -Creates and returns a new resolver. It only supports UDP, so make sure -your answer sections fit into a DNS packet. +Creates and returns a new resolver. The following options are supported: @@ -375,8 +694,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 => [...] @@ -395,10 +715,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<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 @@ -407,38 +739,62 @@ 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 => 300, # 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; $self } -=item $resolver->parse_resolv_conv ($string) +=item $resolver->parse_resolv_conf ($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). @@ -460,8 +816,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"; } @@ -492,26 +848,120 @@ $self->_compile; } -=item $resolver->load_resolv_conf +sub _parse_resolv_conf_file { + my ($self, $resolv_conf) = @_; -Tries to load and parse F. If there will ever be windows -support, then this function will do the right thing under windows, too. + open my $fh, "<", $resolv_conf + or Carp::croak "$resolv_conf: $!"; + + local $/; + $self->parse_resolv_conf (<$fh>); +} + +=item $resolver->os_config + +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} = []; - local $/; - $self->parse_resolv_conf (<$fh>); + if ((AnyEvent::WIN32 || $^O =~ /cygwin/i)) { + no strict 'refs'; + + # 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 else + + $self->_parse_resolv_conf_file ("/etc/resolv.conf") + if -e "/etc/resolv.conf"; + } +} + +=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} }) { @@ -523,112 +973,222 @@ $self->{retry} = \@retry; } +sub _feed { + my ($self, $res) = @_; + + ($res) = $res =~ /^(.*)$/s + if AnyEvent::TAINT && $self->{untaint}; + + $res = dns_unpack $res + or return; + + my $id = $self->{id}{$res->{id}}; + + return unless ref $id; + + $NOW = time; + $id->[1]->($res); +} + sub _recv { - my ($self) = @_; + my ($self, $pkt, $peer) = @_; - while (my $peer = recv $self->{fh}, my $res, 1024, 0) { - my ($port, $host) = Socket::unpack_sockaddr_in $peer; + # we ignore errors (often one gets port unreachable, but there is + # no good way to take advantage of that. - return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; + my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer); - $res = AnyEvent::DNS::dns_unpack $res - or return; + return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; - my $id = $self->{id}{$res->{id}}; + $self->_feed ($pkt); +} - return unless ref $id; +sub _free_id { + my ($self, $id, $timeout) = @_; - $NOW = time; - $id->[1]->($res); + 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) = @_; - # success - $self->{id}{$req->[2]} = 1; - push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; - --$self->{outstanding}; - $self->_scheduler; + 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; + + require 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]); + }); + }); + + }, sub { $timeout }); - $req->[1]->($res); + } else { + # success + $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 == AnyEvent::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 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}) { - my $req = shift @{ $self->{queue} } - or last; - while () { - $req->[2] = int rand 65536; - last unless exists $self->{id}{$req->[2]}; + 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; } - $self->{id}{$req->[2]} = 1; - substr $req->[0], 0, 2, pack "n", $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->_exec ($req); - ++$self->{outstanding}; - $self->_exec ($req, 0); + } 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; + } } } =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 sub request($$) { my ($self, $req, $cb) = @_; - push @{ $self->{queue} }, [(AnyEvent::DNS::dns_pack $req), $cb]; + push @{ $self->{queue} }, [dns_pack $req, $cb]; $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. + +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. The following options are supported: @@ -638,14 +1198,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" @@ -656,19 +1218,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 { @@ -676,20 +1254,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 @@ -712,15 +1281,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 = "$qname." . shift @search) =~ s/\.$//; - my $depth = 2; + (my $name = lc "$qname." . shift @search) =~ s/\.$//; + my $depth = 10; # advance in cname-chain - my $do_req; $do_req = sub { + $do_req = sub { $self->request ({ rd => 1, qd => [[$name, $qtype, $class]], @@ -732,20 +1303,20 @@ while () { # results found? - my @rr = grep $_->[0] eq $name && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; + 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 - my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} }; + my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} }; if (@rr) { $depth-- or return $do_search->(); # cname chain too long $cname = 1; - $name = $rr[0][3]; + $name = lc $rr[0][3]; } elsif ($cname) { # follow the cname @@ -765,14 +1336,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