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.7 by root, Fri May 23 05:30:59 2008 UTC vs.
Revision 1.28 by root, Sun May 25 01:05:27 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", sub { $cv->send (@_) };
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.
13 18
19The stub resolver supports DNS over UDP, optional EDNS0 support for up to
204kiB datagrams and automatically falls back to virtual circuit mode for
21large responses.
22
14=head2 CONVENIENCE FUNCTIONS 23=head2 CONVENIENCE FUNCTIONS
15 24
16=over 4 25=over 4
17 26
18=cut 27=cut
… …
20package AnyEvent::DNS; 29package AnyEvent::DNS;
21 30
22no warnings; 31no warnings;
23use strict; 32use strict;
24 33
25use AnyEvent::Util ();
26use AnyEvent::Handle (); 34use AnyEvent::Handle ();
27 35
28=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs) 36=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
29 37
30NOT YET IMPLEMENTED
31
32Tries to resolve the given nodename and service name into sockaddr 38Tries to resolve the given nodename and service name into protocol families
33structures usable to connect to this node and service in a 39and sockaddr structures usable to connect to this node and service in a
34protocol-independent way. It works similarly to the getaddrinfo posix 40protocol-independent way. It works remotely similar to the getaddrinfo
35function. 41posix function.
42
43C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
44either a service name (port name from F</etc/services>) or a numerical
45port number. If both C<$node> and C<$service> are names, then SRV records
46will be consulted to find the real service, otherwise they will be
47used as-is. If you know that the service name is not in your services
48database, then you can specify the service in the format C<name=port>
49(e.g. C<http=80>).
50
51C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
52C<sctp>. The default is C<tcp>.
53
54C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
55only IPv4) or C<6> (use only IPv6). This setting might be influenced by
56C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
57
58C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
59C<undef> in which case it gets automatically chosen).
60
61The callback will receive zero or more array references that contain
62C<$family, $type, $proto> for use in C<socket> and a binary
63C<$sockaddr> for use in C<connect> (or C<bind>).
64
65The application should try these in the order given.
36 66
37Example: 67Example:
38 68
39 AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... }; 69 AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
40 70
41=item AnyEvent::DNS::a $domain, $cb->(@addrs) 71=item AnyEvent::DNS::a $domain, $cb->(@addrs)
42 72
43Tries to resolve the given domain to IPv4 address(es). 73Tries to resolve the given domain to IPv4 address(es).
74
75=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
76
77Tries to resolve the given domain to IPv6 address(es).
44 78
45=item AnyEvent::DNS::mx $domain, $cb->(@hostnames) 79=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
46 80
47Tries to resolve the given domain into a sorted (lower preference value 81Tries to resolve the given domain into a sorted (lower preference value
48first) list of domain names. 82first) list of domain names.
… …
58=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 92=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
59 93
60Tries to resolve the given service, protocol and domain name into a list 94Tries to resolve the given service, protocol and domain name into a list
61of service records. 95of service records.
62 96
63Each srv_rr is an arrayref with the following contents: 97Each srv_rr is an array reference with the following contents:
64C<[$priority, $weight, $transport, $target]>. 98C<[$priority, $weight, $transport, $target]>.
65 99
66They will be sorted with lowest priority, highest weight first (TODO: 100They will be sorted with lowest priority, highest weight first (TODO:
67should use the rfc algorithm to reorder same-priority records for weight). 101should use the RFC algorithm to reorder same-priority records for weight).
68 102
69Example: 103Example:
70 104
71 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 105 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
72 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 106 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
… …
74=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames) 108=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
75 109
76Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form) 110Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
77into it's hostname(s). 111into it's hostname(s).
78 112
79Requires the Socket6 module for IPv6 support.
80
81Example: 113Example:
82 114
83 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 115 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
84 # => f.root-servers.net 116 # => f.root-servers.net
85 117
… …
94 126
95sub a($$) { 127sub a($$) {
96 my ($domain, $cb) = @_; 128 my ($domain, $cb) = @_;
97 129
98 resolver->resolve ($domain => "a", sub { 130 resolver->resolve ($domain => "a", sub {
131 $cb->(map $_->[3], @_);
132 });
133}
134
135sub aaaa($$) {
136 my ($domain, $cb) = @_;
137
138 resolver->resolve ($domain => "aaaa", sub {
99 $cb->(map $_->[3], @_); 139 $cb->(map $_->[3], @_);
100 }); 140 });
101} 141}
102 142
103sub mx($$) { 143sub mx($$) {
… …
134} 174}
135 175
136sub ptr($$) { 176sub ptr($$) {
137 my ($ip, $cb) = @_; 177 my ($ip, $cb) = @_;
138 178
139 my $name; 179 $ip = AnyEvent::Socket::parse_ip ($ip)
180 or return $cb->();
140 181
141 if (AnyEvent::Util::dotted_quad $ip) { 182 if (4 == length $ip) {
142 $name = join ".", (reverse split /\./, $ip), "in-addr.arpa."; 183 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
143 } else { 184 } else {
144 require Socket6; 185 $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
145 $name = join ".",
146 (reverse split //,
147 unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
148 "ip6.arpa.";
149 } 186 }
150 187
151 resolver->resolve ($name => "ptr", sub { 188 resolver->resolve ($ip => "ptr", sub {
152 $cb->(map $_->[3], @_); 189 $cb->(map $_->[3], @_);
153 }); 190 });
154} 191}
155 192
156sub any($$) { 193sub any($$) {
157 my ($domain, $cb) = @_; 194 my ($domain, $cb) = @_;
158 195
159 resolver->resolve ($domain => "*", $cb); 196 resolver->resolve ($domain => "*", $cb);
160} 197}
161 198
199#############################################################################
200
201sub addr($$$$$$) {
202 my ($node, $service, $proto, $family, $type, $cb) = @_;
203
204 unless (&AnyEvent::Util::AF_INET6) {
205 $family != 6
206 or return $cb->();
207
208 $family ||= 4;
209 }
210
211 $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
212 $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
213
214 $family ||=4 unless $AnyEvent::PROTOCOL{ipv6};
215 $family ||=6 unless $AnyEvent::PROTOCOL{ipv4};
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->(
241 map $_->[2],
242 sort {
243 $AnyEvent::PROTOCOL{$a->[1]} <=> $AnyEvent::PROTOCOL{$b->[1]}
244 or $a->[0] <=> $b->[0]
245 }
246 @res
247 )
248 });
249
250 $cv->begin;
251 for my $idx (0 .. $#target) {
252 my ($node, $port) = @{ $target[$idx] };
253
254 if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
255 if (4 == length $noden && $family != 6) {
256 push @res, [$idx, "ipv4", [Socket::AF_INET, $type, $proton,
257 AnyEvent::Socket::pack_sockaddr ($port, $noden)]]
258 }
259
260 if (16 == length $noden && $family != 4) {
261 push @res, [$idx, "ipv6", [&AnyEvent::Util::AF_INET6, $type, $proton,
262 AnyEvent::Socket::pack_sockaddr ( $port, $noden)]]
263 }
264 } else {
265 # ipv4
266 if ($family != 6) {
267 $cv->begin;
268 a $node, sub {
269 push @res, [$idx, "ipv4", [Socket::AF_INET, $type, $proton,
270 AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv4 ($_))]]
271 for @_;
272 $cv->end;
273 };
274 }
275
276 # ipv6
277 if ($family != 4) {
278 $cv->begin;
279 aaaa $node, sub {
280 push @res, [$idx, "ipv6", [&AnyEvent::Socket::AF_INET6, $type, $proton,
281 AnyEvent::Socket::pack_sockaddr ($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 ($node eq "localhost") {
293 @target = (["127.0.0.1", $port], ["::1", $port]);
294 &$resolve;
295 } elsif (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
296 srv $service, $proto, $node, sub {
297 my (@srv) = @_;
298
299 # no srv records, continue traditionally
300 @srv
301 or return &$resolve;
302
303 # only srv record has "." => abort
304 $srv[0][2] ne "." || $#srv
305 or return $cb->();
306
307 # use srv records then
308 @target = map ["$_->[3].", $_->[2]],
309 grep $_->[3] ne ".",
310 @srv;
311
312 &$resolve;
313 };
314 } else {
315 &$resolve;
316 }
317}
318
319#############################################################################
320
321=back
322
162=head2 DNS EN-/DECODING FUNCTIONS 323=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
163 324
164=over 4 325=over 4
165 326
327=item $AnyEvent::DNS::EDNS0
328
329This variable decides whether dns_pack automatically enables EDNS0
330support. By default, this is disabled (C<0>), unless overridden by
331C<$ENV{PERL_ANYEVENT_EDNS0>), but when set to C<1>, AnyEvent::DNS will use
332EDNS0 in all requests.
333
166=cut 334=cut
335
336our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
167 337
168our %opcode_id = ( 338our %opcode_id = (
169 query => 0, 339 query => 0,
170 iquery => 1, 340 iquery => 1,
171 status => 2, 341 status => 2,
… …
309 + $rcode_id{$req->{rc}} * 0x0001, 479 + $rcode_id{$req->{rc}} * 0x0001,
310 480
311 scalar @{ $req->{qd} || [] }, 481 scalar @{ $req->{qd} || [] },
312 scalar @{ $req->{an} || [] }, 482 scalar @{ $req->{an} || [] },
313 scalar @{ $req->{ns} || [] }, 483 scalar @{ $req->{ns} || [] },
314 1 + scalar @{ $req->{ar} || [] }, # include EDNS0 option 484 $EDNS0 + scalar @{ $req->{ar} || [] }, # include EDNS0 option here
315 485
316 (join "", map _enc_qd, @{ $req->{qd} || [] }), 486 (join "", map _enc_qd, @{ $req->{qd} || [] }),
317 (join "", map _enc_rr, @{ $req->{an} || [] }), 487 (join "", map _enc_rr, @{ $req->{an} || [] }),
318 (join "", map _enc_rr, @{ $req->{ns} || [] }), 488 (join "", map _enc_rr, @{ $req->{ns} || [] }),
319 (join "", map _enc_rr, @{ $req->{ar} || [] }), 489 (join "", map _enc_rr, @{ $req->{ar} || [] }),
320 490
321 (pack "C nnNn", 0, 41, 4000, 0, 0) # EDNS0, 4k udp payload size 491 ($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size
322} 492}
323 493
324our $ofs; 494our $ofs;
325our $pkt; 495our $pkt;
326 496
… …
355 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 525 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
356 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 526 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
357} 527}
358 528
359our %dec_rr = ( 529our %dec_rr = (
360 1 => sub { Socket::inet_ntoa $_ }, # a 530 1 => sub { join ".", unpack "C4" }, # a
361 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 531 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
362 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 532 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
363 6 => sub { 533 6 => sub {
364 local $ofs = $ofs - length; 534 local $ofs = $ofs - length;
365 my $mname = _dec_qname; 535 my $mname = _dec_qname;
366 my $rname = _dec_qname; 536 my $rname = _dec_qname;
367 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 537 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
368 }, # soa 538 }, # soa
369 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks 539 11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks
370 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 540 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
371 13 => sub { unpack "C/a C/a", $_ }, # hinfo 541 13 => sub { unpack "C/a C/a", $_ }, # hinfo
372 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 542 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
373 16 => sub { unpack "(C/a)*", $_ }, # txt 543 16 => sub { unpack "(C/a)*", $_ }, # txt
374 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 544 28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
375 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 545 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
376 99 => sub { unpack "(C/a)*", $_ }, # spf 546 99 => sub { unpack "(C/a)*", $_ }, # spf
377); 547);
378 548
379sub _dec_rr { 549sub _dec_rr {
… …
394 564
395Unpacks a DNS packet into a perl data structure. 565Unpacks a DNS packet into a perl data structure.
396 566
397Examples: 567Examples:
398 568
399 # a non-successful reply 569 # an unsuccessful reply
400 { 570 {
401 'qd' => [ 571 'qd' => [
402 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] 572 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
403 ], 573 ],
404 'rc' => 'nxdomain', 574 'rc' => 'nxdomain',
… …
408 'uni-karlsruhe.de', 578 'uni-karlsruhe.de',
409 'soa', 579 'soa',
410 'in', 580 'in',
411 'netserv.rz.uni-karlsruhe.de', 581 'netserv.rz.uni-karlsruhe.de',
412 'hostmaster.rz.uni-karlsruhe.de', 582 'hostmaster.rz.uni-karlsruhe.de',
413 2008052201, 583 2008052201, 10800, 1800, 2592000, 86400
414 10800,
415 1800,
416 2592000,
417 86400
418 ] 584 ]
419 ], 585 ],
420 'tc' => '', 586 'tc' => '',
421 'ra' => 1, 587 'ra' => 1,
422 'qr' => 1, 588 'qr' => 1,
… …
488 654
489=back 655=back
490 656
491=head2 THE AnyEvent::DNS RESOLVER CLASS 657=head2 THE AnyEvent::DNS RESOLVER CLASS
492 658
493This is the class which deos the actual protocol work. 659This is the class which does the actual protocol work.
494 660
495=over 4 661=over 4
496 662
497=cut 663=cut
498 664
… …
518our $RESOLVER; 684our $RESOLVER;
519 685
520sub resolver() { 686sub resolver() {
521 $RESOLVER || do { 687 $RESOLVER || do {
522 $RESOLVER = new AnyEvent::DNS; 688 $RESOLVER = new AnyEvent::DNS;
523 $RESOLVER->load_resolv_conf; 689 $RESOLVER->os_config;
524 $RESOLVER 690 $RESOLVER
525 } 691 }
526} 692}
527 693
528=item $resolver = new AnyEvent::DNS key => value... 694=item $resolver = new AnyEvent::DNS key => value...
… …
533 699
534=over 4 700=over 4
535 701
536=item server => [...] 702=item server => [...]
537 703
538A list of server addressses (default C<v127.0.0.1>) in network format (4 704A list of server addresses (default: C<v127.0.0.1>) in network format (4
539octets for IPv4, 16 octets for IPv6 - not yet supported). 705octets for IPv4, 16 octets for IPv6 - not yet supported).
540 706
541=item timeout => [...] 707=item timeout => [...]
542 708
543A list of timeouts to use (also determines the number of retries). To make 709A list of timeouts to use (also determines the number of retries). To make
… …
554tries to resolve the name without any suffixes first. 720tries to resolve the name without any suffixes first.
555 721
556=item max_outstanding => $integer 722=item max_outstanding => $integer
557 723
558Most name servers do not handle many parallel requests very well. This option 724Most name servers do not handle many parallel requests very well. This option
559limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means 725limits the number of outstanding requests to C<$n> (default: C<10>), that means
560if you request more than this many requests, then the additional requests will be queued 726if you request more than this many requests, then the additional requests will be queued
561until some other requests have been resolved. 727until some other requests have been resolved.
728
729=item reuse => $seconds
730
731The number of seconds (default: C<300>) that a query id cannot be re-used
732after a timeout. If there as no time-out then query id's can be reused
733immediately.
562 734
563=back 735=back
564 736
565=cut 737=cut
566 738
… …
595 $self 767 $self
596} 768}
597 769
598=item $resolver->parse_resolv_conv ($string) 770=item $resolver->parse_resolv_conv ($string)
599 771
600Parses the given string a sif it were a F<resolv.conf> file. The following 772Parses the given string as if it were a F<resolv.conf> file. The following
601directives are supported: 773directives are supported (but not necessarily implemented).
602 774
603C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 775C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
604C<options> (C<timeout>, C<attempts>, C<ndots>). 776C<options> (C<timeout>, C<attempts>, C<ndots>).
605 777
606Everything else is silently ignored. 778Everything else is silently ignored.
… …
618 for (split /\n/, $resolvconf) { 790 for (split /\n/, $resolvconf) {
619 if (/^\s*#/) { 791 if (/^\s*#/) {
620 # comment 792 # comment
621 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { 793 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
622 my $ip = $1; 794 my $ip = $1;
623 if (AnyEvent::Util::dotted_quad $ip) { 795 if (my $ipn = AnyEvent::Socket::parse_ip ($ip)) {
624 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; 796 push @{ $self->{server} }, $ipn;
625 } else { 797 } else {
626 warn "nameserver $ip invalid and ignored\n"; 798 warn "nameserver $ip invalid and ignored\n";
627 } 799 }
628 } elsif (/^\s*domain\s+(\S*)\s+$/i) { 800 } elsif (/^\s*domain\s+(\S*)\s+$/i) {
629 $self->{search} = [$1]; 801 $self->{search} = [$1];
… …
650 if $attempts; 822 if $attempts;
651 823
652 $self->_compile; 824 $self->_compile;
653} 825}
654 826
655=item $resolver->load_resolv_conf 827=item $resolver->os_config
656 828
657Tries to load and parse F</etc/resolv.conf>. If there will ever be windows 829Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various
658support, then this function will do the right thing under windows, too. 830egregious hacks on windows to force the DNS servers and searchlist out of the system.
659 831
660=cut 832=cut
661 833
662sub load_resolv_conf { 834sub os_config {
663 my ($self) = @_; 835 my ($self) = @_;
664 836
837 if ($^O =~ /mswin32|cygwin/i) {
838 # yeah, it suxx... lets hope DNS is DNS in all locales
839
840 if (open my $fh, "ipconfig /all |") {
841 delete $self->{server};
842 delete $self->{search};
843
844 while (<$fh>) {
845 # first DNS.* is suffix list
846 if (/^\s*DNS/) {
847 while (/\s+([[:alnum:].\-]+)\s*$/) {
848 push @{ $self->{search} }, $1;
849 $_ = <$fh>;
850 }
851 last;
852 }
853 }
854
855 while (<$fh>) {
856 # second DNS.* is server address list
857 if (/^\s*DNS/) {
858 while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
859 my $ipn = AnyEvent::Socket::parse_ip ("$1"); # "" is necessary here, apparently
860 push @{ $self->{server} }, $ipn
861 if $ipn;
862 $_ = <$fh>;
863 }
864 last;
865 }
866 }
867
868 $self->_compile;
869 }
870 } else {
871 # try resolv.conf everywhere
872
665 open my $fh, "</etc/resolv.conf" 873 if (open my $fh, "</etc/resolv.conf") {
666 or return;
667
668 local $/; 874 local $/;
669 $self->parse_resolv_conf (<$fh>); 875 $self->parse_resolv_conf (<$fh>);
876 }
877 }
670} 878}
671 879
672sub _compile { 880sub _compile {
673 my $self = shift; 881 my $self = shift;
674 882
… …
698} 906}
699 907
700sub _recv { 908sub _recv {
701 my ($self) = @_; 909 my ($self) = @_;
702 910
703 while (my $peer = recv $self->{fh}, my $res, 4000, 0) { 911 while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
704 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 912 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
705 913
706 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 914 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
707 915
708 $self->_feed ($res); 916 $self->_feed ($res);
709 } 917 }
710} 918}
711 919
920sub _free_id {
921 my ($self, $id, $timeout) = @_;
922
923 if ($timeout) {
924 # we need to block the id for a while
925 $self->{id}{$id} = 1;
926 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
927 } else {
928 # we can quickly recycle the id
929 delete $self->{id}{$id};
930 }
931
932 --$self->{outstanding};
933 $self->_scheduler;
934}
935
936# execute a single request, involves sending it with timeouts to multiple servers
712sub _exec { 937sub _exec {
713 my ($self, $req, $retry) = @_; 938 my ($self, $req) = @_;
714 939
940 my $retry; # of retries
941 my $do_retry;
942
943 $do_retry = sub {
715 if (my $retry_cfg = $self->{retry}[$retry]) { 944 my $retry_cfg = $self->{retry}[$retry++]
945 or do {
946 # failure
947 $self->_free_id ($req->[2], $retry > 1);
948 undef $do_retry; return $req->[1]->();
949 };
950
716 my ($server, $timeout) = @$retry_cfg; 951 my ($server, $timeout) = @$retry_cfg;
717 952
718 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 953 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
719 $NOW = time; 954 $NOW = time;
720 955
721 # timeout, try next 956 # timeout, try next
722 $self->_exec ($req, $retry + 1); 957 &$do_retry;
723 }), sub { 958 }), sub {
724 my ($res) = @_; 959 my ($res) = @_;
725 960
726 if ($res->{tc}) { 961 if ($res->{tc}) {
727 # success, but truncated, so use tcp 962 # success, but truncated, so use tcp
728 AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub { 963 AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
729 my ($fh) = @_ 964 my ($fh) = @_
730 or return $self->_exec ($req, $retry + 1); 965 or return &$do_retry;
731 966
732 my $handle = new AnyEvent::Handle 967 my $handle = new AnyEvent::Handle
733 fh => $fh, 968 fh => $fh,
734 on_error => sub { 969 on_error => sub {
735 # failure, try next 970 # failure, try next
736 $self->_exec ($req, $retry + 1); 971 &$do_retry;
737 }; 972 };
738 973
739 $handle->push_write (pack "n/a", $req->[0]); 974 $handle->push_write (pack "n/a", $req->[0]);
740 $handle->push_read_chunk (2, sub { 975 $handle->push_read (chunk => 2, sub {
741 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { 976 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
742 $self->_feed ($_[1]); 977 $self->_feed ($_[1]);
743 }); 978 });
744 }); 979 });
745 shutdown $fh, 1; 980 shutdown $fh, 1;
746 981
747 }, sub { $timeout }; 982 }, sub { $timeout });
748 983
749 } else { 984 } else {
750 # success 985 # success
751 $self->{id}{$req->[2]} = 1; 986 $self->_free_id ($req->[2], $retry > 1);
752 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 987 undef $do_retry; return $req->[1]->($res);
753 --$self->{outstanding};
754 $self->_scheduler;
755
756 $req->[1]->($res);
757 } 988 }
758 }]; 989 }];
759 990
760 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 991 send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);
761 } else {
762 # failure
763 $self->{id}{$req->[2]} = 1;
764 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
765 --$self->{outstanding};
766 $self->_scheduler;
767
768 $req->[1]->();
769 } 992 };
993
994 &$do_retry;
770} 995}
771 996
772sub _scheduler { 997sub _scheduler {
773 my ($self) = @_; 998 my ($self) = @_;
774 999
775 $NOW = time; 1000 $NOW = time;
776 1001
777 # first clear id reuse queue 1002 # first clear id reuse queue
778 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] } 1003 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
779 while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW; 1004 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
780 1005
781 while ($self->{outstanding} < $self->{max_outstanding}) { 1006 while ($self->{outstanding} < $self->{max_outstanding}) {
1007
1008 if (@{ $self->{reuse_q} } >= 30000) {
1009 # we ran out of ID's, wait a bit
1010 $self->{reuse_to} ||= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
1011 delete $self->{reuse_to};
1012 $self->_scheduler;
1013 });
1014 last;
1015 }
1016
782 my $req = shift @{ $self->{queue} } 1017 my $req = shift @{ $self->{queue} }
783 or last; 1018 or last;
784 1019
785 while () { 1020 while () {
786 $req->[2] = int rand 65536; 1021 $req->[2] = int rand 65536;
787 last unless exists $self->{id}{$req->[2]}; 1022 last unless exists $self->{id}{$req->[2]};
788 } 1023 }
789 1024
1025 ++$self->{outstanding};
790 $self->{id}{$req->[2]} = 1; 1026 $self->{id}{$req->[2]} = 1;
791 substr $req->[0], 0, 2, pack "n", $req->[2]; 1027 substr $req->[0], 0, 2, pack "n", $req->[2];
792 1028
793 ++$self->{outstanding};
794 $self->_exec ($req, 0); 1029 $self->_exec ($req);
795 } 1030 }
796} 1031}
797 1032
798=item $resolver->request ($req, $cb->($res)) 1033=item $resolver->request ($req, $cb->($res))
799 1034
… …
819The callback will be invoked with a list of matching result records or 1054The callback will be invoked with a list of matching result records or
820none on any error or if the name could not be found. 1055none on any error or if the name could not be found.
821 1056
822CNAME chains (although illegal) are followed up to a length of 8. 1057CNAME chains (although illegal) are followed up to a length of 8.
823 1058
824Note that this resolver is just a stub resolver: it requires a nameserver 1059Note that this resolver is just a stub resolver: it requires a name server
825supporting recursive queries, will not do any recursive queries itself and 1060supporting recursive queries, will not do any recursive queries itself and
826is not secure when used against an untrusted name server. 1061is not secure when used against an untrusted name server.
827 1062
828The following options are supported: 1063The following options are supported:
829 1064
… …
905 my %atype = $opt{accept} 1140 my %atype = $opt{accept}
906 ? map +($_ => 1), @{ $opt{accept} } 1141 ? map +($_ => 1), @{ $opt{accept} }
907 : ($qtype => 1); 1142 : ($qtype => 1);
908 1143
909 # advance in searchlist 1144 # advance in searchlist
910 my $do_search; $do_search = sub { 1145 my ($do_search, $do_req);
1146
1147 $do_search = sub {
911 @search 1148 @search
912 or return $cb->(); 1149 or (undef $do_search), (undef $do_req), return $cb->();
913 1150
914 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1151 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
915 my $depth = 2; 1152 my $depth = 2;
916 1153
917 # advance in cname-chain 1154 # advance in cname-chain
918 my $do_req; $do_req = sub { 1155 $do_req = sub {
919 $self->request ({ 1156 $self->request ({
920 rd => 1, 1157 rd => 1,
921 qd => [[$name, $qtype, $class]], 1158 qd => [[$name, $qtype, $class]],
922 }, sub { 1159 }, sub {
923 my ($res) = @_ 1160 my ($res) = @_
… …
927 1164
928 while () { 1165 while () {
929 # results found? 1166 # results found?
930 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 1167 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
931 1168
932 return $cb->(@rr) 1169 (undef $do_search), (undef $do_req), return $cb->(@rr)
933 if @rr; 1170 if @rr;
934 1171
935 # see if there is a cname we can follow 1172 # see if there is a cname we can follow
936 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} }; 1173 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
937 1174
… …
958 }; 1195 };
959 1196
960 $do_search->(); 1197 $do_search->();
961} 1198}
962 1199
1200use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1201
9631; 12021;
964 1203
965=back 1204=back
966 1205
967=head1 AUTHOR 1206=head1 AUTHOR

Diff Legend

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