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.41 by root, Thu May 29 06:17:03 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::Sockdt::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,
… …
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 option
567limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means 587limits the number of outstanding requests to C<$n> (default: C<10>), that means
568if you request more than this many requests, then the additional requests will be queued 588if you request more than this many requests, then the additional requests will be queued
569until some other requests have been resolved. 589until some other requests have been resolved.
570 590
571=item reuse => $seconds 591=item reuse => $seconds
572 592
573The number of seconds (default: C<60>) that a query id cannot be re-used 593The 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 594after 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 595immediately.
576C<30000 / $seconds> (and thus C<500> requests/s by default).
577 596
578=back 597=back
579 598
580=cut 599=cut
581 600
582sub new { 601sub new {
583 my ($class, %arg) = @_; 602 my ($class, %arg) = @_;
584 603
604 # try to create a ipv4 and an ipv6 socket
605 # only fail when we cnanot create either
606
585 socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0 607 socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
586 or Carp::croak "socket: $!"; 608 socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
587 609
588 AnyEvent::Util::fh_nonblocking $fh, 1; 610 $fh4 || $fh6
611 or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
589 612
590 my $self = bless { 613 my $self = bless {
591 server => [v127.0.0.1], 614 server => [],
592 timeout => [2, 5, 5], 615 timeout => [2, 5, 5],
593 search => [], 616 search => [],
594 ndots => 1, 617 ndots => 1,
595 max_outstanding => 10, 618 max_outstanding => 10,
596 reuse => 60, # reuse id's after 5 minutes only, if possible 619 reuse => 300, # reuse id's after 5 minutes only, if possible
597 %arg, 620 %arg,
598 fh => $fh,
599 reuse_q => [], 621 reuse_q => [],
600 }, $class; 622 }, $class;
601 623
602 # search should default to gethostname's domain 624 # search should default to gethostname's domain
603 # but perl lacks a good posix module 625 # but perl lacks a good posix module
604 626
605 Scalar::Util::weaken (my $wself = $self); 627 Scalar::Util::weaken (my $wself = $self);
628
629 if ($fh4) {
630 AnyEvent::Util::fh_nonblocking $fh4, 1;
631 $self->{fh4} = $fh4;
606 $self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv }); 632 $self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
633 if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
634 $wself->_recv ($pkt, $peer);
635 }
636 });
637 }
638
639 if ($fh6) {
640 $self->{fh6} = $fh6;
641 AnyEvent::Util::fh_nonblocking $fh6, 1;
642 $self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
643 if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
644 $wself->_recv ($pkt, $peer);
645 }
646 });
647 }
607 648
608 $self->_compile; 649 $self->_compile;
609 650
610 $self 651 $self
611} 652}
612 653
613=item $resolver->parse_resolv_conv ($string) 654=item $resolver->parse_resolv_conv ($string)
614 655
615Parses the given string a sif it were a F<resolv.conf> file. The following 656Parses the given string as if it were a F<resolv.conf> file. The following
616directives are supported (but not neecssarily implemented). 657directives are supported (but not necessarily implemented).
617 658
618C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 659C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
619C<options> (C<timeout>, C<attempts>, C<ndots>). 660C<options> (C<timeout>, C<attempts>, C<ndots>).
620 661
621Everything else is silently ignored. 662Everything else is silently ignored.
… …
633 for (split /\n/, $resolvconf) { 674 for (split /\n/, $resolvconf) {
634 if (/^\s*#/) { 675 if (/^\s*#/) {
635 # comment 676 # comment
636 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { 677 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
637 my $ip = $1; 678 my $ip = $1;
638 if (AnyEvent::Util::dotted_quad $ip) { 679 if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
639 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; 680 push @{ $self->{server} }, $ipn;
640 } else { 681 } else {
641 warn "nameserver $ip invalid and ignored\n"; 682 warn "nameserver $ip invalid and ignored\n";
642 } 683 }
643 } elsif (/^\s*domain\s+(\S*)\s+$/i) { 684 } elsif (/^\s*domain\s+(\S*)\s+$/i) {
644 $self->{search} = [$1]; 685 $self->{search} = [$1];
… …
667 $self->_compile; 708 $self->_compile;
668} 709}
669 710
670=item $resolver->os_config 711=item $resolver->os_config
671 712
672Tries so load and parse F</etc/resolv.conf> on portable opertaing systems. Tries various 713Tries 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. 714egregious hacks on windows to force the DNS servers and searchlist out of the system.
674 715
675=cut 716=cut
676 717
677sub os_config { 718sub os_config {
678 my ($self) = @_; 719 my ($self) = @_;
679 720
680 if ($^O =~ /mswin32|cygwin/i) { 721 $self->{server} = [];
681 # yeah, it suxx... lets hope DNS is DNS in all locales 722 $self->{search} = [];
723
724 if (AnyEvent::WIN32 || $^O =~ /cygwin/i) {
725 no strict 'refs';
726
727 # there are many options to find the current nameservers etc. on windows
728 # all of them don't work consistently:
729 # - the registry thing needs separate code on win32 native vs. cygwin
730 # - the registry layout differs between windows versions
731 # - calling windows api functions doesn't work on cygwin
732 # - ipconfig uses locale-specific messages
733
734 # we use ipconfig parsing because, despite all it's brokenness,
735 # it seems most stable in practise.
736 # for good measure, we append a fallback nameserver to our list.
682 737
683 if (open my $fh, "ipconfig /all |") { 738 if (open my $fh, "ipconfig /all |") {
684 delete $self->{server}; 739 # parsing strategy: we go through the output and look for
685 delete $self->{search}; 740 # :-lines with DNS in them. everything in those is regarded as
741 # either a nameserver (if it parses as an ip address), or a suffix
742 # (all else).
686 743
744 my $dns;
687 while (<$fh>) { 745 while (<$fh>) {
688 # first DNS.* is suffix list 746 if (s/^\s.*\bdns\b.*://i) {
689 if (/^\s*DNS/) { 747 $dns = 1;
690 while (/\s+([[:alnum:].\-]+)\s*$/) { 748 } elsif (/^\S/ || /^\s[^:]{16,}: /) {
749 $dns = 0;
750 }
751 if ($dns && /^\s*(\S+)\s*$/) {
752 my $s = $1;
753 $s =~ s/%\d+(?!\S)//; # get rid of scope id
754 if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
755 push @{ $self->{server} }, $ipn;
756 } else {
691 push @{ $self->{search} }, $1; 757 push @{ $self->{search} }, $s;
692 $_ = <$fh>;
693 } 758 }
694 last;
695 } 759 }
696 } 760 }
697 761
698 while (<$fh>) { 762 # always add one fallback server
699 # second DNS.* is server address list 763 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 764
711 $self->_compile; 765 $self->_compile;
712 } 766 }
713 } else { 767 } else {
714 # try resolv.conf everywhere 768 # try resolv.conf everywhere
… …
721} 775}
722 776
723sub _compile { 777sub _compile {
724 my $self = shift; 778 my $self = shift;
725 779
780 my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
781 my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
782
783 unless (@{ $self->{server} }) {
784 # use 127.0.0.1 by default, and one opendns nameserver as fallback
785 $self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
786 }
787
726 my @retry; 788 my @retry;
727 789
728 for my $timeout (@{ $self->{timeout} }) { 790 for my $timeout (@{ $self->{timeout} }) {
729 for my $server (@{ $self->{server} }) { 791 for my $server (@{ $self->{server} }) {
730 push @retry, [$server, $timeout]; 792 push @retry, [$server, $timeout];
… …
747 $NOW = time; 809 $NOW = time;
748 $id->[1]->($res); 810 $id->[1]->($res);
749} 811}
750 812
751sub _recv { 813sub _recv {
752 my ($self) = @_; 814 my ($self, $pkt, $peer) = @_;
753 815
754 while (my $peer = recv $self->{fh}, my $res, 4096, 0) { 816 # we ignore errors (often one gets port unreachable, but there is
817 # no good way to take advantage of that.
818
755 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 819 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
756 820
757 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 821 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
758 822
759 $self->_feed ($res); 823 $self->_feed ($pkt);
824}
825
826sub _free_id {
827 my ($self, $id, $timeout) = @_;
828
829 if ($timeout) {
830 # we need to block the id for a while
831 $self->{id}{$id} = 1;
832 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
833 } else {
834 # we can quickly recycle the id
835 delete $self->{id}{$id};
760 } 836 }
761}
762 837
838 --$self->{outstanding};
839 $self->_scheduler;
840}
841
842# execute a single request, involves sending it with timeouts to multiple servers
763sub _exec { 843sub _exec {
764 my ($self, $req, $retry) = @_; 844 my ($self, $req) = @_;
765 845
846 my $retry; # of retries
847 my $do_retry;
848
849 $do_retry = sub {
766 if (my $retry_cfg = $self->{retry}[$retry]) { 850 my $retry_cfg = $self->{retry}[$retry++]
851 or do {
852 # failure
853 $self->_free_id ($req->[2], $retry > 1);
854 undef $do_retry; return $req->[1]->();
855 };
856
767 my ($server, $timeout) = @$retry_cfg; 857 my ($server, $timeout) = @$retry_cfg;
768 858
769 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 859 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
770 $NOW = time; 860 $NOW = time;
771 861
772 # timeout, try next 862 # timeout, try next
773 $self->_exec ($req, $retry + 1); 863 &$do_retry;
774 }), sub { 864 }), sub {
775 my ($res) = @_; 865 my ($res) = @_;
776 866
777 if ($res->{tc}) { 867 if ($res->{tc}) {
778 # success, but truncated, so use tcp 868 # success, but truncated, so use tcp
779 AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub { 869 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
780 my ($fh) = @_ 870 my ($fh) = @_
781 or return $self->_exec ($req, $retry + 1); 871 or return &$do_retry;
782 872
783 my $handle = new AnyEvent::Handle 873 my $handle = new AnyEvent::Handle
784 fh => $fh, 874 fh => $fh,
785 on_error => sub { 875 on_error => sub {
786 # failure, try next 876 # failure, try next
787 $self->_exec ($req, $retry + 1); 877 &$do_retry;
788 }; 878 };
789 879
790 $handle->push_write (pack "n/a", $req->[0]); 880 $handle->push_write (pack "n/a", $req->[0]);
791 $handle->push_read_chunk (2, sub { 881 $handle->push_read (chunk => 2, sub {
792 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { 882 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
793 $self->_feed ($_[1]); 883 $self->_feed ($_[1]);
794 }); 884 });
795 }); 885 });
796 shutdown $fh, 1; 886 shutdown $fh, 1;
797 887
798 }, sub { $timeout }; 888 }, sub { $timeout });
799 889
800 } else { 890 } else {
801 # success 891 # success
802 $self->{id}{$req->[2]} = 1; 892 $self->_free_id ($req->[2], $retry > 1);
803 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 893 undef $do_retry; return $req->[1]->($res);
804 --$self->{outstanding};
805 $self->_scheduler;
806
807 $req->[1]->($res);
808 } 894 }
809 }]; 895 }];
896
897 my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
810 898
811 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 899 my $fh = AF_INET == Socket::sockaddr_family ($sa)
812 } else { 900 ? $self->{fh4} : $self->{fh6}
813 # failure 901 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 902
819 $req->[1]->(); 903 send $fh, $req->[0], 0, $sa;
820 } 904 };
905
906 &$do_retry;
821} 907}
822 908
823sub _scheduler { 909sub _scheduler {
824 my ($self) = @_; 910 my ($self) = @_;
825 911
… …
846 while () { 932 while () {
847 $req->[2] = int rand 65536; 933 $req->[2] = int rand 65536;
848 last unless exists $self->{id}{$req->[2]}; 934 last unless exists $self->{id}{$req->[2]};
849 } 935 }
850 936
937 ++$self->{outstanding};
851 $self->{id}{$req->[2]} = 1; 938 $self->{id}{$req->[2]} = 1;
852 substr $req->[0], 0, 2, pack "n", $req->[2]; 939 substr $req->[0], 0, 2, pack "n", $req->[2];
853 940
854 ++$self->{outstanding};
855 $self->_exec ($req, 0); 941 $self->_exec ($req);
856 } 942 }
857} 943}
858 944
859=item $resolver->request ($req, $cb->($res)) 945=item $resolver->request ($req, $cb->($res))
860 946
… …
880The callback will be invoked with a list of matching result records or 966The callback will be invoked with a list of matching result records or
881none on any error or if the name could not be found. 967none on any error or if the name could not be found.
882 968
883CNAME chains (although illegal) are followed up to a length of 8. 969CNAME chains (although illegal) are followed up to a length of 8.
884 970
885Note that this resolver is just a stub resolver: it requires a nameserver 971Note that this resolver is just a stub resolver: it requires a name server
886supporting recursive queries, will not do any recursive queries itself and 972supporting recursive queries, will not do any recursive queries itself and
887is not secure when used against an untrusted name server. 973is not secure when used against an untrusted name server.
888 974
889The following options are supported: 975The following options are supported:
890 976
… …
966 my %atype = $opt{accept} 1052 my %atype = $opt{accept}
967 ? map +($_ => 1), @{ $opt{accept} } 1053 ? map +($_ => 1), @{ $opt{accept} }
968 : ($qtype => 1); 1054 : ($qtype => 1);
969 1055
970 # advance in searchlist 1056 # advance in searchlist
971 my $do_search; $do_search = sub { 1057 my ($do_search, $do_req);
1058
1059 $do_search = sub {
972 @search 1060 @search
973 or return $cb->(); 1061 or (undef $do_search), (undef $do_req), return $cb->();
974 1062
975 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1063 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
976 my $depth = 2; 1064 my $depth = 2;
977 1065
978 # advance in cname-chain 1066 # advance in cname-chain
979 my $do_req; $do_req = sub { 1067 $do_req = sub {
980 $self->request ({ 1068 $self->request ({
981 rd => 1, 1069 rd => 1,
982 qd => [[$name, $qtype, $class]], 1070 qd => [[$name, $qtype, $class]],
983 }, sub { 1071 }, sub {
984 my ($res) = @_ 1072 my ($res) = @_
… …
988 1076
989 while () { 1077 while () {
990 # results found? 1078 # results found?
991 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 1079 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
992 1080
993 return $cb->(@rr) 1081 (undef $do_search), (undef $do_req), return $cb->(@rr)
994 if @rr; 1082 if @rr;
995 1083
996 # see if there is a cname we can follow 1084 # see if there is a cname we can follow
997 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} }; 1085 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
998 1086
… …
1019 }; 1107 };
1020 1108
1021 $do_search->(); 1109 $do_search->();
1022} 1110}
1023 1111
1112use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1113
10241; 11141;
1025 1115
1026=back 1116=back
1027 1117
1028=head1 AUTHOR 1118=head1 AUTHOR

Diff Legend

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