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

Diff Legend

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