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.6 by root, Fri May 23 05:16:57 2008 UTC vs.
Revision 1.34 by root, Mon May 26 05:46:35 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
36use AnyEvent qw(WIN32);
26use AnyEvent::Handle (); 37use AnyEvent::Handle ();
27 38
39our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
40
28=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs) 41=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
29 42
30NOT YET IMPLEMENTED
31
32Tries to resolve the given nodename and service name into sockaddr 43Tries to resolve the given nodename and service name into protocol families
33structures usable to connect to this node and service in a 44and sockaddr structures usable to connect to this node and service in a
34protocol-independent way. It works similarly to the getaddrinfo posix 45protocol-independent way. It works remotely similar to the getaddrinfo
35function. 46posix function.
47
48C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
49either a service name (port name from F</etc/services>) or a numerical
50port number. If both C<$node> and C<$service> are names, then SRV records
51will be consulted to find the real service, otherwise they will be
52used as-is. If you know that the service name is not in your services
53database, then you can specify the service in the format C<name=port>
54(e.g. C<http=80>).
55
56C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
57C<sctp>. The default is C<tcp>.
58
59C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
60only IPv4) or C<6> (use only IPv6). This setting might be influenced by
61C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
62
63C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
64C<undef> in which case it gets automatically chosen).
65
66The callback will receive zero or more array references that contain
67C<$family, $type, $proto> for use in C<socket> and a binary
68C<$sockaddr> for use in C<connect> (or C<bind>).
69
70The application should try these in the order given.
36 71
37Example: 72Example:
38 73
39 AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... }; 74 AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
40 75
41=item AnyEvent::DNS::a $domain, $cb->(@addrs) 76=item AnyEvent::DNS::a $domain, $cb->(@addrs)
42 77
43Tries to resolve the given domain to IPv4 address(es). 78Tries to resolve the given domain to IPv4 address(es).
79
80=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
81
82Tries to resolve the given domain to IPv6 address(es).
44 83
45=item AnyEvent::DNS::mx $domain, $cb->(@hostnames) 84=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
46 85
47Tries to resolve the given domain into a sorted (lower preference value 86Tries to resolve the given domain into a sorted (lower preference value
48first) list of domain names. 87first) list of domain names.
… …
58=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 97=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
59 98
60Tries to resolve the given service, protocol and domain name into a list 99Tries to resolve the given service, protocol and domain name into a list
61of service records. 100of service records.
62 101
63Each srv_rr is an arrayref with the following contents: 102Each srv_rr is an array reference with the following contents:
64C<[$priority, $weight, $transport, $target]>. 103C<[$priority, $weight, $transport, $target]>.
65 104
66They will be sorted with lowest priority, highest weight first (TODO: 105They will be sorted with lowest priority, highest weight first (TODO:
67should use the rfc algorithm to reorder same-priority records for weight). 106should use the RFC algorithm to reorder same-priority records for weight).
68 107
69Example: 108Example:
70 109
71 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 110 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
72 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 111 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
… …
74=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames) 113=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
75 114
76Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form) 115Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
77into it's hostname(s). 116into it's hostname(s).
78 117
79Requires the Socket6 module for IPv6 support.
80
81Example: 118Example:
82 119
83 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 120 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
84 # => f.root-servers.net 121 # => f.root-servers.net
85 122
… …
94 131
95sub a($$) { 132sub a($$) {
96 my ($domain, $cb) = @_; 133 my ($domain, $cb) = @_;
97 134
98 resolver->resolve ($domain => "a", sub { 135 resolver->resolve ($domain => "a", sub {
136 $cb->(map $_->[3], @_);
137 });
138}
139
140sub aaaa($$) {
141 my ($domain, $cb) = @_;
142
143 resolver->resolve ($domain => "aaaa", sub {
99 $cb->(map $_->[3], @_); 144 $cb->(map $_->[3], @_);
100 }); 145 });
101} 146}
102 147
103sub mx($$) { 148sub mx($$) {
… …
134} 179}
135 180
136sub ptr($$) { 181sub ptr($$) {
137 my ($ip, $cb) = @_; 182 my ($ip, $cb) = @_;
138 183
139 my $name; 184 $ip = AnyEvent::Socket::parse_ip ($ip)
185 or return $cb->();
140 186
141 if (AnyEvent::Util::dotted_quad $ip) { 187 if (4 == length $ip) {
142 $name = join ".", (reverse split /\./, $ip), "in-addr.arpa."; 188 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
143 } else { 189 } else {
144 require Socket6; 190 $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 } 191 }
150 192
151 resolver->resolve ($name => "ptr", sub { 193 resolver->resolve ($ip => "ptr", sub {
152 $cb->(map $_->[3], @_); 194 $cb->(map $_->[3], @_);
153 }); 195 });
154} 196}
155 197
156sub any($$) { 198sub any($$) {
157 my ($domain, $cb) = @_; 199 my ($domain, $cb) = @_;
158 200
159 resolver->resolve ($domain => "*", $cb); 201 resolver->resolve ($domain => "*", $cb);
160} 202}
161 203
204#############################################################################
205
206sub addr($$$$$$) {
207 my ($node, $service, $proto, $family, $type, $cb) = @_;
208
209 unless (&AnyEvent::Util::AF_INET6) {
210 $family != 6
211 or return $cb->();
212
213 $family ||= 4;
214 }
215
216 $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
217 $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
218
219 $family ||=4 unless $AnyEvent::PROTOCOL{ipv6};
220 $family ||=6 unless $AnyEvent::PROTOCOL{ipv4};
221
222 $proto ||= "tcp";
223 $type ||= $proto eq "udp" ? SOCK_DGRAM : SOCK_STREAM;
224
225 my $proton = (getprotobyname $proto)[2]
226 or Carp::croak "$proto: protocol unknown";
227
228 my $port;
229
230 if ($service =~ /^(\S+)=(\d+)$/) {
231 ($service, $port) = ($1, $2);
232 } elsif ($service =~ /^\d+$/) {
233 ($service, $port) = (undef, $service);
234 } else {
235 $port = (getservbyname $service, $proto)[2]
236 or Carp::croak "$service/$proto: service unknown";
237 }
238
239 my @target = [$node, $port];
240
241 # resolve a records / provide sockaddr structures
242 my $resolve = sub {
243 my @res;
244 my $cv = AnyEvent->condvar (cb => sub {
245 $cb->(
246 map $_->[2],
247 sort {
248 $AnyEvent::PROTOCOL{$b->[1]} <=> $AnyEvent::PROTOCOL{$a->[1]}
249 or $a->[0] <=> $b->[0]
250 }
251 @res
252 )
253 });
254
255 $cv->begin;
256 for my $idx (0 .. $#target) {
257 my ($node, $port) = @{ $target[$idx] };
258
259 if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
260 if (4 == length $noden && $family != 6) {
261 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
262 AnyEvent::Socket::pack_sockaddr ($port, $noden)]]
263 }
264
265 if (16 == length $noden && $family != 4) {
266 push @res, [$idx, "ipv6", [&AnyEvent::Util::AF_INET6, $type, $proton,
267 AnyEvent::Socket::pack_sockaddr ( $port, $noden)]]
268 }
269 } else {
270 # ipv4
271 if ($family != 6) {
272 $cv->begin;
273 a $node, sub {
274 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
275 AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv4 ($_))]]
276 for @_;
277 $cv->end;
278 };
279 }
280
281 # ipv6
282 if ($family != 4) {
283 $cv->begin;
284 aaaa $node, sub {
285 push @res, [$idx, "ipv6", [&AnyEvent::Socket::AF_INET6, $type, $proton,
286 AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv6 ($_))]]
287 for @_;
288 $cv->end;
289 };
290 }
291 }
292 }
293 $cv->end;
294 };
295
296 # try srv records, if applicable
297 if ($node eq "localhost") {
298 @target = (["127.0.0.1", $port], ["::1", $port]);
299 &$resolve;
300 } elsif (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
301 srv $service, $proto, $node, sub {
302 my (@srv) = @_;
303
304 # no srv records, continue traditionally
305 @srv
306 or return &$resolve;
307
308 # only srv record has "." => abort
309 $srv[0][2] ne "." || $#srv
310 or return $cb->();
311
312 # use srv records then
313 @target = map ["$_->[3].", $_->[2]],
314 grep $_->[3] ne ".",
315 @srv;
316
317 &$resolve;
318 };
319 } else {
320 &$resolve;
321 }
322}
323
324#############################################################################
325
326=back
327
162=head2 DNS EN-/DECODING FUNCTIONS 328=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
163 329
164=over 4 330=over 4
165 331
332=item $AnyEvent::DNS::EDNS0
333
334This variable decides whether dns_pack automatically enables EDNS0
335support. By default, this is disabled (C<0>), unless overridden by
336C<$ENV{PERL_ANYEVENT_EDNS0>), but when set to C<1>, AnyEvent::DNS will use
337EDNS0 in all requests.
338
166=cut 339=cut
340
341our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
167 342
168our %opcode_id = ( 343our %opcode_id = (
169 query => 0, 344 query => 0,
170 iquery => 1, 345 iquery => 1,
171 status => 2, 346 status => 2,
… …
240); 415);
241 416
242our %class_str = reverse %class_id; 417our %class_str = reverse %class_id;
243 418
244# names MUST have a trailing dot 419# names MUST have a trailing dot
245sub _enc_qname($) { 420sub _enc_name($) {
246 pack "(C/a)*", (split /\./, shift), "" 421 pack "(C/a*)*", (split /\./, shift), ""
247} 422}
248 423
249sub _enc_qd() { 424sub _enc_qd() {
250 (_enc_qname $_->[0]) . pack "nn", 425 (_enc_name $_->[0]) . pack "nn",
251 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}), 426 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
252 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"}) 427 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"})
253} 428}
254 429
255sub _enc_rr() { 430sub _enc_rr() {
… …
293=cut 468=cut
294 469
295sub dns_pack($) { 470sub dns_pack($) {
296 my ($req) = @_; 471 my ($req) = @_;
297 472
298 pack "nn nnnn a* a* a* a*", 473 pack "nn nnnn a* a* a* a* a*",
299 $req->{id}, 474 $req->{id},
300 475
301 ! !$req->{qr} * 0x8000 476 ! !$req->{qr} * 0x8000
302 + $opcode_id{$req->{op}} * 0x0800 477 + $opcode_id{$req->{op}} * 0x0800
303 + ! !$req->{aa} * 0x0400 478 + ! !$req->{aa} * 0x0400
… …
309 + $rcode_id{$req->{rc}} * 0x0001, 484 + $rcode_id{$req->{rc}} * 0x0001,
310 485
311 scalar @{ $req->{qd} || [] }, 486 scalar @{ $req->{qd} || [] },
312 scalar @{ $req->{an} || [] }, 487 scalar @{ $req->{an} || [] },
313 scalar @{ $req->{ns} || [] }, 488 scalar @{ $req->{ns} || [] },
314 scalar @{ $req->{ar} || [] }, 489 $EDNS0 + scalar @{ $req->{ar} || [] }, # include EDNS0 option here
315 490
316 (join "", map _enc_qd, @{ $req->{qd} || [] }), 491 (join "", map _enc_qd, @{ $req->{qd} || [] }),
317 (join "", map _enc_rr, @{ $req->{an} || [] }), 492 (join "", map _enc_rr, @{ $req->{an} || [] }),
318 (join "", map _enc_rr, @{ $req->{ns} || [] }), 493 (join "", map _enc_rr, @{ $req->{ns} || [] }),
319 (join "", map _enc_rr, @{ $req->{ar} || [] }); 494 (join "", map _enc_rr, @{ $req->{ar} || [] }),
495
496 ($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size
320} 497}
321 498
322our $ofs; 499our $ofs;
323our $pkt; 500our $pkt;
324 501
325# bitches 502# bitches
326sub _dec_qname { 503sub _dec_name {
327 my @res; 504 my @res;
328 my $redir; 505 my $redir;
329 my $ptr = $ofs; 506 my $ptr = $ofs;
330 my $cnt; 507 my $cnt;
331 508
332 while () { 509 while () {
333 return undef if ++$cnt >= 256; # to avoid DoS attacks 510 return undef if ++$cnt >= 256; # to avoid DoS attacks
334 511
335 my $len = ord substr $pkt, $ptr++, 1; 512 my $len = ord substr $pkt, $ptr++, 1;
336 513
337 if ($len & 0xc0) { 514 if ($len >= 0xc0) {
338 $ptr++; 515 $ptr++;
339 $ofs = $ptr if $ptr > $ofs; 516 $ofs = $ptr if $ptr > $ofs;
340 $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff; 517 $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
341 } elsif ($len) { 518 } elsif ($len) {
342 push @res, substr $pkt, $ptr, $len; 519 push @res, substr $pkt, $ptr, $len;
… …
347 } 524 }
348 } 525 }
349} 526}
350 527
351sub _dec_qd { 528sub _dec_qd {
352 my $qname = _dec_qname; 529 my $qname = _dec_name;
353 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 530 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
354 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 531 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
355} 532}
356 533
357our %dec_rr = ( 534our %dec_rr = (
358 1 => sub { Socket::inet_ntoa $_ }, # a 535 1 => sub { join ".", unpack "C4", $_ }, # a
359 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 536 2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
360 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 537 5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
361 6 => sub { 538 6 => sub {
362 local $ofs = $ofs - length; 539 local $ofs = $ofs - length;
363 my $mname = _dec_qname; 540 my $mname = _dec_name;
364 my $rname = _dec_qname; 541 my $rname = _dec_name;
365 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 542 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
366 }, # soa 543 }, # soa
367 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks 544 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
368 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 545 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
369 13 => sub { unpack "C/a C/a", $_ }, # hinfo 546 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
370 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 547 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
371 16 => sub { unpack "(C/a)*", $_ }, # txt 548 16 => sub { unpack "(C/a*)*", $_ }, # txt
372 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 549 28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
373 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 550 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
374 99 => sub { unpack "(C/a)*", $_ }, # spf 551 99 => sub { unpack "(C/a*)*", $_ }, # spf
375); 552);
376 553
377sub _dec_rr { 554sub _dec_rr {
378 my $qname = _dec_qname; 555 my $name = _dec_name;
379 556
380 my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10; 557 my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
381 local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen; 558 local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
382 559
383 [ 560 [
384 $qname, 561 $name,
385 $type_str{$rt} || $rt, 562 $type_str{$rt} || $rt,
386 $class_str{$rc} || $rc, 563 $class_str{$rc} || $rc,
387 ($dec_rr{$rt} || sub { $_ })->(), 564 ($dec_rr{$rt} || sub { $_ })->(),
388 ] 565 ]
389} 566}
… …
392 569
393Unpacks a DNS packet into a perl data structure. 570Unpacks a DNS packet into a perl data structure.
394 571
395Examples: 572Examples:
396 573
397 # a non-successful reply 574 # an unsuccessful reply
398 { 575 {
399 'qd' => [ 576 'qd' => [
400 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] 577 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
401 ], 578 ],
402 'rc' => 'nxdomain', 579 'rc' => 'nxdomain',
… …
406 'uni-karlsruhe.de', 583 'uni-karlsruhe.de',
407 'soa', 584 'soa',
408 'in', 585 'in',
409 'netserv.rz.uni-karlsruhe.de', 586 'netserv.rz.uni-karlsruhe.de',
410 'hostmaster.rz.uni-karlsruhe.de', 587 'hostmaster.rz.uni-karlsruhe.de',
411 2008052201, 588 2008052201, 10800, 1800, 2592000, 86400
412 10800,
413 1800,
414 2592000,
415 86400
416 ] 589 ]
417 ], 590 ],
418 'tc' => '', 591 'tc' => '',
419 'ra' => 1, 592 'ra' => 1,
420 'qr' => 1, 593 'qr' => 1,
… …
486 659
487=back 660=back
488 661
489=head2 THE AnyEvent::DNS RESOLVER CLASS 662=head2 THE AnyEvent::DNS RESOLVER CLASS
490 663
491This is the class which deos the actual protocol work. 664This is the class which does the actual protocol work.
492 665
493=over 4 666=over 4
494 667
495=cut 668=cut
496 669
… …
516our $RESOLVER; 689our $RESOLVER;
517 690
518sub resolver() { 691sub resolver() {
519 $RESOLVER || do { 692 $RESOLVER || do {
520 $RESOLVER = new AnyEvent::DNS; 693 $RESOLVER = new AnyEvent::DNS;
521 $RESOLVER->load_resolv_conf; 694 $RESOLVER->os_config;
522 $RESOLVER 695 $RESOLVER
523 } 696 }
524} 697}
525 698
526=item $resolver = new AnyEvent::DNS key => value... 699=item $resolver = new AnyEvent::DNS key => value...
… …
531 704
532=over 4 705=over 4
533 706
534=item server => [...] 707=item server => [...]
535 708
536A list of server addressses (default C<v127.0.0.1>) in network format (4 709A list of server addresses (default: C<v127.0.0.1>) in network format (4
537octets for IPv4, 16 octets for IPv6 - not yet supported). 710octets for IPv4, 16 octets for IPv6 - not yet supported).
538 711
539=item timeout => [...] 712=item timeout => [...]
540 713
541A list of timeouts to use (also determines the number of retries). To make 714A list of timeouts to use (also determines the number of retries). To make
… …
552tries to resolve the name without any suffixes first. 725tries to resolve the name without any suffixes first.
553 726
554=item max_outstanding => $integer 727=item max_outstanding => $integer
555 728
556Most name servers do not handle many parallel requests very well. This option 729Most name servers do not handle many parallel requests very well. This option
557limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means 730limits the number of outstanding requests to C<$n> (default: C<10>), that means
558if you request more than this many requests, then the additional requests will be queued 731if you request more than this many requests, then the additional requests will be queued
559until some other requests have been resolved. 732until some other requests have been resolved.
560 733
734=item reuse => $seconds
735
736The number of seconds (default: C<300>) that a query id cannot be re-used
737after a timeout. If there as no time-out then query id's can be reused
738immediately.
739
561=back 740=back
562 741
563=cut 742=cut
564 743
565sub new { 744sub new {
566 my ($class, %arg) = @_; 745 my ($class, %arg) = @_;
567 746
568 socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0 747 socket my $fh, AF_INET, &Socket::SOCK_DGRAM, 0
569 or Carp::croak "socket: $!"; 748 or Carp::croak "socket: $!";
570 749
571 AnyEvent::Util::fh_nonblocking $fh, 1; 750 AnyEvent::Util::fh_nonblocking $fh, 1;
572 751
573 my $self = bless { 752 my $self = bless {
574 server => [v127.0.0.1], 753 server => [],
575 timeout => [2, 5, 5], 754 timeout => [2, 5, 5],
576 search => [], 755 search => [],
577 ndots => 1, 756 ndots => 1,
578 max_outstanding => 10, 757 max_outstanding => 10,
579 reuse => 300, # reuse id's after 5 minutes only, if possible 758 reuse => 300, # reuse id's after 5 minutes only, if possible
… …
593 $self 772 $self
594} 773}
595 774
596=item $resolver->parse_resolv_conv ($string) 775=item $resolver->parse_resolv_conv ($string)
597 776
598Parses the given string a sif it were a F<resolv.conf> file. The following 777Parses the given string as if it were a F<resolv.conf> file. The following
599directives are supported: 778directives are supported (but not necessarily implemented).
600 779
601C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 780C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
602C<options> (C<timeout>, C<attempts>, C<ndots>). 781C<options> (C<timeout>, C<attempts>, C<ndots>).
603 782
604Everything else is silently ignored. 783Everything else is silently ignored.
… …
616 for (split /\n/, $resolvconf) { 795 for (split /\n/, $resolvconf) {
617 if (/^\s*#/) { 796 if (/^\s*#/) {
618 # comment 797 # comment
619 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { 798 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
620 my $ip = $1; 799 my $ip = $1;
621 if (AnyEvent::Util::dotted_quad $ip) { 800 if (my $ipn = AnyEvent::Socket::parse_ip ($ip)) {
622 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; 801 push @{ $self->{server} }, $ipn;
623 } else { 802 } else {
624 warn "nameserver $ip invalid and ignored\n"; 803 warn "nameserver $ip invalid and ignored\n";
625 } 804 }
626 } elsif (/^\s*domain\s+(\S*)\s+$/i) { 805 } elsif (/^\s*domain\s+(\S*)\s+$/i) {
627 $self->{search} = [$1]; 806 $self->{search} = [$1];
… …
648 if $attempts; 827 if $attempts;
649 828
650 $self->_compile; 829 $self->_compile;
651} 830}
652 831
653=item $resolver->load_resolv_conf 832=item $resolver->os_config
654 833
655Tries to load and parse F</etc/resolv.conf>. If there will ever be windows 834Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various
656support, then this function will do the right thing under windows, too. 835egregious hacks on windows to force the DNS servers and searchlist out of the system.
657 836
658=cut 837=cut
659 838
660sub load_resolv_conf { 839sub os_config {
661 my ($self) = @_; 840 my ($self) = @_;
662 841
842 $self->{server} = [];
843 $self->{search} = [];
844
845 if (WIN32 || $^O =~ /cygwin/i) {
846 no strict 'refs';
847
848 # there are many options to find the current nameservers etc. on windows
849 # all of them don't work consistently:
850 # - the registry thing needs separate code on win32 native vs. cygwin
851 # - the registry layout differs between windows versions
852 # - calling windows api functions doesn't work on cygwin
853 # - ipconfig uses locale-specific messages
854
855 # we use ipconfig parsing because, despite all it's brokenness,
856 # it seems most stable in practise.
857 # for good measure, we append a fallback nameserver to our list.
858
859 if (open my $fh, "ipconfig /all |") {
860 # parsing strategy: we go through the output and look for
861 # :-lines with DNS in them. everything in those is regarded as
862 # either a nameserver (if it parses as an ip address), or a suffix
863 # (all else).
864
865 my $dns;
866 while (<$fh>) {
867 if (s/^\s.*\bdns\b.*://i) {
868 $dns = 1;
869 } elsif (/^\S/ || /^\s[^:]{16,}: /) {
870 $dns = 0;
871 }
872 if ($dns && /^\s*(\S+)\s*$/) {
873 my $s = $1;
874 $s =~ s/%\d+(?!\S)//; # get rid of scope id
875 if (my $ipn = AnyEvent::Socket::parse_ip ($s)) {
876 push @{ $self->{server} }, $ipn;
877 } else {
878 push @{ $self->{search} }, $s;
879 }
880 }
881 }
882
883 # always add one fallback server
884 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
885
886 $self->_compile;
887 }
888 } else {
889 # try resolv.conf everywhere
890
663 open my $fh, "</etc/resolv.conf" 891 if (open my $fh, "</etc/resolv.conf") {
664 or return;
665
666 local $/; 892 local $/;
667 $self->parse_resolv_conf (<$fh>); 893 $self->parse_resolv_conf (<$fh>);
894 }
895 }
668} 896}
669 897
670sub _compile { 898sub _compile {
671 my $self = shift; 899 my $self = shift;
900
901 # we currently throw away all ipv6 nameservers, we do not yet support those
902
903 my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
904 my %server; $self->{server} = [grep 4 == length, grep !$server{$_}++, @{ $self->{server} }];
905
906 unless (@{ $self->{server} }) {
907 # use 127.0.0.1 by default, and one opendns nameserver as fallback
908 $self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
909 }
672 910
673 my @retry; 911 my @retry;
674 912
675 for my $timeout (@{ $self->{timeout} }) { 913 for my $timeout (@{ $self->{timeout} }) {
676 for my $server (@{ $self->{server} }) { 914 for my $server (@{ $self->{server} }) {
… …
696} 934}
697 935
698sub _recv { 936sub _recv {
699 my ($self) = @_; 937 my ($self) = @_;
700 938
939 # we ignore errors (often one gets port unreachable, but there is
940 # no good way to take advantage of that.
701 while (my $peer = recv $self->{fh}, my $res, 1024, 0) { 941 while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
702 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 942 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
703 943
704 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 944 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
705 945
706 $self->_feed ($res); 946 $self->_feed ($res);
707 } 947 }
708} 948}
709 949
950sub _free_id {
951 my ($self, $id, $timeout) = @_;
952
953 if ($timeout) {
954 # we need to block the id for a while
955 $self->{id}{$id} = 1;
956 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
957 } else {
958 # we can quickly recycle the id
959 delete $self->{id}{$id};
960 }
961
962 --$self->{outstanding};
963 $self->_scheduler;
964}
965
966# execute a single request, involves sending it with timeouts to multiple servers
710sub _exec { 967sub _exec {
711 my ($self, $req, $retry) = @_; 968 my ($self, $req) = @_;
712 969
970 my $retry; # of retries
971 my $do_retry;
972
973 $do_retry = sub {
713 if (my $retry_cfg = $self->{retry}[$retry]) { 974 my $retry_cfg = $self->{retry}[$retry++]
975 or do {
976 # failure
977 $self->_free_id ($req->[2], $retry > 1);
978 undef $do_retry; return $req->[1]->();
979 };
980
714 my ($server, $timeout) = @$retry_cfg; 981 my ($server, $timeout) = @$retry_cfg;
715 982
716 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 983 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
717 $NOW = time; 984 $NOW = time;
718 985
719 # timeout, try next 986 # timeout, try next
720 $self->_exec ($req, $retry + 1); 987 &$do_retry;
721 }), sub { 988 }), sub {
722 my ($res) = @_; 989 my ($res) = @_;
723 990
724 if ($res->{tc}) { 991 if ($res->{tc}) {
725 # success, but truncated, so use tcp 992 # success, but truncated, so use tcp
726 AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub { 993 AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
727 my ($fh) = @_ 994 my ($fh) = @_
728 or return $self->_exec ($req, $retry + 1); 995 or return &$do_retry;
729 996
730 my $handle = new AnyEvent::Handle 997 my $handle = new AnyEvent::Handle
731 fh => $fh, 998 fh => $fh,
732 on_error => sub { 999 on_error => sub {
733 # failure, try next 1000 # failure, try next
734 $self->_exec ($req, $retry + 1); 1001 &$do_retry;
735 }; 1002 };
736 1003
737 $handle->push_write (pack "n/a", $req->[0]); 1004 $handle->push_write (pack "n/a", $req->[0]);
738 $handle->push_read_chunk (2, sub { 1005 $handle->push_read (chunk => 2, sub {
739 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { 1006 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
740 $self->_feed ($_[1]); 1007 $self->_feed ($_[1]);
741 }); 1008 });
742 }); 1009 });
743 shutdown $fh, 1; 1010 shutdown $fh, 1;
744 1011
745 }, sub { $timeout }; 1012 }, sub { $timeout });
746 1013
747 } else { 1014 } else {
748 # success 1015 # success
749 $self->{id}{$req->[2]} = 1; 1016 $self->_free_id ($req->[2], $retry > 1);
750 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 1017 undef $do_retry; return $req->[1]->($res);
751 --$self->{outstanding};
752 $self->_scheduler;
753
754 $req->[1]->($res);
755 } 1018 }
756 }]; 1019 }];
757 1020
758 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 1021 send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);
759 } else {
760 # failure
761 $self->{id}{$req->[2]} = 1;
762 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
763 --$self->{outstanding};
764 $self->_scheduler;
765
766 $req->[1]->();
767 } 1022 };
1023
1024 &$do_retry;
768} 1025}
769 1026
770sub _scheduler { 1027sub _scheduler {
771 my ($self) = @_; 1028 my ($self) = @_;
772 1029
773 $NOW = time; 1030 $NOW = time;
774 1031
775 # first clear id reuse queue 1032 # first clear id reuse queue
776 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] } 1033 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
777 while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW; 1034 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
778 1035
779 while ($self->{outstanding} < $self->{max_outstanding}) { 1036 while ($self->{outstanding} < $self->{max_outstanding}) {
1037
1038 if (@{ $self->{reuse_q} } >= 30000) {
1039 # we ran out of ID's, wait a bit
1040 $self->{reuse_to} ||= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
1041 delete $self->{reuse_to};
1042 $self->_scheduler;
1043 });
1044 last;
1045 }
1046
780 my $req = shift @{ $self->{queue} } 1047 my $req = shift @{ $self->{queue} }
781 or last; 1048 or last;
782 1049
783 while () { 1050 while () {
784 $req->[2] = int rand 65536; 1051 $req->[2] = int rand 65536;
785 last unless exists $self->{id}{$req->[2]}; 1052 last unless exists $self->{id}{$req->[2]};
786 } 1053 }
787 1054
1055 ++$self->{outstanding};
788 $self->{id}{$req->[2]} = 1; 1056 $self->{id}{$req->[2]} = 1;
789 substr $req->[0], 0, 2, pack "n", $req->[2]; 1057 substr $req->[0], 0, 2, pack "n", $req->[2];
790 1058
791 ++$self->{outstanding};
792 $self->_exec ($req, 0); 1059 $self->_exec ($req);
793 } 1060 }
794} 1061}
795 1062
796=item $resolver->request ($req, $cb->($res)) 1063=item $resolver->request ($req, $cb->($res))
797 1064
… …
817The callback will be invoked with a list of matching result records or 1084The callback will be invoked with a list of matching result records or
818none on any error or if the name could not be found. 1085none on any error or if the name could not be found.
819 1086
820CNAME chains (although illegal) are followed up to a length of 8. 1087CNAME chains (although illegal) are followed up to a length of 8.
821 1088
822Note that this resolver is just a stub resolver: it requires a nameserver 1089Note that this resolver is just a stub resolver: it requires a name server
823supporting recursive queries, will not do any recursive queries itself and 1090supporting recursive queries, will not do any recursive queries itself and
824is not secure when used against an untrusted name server. 1091is not secure when used against an untrusted name server.
825 1092
826The following options are supported: 1093The following options are supported:
827 1094
… …
903 my %atype = $opt{accept} 1170 my %atype = $opt{accept}
904 ? map +($_ => 1), @{ $opt{accept} } 1171 ? map +($_ => 1), @{ $opt{accept} }
905 : ($qtype => 1); 1172 : ($qtype => 1);
906 1173
907 # advance in searchlist 1174 # advance in searchlist
908 my $do_search; $do_search = sub { 1175 my ($do_search, $do_req);
1176
1177 $do_search = sub {
909 @search 1178 @search
910 or return $cb->(); 1179 or (undef $do_search), (undef $do_req), return $cb->();
911 1180
912 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1181 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
913 my $depth = 2; 1182 my $depth = 2;
914 1183
915 # advance in cname-chain 1184 # advance in cname-chain
916 my $do_req; $do_req = sub { 1185 $do_req = sub {
917 $self->request ({ 1186 $self->request ({
918 rd => 1, 1187 rd => 1,
919 qd => [[$name, $qtype, $class]], 1188 qd => [[$name, $qtype, $class]],
920 }, sub { 1189 }, sub {
921 my ($res) = @_ 1190 my ($res) = @_
… …
925 1194
926 while () { 1195 while () {
927 # results found? 1196 # results found?
928 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 1197 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
929 1198
930 return $cb->(@rr) 1199 (undef $do_search), (undef $do_req), return $cb->(@rr)
931 if @rr; 1200 if @rr;
932 1201
933 # see if there is a cname we can follow 1202 # see if there is a cname we can follow
934 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} }; 1203 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
935 1204
… …
956 }; 1225 };
957 1226
958 $do_search->(); 1227 $do_search->();
959} 1228}
960 1229
1230use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1231
9611; 12321;
962 1233
963=back 1234=back
964 1235
965=head1 AUTHOR 1236=head1 AUTHOR

Diff Legend

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