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.46 by root, Thu May 29 06:53:00 2008 UTC vs.
Revision 1.105 by root, Fri Jul 17 14:57:03 2009 UTC

… …
2 2
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 8
9 my $cv = AnyEvent->condvar; 9 my $cv = AnyEvent->condvar;
10 AnyEvent::DNS::a "www.google.de", $cv; 10 AnyEvent::DNS::a "www.google.de", $cv;
11 # ... later 11 # ... later
12 my @addrs = $cv->recv; 12 my @addrs = $cv->recv;
13 13
14=head1 DESCRIPTION 14=head1 DESCRIPTION
15 15
16This module offers both a number of DNS convenience functions as well 16This module offers both a number of DNS convenience functions as well
17as a fully asynchronous and high-performance pure-perl stub resolver. 17as a fully asynchronous and high-performance pure-perl stub resolver.
… …
29package AnyEvent::DNS; 29package AnyEvent::DNS;
30 30
31no warnings; 31no warnings;
32use strict; 32use strict;
33 33
34use Carp ();
34use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM); 35use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
35 36
36use AnyEvent (); 37use AnyEvent ();
37use AnyEvent::Handle ();
38use AnyEvent::Util qw(AF_INET6); 38use AnyEvent::Util qw(AF_INET6);
39 39
40our $VERSION = '1.0'; 40our $VERSION = 4.83;
41 41
42our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222); 42our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
43 43
44=item AnyEvent::DNS::a $domain, $cb->(@addrs) 44=item AnyEvent::DNS::a $domain, $cb->(@addrs)
45 45
… …
65=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 65=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
66 66
67Tries 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
68of service records. 68of service records.
69 69
70Each srv_rr is an array reference with the following contents: 70Each C<$srv_rr> is an array reference with the following contents:
71C<[$priority, $weight, $transport, $target]>. 71C<[$priority, $weight, $transport, $target]>.
72 72
73They will be sorted with lowest priority, highest weight first (TODO: 73They will be sorted with lowest priority first, then randomly
74should use the RFC algorithm to reorder same-priority records for weight). 74distributed by weight as per RFC 2782.
75 75
76Example: 76Example:
77 77
78 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 78 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
79 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 79 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
80 80
81=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames) 81=item AnyEvent::DNS::ptr $domain, $cb->(@hostnames)
82
83Tries to make a PTR lookup on the given domain. See C<reverse_lookup>
84and C<reverse_verify> if you want to resolve an IP address to a hostname
85instead.
86
87=item AnyEvent::DNS::any $domain, $cb->(@rrs)
88
89Tries to resolve the given domain and passes all resource records found to
90the callback.
91
92=item AnyEvent::DNS::reverse_lookup $ipv4_or_6, $cb->(@hostnames)
82 93
83Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form) 94Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
84into it's hostname(s). 95into it's hostname(s). Handles V4MAPPED and V4COMPAT IPv6 addresses
96transparently.
97
98=item AnyEvent::DNS::reverse_verify $ipv4_or_6, $cb->(@hostnames)
99
100The same as C<reverse_lookup>, but does forward-lookups to verify that
101the resolved hostnames indeed point to the address, which makes spoofing
102harder.
103
104If you want to resolve an address into a hostname, this is the preferred
105method: The DNS records could still change, but at least this function
106verified that the hostname, at one point in the past, pointed at the IP
107address you originally resolved.
85 108
86Example: 109Example:
87 110
88 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 111 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
89 # => f.root-servers.net 112 # => f.root-servers.net
90
91=item AnyEvent::DNS::any $domain, $cb->(@rrs)
92
93Tries to resolve the given domain and passes all resource records found to
94the callback.
95 113
96=cut 114=cut
97 115
98sub MAX_PKT() { 4096 } # max packet size we advertise and accept 116sub MAX_PKT() { 4096 } # max packet size we advertise and accept
99 117
… …
144sub srv($$$$) { 162sub srv($$$$) {
145 my ($service, $proto, $domain, $cb) = @_; 163 my ($service, $proto, $domain, $cb) = @_;
146 164
147 # todo, ask for any and check glue records 165 # todo, ask for any and check glue records
148 resolver->resolve ("_$service._$proto.$domain" => "srv", sub { 166 resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
149 $cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] || $b->[4] <=> $a->[4] } @_); 167 my @res;
168
169 # classify by priority
170 my %pri;
171 push @{ $pri{$_->[3]} }, [ @$_[3,4,5,6] ]
172 for @_;
173
174 # order by priority
175 for my $pri (sort { $a <=> $b } keys %pri) {
176 # order by weight
177 my @rr = sort { $a->[1] <=> $b->[1] } @{ delete $pri{$pri} };
178
179 my $sum; $sum += $_->[1] for @rr;
180
181 while (@rr) {
182 my $w = int rand $sum + 1;
183 for (0 .. $#rr) {
184 if (($w -= $rr[$_][1]) <= 0) {
185 $sum -= $rr[$_][1];
186 push @res, splice @rr, $_, 1, ();
187 last;
188 }
189 }
190 }
191 }
192
193 $cb->(@res);
150 }); 194 });
151} 195}
152 196
153sub ptr($$) { 197sub ptr($$) {
198 my ($domain, $cb) = @_;
199
200 resolver->resolve ($domain => "ptr", sub {
201 $cb->(map $_->[3], @_);
202 });
203}
204
205sub any($$) {
206 my ($domain, $cb) = @_;
207
208 resolver->resolve ($domain => "*", $cb);
209}
210
211# convert textual ip address into reverse lookup form
212sub _munge_ptr($) {
213 my $ipn = $_[0]
214 or return;
215
216 my $ptr;
217
218 my $af = AnyEvent::Socket::address_family ($ipn);
219
220 if ($af == AF_INET6) {
221 $ipn = substr $ipn, 0, 16; # anticipate future expansion
222
223 # handle v4mapped and v4compat
224 if ($ipn =~ s/^\x00{10}(?:\xff\xff|\x00\x00)//) {
225 $af = AF_INET;
226 } else {
227 $ptr = join ".", (reverse split //, unpack "H32", $ipn), "ip6.arpa.";
228 }
229 }
230
231 if ($af == AF_INET) {
232 $ptr = join ".", (reverse unpack "C4", $ipn), "in-addr.arpa.";
233 }
234
235 $ptr
236}
237
238sub reverse_lookup($$) {
154 my ($ip, $cb) = @_; 239 my ($ip, $cb) = @_;
155 240
156 $ip = AnyEvent::Socket::parse_address ($ip) 241 $ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
157 or return $cb->(); 242 or return $cb->();
158
159 my $af = AnyEvent::Socket::address_family ($ip);
160
161 if ($af == AF_INET) {
162 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
163 } elsif ($af == AF_INET6) {
164 $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
165 } else {
166 return $cb->();
167 }
168 243
169 resolver->resolve ($ip => "ptr", sub { 244 resolver->resolve ($ip => "ptr", sub {
170 $cb->(map $_->[3], @_); 245 $cb->(map $_->[3], @_);
171 }); 246 });
172} 247}
173 248
174sub any($$) { 249sub reverse_verify($$) {
175 my ($domain, $cb) = @_; 250 my ($ip, $cb) = @_;
251
252 my $ipn = AnyEvent::Socket::parse_address ($ip)
253 or return $cb->();
176 254
177 resolver->resolve ($domain => "*", $cb); 255 my $af = AnyEvent::Socket::address_family ($ipn);
256
257 my @res;
258 my $cnt;
259
260 my $ptr = _munge_ptr $ipn
261 or return $cb->();
262
263 $ip = AnyEvent::Socket::format_address ($ipn); # normalise into the same form
264
265 ptr $ptr, sub {
266 for my $name (@_) {
267 ++$cnt;
268
269 # () around AF_INET to work around bug in 5.8
270 resolver->resolve ("$name." => ($af == (AF_INET) ? "a" : "aaaa"), sub {
271 for (@_) {
272 push @res, $name
273 if $_->[3] eq $ip;
274 }
275 $cb->(@res) unless --$cnt;
276 });
277 }
278
279 $cb->() unless $cnt;
280 };
178} 281}
179 282
180################################################################################# 283#################################################################################
181 284
182=back 285=back
… …
192C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use 295C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use
193EDNS0 in all requests. 296EDNS0 in all requests.
194 297
195=cut 298=cut
196 299
197our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0 300our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0}*1; # set to 1 to enable (partial) edns0
198 301
199our %opcode_id = ( 302our %opcode_id = (
200 query => 0, 303 query => 0,
201 iquery => 1, 304 iquery => 1,
202 status => 2, 305 status => 2,
… …
248 minfo => 14, 351 minfo => 14,
249 mx => 15, 352 mx => 15,
250 txt => 16, 353 txt => 16,
251 aaaa => 28, 354 aaaa => 28,
252 srv => 33, 355 srv => 33,
356 naptr => 35, # rfc2915
357 dname => 39, # rfc2672
253 opt => 41, 358 opt => 41,
254 spf => 99, 359 spf => 99,
255 tkey => 249, 360 tkey => 249,
256 tsig => 250, 361 tsig => 250,
257 ixfr => 251, 362 ixfr => 251,
… …
286 die "encoding of resource records is not supported"; 391 die "encoding of resource records is not supported";
287} 392}
288 393
289=item $pkt = AnyEvent::DNS::dns_pack $dns 394=item $pkt = AnyEvent::DNS::dns_pack $dns
290 395
291Packs a perl data structure into a DNS packet. Reading RFC1034 is strongly 396Packs a perl data structure into a DNS packet. Reading RFC 1035 is strongly
292recommended, then everything will be totally clear. Or maybe not. 397recommended, then everything will be totally clear. Or maybe not.
293 398
294Resource records are not yet encodable. 399Resource records are not yet encodable.
295 400
296Examples: 401Examples:
297 402
298 # very simple request, using lots of default values: 403 # very simple request, using lots of default values:
299 { rd => 1, qd => [ [ "host.domain", "a"] ] } 404 { rd => 1, qd => [ [ "host.domain", "a"] ] }
300 405
301 # more complex example, showing how flags etc. are named: 406 # more complex example, showing how flags etc. are named:
302 407
303 { 408 {
304 id => 10000, 409 id => 10000,
305 op => "query", 410 op => "query",
306 rc => "nxdomain", 411 rc => "nxdomain",
307 412
308 # flags 413 # flags
309 qr => 1, 414 qr => 1,
310 aa => 0, 415 aa => 0,
311 tc => 0, 416 tc => 0,
312 rd => 0, 417 rd => 0,
313 ra => 0, 418 ra => 0,
314 ad => 0, 419 ad => 0,
315 cd => 0, 420 cd => 0,
316 421
317 qd => [@rr], # query section 422 qd => [@rr], # query section
318 an => [@rr], # answer section 423 an => [@rr], # answer section
319 ns => [@rr], # authority section 424 ns => [@rr], # authority section
320 ar => [@rr], # additional records section 425 ar => [@rr], # additional records section
321 } 426 }
322 427
323=cut 428=cut
324 429
325sub dns_pack($) { 430sub dns_pack($) {
326 my ($req) = @_; 431 my ($req) = @_;
… …
399 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks 504 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
400 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr 505 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
401 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo 506 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
402 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx 507 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
403 16 => sub { unpack "(C/a*)*", $_ }, # txt 508 16 => sub { unpack "(C/a*)*", $_ }, # txt
404 28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa 509 28 => sub { AnyEvent::Socket::format_ipv6 ($_) }, # aaaa
405 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv 510 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
511 35 => sub { # naptr
512 # requires perl 5.10, sorry
513 my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_;
514 local $ofs = $ofs + $offset - length;
515 ($order, $preference, $flags, $service, $regexp, _dec_name)
516 },
517 39 => sub { local $ofs = $ofs - length; _dec_name }, # dname
406 99 => sub { unpack "(C/a*)*", $_ }, # spf 518 99 => sub { unpack "(C/a*)*", $_ }, # spf
407); 519);
408 520
409sub _dec_rr { 521sub _dec_rr {
410 my $name = _dec_name; 522 my $name = _dec_name;
… …
424 536
425Unpacks a DNS packet into a perl data structure. 537Unpacks a DNS packet into a perl data structure.
426 538
427Examples: 539Examples:
428 540
429 # an unsuccessful reply 541 # an unsuccessful reply
430 { 542 {
431 'qd' => [ 543 'qd' => [
432 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] 544 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
433 ], 545 ],
434 'rc' => 'nxdomain', 546 'rc' => 'nxdomain',
435 'ar' => [], 547 'ar' => [],
436 'ns' => [ 548 'ns' => [
437 [ 549 [
438 'uni-karlsruhe.de', 550 'uni-karlsruhe.de',
439 'soa', 551 'soa',
440 'in', 552 'in',
441 'netserv.rz.uni-karlsruhe.de', 553 'netserv.rz.uni-karlsruhe.de',
442 'hostmaster.rz.uni-karlsruhe.de', 554 'hostmaster.rz.uni-karlsruhe.de',
443 2008052201, 10800, 1800, 2592000, 86400 555 2008052201, 10800, 1800, 2592000, 86400
444 ] 556 ]
445 ], 557 ],
446 'tc' => '', 558 'tc' => '',
447 'ra' => 1, 559 'ra' => 1,
448 'qr' => 1, 560 'qr' => 1,
449 'id' => 45915, 561 'id' => 45915,
450 'aa' => '', 562 'aa' => '',
451 'an' => [], 563 'an' => [],
452 'rd' => 1, 564 'rd' => 1,
453 'op' => 'query' 565 'op' => 'query'
454 } 566 }
455 567
456 # a successful reply 568 # a successful reply
457 569
458 { 570 {
459 'qd' => [ [ 'www.google.de', 'a', 'in' ] ], 571 'qd' => [ [ 'www.google.de', 'a', 'in' ] ],
460 'rc' => 0, 572 'rc' => 0,
461 'ar' => [ 573 'ar' => [
462 [ 'a.l.google.com', 'a', 'in', '209.85.139.9' ], 574 [ 'a.l.google.com', 'a', 'in', '209.85.139.9' ],
463 [ 'b.l.google.com', 'a', 'in', '64.233.179.9' ], 575 [ 'b.l.google.com', 'a', 'in', '64.233.179.9' ],
464 [ 'c.l.google.com', 'a', 'in', '64.233.161.9' ], 576 [ 'c.l.google.com', 'a', 'in', '64.233.161.9' ],
465 ], 577 ],
466 'ns' => [ 578 'ns' => [
467 [ 'l.google.com', 'ns', 'in', 'a.l.google.com' ], 579 [ 'l.google.com', 'ns', 'in', 'a.l.google.com' ],
468 [ 'l.google.com', 'ns', 'in', 'b.l.google.com' ], 580 [ 'l.google.com', 'ns', 'in', 'b.l.google.com' ],
469 ], 581 ],
470 'tc' => '', 582 'tc' => '',
471 'ra' => 1, 583 'ra' => 1,
472 'qr' => 1, 584 'qr' => 1,
473 'id' => 64265, 585 'id' => 64265,
474 'aa' => '', 586 'aa' => '',
475 'an' => [ 587 'an' => [
476 [ 'www.google.de', 'cname', 'in', 'www.google.com' ], 588 [ 'www.google.de', 'cname', 'in', 'www.google.com' ],
477 [ 'www.google.com', 'cname', 'in', 'www.l.google.com' ], 589 [ 'www.google.com', 'cname', 'in', 'www.l.google.com' ],
478 [ 'www.l.google.com', 'a', 'in', '66.249.93.104' ], 590 [ 'www.l.google.com', 'a', 'in', '66.249.93.104' ],
479 [ 'www.l.google.com', 'a', 'in', '66.249.93.147' ], 591 [ 'www.l.google.com', 'a', 'in', '66.249.93.147' ],
480 ], 592 ],
481 'rd' => 1, 593 'rd' => 1,
482 'op' => 0 594 'op' => 0
483 } 595 }
484 596
485=cut 597=cut
486 598
487sub dns_unpack($) { 599sub dns_unpack($) {
488 local $pkt = shift; 600 local $pkt = shift;
… …
537calls. 649calls.
538 650
539Unless you have special needs, prefer this function over creating your own 651Unless you have special needs, prefer this function over creating your own
540resolver object. 652resolver object.
541 653
654The resolver is created with the following parameters:
655
656 untaint enabled
657 max_outstanding $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}
658
659C<os_config> will be used for OS-specific configuration, unless
660C<$ENV{PERL_ANYEVENT_RESOLV_CONF}> is specified, in which case that file
661gets parsed.
662
542=cut 663=cut
543 664
544our $RESOLVER; 665our $RESOLVER;
545 666
546sub resolver() { 667sub resolver() {
547 $RESOLVER || do { 668 $RESOLVER || do {
548 $RESOLVER = new AnyEvent::DNS; 669 $RESOLVER = new AnyEvent::DNS
670 untaint => 1,
671 exists $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}
672 ? (max_outstanding => $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}*1 || 1) : (),
673 ;
674
675 exists $ENV{PERL_ANYEVENT_RESOLV_CONF}
676 ? length $ENV{PERL_ANYEVENT_RESOLV_CONF} && $RESOLVER->_parse_resolv_conf_file ($ENV{PERL_ANYEVENT_RESOLV_CONF})
549 $RESOLVER->os_config; 677 : $RESOLVER->os_config;
678
550 $RESOLVER 679 $RESOLVER
551 } 680 }
552} 681}
553 682
554=item $resolver = new AnyEvent::DNS key => value... 683=item $resolver = new AnyEvent::DNS key => value...
… …
589been resolved. 718been resolved.
590 719
591=item reuse => $seconds 720=item reuse => $seconds
592 721
593The number of seconds (default: C<300>) that a query id cannot be re-used 722The number of seconds (default: C<300>) that a query id cannot be re-used
594after a timeout. If there as no time-out then query id's can be reused 723after a timeout. If there was no time-out then query ids can be reused
595immediately. 724immediately.
725
726=item untaint => $boolean
727
728When true, then the resolver will automatically untaint results, and might
729also ignore certain environment variables.
596 730
597=back 731=back
598 732
599=cut 733=cut
600 734
601sub new { 735sub new {
602 my ($class, %arg) = @_; 736 my ($class, %arg) = @_;
603
604 # try to create a ipv4 and an ipv6 socket
605 # only fail when we cnanot create either
606
607 socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
608 socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
609
610 $fh4 || $fh6
611 or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
612 737
613 my $self = bless { 738 my $self = bless {
614 server => [], 739 server => [],
615 timeout => [2, 5, 5], 740 timeout => [2, 5, 5],
616 search => [], 741 search => [],
617 ndots => 1, 742 ndots => 1,
618 max_outstanding => 10, 743 max_outstanding => 10,
619 reuse => 300, # reuse id's after 5 minutes only, if possible 744 reuse => 300,
620 %arg, 745 %arg,
621 reuse_q => [], 746 reuse_q => [],
622 }, $class; 747 }, $class;
623 748
624 # search should default to gethostname's domain 749 # search should default to gethostname's domain
625 # but perl lacks a good posix module 750 # but perl lacks a good posix module
626 751
752 # try to create an ipv4 and an ipv6 socket
753 # only fail when we cannot create either
754 my $got_socket;
755
627 Scalar::Util::weaken (my $wself = $self); 756 Scalar::Util::weaken (my $wself = $self);
628 757
629 if ($fh4) { 758 if (socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0) {
759 ++$got_socket;
760
630 AnyEvent::Util::fh_nonblocking $fh4, 1; 761 AnyEvent::Util::fh_nonblocking $fh4, 1;
631 $self->{fh4} = $fh4; 762 $self->{fh4} = $fh4;
632 $self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub { 763 $self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
633 if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) { 764 if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
634 $wself->_recv ($pkt, $peer); 765 $wself->_recv ($pkt, $peer);
635 } 766 }
636 }); 767 });
637 } 768 }
638 769
639 if ($fh6) { 770 if (AF_INET6 && socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0) {
771 ++$got_socket;
772
640 $self->{fh6} = $fh6; 773 $self->{fh6} = $fh6;
641 AnyEvent::Util::fh_nonblocking $fh6, 1; 774 AnyEvent::Util::fh_nonblocking $fh6, 1;
642 $self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub { 775 $self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
643 if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) { 776 if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
644 $wself->_recv ($pkt, $peer); 777 $wself->_recv ($pkt, $peer);
645 } 778 }
646 }); 779 });
647 } 780 }
648 781
782 $got_socket
783 or Carp::croak "unable to create either an IPv4 or an IPv6 socket";
784
649 $self->_compile; 785 $self->_compile;
650 786
651 $self 787 $self
652} 788}
653 789
654=item $resolver->parse_resolv_conv ($string) 790=item $resolver->parse_resolv_conf ($string)
655 791
656Parses the given string as if it were a F<resolv.conf> file. The following 792Parses the given string as if it were a F<resolv.conf> file. The following
657directives are supported (but not necessarily implemented). 793directives are supported (but not necessarily implemented).
658 794
659C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 795C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
… …
706 if $attempts; 842 if $attempts;
707 843
708 $self->_compile; 844 $self->_compile;
709} 845}
710 846
847sub _parse_resolv_conf_file {
848 my ($self, $resolv_conf) = @_;
849
850 open my $fh, "<:perlio", $resolv_conf
851 or Carp::croak "$resolv_conf: $!";
852
853 local $/;
854 $self->parse_resolv_conf (<$fh>);
855}
856
711=item $resolver->os_config 857=item $resolver->os_config
712 858
713Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various 859Tries so load and parse F</etc/resolv.conf> on portable operating
714egregious hacks on windows to force the DNS servers and searchlist out of the system. 860systems. Tries various egregious hacks on windows to force the DNS servers
861and searchlist out of the system.
715 862
716=cut 863=cut
717 864
718sub os_config { 865sub os_config {
719 my ($self) = @_; 866 my ($self) = @_;
720 867
721 $self->{server} = []; 868 $self->{server} = [];
722 $self->{search} = []; 869 $self->{search} = [];
723 870
724 if (AnyEvent::WIN32 || $^O =~ /cygwin/i) { 871 if ((AnyEvent::WIN32 || $^O =~ /cygwin/i)) {
725 no strict 'refs'; 872 no strict 'refs';
726 873
727 # there are many options to find the current nameservers etc. on windows 874 # there are many options to find the current nameservers etc. on windows
728 # all of them don't work consistently: 875 # all of them don't work consistently:
729 # - the registry thing needs separate code on win32 native vs. cygwin 876 # - the registry thing needs separate code on win32 native vs. cygwin
730 # - the registry layout differs between windows versions 877 # - the registry layout differs between windows versions
731 # - calling windows api functions doesn't work on cygwin 878 # - calling windows api functions doesn't work on cygwin
732 # - ipconfig uses locale-specific messages 879 # - ipconfig uses locale-specific messages
733 880
734 # we use ipconfig parsing because, despite all it's brokenness, 881 # we use ipconfig parsing because, despite all its brokenness,
735 # it seems most stable in practise. 882 # it seems most stable in practise.
736 # for good measure, we append a fallback nameserver to our list. 883 # for good measure, we append a fallback nameserver to our list.
737 884
738 if (open my $fh, "ipconfig /all |") { 885 if (open my $fh, "ipconfig /all |") {
739 # parsing strategy: we go through the output and look for 886 # parsing strategy: we go through the output and look for
… …
748 } elsif (/^\S/ || /^\s[^:]{16,}: /) { 895 } elsif (/^\S/ || /^\s[^:]{16,}: /) {
749 $dns = 0; 896 $dns = 0;
750 } 897 }
751 if ($dns && /^\s*(\S+)\s*$/) { 898 if ($dns && /^\s*(\S+)\s*$/) {
752 my $s = $1; 899 my $s = $1;
753 $s =~ s/%\d+(?!\S)//; # get rid of scope id 900 $s =~ s/%\d+(?!\S)//; # get rid of ipv6 scope id
754 if (my $ipn = AnyEvent::Socket::parse_address ($s)) { 901 if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
755 push @{ $self->{server} }, $ipn; 902 push @{ $self->{server} }, $ipn;
756 } else { 903 } else {
757 push @{ $self->{search} }, $s; 904 push @{ $self->{search} }, $s;
758 } 905 }
… …
763 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK]; 910 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
764 911
765 $self->_compile; 912 $self->_compile;
766 } 913 }
767 } else { 914 } else {
768 # try resolv.conf everywhere 915 # try resolv.conf everywhere else
769 916
770 if (open my $fh, "</etc/resolv.conf") { 917 $self->_parse_resolv_conf_file ("/etc/resolv.conf")
771 local $/; 918 if -e "/etc/resolv.conf";
772 $self->parse_resolv_conf (<$fh>);
773 }
774 } 919 }
920}
921
922=item $resolver->timeout ($timeout, ...)
923
924Sets the timeout values. See the C<timeout> constructor argument (and note
925that this method uses the values itself, not an array-reference).
926
927=cut
928
929sub timeout {
930 my ($self, @timeout) = @_;
931
932 $self->{timeout} = \@timeout;
933 $self->_compile;
934}
935
936=item $resolver->max_outstanding ($nrequests)
937
938Sets the maximum number of outstanding requests to C<$nrequests>. See the
939C<max_outstanding> constructor argument.
940
941=cut
942
943sub max_outstanding {
944 my ($self, $max) = @_;
945
946 $self->{max_outstanding} = $max;
947 $self->_scheduler;
775} 948}
776 949
777sub _compile { 950sub _compile {
778 my $self = shift; 951 my $self = shift;
779 952
… …
796 $self->{retry} = \@retry; 969 $self->{retry} = \@retry;
797} 970}
798 971
799sub _feed { 972sub _feed {
800 my ($self, $res) = @_; 973 my ($self, $res) = @_;
974
975 ($res) = $res =~ /^(.*)$/s
976 if AnyEvent::TAINT && $self->{untaint};
801 977
802 $res = dns_unpack $res 978 $res = dns_unpack $res
803 or return; 979 or return;
804 980
805 my $id = $self->{id}{$res->{id}}; 981 my $id = $self->{id}{$res->{id}};
… …
858 1034
859 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 1035 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
860 $NOW = time; 1036 $NOW = time;
861 1037
862 # timeout, try next 1038 # timeout, try next
863 &$do_retry; 1039 &$do_retry if $do_retry;
864 }), sub { 1040 }), sub {
865 my ($res) = @_; 1041 my ($res) = @_;
866 1042
867 if ($res->{tc}) { 1043 if ($res->{tc}) {
868 # success, but truncated, so use tcp 1044 # success, but truncated, so use tcp
869 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub { 1045 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
1046 return unless $do_retry; # some other request could have invalidated us already
1047
870 my ($fh) = @_ 1048 my ($fh) = @_
871 or return &$do_retry; 1049 or return &$do_retry;
872 1050
1051 require AnyEvent::Handle;
1052
873 my $handle = new AnyEvent::Handle 1053 my $handle; $handle = new AnyEvent::Handle
874 fh => $fh, 1054 fh => $fh,
1055 timeout => $timeout,
875 on_error => sub { 1056 on_error => sub {
1057 undef $handle;
1058 return unless $do_retry; # some other request could have invalidated us already
876 # failure, try next 1059 # failure, try next
877 &$do_retry; 1060 &$do_retry;
878 }; 1061 };
879 1062
880 $handle->push_write (pack "n/a", $req->[0]); 1063 $handle->push_write (pack "n/a", $req->[0]);
881 $handle->push_read (chunk => 2, sub { 1064 $handle->push_read (chunk => 2, sub {
882 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub { 1065 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
1066 undef $handle;
883 $self->_feed ($_[1]); 1067 $self->_feed ($_[1]);
884 }); 1068 });
885 }); 1069 });
886 shutdown $fh, 1;
887 1070
888 }, sub { $timeout }); 1071 }, sub { $timeout });
889 1072
890 } else { 1073 } else {
891 # success 1074 # success
… …
907} 1090}
908 1091
909sub _scheduler { 1092sub _scheduler {
910 my ($self) = @_; 1093 my ($self) = @_;
911 1094
1095 no strict 'refs';
1096
912 $NOW = time; 1097 $NOW = time;
913 1098
914 # first clear id reuse queue 1099 # first clear id reuse queue
915 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] } 1100 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
916 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW; 1101 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
… …
924 $self->_scheduler; 1109 $self->_scheduler;
925 }); 1110 });
926 last; 1111 last;
927 } 1112 }
928 1113
929 my $req = shift @{ $self->{queue} } 1114 if (my $req = shift @{ $self->{queue} }) {
930 or last; 1115 # found a request in the queue, execute it
931
932 while () { 1116 while () {
933 $req->[2] = int rand 65536; 1117 $req->[2] = int rand 65536;
934 last unless exists $self->{id}{$req->[2]}; 1118 last unless exists $self->{id}{$req->[2]};
1119 }
1120
1121 ++$self->{outstanding};
1122 $self->{id}{$req->[2]} = 1;
1123 substr $req->[0], 0, 2, pack "n", $req->[2];
1124
1125 $self->_exec ($req);
1126
1127 } elsif (my $cb = shift @{ $self->{wait} }) {
1128 # found a wait_for_slot callback, call that one first
1129 $cb->($self);
1130
1131 } else {
1132 # nothing to do, just exit
1133 last;
935 } 1134 }
936
937 ++$self->{outstanding};
938 $self->{id}{$req->[2]} = 1;
939 substr $req->[0], 0, 2, pack "n", $req->[2];
940
941 $self->_exec ($req);
942 } 1135 }
943} 1136}
944 1137
945=item $resolver->request ($req, $cb->($res)) 1138=item $resolver->request ($req, $cb->($res))
946 1139
1140This is the main low-level workhorse for sending DNS requests.
1141
947Sends a single request (a hash-ref formated as specified for 1142This function sends a single request (a hash-ref formated as specified
948C<dns_pack>) to the configured nameservers including 1143for C<dns_pack>) to the configured nameservers in turn until it gets a
1144response. It handles timeouts, retries and automatically falls back to
1145virtual circuit mode (TCP) when it receives a truncated reply.
1146
949retries. Calls the callback with the decoded response packet if a reply 1147Calls the callback with the decoded response packet if a reply was
950was received, or no arguments on timeout. 1148received, or no arguments in case none of the servers answered.
951 1149
952=cut 1150=cut
953 1151
954sub request($$) { 1152sub request($$) {
955 my ($self, $req, $cb) = @_; 1153 my ($self, $req, $cb) = @_;
956 1154
957 push @{ $self->{queue} }, [dns_pack $req, $cb]; 1155 push @{ $self->{queue} }, [dns_pack $req, $cb];
958 $self->_scheduler; 1156 $self->_scheduler;
959} 1157}
960 1158
961=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr)) 1159=item $resolver->resolve ($qname, $qtype, %options, $cb->(@rr))
962 1160
963Queries the DNS for the given domain name C<$qname> of type C<$qtype>. 1161Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
964 1162
965A C<$qtype> is either a numerical query type (e.g. C<1> for A recods) or 1163A C<$qtype> is either a numerical query type (e.g. C<1> for A records) or
966a lowercase name (you have to look at the source to see which aliases are 1164a lowercase name (you have to look at the source to see which aliases are
967supported, but all types from RFC 1034, C<aaaa>, C<srv>, C<spf> and a few 1165supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
968more are known to this module). A qtype of "*" is supported and means 1166more are known to this module). A C<$qtype> of "*" is supported and means
969"any" record type. 1167"any" record type.
970 1168
971The callback will be invoked with a list of matching result records or 1169The callback will be invoked with a list of matching result records or
972none on any error or if the name could not be found. 1170none on any error or if the name could not be found.
973 1171
974CNAME chains (although illegal) are followed up to a length of 8. 1172CNAME chains (although illegal) are followed up to a length of 10.
975 1173
976The callback will be invoked with an result code in string form (noerror, 1174The callback will be invoked with arraryefs of the form C<[$name, $type,
977formerr, servfail, nxdomain, notimp, refused and so on), or numerical 1175$class, @data>], where C<$name> is the domain name, C<$type> a type string
978form if the result code is not supported. The remaining arguments are 1176or number, C<$class> a class name and @data is resource-record-dependent
979arraryefs of the form C<[$name, $type, $class, @data>], where C<$name> is 1177data. For C<a> records, this will be the textual IPv4 addresses, for C<ns>
980the domain name, C<$type> a type string or number, C<$class> a class name 1178or C<cname> records this will be a domain name, for C<txt> records these
981and @data is resource-record-dependent data. For C<a> records, this will 1179are all the strings and so on.
982be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
983a domain name, for C<txt> records these are all the strings and so on.
984 1180
985All types mentioned in RFC 1034, C<aaaa>, C<srv> and C<spf> are 1181All types mentioned in RFC 1035, C<aaaa>, C<srv>, C<naptr> and C<spf> are
986decoded. All resource records not known to this module will just return 1182decoded. All resource records not known to this module will have
987the raw C<rdata> field as fourth entry. 1183the raw C<rdata> field as fourth entry.
988 1184
989Note that this resolver is just a stub resolver: it requires a name server 1185Note that this resolver is just a stub resolver: it requires a name server
990supporting recursive queries, will not do any recursive queries itself and 1186supporting recursive queries, will not do any recursive queries itself and
991is not secure when used against an untrusted name server. 1187is not secure when used against an untrusted name server.
… …
996 1192
997=item search => [$suffix...] 1193=item search => [$suffix...]
998 1194
999Use the given search list (which might be empty), by appending each one 1195Use the given search list (which might be empty), by appending each one
1000in turn to the C<$qname>. If this option is missing then the configured 1196in turn to the C<$qname>. If this option is missing then the configured
1001C<ndots> and C<search> define its value. If the C<$qname> ends in a dot, 1197C<ndots> and C<search> values define its value (depending on C<ndots>, the
1002then the searchlist will be ignored. 1198empty suffix will be prepended or appended to that C<search> value). If
1199the C<$qname> ends in a dot, then the searchlist will be ignored.
1003 1200
1004=item accept => [$type...] 1201=item accept => [$type...]
1005 1202
1006Lists the acceptable result types: only result types in this set will be 1203Lists the acceptable result types: only result types in this set will be
1007accepted and returned. The default includes the C<$qtype> and nothing 1204accepted and returned. The default includes the C<$qtype> and nothing
… …
1085 $do_search = sub { 1282 $do_search = sub {
1086 @search 1283 @search
1087 or (undef $do_search), (undef $do_req), return $cb->(); 1284 or (undef $do_search), (undef $do_req), return $cb->();
1088 1285
1089 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1286 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
1090 my $depth = 2; 1287 my $depth = 10;
1091 1288
1092 # advance in cname-chain 1289 # advance in cname-chain
1093 $do_req = sub { 1290 $do_req = sub {
1094 $self->request ({ 1291 $self->request ({
1095 rd => 1, 1292 rd => 1,
… …
1113 if (@rr) { 1310 if (@rr) {
1114 $depth-- 1311 $depth--
1115 or return $do_search->(); # cname chain too long 1312 or return $do_search->(); # cname chain too long
1116 1313
1117 $cname = 1; 1314 $cname = 1;
1118 $name = $rr[0][3]; 1315 $name = lc $rr[0][3];
1119 1316
1120 } elsif ($cname) { 1317 } elsif ($cname) {
1121 # follow the cname 1318 # follow the cname
1122 return $do_req->(); 1319 return $do_req->();
1123 1320
… …
1133 }; 1330 };
1134 1331
1135 $do_search->(); 1332 $do_search->();
1136} 1333}
1137 1334
1335=item $resolver->wait_for_slot ($cb->($resolver))
1336
1337Wait until a free request slot is available and call the callback with the
1338resolver object.
1339
1340A request slot is used each time a request is actually sent to the
1341nameservers: There are never more than C<max_outstanding> of them.
1342
1343Although you can submit more requests (they will simply be queued until
1344a request slot becomes available), sometimes, usually for rate-limiting
1345purposes, it is useful to instead wait for a slot before generating the
1346request (or simply to know when the request load is low enough so one can
1347submit requests again).
1348
1349This is what this method does: The callback will be called when submitting
1350a DNS request will not result in that request being queued. The callback
1351may or may not generate any requests in response.
1352
1353Note that the callback will only be invoked when the request queue is
1354empty, so this does not play well if somebody else keeps the request queue
1355full at all times.
1356
1357=cut
1358
1359sub wait_for_slot {
1360 my ($self, $cb) = @_;
1361
1362 push @{ $self->{wait} }, $cb;
1363 $self->_scheduler;
1364}
1365
1138use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end 1366use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1139 1367
11401; 13681;
1141 1369
1142=back 1370=back
1143 1371
1144=head1 AUTHOR 1372=head1 AUTHOR
1145 1373
1146 Marc Lehmann <schmorp@schmorp.de> 1374 Marc Lehmann <schmorp@schmorp.de>
1147 http://home.schmorp.de/ 1375 http://home.schmorp.de/
1148 1376
1149=cut 1377=cut
1150 1378

Diff Legend

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