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.20 by root, Fri May 23 23:44:55 2008 UTC vs.
Revision 1.42 by root, Thu May 29 06:17:52 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
36use AnyEvent ();
29use AnyEvent::Handle (); 37use AnyEvent::Handle ();
38use AnyEvent::Util qw(AF_INET6);
30 39
31=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...) 40our $VERSION = '1.0';
32 41
33Tries to resolve the given nodename and service name into protocol families 42our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
34and sockaddr structures usable to connect to this node and service in a
35protocol-independent way. It works remotely similar to the getaddrinfo
36posix function.
37
38C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
39either a service name (port name from F</etc/services>) or a numerical
40port number. If both C<$node> and C<$service> are names, then SRV records
41will be consulted to find the real service, otherwise they will be
42used as-is. If you know that the service name is not in your services
43database, then you cna specify the service in the format C<name=port>
44(e.g. C<http=80>).
45
46C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
47C<sctp>. The default is C<tcp>.
48
49C<$family> must be either C<0> (meaning any protocol is ok), C<4> (use
50only IPv4) or C<6> (use only IPv6). This setting might be influenced by
51C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
52
53C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
54C<undef> in which case it gets automatically chosen).
55
56The callback will receive zero or more array references that contain
57C<$family, $type, $proto> for use in C<socket> and a binary
58C<$sockaddr> for use in C<connect> (or C<bind>).
59
60The application should try these in the order given.
61
62Example:
63
64 AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
65 43
66=item AnyEvent::DNS::a $domain, $cb->(@addrs) 44=item AnyEvent::DNS::a $domain, $cb->(@addrs)
67 45
68Tries to resolve the given domain to IPv4 address(es). 46Tries to resolve the given domain to IPv4 address(es).
69 47
… …
87=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 65=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
88 66
89Tries 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
90of service records. 68of service records.
91 69
92Each srv_rr is an arrayref with the following contents: 70Each srv_rr is an array reference with the following contents:
93C<[$priority, $weight, $transport, $target]>. 71C<[$priority, $weight, $transport, $target]>.
94 72
95They will be sorted with lowest priority, highest weight first (TODO: 73They will be sorted with lowest priority, highest weight first (TODO:
96should use the rfc algorithm to reorder same-priority records for weight). 74should use the RFC algorithm to reorder same-priority records for weight).
97 75
98Example: 76Example:
99 77
100 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 78 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
101 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 79 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
… …
114 92
115Tries 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
116the callback. 94the callback.
117 95
118=cut 96=cut
97
98sub MAX_PKT() { 4096 } # max packet size we advertise and accept
99
100sub DOMAIN_PORT() { 53 } # if this changes drop me a note
119 101
120sub resolver; 102sub resolver;
121 103
122sub a($$) { 104sub a($$) {
123 my ($domain, $cb) = @_; 105 my ($domain, $cb) = @_;
… …
169} 151}
170 152
171sub ptr($$) { 153sub ptr($$) {
172 my ($ip, $cb) = @_; 154 my ($ip, $cb) = @_;
173 155
174 $ip = AnyEvent::Socket::parse_ip ($ip) 156 $ip = AnyEvent::Socket::parse_address ($ip)
175 or return $cb->(); 157 or return $cb->();
176 158
177 if (4 == length $ip) { 159 my $af = AnyEvent::Socket::address_family ($ip);
160
161 if ($af == AF_INET) {
178 $ip = 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.";
179 } else { 165 } else {
180 $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa."; 166 return $cb->();
181 } 167 }
182 168
183 resolver->resolve ($ip => "ptr", sub { 169 resolver->resolve ($ip => "ptr", sub {
184 $cb->(map $_->[3], @_); 170 $cb->(map $_->[3], @_);
185 }); 171 });
… …
189 my ($domain, $cb) = @_; 175 my ($domain, $cb) = @_;
190 176
191 resolver->resolve ($domain => "*", $cb); 177 resolver->resolve ($domain => "*", $cb);
192} 178}
193 179
194############################################################################# 180#################################################################################
195
196# $port, $host
197sub pack_sockaddr_in6($$) {
198 pack "nnN a16 N",
199 Socket::AF_INET6,
200 $_[0], # port
201 0, # flowinfo
202 $_[1], # addr
203 0 # scope id
204}
205
206sub addr($$$$$$) {
207 my ($node, $service, $proto, $family, $type, $cb) = @_;
208
209 unless (eval { &Socket::AF_INET6 }) {
210 $family != 6
211 or return $cb->();
212
213 $family ||= 4;
214 }
215
216 $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
217 $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
218
219 $family ||=4 unless $AnyEvent::PROTOCOL{ipv6};
220 $family ||=6 unless $AnyEvent::PROTOCOL{ipv4};
221
222 $proto ||= "tcp";
223 $type ||= $proto eq "udp" ? Socket::SOCK_DGRAM : Socket::SOCK_STREAM;
224
225 my $proton = (getprotobyname $proto)[2]
226 or Carp::croak "$proto: protocol unknown";
227
228 my $port;
229
230 if ($service =~ /^(\S+)=(\d+)$/) {
231 ($service, $port) = ($1, $2);
232 } elsif ($service =~ /^\d+$/) {
233 ($service, $port) = (undef, $service);
234 } else {
235 $port = (getservbyname $service, $proto)[2]
236 or Carp::croak "$service/$proto: service unknown";
237 }
238
239 my @target = [$node, $port];
240
241 # resolve a records / provide sockaddr structures
242 my $resolve = sub {
243 my @res;
244 my $cv = AnyEvent->condvar (cb => sub {
245 $cb->(map $_->[1], sort { $a->[0] <=> $b->[0] } @res)
246 });
247
248 $cv->begin;
249 for my $idx (0 .. $#target) {
250 my ($node, $port) = @{ $target[$idx] };
251
252 if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
253 if (4 == length $noden && $family != 6) {
254 push @res, [$idx, [Socket::AF_INET, $type, $proton,
255 Socket::pack_sockaddr_in $port, $noden]]
256 }
257
258 if (16 == length $noden && $family != 4) {
259 push @res, [$idx, [Socket::AF_INET6, $type, $proton,
260 pack_sockaddr_in6 $port, $noden]]
261 }
262 } else {
263 # ipv4
264 if ($family != 6) {
265 $cv->begin;
266 a $node, sub {
267 push @res, [$idx, [Socket::AF_INET, $type, $proton,
268 Socket::pack_sockaddr_in $port, AnyEvent::Socket::parse_ipv4 ($_)]]
269 for @_;
270 $cv->end;
271 };
272 }
273
274 my $idx = $idx + 0.5; # prefer ipv4 for now
275
276 # ipv6
277 if ($family != 4) {
278 $cv->begin;
279 aaaa $node, sub {
280 push @res, [$idx, [Socket::AF_INET6, $type, $proton,
281 pack_sockaddr_in6 $port, AnyEvent::Socket::parse_ipv6 ($_)]]
282 for @_;
283 $cv->end;
284 };
285 }
286 }
287 }
288 $cv->end;
289 };
290
291 # try srv records, if applicable
292 if (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
293 srv $service, $proto, $node, sub {
294 my (@srv) = @_;
295
296 # no srv records, continue traditionally
297 @srv
298 or return &$resolve;
299
300 # only srv record has "." => abort
301 $srv[0][2] ne "." || $#srv
302 or return $cb->();
303
304 # use srv records then
305 @target = map [$_->[3], $_->[2]],
306 grep $_->[3] ne ".",
307 @srv;
308
309 &$resolve;
310 };
311 } else {
312 &$resolve;
313 }
314}
315
316#############################################################################
317 181
318=back 182=back
319 183
320=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS 184=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
321 185
322=over 4 186=over 4
323 187
324=item $AnyEvent::DNS::EDNS0 188=item $AnyEvent::DNS::EDNS0
325 189
326This variable decides whether dns_pack automatically enables EDNS0 190This variable decides whether dns_pack automatically enables EDNS0
327support. By default, this is disabled (C<0>), but when set to C<1>, 191support. By default, this is disabled (C<0>), unless overridden by
328AnyEvent::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.
329 194
330=cut 195=cut
331 196
332our $EDNS0 = 0; # set to 1 to enable (partial) edns0 197our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
333 198
334our %opcode_id = ( 199our %opcode_id = (
335 query => 0, 200 query => 0,
336 iquery => 1, 201 iquery => 1,
337 status => 2, 202 status => 2,
… …
406); 271);
407 272
408our %class_str = reverse %class_id; 273our %class_str = reverse %class_id;
409 274
410# names MUST have a trailing dot 275# names MUST have a trailing dot
411sub _enc_qname($) { 276sub _enc_name($) {
412 pack "(C/a)*", (split /\./, shift), "" 277 pack "(C/a*)*", (split /\./, shift), ""
413} 278}
414 279
415sub _enc_qd() { 280sub _enc_qd() {
416 (_enc_qname $_->[0]) . pack "nn", 281 (_enc_name $_->[0]) . pack "nn",
417 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}), 282 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
418 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"}) 283 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"})
419} 284}
420 285
421sub _enc_rr() { 286sub _enc_rr() {
… …
482 (join "", map _enc_qd, @{ $req->{qd} || [] }), 347 (join "", map _enc_qd, @{ $req->{qd} || [] }),
483 (join "", map _enc_rr, @{ $req->{an} || [] }), 348 (join "", map _enc_rr, @{ $req->{an} || [] }),
484 (join "", map _enc_rr, @{ $req->{ns} || [] }), 349 (join "", map _enc_rr, @{ $req->{ns} || [] }),
485 (join "", map _enc_rr, @{ $req->{ar} || [] }), 350 (join "", map _enc_rr, @{ $req->{ar} || [] }),
486 351
487 ($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
488} 353}
489 354
490our $ofs; 355our $ofs;
491our $pkt; 356our $pkt;
492 357
493# bitches 358# bitches
494sub _dec_qname { 359sub _dec_name {
495 my @res; 360 my @res;
496 my $redir; 361 my $redir;
497 my $ptr = $ofs; 362 my $ptr = $ofs;
498 my $cnt; 363 my $cnt;
499 364
500 while () { 365 while () {
501 return undef if ++$cnt >= 256; # to avoid DoS attacks 366 return undef if ++$cnt >= 256; # to avoid DoS attacks
502 367
503 my $len = ord substr $pkt, $ptr++, 1; 368 my $len = ord substr $pkt, $ptr++, 1;
504 369
505 if ($len & 0xc0) { 370 if ($len >= 0xc0) {
506 $ptr++; 371 $ptr++;
507 $ofs = $ptr if $ptr > $ofs; 372 $ofs = $ptr if $ptr > $ofs;
508 $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff; 373 $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
509 } elsif ($len) { 374 } elsif ($len) {
510 push @res, substr $pkt, $ptr, $len; 375 push @res, substr $pkt, $ptr, $len;
… …
515 } 380 }
516 } 381 }
517} 382}
518 383
519sub _dec_qd { 384sub _dec_qd {
520 my $qname = _dec_qname; 385 my $qname = _dec_name;
521 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 386 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
522 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 387 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
523} 388}
524 389
525our %dec_rr = ( 390our %dec_rr = (
526 1 => sub { join ".", unpack "C4" }, # a 391 1 => sub { join ".", unpack "C4", $_ }, # a
527 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 392 2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
528 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 393 5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
529 6 => sub { 394 6 => sub {
530 local $ofs = $ofs - length; 395 local $ofs = $ofs - length;
531 my $mname = _dec_qname; 396 my $mname = _dec_name;
532 my $rname = _dec_qname; 397 my $rname = _dec_name;
533 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 398 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
534 }, # soa 399 }, # soa
535 11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks 400 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
536 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 401 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
537 13 => sub { unpack "C/a C/a", $_ }, # hinfo 402 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
538 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
539 16 => sub { unpack "(C/a)*", $_ }, # txt 404 16 => sub { unpack "(C/a*)*", $_ }, # txt
540 28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa 405 28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
541 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
542 99 => sub { unpack "(C/a)*", $_ }, # spf 407 99 => sub { unpack "(C/a*)*", $_ }, # spf
543); 408);
544 409
545sub _dec_rr { 410sub _dec_rr {
546 my $qname = _dec_qname; 411 my $name = _dec_name;
547 412
548 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;
549 local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen; 414 local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
550 415
551 [ 416 [
552 $qname, 417 $name,
553 $type_str{$rt} || $rt, 418 $type_str{$rt} || $rt,
554 $class_str{$rc} || $rc, 419 $class_str{$rc} || $rc,
555 ($dec_rr{$rt} || sub { $_ })->(), 420 ($dec_rr{$rt} || sub { $_ })->(),
556 ] 421 ]
557} 422}
… …
695 560
696=over 4 561=over 4
697 562
698=item server => [...] 563=item server => [...]
699 564
700A 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
701octets 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).
702 568
703=item timeout => [...] 569=item timeout => [...]
704 570
705A 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
706three 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,
… …
716tries to resolve the name without any suffixes first. 582tries to resolve the name without any suffixes first.
717 583
718=item max_outstanding => $integer 584=item max_outstanding => $integer
719 585
720Most 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
721limits 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
722if 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
723until some other requests have been resolved. 589until some other requests have been resolved.
724 590
725=item reuse => $seconds 591=item reuse => $seconds
726 592
727The 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
728after 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
729at the same time, the long-term maximum number of requests per second is 595immediately.
730C<30000 / $seconds> (and thus C<500> requests/s by default).
731 596
732=back 597=back
733 598
734=cut 599=cut
735 600
736sub new { 601sub new {
737 my ($class, %arg) = @_; 602 my ($class, %arg) = @_;
738 603
604 # try to create a ipv4 and an ipv6 socket
605 # only fail when we cnanot create either
606
739 socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0 607 socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
740 or Carp::croak "socket: $!"; 608 socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
741 609
742 AnyEvent::Util::fh_nonblocking $fh, 1; 610 $fh4 || $fh6
611 or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
743 612
744 my $self = bless { 613 my $self = bless {
745 server => [v127.0.0.1], 614 server => [],
746 timeout => [2, 5, 5], 615 timeout => [2, 5, 5],
747 search => [], 616 search => [],
748 ndots => 1, 617 ndots => 1,
749 max_outstanding => 10, 618 max_outstanding => 10,
750 reuse => 60, # reuse id's after 5 minutes only, if possible 619 reuse => 300, # reuse id's after 5 minutes only, if possible
751 %arg, 620 %arg,
752 fh => $fh,
753 reuse_q => [], 621 reuse_q => [],
754 }, $class; 622 }, $class;
755 623
756 # search should default to gethostname's domain 624 # search should default to gethostname's domain
757 # but perl lacks a good posix module 625 # but perl lacks a good posix module
758 626
759 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;
760 $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 }
761 648
762 $self->_compile; 649 $self->_compile;
763 650
764 $self 651 $self
765} 652}
766 653
767=item $resolver->parse_resolv_conv ($string) 654=item $resolver->parse_resolv_conv ($string)
768 655
769Parses 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
770directives are supported (but not neecssarily implemented). 657directives are supported (but not necessarily implemented).
771 658
772C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 659C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
773C<options> (C<timeout>, C<attempts>, C<ndots>). 660C<options> (C<timeout>, C<attempts>, C<ndots>).
774 661
775Everything else is silently ignored. 662Everything else is silently ignored.
… …
787 for (split /\n/, $resolvconf) { 674 for (split /\n/, $resolvconf) {
788 if (/^\s*#/) { 675 if (/^\s*#/) {
789 # comment 676 # comment
790 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { 677 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
791 my $ip = $1; 678 my $ip = $1;
792 if (AnyEvent::Util::dotted_quad $ip) { 679 if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
793 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; 680 push @{ $self->{server} }, $ipn;
794 } else { 681 } else {
795 warn "nameserver $ip invalid and ignored\n"; 682 warn "nameserver $ip invalid and ignored\n";
796 } 683 }
797 } elsif (/^\s*domain\s+(\S*)\s+$/i) { 684 } elsif (/^\s*domain\s+(\S*)\s+$/i) {
798 $self->{search} = [$1]; 685 $self->{search} = [$1];
… …
821 $self->_compile; 708 $self->_compile;
822} 709}
823 710
824=item $resolver->os_config 711=item $resolver->os_config
825 712
826Tries 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
827egregious 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.
828 715
829=cut 716=cut
830 717
831sub os_config { 718sub os_config {
832 my ($self) = @_; 719 my ($self) = @_;
833 720
834 if ($^O =~ /mswin32|cygwin/i) { 721 $self->{server} = [];
835 # 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.
836 737
837 if (open my $fh, "ipconfig /all |") { 738 if (open my $fh, "ipconfig /all |") {
838 delete $self->{server}; 739 # parsing strategy: we go through the output and look for
839 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).
840 743
744 my $dns;
841 while (<$fh>) { 745 while (<$fh>) {
842 # first DNS.* is suffix list 746 if (s/^\s.*\bdns\b.*://i) {
843 if (/^\s*DNS/) { 747 $dns = 1;
844 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 {
845 push @{ $self->{search} }, $1; 757 push @{ $self->{search} }, $s;
846 $_ = <$fh>;
847 } 758 }
848 last;
849 } 759 }
850 } 760 }
851 761
852 while (<$fh>) { 762 # always add one fallback server
853 # second DNS.* is server address list 763 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
854 if (/^\s*DNS/) {
855 while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
856 my $ip = $1;
857 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip
858 if AnyEvent::Util::dotted_quad $ip;
859 $_ = <$fh>;
860 }
861 last;
862 }
863 }
864 764
865 $self->_compile; 765 $self->_compile;
866 } 766 }
867 } else { 767 } else {
868 # try resolv.conf everywhere 768 # try resolv.conf everywhere
… …
875} 775}
876 776
877sub _compile { 777sub _compile {
878 my $self = shift; 778 my $self = shift;
879 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
880 my @retry; 788 my @retry;
881 789
882 for my $timeout (@{ $self->{timeout} }) { 790 for my $timeout (@{ $self->{timeout} }) {
883 for my $server (@{ $self->{server} }) { 791 for my $server (@{ $self->{server} }) {
884 push @retry, [$server, $timeout]; 792 push @retry, [$server, $timeout];
… …
901 $NOW = time; 809 $NOW = time;
902 $id->[1]->($res); 810 $id->[1]->($res);
903} 811}
904 812
905sub _recv { 813sub _recv {
906 my ($self) = @_; 814 my ($self, $pkt, $peer) = @_;
907 815
908 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
909 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 819 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
910 820
911 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 821 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
912 822
913 $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};
914 } 836 }
915}
916 837
838 --$self->{outstanding};
839 $self->_scheduler;
840}
841
842# execute a single request, involves sending it with timeouts to multiple servers
917sub _exec { 843sub _exec {
918 my ($self, $req, $retry) = @_; 844 my ($self, $req) = @_;
919 845
846 my $retry; # of retries
847 my $do_retry;
848
849 $do_retry = sub {
920 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
921 my ($server, $timeout) = @$retry_cfg; 857 my ($server, $timeout) = @$retry_cfg;
922 858
923 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 859 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
924 $NOW = time; 860 $NOW = time;
925 861
926 # timeout, try next 862 # timeout, try next
927 $self->_exec ($req, $retry + 1); 863 &$do_retry;
928 }), sub { 864 }), sub {
929 my ($res) = @_; 865 my ($res) = @_;
930 866
931 if ($res->{tc}) { 867 if ($res->{tc}) {
932 # success, but truncated, so use tcp 868 # success, but truncated, so use tcp
933 AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub { 869 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
934 my ($fh) = @_ 870 my ($fh) = @_
935 or return $self->_exec ($req, $retry + 1); 871 or return &$do_retry;
936 872
937 my $handle = new AnyEvent::Handle 873 my $handle = new AnyEvent::Handle
938 fh => $fh, 874 fh => $fh,
939 on_error => sub { 875 on_error => sub {
940 # failure, try next 876 # failure, try next
941 $self->_exec ($req, $retry + 1); 877 &$do_retry;
942 }; 878 };
943 879
944 $handle->push_write (pack "n/a", $req->[0]); 880 $handle->push_write (pack "n/a", $req->[0]);
945 $handle->push_read_chunk (2, sub { 881 $handle->push_read (chunk => 2, sub {
946 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { 882 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
947 $self->_feed ($_[1]); 883 $self->_feed ($_[1]);
948 }); 884 });
949 }); 885 });
950 shutdown $fh, 1; 886 shutdown $fh, 1;
951 887
952 }, sub { $timeout }); 888 }, sub { $timeout });
953 889
954 } else { 890 } else {
955 # success 891 # success
956 $self->{id}{$req->[2]} = 1; 892 $self->_free_id ($req->[2], $retry > 1);
957 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 893 undef $do_retry; return $req->[1]->($res);
958 --$self->{outstanding};
959 $self->_scheduler;
960
961 $req->[1]->($res);
962 } 894 }
963 }]; 895 }];
896
897 my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
964 898
965 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 899 my $fh = AF_INET == Socket::sockaddr_family ($sa)
966 } else { 900 ? $self->{fh4} : $self->{fh6}
967 # failure 901 or return &$do_retry;
968 $self->{id}{$req->[2]} = 1;
969 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
970 --$self->{outstanding};
971 $self->_scheduler;
972 902
973 $req->[1]->(); 903 send $fh, $req->[0], 0, $sa;
974 } 904 };
905
906 &$do_retry;
975} 907}
976 908
977sub _scheduler { 909sub _scheduler {
978 my ($self) = @_; 910 my ($self) = @_;
979 911
… …
1000 while () { 932 while () {
1001 $req->[2] = int rand 65536; 933 $req->[2] = int rand 65536;
1002 last unless exists $self->{id}{$req->[2]}; 934 last unless exists $self->{id}{$req->[2]};
1003 } 935 }
1004 936
937 ++$self->{outstanding};
1005 $self->{id}{$req->[2]} = 1; 938 $self->{id}{$req->[2]} = 1;
1006 substr $req->[0], 0, 2, pack "n", $req->[2]; 939 substr $req->[0], 0, 2, pack "n", $req->[2];
1007 940
1008 ++$self->{outstanding};
1009 $self->_exec ($req, 0); 941 $self->_exec ($req);
1010 } 942 }
1011} 943}
1012 944
1013=item $resolver->request ($req, $cb->($res)) 945=item $resolver->request ($req, $cb->($res))
1014 946
… …
1034The 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
1035none on any error or if the name could not be found. 967none on any error or if the name could not be found.
1036 968
1037CNAME chains (although illegal) are followed up to a length of 8. 969CNAME chains (although illegal) are followed up to a length of 8.
1038 970
1039Note 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
1040supporting recursive queries, will not do any recursive queries itself and 972supporting recursive queries, will not do any recursive queries itself and
1041is not secure when used against an untrusted name server. 973is not secure when used against an untrusted name server.
1042 974
1043The following options are supported: 975The following options are supported:
1044 976
… …
1120 my %atype = $opt{accept} 1052 my %atype = $opt{accept}
1121 ? map +($_ => 1), @{ $opt{accept} } 1053 ? map +($_ => 1), @{ $opt{accept} }
1122 : ($qtype => 1); 1054 : ($qtype => 1);
1123 1055
1124 # advance in searchlist 1056 # advance in searchlist
1125 my $do_search; $do_search = sub { 1057 my ($do_search, $do_req);
1058
1059 $do_search = sub {
1126 @search 1060 @search
1127 or return $cb->(); 1061 or (undef $do_search), (undef $do_req), return $cb->();
1128 1062
1129 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1063 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
1130 my $depth = 2; 1064 my $depth = 2;
1131 1065
1132 # advance in cname-chain 1066 # advance in cname-chain
1133 my $do_req; $do_req = sub { 1067 $do_req = sub {
1134 $self->request ({ 1068 $self->request ({
1135 rd => 1, 1069 rd => 1,
1136 qd => [[$name, $qtype, $class]], 1070 qd => [[$name, $qtype, $class]],
1137 }, sub { 1071 }, sub {
1138 my ($res) = @_ 1072 my ($res) = @_
… …
1142 1076
1143 while () { 1077 while () {
1144 # results found? 1078 # results found?
1145 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} };
1146 1080
1147 return $cb->(@rr) 1081 (undef $do_search), (undef $do_req), return $cb->(@rr)
1148 if @rr; 1082 if @rr;
1149 1083
1150 # see if there is a cname we can follow 1084 # see if there is a cname we can follow
1151 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} };
1152 1086

Diff Legend

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