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

Diff Legend

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