ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/DNS.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.14 by root, Fri May 23 16:00:36 2008 UTC vs.
Revision 1.43 by root, Thu May 29 06:19:22 2008 UTC

… …
3AnyEvent::DNS - fully asynchronous DNS resolution 3AnyEvent::DNS - fully asynchronous DNS resolution
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use AnyEvent::DNS; 7 use AnyEvent::DNS;
8
9 my $cv = AnyEvent->condvar;
10 AnyEvent::DNS::a "www.google.de", $cv;
11 # ... later
12 my @addrs = $cv->recv;
8 13
9=head1 DESCRIPTION 14=head1 DESCRIPTION
10 15
11This module offers both a number of DNS convenience functions as well 16This module offers both a number of DNS convenience functions as well
12as a fully asynchronous and high-performance pure-perl stub resolver. 17as a fully asynchronous and high-performance pure-perl stub resolver.
… …
24package AnyEvent::DNS; 29package AnyEvent::DNS;
25 30
26no warnings; 31no warnings;
27use strict; 32use strict;
28 33
34use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
35
29use AnyEvent::Util (); 36use AnyEvent ();
30use AnyEvent::Handle (); 37use AnyEvent::Handle ();
38use AnyEvent::Util qw(AF_INET6);
31 39
32=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs) 40our $VERSION = '1.0';
33 41
34NOT YET IMPLEMENTED 42our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
35
36Tries to resolve the given nodename and service name into sockaddr
37structures usable to connect to this node and service in a
38protocol-independent way. It works similarly to the getaddrinfo posix
39function.
40
41Example:
42
43 AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
44 43
45=item AnyEvent::DNS::a $domain, $cb->(@addrs) 44=item AnyEvent::DNS::a $domain, $cb->(@addrs)
46 45
47Tries to resolve the given domain to IPv4 address(es). 46Tries to resolve the given domain to IPv4 address(es).
47
48=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
49
50Tries to resolve the given domain to IPv6 address(es).
48 51
49=item AnyEvent::DNS::mx $domain, $cb->(@hostnames) 52=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
50 53
51Tries to resolve the given domain into a sorted (lower preference value 54Tries to resolve the given domain into a sorted (lower preference value
52first) list of domain names. 55first) list of domain names.
… …
62=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 65=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
63 66
64Tries to resolve the given service, protocol and domain name into a list 67Tries to resolve the given service, protocol and domain name into a list
65of service records. 68of service records.
66 69
67Each srv_rr is an arrayref with the following contents: 70Each srv_rr is an array reference with the following contents:
68C<[$priority, $weight, $transport, $target]>. 71C<[$priority, $weight, $transport, $target]>.
69 72
70They will be sorted with lowest priority, highest weight first (TODO: 73They will be sorted with lowest priority, highest weight first (TODO:
71should use the rfc algorithm to reorder same-priority records for weight). 74should use the RFC algorithm to reorder same-priority records for weight).
72 75
73Example: 76Example:
74 77
75 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 78 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
76 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 79 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
… …
78=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames) 81=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
79 82
80Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form) 83Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
81into it's hostname(s). 84into it's hostname(s).
82 85
83Requires the Socket6 module for IPv6 support.
84
85Example: 86Example:
86 87
87 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 88 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
88 # => f.root-servers.net 89 # => f.root-servers.net
89 90
… …
92Tries to resolve the given domain and passes all resource records found to 93Tries to resolve the given domain and passes all resource records found to
93the callback. 94the callback.
94 95
95=cut 96=cut
96 97
98sub MAX_PKT() { 4096 } # max packet size we advertise and accept
99
100sub DOMAIN_PORT() { 53 } # if this changes drop me a note
101
97sub resolver; 102sub resolver;
98 103
99sub a($$) { 104sub a($$) {
100 my ($domain, $cb) = @_; 105 my ($domain, $cb) = @_;
101 106
102 resolver->resolve ($domain => "a", sub { 107 resolver->resolve ($domain => "a", sub {
108 $cb->(map $_->[3], @_);
109 });
110}
111
112sub aaaa($$) {
113 my ($domain, $cb) = @_;
114
115 resolver->resolve ($domain => "aaaa", sub {
103 $cb->(map $_->[3], @_); 116 $cb->(map $_->[3], @_);
104 }); 117 });
105} 118}
106 119
107sub mx($$) { 120sub mx($$) {
… …
138} 151}
139 152
140sub ptr($$) { 153sub ptr($$) {
141 my ($ip, $cb) = @_; 154 my ($ip, $cb) = @_;
142 155
143 my $name; 156 $ip = AnyEvent::Socket::parse_address ($ip)
157 or return $cb->();
144 158
145 if (AnyEvent::Util::dotted_quad $ip) { 159 my $af = AnyEvent::Socket::address_family ($ip);
160
161 if ($af == AF_INET) {
146 $name = join ".", (reverse split /\./, $ip), "in-addr.arpa."; 162 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
163 } elsif ($af == AF_INET6) {
164 $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
147 } else { 165 } else {
148 require Socket6; 166 return $cb->();
149 $name = join ".",
150 (reverse split //,
151 unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
152 "ip6.arpa.";
153 } 167 }
154 168
155 resolver->resolve ($name => "ptr", sub { 169 resolver->resolve ($ip => "ptr", sub {
156 $cb->(map $_->[3], @_); 170 $cb->(map $_->[3], @_);
157 }); 171 });
158} 172}
159 173
160sub any($$) { 174sub any($$) {
161 my ($domain, $cb) = @_; 175 my ($domain, $cb) = @_;
162 176
163 resolver->resolve ($domain => "*", $cb); 177 resolver->resolve ($domain => "*", $cb);
164} 178}
165 179
180#################################################################################
181
182=back
183
166=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS 184=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
167 185
168=over 4 186=over 4
169 187
170=item $AnyEvent::DNS::EDNS0 188=item $AnyEvent::DNS::EDNS0
171 189
172This variable decides whether dns_pack automatically enables EDNS0 190This variable decides whether dns_pack automatically enables EDNS0
173support. By default, this is disabled (C<0>), but when set to C<1>, 191support. By default, this is disabled (C<0>), unless overridden by
174AnyEvent::DNS will use EDNS0 in all requests. 192C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use
193EDNS0 in all requests.
175 194
176=cut 195=cut
177 196
178our $EDNS0 = 0; # set to 1 to enable (partial) edns0 197our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
179 198
180our %opcode_id = ( 199our %opcode_id = (
181 query => 0, 200 query => 0,
182 iquery => 1, 201 iquery => 1,
183 status => 2, 202 status => 2,
… …
252); 271);
253 272
254our %class_str = reverse %class_id; 273our %class_str = reverse %class_id;
255 274
256# names MUST have a trailing dot 275# names MUST have a trailing dot
257sub _enc_qname($) { 276sub _enc_name($) {
258 pack "(C/a)*", (split /\./, shift), "" 277 pack "(C/a*)*", (split /\./, shift), ""
259} 278}
260 279
261sub _enc_qd() { 280sub _enc_qd() {
262 (_enc_qname $_->[0]) . pack "nn", 281 (_enc_name $_->[0]) . pack "nn",
263 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}), 282 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
264 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"}) 283 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"})
265} 284}
266 285
267sub _enc_rr() { 286sub _enc_rr() {
… …
328 (join "", map _enc_qd, @{ $req->{qd} || [] }), 347 (join "", map _enc_qd, @{ $req->{qd} || [] }),
329 (join "", map _enc_rr, @{ $req->{an} || [] }), 348 (join "", map _enc_rr, @{ $req->{an} || [] }),
330 (join "", map _enc_rr, @{ $req->{ns} || [] }), 349 (join "", map _enc_rr, @{ $req->{ns} || [] }),
331 (join "", map _enc_rr, @{ $req->{ar} || [] }), 350 (join "", map _enc_rr, @{ $req->{ar} || [] }),
332 351
333 ($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size 352 ($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0, 4kiB udp payload size
334} 353}
335 354
336our $ofs; 355our $ofs;
337our $pkt; 356our $pkt;
338 357
339# bitches 358# bitches
340sub _dec_qname { 359sub _dec_name {
341 my @res; 360 my @res;
342 my $redir; 361 my $redir;
343 my $ptr = $ofs; 362 my $ptr = $ofs;
344 my $cnt; 363 my $cnt;
345 364
346 while () { 365 while () {
347 return undef if ++$cnt >= 256; # to avoid DoS attacks 366 return undef if ++$cnt >= 256; # to avoid DoS attacks
348 367
349 my $len = ord substr $pkt, $ptr++, 1; 368 my $len = ord substr $pkt, $ptr++, 1;
350 369
351 if ($len & 0xc0) { 370 if ($len >= 0xc0) {
352 $ptr++; 371 $ptr++;
353 $ofs = $ptr if $ptr > $ofs; 372 $ofs = $ptr if $ptr > $ofs;
354 $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff; 373 $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
355 } elsif ($len) { 374 } elsif ($len) {
356 push @res, substr $pkt, $ptr, $len; 375 push @res, substr $pkt, $ptr, $len;
… …
361 } 380 }
362 } 381 }
363} 382}
364 383
365sub _dec_qd { 384sub _dec_qd {
366 my $qname = _dec_qname; 385 my $qname = _dec_name;
367 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 386 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
368 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 387 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
369} 388}
370 389
371our %dec_rr = ( 390our %dec_rr = (
372 1 => sub { Socket::inet_ntoa $_ }, # a 391 1 => sub { join ".", unpack "C4", $_ }, # a
373 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 392 2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
374 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 393 5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
375 6 => sub { 394 6 => sub {
376 local $ofs = $ofs - length; 395 local $ofs = $ofs - length;
377 my $mname = _dec_qname; 396 my $mname = _dec_name;
378 my $rname = _dec_qname; 397 my $rname = _dec_name;
379 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 398 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
380 }, # soa 399 }, # soa
381 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks 400 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
382 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 401 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
383 13 => sub { unpack "C/a C/a", $_ }, # hinfo 402 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
384 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 403 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
385 16 => sub { unpack "(C/a)*", $_ }, # txt 404 16 => sub { unpack "(C/a*)*", $_ }, # txt
386 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 405 28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
387 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 406 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
388 99 => sub { unpack "(C/a)*", $_ }, # spf 407 99 => sub { unpack "(C/a*)*", $_ }, # spf
389); 408);
390 409
391sub _dec_rr { 410sub _dec_rr {
392 my $qname = _dec_qname; 411 my $name = _dec_name;
393 412
394 my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10; 413 my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
395 local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen; 414 local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
396 415
397 [ 416 [
398 $qname, 417 $name,
399 $type_str{$rt} || $rt, 418 $type_str{$rt} || $rt,
400 $class_str{$rc} || $rc, 419 $class_str{$rc} || $rc,
401 ($dec_rr{$rt} || sub { $_ })->(), 420 ($dec_rr{$rt} || sub { $_ })->(),
402 ] 421 ]
403} 422}
… …
541 560
542=over 4 561=over 4
543 562
544=item server => [...] 563=item server => [...]
545 564
546A list of server addressses (default: C<v127.0.0.1>) in network format (4 565A list of server addresses (default: C<v127.0.0.1>) in network format
547octets for IPv4, 16 octets for IPv6 - not yet supported). 566(i.e. as returned by C<AnyEvent::Socket::parse_address> - both IPv4 and
567IPv6 are supported).
548 568
549=item timeout => [...] 569=item timeout => [...]
550 570
551A list of timeouts to use (also determines the number of retries). To make 571A list of timeouts to use (also determines the number of retries). To make
552three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2, 572three retries with individual time-outs of 2, 5 and 5 seconds, use C<[2,
… …
561The number of dots (default: C<1>) that a name must have so that the resolver 581The number of dots (default: C<1>) that a name must have so that the resolver
562tries to resolve the name without any suffixes first. 582tries to resolve the name without any suffixes first.
563 583
564=item max_outstanding => $integer 584=item max_outstanding => $integer
565 585
566Most name servers do not handle many parallel requests very well. This option 586Most name servers do not handle many parallel requests very well. This
567limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means 587option limits the number of outstanding requests to C<$integer>
568if you request more than this many requests, then the additional requests will be queued 588(default: C<10>), that means if you request more than this many requests,
569until some other requests have been resolved. 589then the additional requests will be queued until some other requests have
590been resolved.
570 591
571=item reuse => $seconds 592=item reuse => $seconds
572 593
573The number of seconds (default: C<60>) that a query id cannot be re-used 594The number of seconds (default: C<300>) that a query id cannot be re-used
574after a request. Since AnyEvent::DNS will only allocate up to 30000 ID's 595after a timeout. If there as no time-out then query id's can be reused
575at the same time, the long-term maximum number of requests per second is 596immediately.
576C<30000 / $seconds> (and thus C<500> requests/s by default).
577 597
578=back 598=back
579 599
580=cut 600=cut
581 601
582sub new { 602sub new {
583 my ($class, %arg) = @_; 603 my ($class, %arg) = @_;
584 604
605 # try to create a ipv4 and an ipv6 socket
606 # only fail when we cnanot create either
607
585 socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0 608 socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
586 or Carp::croak "socket: $!"; 609 socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
587 610
588 AnyEvent::Util::fh_nonblocking $fh, 1; 611 $fh4 || $fh6
612 or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
589 613
590 my $self = bless { 614 my $self = bless {
591 server => [v127.0.0.1], 615 server => [],
592 timeout => [2, 5, 5], 616 timeout => [2, 5, 5],
593 search => [], 617 search => [],
594 ndots => 1, 618 ndots => 1,
595 max_outstanding => 10, 619 max_outstanding => 10,
596 reuse => 60, # reuse id's after 5 minutes only, if possible 620 reuse => 300, # reuse id's after 5 minutes only, if possible
597 %arg, 621 %arg,
598 fh => $fh,
599 reuse_q => [], 622 reuse_q => [],
600 }, $class; 623 }, $class;
601 624
602 # search should default to gethostname's domain 625 # search should default to gethostname's domain
603 # but perl lacks a good posix module 626 # but perl lacks a good posix module
604 627
605 Scalar::Util::weaken (my $wself = $self); 628 Scalar::Util::weaken (my $wself = $self);
629
630 if ($fh4) {
631 AnyEvent::Util::fh_nonblocking $fh4, 1;
632 $self->{fh4} = $fh4;
606 $self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv }); 633 $self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
634 if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
635 $wself->_recv ($pkt, $peer);
636 }
637 });
638 }
639
640 if ($fh6) {
641 $self->{fh6} = $fh6;
642 AnyEvent::Util::fh_nonblocking $fh6, 1;
643 $self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
644 if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
645 $wself->_recv ($pkt, $peer);
646 }
647 });
648 }
607 649
608 $self->_compile; 650 $self->_compile;
609 651
610 $self 652 $self
611} 653}
612 654
613=item $resolver->parse_resolv_conv ($string) 655=item $resolver->parse_resolv_conv ($string)
614 656
615Parses the given string a sif it were a F<resolv.conf> file. The following 657Parses the given string as if it were a F<resolv.conf> file. The following
616directives are supported (but not neecssarily implemented). 658directives are supported (but not necessarily implemented).
617 659
618C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 660C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
619C<options> (C<timeout>, C<attempts>, C<ndots>). 661C<options> (C<timeout>, C<attempts>, C<ndots>).
620 662
621Everything else is silently ignored. 663Everything else is silently ignored.
… …
633 for (split /\n/, $resolvconf) { 675 for (split /\n/, $resolvconf) {
634 if (/^\s*#/) { 676 if (/^\s*#/) {
635 # comment 677 # comment
636 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { 678 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
637 my $ip = $1; 679 my $ip = $1;
638 if (AnyEvent::Util::dotted_quad $ip) { 680 if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
639 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; 681 push @{ $self->{server} }, $ipn;
640 } else { 682 } else {
641 warn "nameserver $ip invalid and ignored\n"; 683 warn "nameserver $ip invalid and ignored\n";
642 } 684 }
643 } elsif (/^\s*domain\s+(\S*)\s+$/i) { 685 } elsif (/^\s*domain\s+(\S*)\s+$/i) {
644 $self->{search} = [$1]; 686 $self->{search} = [$1];
… …
667 $self->_compile; 709 $self->_compile;
668} 710}
669 711
670=item $resolver->os_config 712=item $resolver->os_config
671 713
672Tries so load and parse F</etc/resolv.conf> on portable opertaing systems. Tries various 714Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various
673egregious hacks on windows to force the dns servers and searchlist out of the config. 715egregious hacks on windows to force the DNS servers and searchlist out of the system.
674 716
675=cut 717=cut
676 718
677sub os_config { 719sub os_config {
678 my ($self) = @_; 720 my ($self) = @_;
679 721
680 if ($^O =~ /mswin32|cygwin/i) { 722 $self->{server} = [];
681 # yeah, it suxx... lets hope DNS is DNS in all locales 723 $self->{search} = [];
724
725 if (AnyEvent::WIN32 || $^O =~ /cygwin/i) {
726 no strict 'refs';
727
728 # there are many options to find the current nameservers etc. on windows
729 # all of them don't work consistently:
730 # - the registry thing needs separate code on win32 native vs. cygwin
731 # - the registry layout differs between windows versions
732 # - calling windows api functions doesn't work on cygwin
733 # - ipconfig uses locale-specific messages
734
735 # we use ipconfig parsing because, despite all it's brokenness,
736 # it seems most stable in practise.
737 # for good measure, we append a fallback nameserver to our list.
682 738
683 if (open my $fh, "ipconfig /all |") { 739 if (open my $fh, "ipconfig /all |") {
684 delete $self->{server}; 740 # parsing strategy: we go through the output and look for
685 delete $self->{search}; 741 # :-lines with DNS in them. everything in those is regarded as
742 # either a nameserver (if it parses as an ip address), or a suffix
743 # (all else).
686 744
745 my $dns;
687 while (<$fh>) { 746 while (<$fh>) {
688 # first DNS.* is suffix list 747 if (s/^\s.*\bdns\b.*://i) {
689 if (/^\s*DNS/) { 748 $dns = 1;
690 while (/\s+([[:alnum:].\-]+)\s*$/) { 749 } elsif (/^\S/ || /^\s[^:]{16,}: /) {
750 $dns = 0;
751 }
752 if ($dns && /^\s*(\S+)\s*$/) {
753 my $s = $1;
754 $s =~ s/%\d+(?!\S)//; # get rid of scope id
755 if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
756 push @{ $self->{server} }, $ipn;
757 } else {
691 push @{ $self->{search} }, $1; 758 push @{ $self->{search} }, $s;
692 $_ = <$fh>;
693 } 759 }
694 last;
695 } 760 }
696 } 761 }
697 762
698 while (<$fh>) { 763 # always add one fallback server
699 # second DNS.* is server address list 764 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
700 if (/^\s*DNS/) {
701 while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
702 my $ip = $1;
703 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip
704 if AnyEvent::Util::dotted_quad $ip;
705 $_ = <$fh>;
706 }
707 last;
708 }
709 }
710 765
711 $self->_compile; 766 $self->_compile;
712 } 767 }
713 } else { 768 } else {
714 # try resolv.conf everywhere 769 # try resolv.conf everywhere
… …
721} 776}
722 777
723sub _compile { 778sub _compile {
724 my $self = shift; 779 my $self = shift;
725 780
781 my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
782 my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
783
784 unless (@{ $self->{server} }) {
785 # use 127.0.0.1 by default, and one opendns nameserver as fallback
786 $self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
787 }
788
726 my @retry; 789 my @retry;
727 790
728 for my $timeout (@{ $self->{timeout} }) { 791 for my $timeout (@{ $self->{timeout} }) {
729 for my $server (@{ $self->{server} }) { 792 for my $server (@{ $self->{server} }) {
730 push @retry, [$server, $timeout]; 793 push @retry, [$server, $timeout];
… …
747 $NOW = time; 810 $NOW = time;
748 $id->[1]->($res); 811 $id->[1]->($res);
749} 812}
750 813
751sub _recv { 814sub _recv {
752 my ($self) = @_; 815 my ($self, $pkt, $peer) = @_;
753 816
754 while (my $peer = recv $self->{fh}, my $res, 4096, 0) { 817 # we ignore errors (often one gets port unreachable, but there is
818 # no good way to take advantage of that.
819
755 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 820 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
756 821
757 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 822 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
758 823
759 $self->_feed ($res); 824 $self->_feed ($pkt);
825}
826
827sub _free_id {
828 my ($self, $id, $timeout) = @_;
829
830 if ($timeout) {
831 # we need to block the id for a while
832 $self->{id}{$id} = 1;
833 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
834 } else {
835 # we can quickly recycle the id
836 delete $self->{id}{$id};
760 } 837 }
761}
762 838
839 --$self->{outstanding};
840 $self->_scheduler;
841}
842
843# execute a single request, involves sending it with timeouts to multiple servers
763sub _exec { 844sub _exec {
764 my ($self, $req, $retry) = @_; 845 my ($self, $req) = @_;
765 846
847 my $retry; # of retries
848 my $do_retry;
849
850 $do_retry = sub {
766 if (my $retry_cfg = $self->{retry}[$retry]) { 851 my $retry_cfg = $self->{retry}[$retry++]
852 or do {
853 # failure
854 $self->_free_id ($req->[2], $retry > 1);
855 undef $do_retry; return $req->[1]->();
856 };
857
767 my ($server, $timeout) = @$retry_cfg; 858 my ($server, $timeout) = @$retry_cfg;
768 859
769 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 860 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
770 $NOW = time; 861 $NOW = time;
771 862
772 # timeout, try next 863 # timeout, try next
773 $self->_exec ($req, $retry + 1); 864 &$do_retry;
774 }), sub { 865 }), sub {
775 my ($res) = @_; 866 my ($res) = @_;
776 867
777 if ($res->{tc}) { 868 if ($res->{tc}) {
778 # success, but truncated, so use tcp 869 # success, but truncated, so use tcp
779 AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub { 870 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
780 my ($fh) = @_ 871 my ($fh) = @_
781 or return $self->_exec ($req, $retry + 1); 872 or return &$do_retry;
782 873
783 my $handle = new AnyEvent::Handle 874 my $handle = new AnyEvent::Handle
784 fh => $fh, 875 fh => $fh,
785 on_error => sub { 876 on_error => sub {
786 # failure, try next 877 # failure, try next
787 $self->_exec ($req, $retry + 1); 878 &$do_retry;
788 }; 879 };
789 880
790 $handle->push_write (pack "n/a", $req->[0]); 881 $handle->push_write (pack "n/a", $req->[0]);
791 $handle->push_read_chunk (2, sub { 882 $handle->push_read (chunk => 2, sub {
792 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { 883 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
793 $self->_feed ($_[1]); 884 $self->_feed ($_[1]);
794 }); 885 });
795 }); 886 });
796 shutdown $fh, 1; 887 shutdown $fh, 1;
797 888
798 }, sub { $timeout }; 889 }, sub { $timeout });
799 890
800 } else { 891 } else {
801 # success 892 # success
802 $self->{id}{$req->[2]} = 1; 893 $self->_free_id ($req->[2], $retry > 1);
803 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 894 undef $do_retry; return $req->[1]->($res);
804 --$self->{outstanding};
805 $self->_scheduler;
806
807 $req->[1]->($res);
808 } 895 }
809 }]; 896 }];
897
898 my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
810 899
811 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 900 my $fh = AF_INET == Socket::sockaddr_family ($sa)
812 } else { 901 ? $self->{fh4} : $self->{fh6}
813 # failure 902 or return &$do_retry;
814 $self->{id}{$req->[2]} = 1;
815 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
816 --$self->{outstanding};
817 $self->_scheduler;
818 903
819 $req->[1]->(); 904 send $fh, $req->[0], 0, $sa;
820 } 905 };
906
907 &$do_retry;
821} 908}
822 909
823sub _scheduler { 910sub _scheduler {
824 my ($self) = @_; 911 my ($self) = @_;
825 912
… …
846 while () { 933 while () {
847 $req->[2] = int rand 65536; 934 $req->[2] = int rand 65536;
848 last unless exists $self->{id}{$req->[2]}; 935 last unless exists $self->{id}{$req->[2]};
849 } 936 }
850 937
938 ++$self->{outstanding};
851 $self->{id}{$req->[2]} = 1; 939 $self->{id}{$req->[2]} = 1;
852 substr $req->[0], 0, 2, pack "n", $req->[2]; 940 substr $req->[0], 0, 2, pack "n", $req->[2];
853 941
854 ++$self->{outstanding};
855 $self->_exec ($req, 0); 942 $self->_exec ($req);
856 } 943 }
857} 944}
858 945
859=item $resolver->request ($req, $cb->($res)) 946=item $resolver->request ($req, $cb->($res))
860 947
… …
880The callback will be invoked with a list of matching result records or 967The callback will be invoked with a list of matching result records or
881none on any error or if the name could not be found. 968none on any error or if the name could not be found.
882 969
883CNAME chains (although illegal) are followed up to a length of 8. 970CNAME chains (although illegal) are followed up to a length of 8.
884 971
885Note that this resolver is just a stub resolver: it requires a nameserver 972Note that this resolver is just a stub resolver: it requires a name server
886supporting recursive queries, will not do any recursive queries itself and 973supporting recursive queries, will not do any recursive queries itself and
887is not secure when used against an untrusted name server. 974is not secure when used against an untrusted name server.
888 975
889The following options are supported: 976The following options are supported:
890 977
… …
966 my %atype = $opt{accept} 1053 my %atype = $opt{accept}
967 ? map +($_ => 1), @{ $opt{accept} } 1054 ? map +($_ => 1), @{ $opt{accept} }
968 : ($qtype => 1); 1055 : ($qtype => 1);
969 1056
970 # advance in searchlist 1057 # advance in searchlist
971 my $do_search; $do_search = sub { 1058 my ($do_search, $do_req);
1059
1060 $do_search = sub {
972 @search 1061 @search
973 or return $cb->(); 1062 or (undef $do_search), (undef $do_req), return $cb->();
974 1063
975 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1064 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
976 my $depth = 2; 1065 my $depth = 2;
977 1066
978 # advance in cname-chain 1067 # advance in cname-chain
979 my $do_req; $do_req = sub { 1068 $do_req = sub {
980 $self->request ({ 1069 $self->request ({
981 rd => 1, 1070 rd => 1,
982 qd => [[$name, $qtype, $class]], 1071 qd => [[$name, $qtype, $class]],
983 }, sub { 1072 }, sub {
984 my ($res) = @_ 1073 my ($res) = @_
… …
988 1077
989 while () { 1078 while () {
990 # results found? 1079 # results found?
991 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 1080 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
992 1081
993 return $cb->(@rr) 1082 (undef $do_search), (undef $do_req), return $cb->(@rr)
994 if @rr; 1083 if @rr;
995 1084
996 # see if there is a cname we can follow 1085 # see if there is a cname we can follow
997 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} }; 1086 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
998 1087
… …
1019 }; 1108 };
1020 1109
1021 $do_search->(); 1110 $do_search->();
1022} 1111}
1023 1112
1113use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1114
10241; 11151;
1025 1116
1026=back 1117=back
1027 1118
1028=head1 AUTHOR 1119=head1 AUTHOR

Diff Legend

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