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.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.25 by root, Sat May 24 17:21:50 2008 UTC

… …
9=head1 DESCRIPTION 9=head1 DESCRIPTION
10 10
11This module offers both a number of DNS convenience functions as well 11This module offers both a number of DNS convenience functions as well
12as a fully asynchronous and high-performance pure-perl stub resolver. 12as a fully asynchronous and high-performance pure-perl stub resolver.
13 13
14The stub resolver supports DNS over UDP, optional EDNS0 support for up to
154kiB datagrams and automatically falls back to virtual circuit mode for
16large responses.
17
14=head2 CONVENIENCE FUNCTIONS 18=head2 CONVENIENCE FUNCTIONS
15 19
16=over 4 20=over 4
17 21
18=cut 22=cut
… …
20package AnyEvent::DNS; 24package AnyEvent::DNS;
21 25
22no warnings; 26no warnings;
23use strict; 27use strict;
24 28
25use AnyEvent::Util (); 29use AnyEvent::Handle ();
26 30
27=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs) 31=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
28 32
29NOT YET IMPLEMENTED
30
31Tries to resolve the given nodename and service name into sockaddr 33Tries to resolve the given nodename and service name into protocol families
32structures usable to connect to this node and service in a 34and sockaddr structures usable to connect to this node and service in a
33protocol-independent way. It works similarly to the getaddrinfo posix 35protocol-independent way. It works remotely similar to the getaddrinfo
34function. 36posix function.
37
38C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
39either a service name (port name from F</etc/services>) or a numerical
40port number. If both C<$node> and C<$service> are names, then SRV records
41will be consulted to find the real service, otherwise they will be
42used as-is. If you know that the service name is not in your services
43database, then you can specify the service in the format C<name=port>
44(e.g. C<http=80>).
45
46C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
47C<sctp>. The default is C<tcp>.
48
49C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
50only IPv4) or C<6> (use only IPv6). This setting might be influenced by
51C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
52
53C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
54C<undef> in which case it gets automatically chosen).
55
56The callback will receive zero or more array references that contain
57C<$family, $type, $proto> for use in C<socket> and a binary
58C<$sockaddr> for use in C<connect> (or C<bind>).
59
60The application should try these in the order given.
35 61
36Example: 62Example:
37 63
38 AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... }; 64 AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
39 65
40=item AnyEvent::DNS::a $domain, $cb->(@addrs) 66=item AnyEvent::DNS::a $domain, $cb->(@addrs)
41 67
42Tries to resolve the given domain to IPv4 address(es). 68Tries to resolve the given domain to IPv4 address(es).
69
70=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
71
72Tries to resolve the given domain to IPv6 address(es).
43 73
44=item AnyEvent::DNS::mx $domain, $cb->(@hostnames) 74=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
45 75
46Tries to resolve the given domain into a sorted (lower preference value 76Tries to resolve the given domain into a sorted (lower preference value
47first) list of domain names. 77first) list of domain names.
… …
57=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 87=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
58 88
59Tries to resolve the given service, protocol and domain name into a list 89Tries to resolve the given service, protocol and domain name into a list
60of service records. 90of service records.
61 91
62Each srv_rr is an arrayref with the following contents: 92Each srv_rr is an array reference with the following contents:
63C<[$priority, $weight, $transport, $target]>. 93C<[$priority, $weight, $transport, $target]>.
64 94
65They will be sorted with lowest priority, highest weight first (TODO: 95They will be sorted with lowest priority, highest weight first (TODO:
66should use the rfc algorithm to reorder same-priority records for weight). 96should use the RFC algorithm to reorder same-priority records for weight).
67 97
68Example: 98Example:
69 99
70 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 100 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
71 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 101 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
… …
73=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames) 103=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
74 104
75Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form) 105Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
76into it's hostname(s). 106into it's hostname(s).
77 107
78Requires the Socket6 module for IPv6 support.
79
80Example: 108Example:
81 109
82 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 110 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
83 # => f.root-servers.net 111 # => f.root-servers.net
84 112
113=item AnyEvent::DNS::any $domain, $cb->(@rrs)
114
115Tries to resolve the given domain and passes all resource records found to
116the callback.
117
85=cut 118=cut
86 119
87sub resolver; 120sub resolver;
88 121
89sub a($$) { 122sub a($$) {
90 my ($domain, $cb) = @_; 123 my ($domain, $cb) = @_;
91 124
92 resolver->resolve ($domain => "a", sub { 125 resolver->resolve ($domain => "a", sub {
126 $cb->(map $_->[3], @_);
127 });
128}
129
130sub aaaa($$) {
131 my ($domain, $cb) = @_;
132
133 resolver->resolve ($domain => "aaaa", sub {
93 $cb->(map $_->[3], @_); 134 $cb->(map $_->[3], @_);
94 }); 135 });
95} 136}
96 137
97sub mx($$) { 138sub mx($$) {
… …
128} 169}
129 170
130sub ptr($$) { 171sub ptr($$) {
131 my ($ip, $cb) = @_; 172 my ($ip, $cb) = @_;
132 173
133 my $name; 174 $ip = AnyEvent::Socket::parse_ip ($ip)
175 or return $cb->();
134 176
135 if (AnyEvent::Util::dotted_quad $ip) { 177 if (4 == length $ip) {
136 $name = join ".", (reverse split /\./, $ip), "in-addr.arpa."; 178 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
137 } else { 179 } else {
138 require Socket6; 180 $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
139 $name = join ".",
140 (reverse split //,
141 unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
142 "ip6.arpa.";
143 } 181 }
144 182
145 resolver->resolve ($name => "ptr", sub { 183 resolver->resolve ($ip => "ptr", sub {
146 $cb->(map $_->[3], @_); 184 $cb->(map $_->[3], @_);
147 }); 185 });
148} 186}
149 187
188sub any($$) {
189 my ($domain, $cb) = @_;
190
191 resolver->resolve ($domain => "*", $cb);
192}
193
194#############################################################################
195
196sub addr($$$$$$) {
197 my ($node, $service, $proto, $family, $type, $cb) = @_;
198
199 unless (&AnyEvent::Socket::AF_INET6) {
200 $family != 6
201 or return $cb->();
202
203 $family ||= 4;
204 }
205
206 $cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
207 $cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
208
209 $family ||=4 unless $AnyEvent::PROTOCOL{ipv6};
210 $family ||=6 unless $AnyEvent::PROTOCOL{ipv4};
211
212 $proto ||= "tcp";
213 $type ||= $proto eq "udp" ? Socket::SOCK_DGRAM : Socket::SOCK_STREAM;
214
215 my $proton = (getprotobyname $proto)[2]
216 or Carp::croak "$proto: protocol unknown";
217
218 my $port;
219
220 if ($service =~ /^(\S+)=(\d+)$/) {
221 ($service, $port) = ($1, $2);
222 } elsif ($service =~ /^\d+$/) {
223 ($service, $port) = (undef, $service);
224 } else {
225 $port = (getservbyname $service, $proto)[2]
226 or Carp::croak "$service/$proto: service unknown";
227 }
228
229 my @target = [$node, $port];
230
231 # resolve a records / provide sockaddr structures
232 my $resolve = sub {
233 my @res;
234 my $cv = AnyEvent->condvar (cb => sub {
235 $cb->(
236 map $_->[2],
237 sort {
238 $AnyEvent::PROTOCOL{$a->[1]} <=> $AnyEvent::PROTOCOL{$b->[1]}
239 or $a->[0] <=> $b->[0]
240 }
241 @res
242 )
243 });
244
245 $cv->begin;
246 for my $idx (0 .. $#target) {
247 my ($node, $port) = @{ $target[$idx] };
248
249 if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
250 if (4 == length $noden && $family != 6) {
251 push @res, [$idx, "ipv4", [Socket::AF_INET, $type, $proton,
252 AnyEvent::Socket::pack_sockaddr ($port, $noden)]]
253 }
254
255 if (16 == length $noden && $family != 4) {
256 push @res, [$idx, "ipv6", [&AnyEvent::Socket::AF_INET6, $type, $proton,
257 AnyEvent::Socket::pack_sockaddr ( $port, $noden)]]
258 }
259 } else {
260 # ipv4
261 if ($family != 6) {
262 $cv->begin;
263 a $node, sub {
264 push @res, [$idx, "ipv4", [Socket::AF_INET, $type, $proton,
265 AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv4 ($_))]]
266 for @_;
267 $cv->end;
268 };
269 }
270
271 # ipv6
272 if ($family != 4) {
273 $cv->begin;
274 aaaa $node, sub {
275 push @res, [$idx, "ipv6", [&AnyEvent::Socket::AF_INET6, $type, $proton,
276 AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv6 ($_))]]
277 for @_;
278 $cv->end;
279 };
280 }
281 }
282 }
283 $cv->end;
284 };
285
286 # try srv records, if applicable
287 if ($node eq "localhost") {
288 @target = (["127.0.0.1", $port], ["::1", $port]);
289 &$resolve;
290 } elsif (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
291 srv $service, $proto, $node, sub {
292 my (@srv) = @_;
293
294 # no srv records, continue traditionally
295 @srv
296 or return &$resolve;
297
298 # only srv record has "." => abort
299 $srv[0][2] ne "." || $#srv
300 or return $cb->();
301
302 # use srv records then
303 @target = map ["$_->[3].", $_->[2]],
304 grep $_->[3] ne ".",
305 @srv;
306
307 &$resolve;
308 };
309 } else {
310 &$resolve;
311 }
312}
313
314#############################################################################
315
316=back
317
150=head2 DNS EN-/DECODING FUNCTIONS 318=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
151 319
152=over 4 320=over 4
153 321
322=item $AnyEvent::DNS::EDNS0
323
324This variable decides whether dns_pack automatically enables EDNS0
325support. By default, this is disabled (C<0>), unless overridden by
326C<$ENV{PERL_ANYEVENT_EDNS0>), but when set to C<1>, AnyEvent::DNS will use
327EDNS0 in all requests.
328
154=cut 329=cut
330
331our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
155 332
156our %opcode_id = ( 333our %opcode_id = (
157 query => 0, 334 query => 0,
158 iquery => 1, 335 iquery => 1,
159 status => 2, 336 status => 2,
337 notify => 4,
338 update => 5,
160 map +($_ => $_), 3..15 339 map +($_ => $_), 3, 6..15
161); 340);
162 341
163our %opcode_str = reverse %opcode_id; 342our %opcode_str = reverse %opcode_id;
164 343
165our %rcode_id = ( 344our %rcode_id = (
166 noerror => 0, 345 noerror => 0,
167 formerr => 1, 346 formerr => 1,
168 servfail => 2, 347 servfail => 2,
169 nxdomain => 3, 348 nxdomain => 3,
170 notimp => 4, 349 notimp => 4,
171 refused => 5, 350 refused => 5,
351 yxdomain => 6, # Name Exists when it should not [RFC 2136]
352 yxrrset => 7, # RR Set Exists when it should not [RFC 2136]
353 nxrrset => 8, # RR Set that should exist does not [RFC 2136]
354 notauth => 9, # Server Not Authoritative for zone [RFC 2136]
355 notzone => 10, # Name not contained in zone [RFC 2136]
356# EDNS0 16 BADVERS Bad OPT Version [RFC 2671]
357# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845]
358# EDNS0 17 BADKEY Key not recognized [RFC 2845]
359# EDNS0 18 BADTIME Signature out of time window [RFC 2845]
360# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930]
361# EDNS0 20 BADNAME Duplicate key name [RFC 2930]
362# EDNS0 21 BADALG Algorithm not supported [RFC 2930]
172 map +($_ => $_), 6..15 363 map +($_ => $_), 11..15
173); 364);
174 365
175our %rcode_str = reverse %rcode_id; 366our %rcode_str = reverse %rcode_id;
176 367
177our %type_id = ( 368our %type_id = (
… …
191 minfo => 14, 382 minfo => 14,
192 mx => 15, 383 mx => 15,
193 txt => 16, 384 txt => 16,
194 aaaa => 28, 385 aaaa => 28,
195 srv => 33, 386 srv => 33,
387 opt => 41,
388 spf => 99,
389 tkey => 249,
390 tsig => 250,
391 ixfr => 251,
196 axfr => 252, 392 axfr => 252,
197 mailb => 253, 393 mailb => 253,
198 "*" => 255, 394 "*" => 255,
199); 395);
200 396
201our %type_str = reverse %type_id; 397our %type_str = reverse %type_id;
202 398
203our %class_id = ( 399our %class_id = (
204 in => 1, 400 in => 1,
205 ch => 3, 401 ch => 3,
206 hs => 4, 402 hs => 4,
403 none => 254,
207 "*" => 255, 404 "*" => 255,
208); 405);
209 406
210our %class_str = reverse %class_id; 407our %class_str = reverse %class_id;
211 408
212# names MUST have a trailing dot 409# names MUST have a trailing dot
… …
247 qr => 1, 444 qr => 1,
248 aa => 0, 445 aa => 0,
249 tc => 0, 446 tc => 0,
250 rd => 0, 447 rd => 0,
251 ra => 0, 448 ra => 0,
449 ad => 0,
450 cd => 0,
252 451
253 qd => [@rr], # query section 452 qd => [@rr], # query section
254 an => [@rr], # answer section 453 an => [@rr], # answer section
255 ns => [@rr], # authority section 454 ns => [@rr], # authority section
256 ar => [@rr], # additional records section 455 ar => [@rr], # additional records section
… …
259=cut 458=cut
260 459
261sub dns_pack($) { 460sub dns_pack($) {
262 my ($req) = @_; 461 my ($req) = @_;
263 462
264 pack "nn nnnn a* a* a* a*", 463 pack "nn nnnn a* a* a* a* a*",
265 $req->{id}, 464 $req->{id},
266 465
267 ! !$req->{qr} * 0x8000 466 ! !$req->{qr} * 0x8000
268 + $opcode_id{$req->{op}} * 0x0800 467 + $opcode_id{$req->{op}} * 0x0800
269 + ! !$req->{aa} * 0x0400 468 + ! !$req->{aa} * 0x0400
270 + ! !$req->{tc} * 0x0200 469 + ! !$req->{tc} * 0x0200
271 + ! !$req->{rd} * 0x0100 470 + ! !$req->{rd} * 0x0100
272 + ! !$req->{ra} * 0x0080 471 + ! !$req->{ra} * 0x0080
472 + ! !$req->{ad} * 0x0020
473 + ! !$req->{cd} * 0x0010
273 + $rcode_id{$req->{rc}} * 0x0001, 474 + $rcode_id{$req->{rc}} * 0x0001,
274 475
275 scalar @{ $req->{qd} || [] }, 476 scalar @{ $req->{qd} || [] },
276 scalar @{ $req->{an} || [] }, 477 scalar @{ $req->{an} || [] },
277 scalar @{ $req->{ns} || [] }, 478 scalar @{ $req->{ns} || [] },
278 scalar @{ $req->{ar} || [] }, 479 $EDNS0 + scalar @{ $req->{ar} || [] }, # include EDNS0 option here
279 480
280 (join "", map _enc_qd, @{ $req->{qd} || [] }), 481 (join "", map _enc_qd, @{ $req->{qd} || [] }),
281 (join "", map _enc_rr, @{ $req->{an} || [] }), 482 (join "", map _enc_rr, @{ $req->{an} || [] }),
282 (join "", map _enc_rr, @{ $req->{ns} || [] }), 483 (join "", map _enc_rr, @{ $req->{ns} || [] }),
283 (join "", map _enc_rr, @{ $req->{ar} || [] }); 484 (join "", map _enc_rr, @{ $req->{ar} || [] }),
485
486 ($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size
284} 487}
285 488
286our $ofs; 489our $ofs;
287our $pkt; 490our $pkt;
288 491
… …
317 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 520 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
318 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 521 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
319} 522}
320 523
321our %dec_rr = ( 524our %dec_rr = (
322 1 => sub { Socket::inet_ntoa $_ }, # a 525 1 => sub { join ".", unpack "C4" }, # a
323 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 526 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
324 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 527 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
325 6 => sub { 528 6 => sub {
326 local $ofs = $ofs - length; 529 local $ofs = $ofs - length;
327 my $mname = _dec_qname; 530 my $mname = _dec_qname;
328 my $rname = _dec_qname; 531 my $rname = _dec_qname;
329 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 532 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
330 }, # soa 533 }, # soa
331 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks 534 11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks
332 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 535 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
333 13 => sub { unpack "C/a C/a", $_ }, 536 13 => sub { unpack "C/a C/a", $_ }, # hinfo
334 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 537 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
335 16 => sub { unpack "C/a", $_ }, # txt 538 16 => sub { unpack "(C/a)*", $_ }, # txt
336 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 539 28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
337 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 540 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
541 99 => sub { unpack "(C/a)*", $_ }, # spf
338); 542);
339 543
340sub _dec_rr { 544sub _dec_rr {
341 my $qname = _dec_qname; 545 my $qname = _dec_qname;
342 546
… …
355 559
356Unpacks a DNS packet into a perl data structure. 560Unpacks a DNS packet into a perl data structure.
357 561
358Examples: 562Examples:
359 563
360 # a non-successful reply 564 # an unsuccessful reply
361 { 565 {
362 'qd' => [ 566 'qd' => [
363 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] 567 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
364 ], 568 ],
365 'rc' => 'nxdomain', 569 'rc' => 'nxdomain',
… …
369 'uni-karlsruhe.de', 573 'uni-karlsruhe.de',
370 'soa', 574 'soa',
371 'in', 575 'in',
372 'netserv.rz.uni-karlsruhe.de', 576 'netserv.rz.uni-karlsruhe.de',
373 'hostmaster.rz.uni-karlsruhe.de', 577 'hostmaster.rz.uni-karlsruhe.de',
374 2008052201, 578 2008052201, 10800, 1800, 2592000, 86400
375 10800,
376 1800,
377 2592000,
378 86400
379 ] 579 ]
380 ], 580 ],
381 'tc' => '', 581 'tc' => '',
382 'ra' => 1, 582 'ra' => 1,
383 'qr' => 1, 583 'qr' => 1,
… …
431 qr => ! ! ($flags & 0x8000), 631 qr => ! ! ($flags & 0x8000),
432 aa => ! ! ($flags & 0x0400), 632 aa => ! ! ($flags & 0x0400),
433 tc => ! ! ($flags & 0x0200), 633 tc => ! ! ($flags & 0x0200),
434 rd => ! ! ($flags & 0x0100), 634 rd => ! ! ($flags & 0x0100),
435 ra => ! ! ($flags & 0x0080), 635 ra => ! ! ($flags & 0x0080),
636 ad => ! ! ($flags & 0x0020),
637 cd => ! ! ($flags & 0x0010),
436 op => $opcode_str{($flags & 0x001e) >> 11}, 638 op => $opcode_str{($flags & 0x001e) >> 11},
437 rc => $rcode_str{($flags & 0x000f)}, 639 rc => $rcode_str{($flags & 0x000f)},
438 640
439 qd => [map _dec_qd, 1 .. $qd], 641 qd => [map _dec_qd, 1 .. $qd],
440 an => [map _dec_rr, 1 .. $an], 642 an => [map _dec_rr, 1 .. $an],
… …
447 649
448=back 650=back
449 651
450=head2 THE AnyEvent::DNS RESOLVER CLASS 652=head2 THE AnyEvent::DNS RESOLVER CLASS
451 653
452This is the class which deos the actual protocol work. 654This is the class which does the actual protocol work.
453 655
454=over 4 656=over 4
455 657
456=cut 658=cut
457 659
… …
477our $RESOLVER; 679our $RESOLVER;
478 680
479sub resolver() { 681sub resolver() {
480 $RESOLVER || do { 682 $RESOLVER || do {
481 $RESOLVER = new AnyEvent::DNS; 683 $RESOLVER = new AnyEvent::DNS;
482 $RESOLVER->load_resolv_conf; 684 $RESOLVER->os_config;
483 $RESOLVER 685 $RESOLVER
484 } 686 }
485} 687}
486 688
487=item $resolver = new AnyEvent::DNS key => value... 689=item $resolver = new AnyEvent::DNS key => value...
488 690
489Creates and returns a new resolver. It only supports UDP, so make sure 691Creates and returns a new resolver.
490your answer sections fit into a DNS packet.
491 692
492The following options are supported: 693The following options are supported:
493 694
494=over 4 695=over 4
495 696
496=item server => [...] 697=item server => [...]
497 698
498A list of server addressses (default C<v127.0.0.1>) in network format (4 699A list of server addresses (default: C<v127.0.0.1>) in network format (4
499octets for IPv4, 16 octets for IPv6 - not yet supported). 700octets for IPv4, 16 octets for IPv6 - not yet supported).
500 701
501=item timeout => [...] 702=item timeout => [...]
502 703
503A list of timeouts to use (also determines the number of retries). To make 704A list of timeouts to use (also determines the number of retries). To make
… …
514tries to resolve the name without any suffixes first. 715tries to resolve the name without any suffixes first.
515 716
516=item max_outstanding => $integer 717=item max_outstanding => $integer
517 718
518Most name servers do not handle many parallel requests very well. This option 719Most name servers do not handle many parallel requests very well. This option
519limits the numbe rof outstanding requests to C<$n> (default: C<10>), that means 720limits the number of outstanding requests to C<$n> (default: C<10>), that means
520if you request more than this many requests, then the additional requests will be queued 721if you request more than this many requests, then the additional requests will be queued
521until some other requests have been resolved. 722until some other requests have been resolved.
723
724=item reuse => $seconds
725
726The number of seconds (default: C<300>) that a query id cannot be re-used
727after a timeout. If there as no time-out then query id's can be reused
728immediately.
522 729
523=back 730=back
524 731
525=cut 732=cut
526 733
… …
555 $self 762 $self
556} 763}
557 764
558=item $resolver->parse_resolv_conv ($string) 765=item $resolver->parse_resolv_conv ($string)
559 766
560Parses the given string a sif it were a F<resolv.conf> file. The following 767Parses the given string as if it were a F<resolv.conf> file. The following
561directives are supported: 768directives are supported (but not necessarily implemented).
562 769
563C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 770C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
564C<options> (C<timeout>, C<attempts>, C<ndots>). 771C<options> (C<timeout>, C<attempts>, C<ndots>).
565 772
566Everything else is silently ignored. 773Everything else is silently ignored.
… …
578 for (split /\n/, $resolvconf) { 785 for (split /\n/, $resolvconf) {
579 if (/^\s*#/) { 786 if (/^\s*#/) {
580 # comment 787 # comment
581 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { 788 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
582 my $ip = $1; 789 my $ip = $1;
583 if (AnyEvent::Util::dotted_quad $ip) { 790 if (my $ipn = AnyEvent::Socket::parse_ip ($ip)) {
584 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; 791 push @{ $self->{server} }, $ipn;
585 } else { 792 } else {
586 warn "nameserver $ip invalid and ignored\n"; 793 warn "nameserver $ip invalid and ignored\n";
587 } 794 }
588 } elsif (/^\s*domain\s+(\S*)\s+$/i) { 795 } elsif (/^\s*domain\s+(\S*)\s+$/i) {
589 $self->{search} = [$1]; 796 $self->{search} = [$1];
… …
610 if $attempts; 817 if $attempts;
611 818
612 $self->_compile; 819 $self->_compile;
613} 820}
614 821
615=item $resolver->load_resolv_conf 822=item $resolver->os_config
616 823
617Tries to load and parse F</etc/resolv.conf>. If there will ever be windows 824Tries so load and parse F</etc/resolv.conf> on portable operating systems. Tries various
618support, then this function will do the right thing under windows, too. 825egregious hacks on windows to force the DNS servers and searchlist out of the system.
619 826
620=cut 827=cut
621 828
622sub load_resolv_conf { 829sub os_config {
623 my ($self) = @_; 830 my ($self) = @_;
624 831
832 if ($^O =~ /mswin32|cygwin/i) {
833 # yeah, it suxx... lets hope DNS is DNS in all locales
834
835 if (open my $fh, "ipconfig /all |") {
836 delete $self->{server};
837 delete $self->{search};
838
839 while (<$fh>) {
840 # first DNS.* is suffix list
841 if (/^\s*DNS/) {
842 while (/\s+([[:alnum:].\-]+)\s*$/) {
843 push @{ $self->{search} }, $1;
844 $_ = <$fh>;
845 }
846 last;
847 }
848 }
849
850 while (<$fh>) {
851 # second DNS.* is server address list
852 if (/^\s*DNS/) {
853 while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
854 my $ipn = AnyEvent::Socket::parse_ip ("$1"); # "" is necessary here, apparently
855 push @{ $self->{server} }, $ipn
856 if $ipn;
857 $_ = <$fh>;
858 }
859 last;
860 }
861 }
862
863 $self->_compile;
864 }
865 } else {
866 # try resolv.conf everywhere
867
625 open my $fh, "</etc/resolv.conf" 868 if (open my $fh, "</etc/resolv.conf") {
626 or return;
627
628 local $/; 869 local $/;
629 $self->parse_resolv_conf (<$fh>); 870 $self->parse_resolv_conf (<$fh>);
871 }
872 }
630} 873}
631 874
632sub _compile { 875sub _compile {
633 my $self = shift; 876 my $self = shift;
634 877
… …
641 } 884 }
642 885
643 $self->{retry} = \@retry; 886 $self->{retry} = \@retry;
644} 887}
645 888
889sub _feed {
890 my ($self, $res) = @_;
891
892 $res = dns_unpack $res
893 or return;
894
895 my $id = $self->{id}{$res->{id}};
896
897 return unless ref $id;
898
899 $NOW = time;
900 $id->[1]->($res);
901}
902
646sub _recv { 903sub _recv {
647 my ($self) = @_; 904 my ($self) = @_;
648 905
649 while (my $peer = recv $self->{fh}, my $res, 1024, 0) { 906 while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
650 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 907 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
651 908
652 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 909 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
653 910
654 $res = dns_unpack $res 911 $self->_feed ($res);
655 or return;
656
657 my $id = $self->{id}{$res->{id}};
658
659 return unless ref $id;
660
661 $NOW = time;
662 $id->[1]->($res);
663 } 912 }
664} 913}
665 914
915sub _free_id {
916 my ($self, $id, $timeout) = @_;
917
918 if ($timeout) {
919 # we need to block the id for a while
920 $self->{id}{$id} = 1;
921 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
922 } else {
923 # we can quickly recycle the id
924 delete $self->{id}{$id};
925 }
926
927 --$self->{outstanding};
928 $self->_scheduler;
929}
930
931# execute a single request, involves sending it with timeouts to multiple servers
666sub _exec { 932sub _exec {
667 my ($self, $req, $retry) = @_; 933 my ($self, $req) = @_;
668 934
935 my $retry; # of retries
936 my $do_retry;
937
938 $do_retry = sub {
669 if (my $retry_cfg = $self->{retry}[$retry]) { 939 my $retry_cfg = $self->{retry}[$retry++]
940 or do {
941 # failure
942 $self->_free_id ($req->[2], $retry > 1);
943 undef $do_retry; return $req->[1]->();
944 };
945
670 my ($server, $timeout) = @$retry_cfg; 946 my ($server, $timeout) = @$retry_cfg;
671 947
672 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 948 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
673 $NOW = time; 949 $NOW = time;
674 950
675 # timeout, try next 951 # timeout, try next
676 $self->_exec ($req, $retry + 1); 952 &$do_retry;
677 }), sub { 953 }), sub {
678 my ($res) = @_; 954 my ($res) = @_;
679 955
956 if ($res->{tc}) {
957 # success, but truncated, so use tcp
958 AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
959 my ($fh) = @_
960 or return &$do_retry;
961
962 my $handle = new AnyEvent::Handle
963 fh => $fh,
964 on_error => sub {
965 # failure, try next
966 &$do_retry;
967 };
968
969 $handle->push_write (pack "n/a", $req->[0]);
970 $handle->push_read_chunk (2, sub {
971 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub {
972 $self->_feed ($_[1]);
973 });
974 });
975 shutdown $fh, 1;
976
977 }, sub { $timeout });
978
979 } else {
680 # success 980 # success
681 $self->{id}{$req->[2]} = 1; 981 $self->_free_id ($req->[2], $retry > 1);
682 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 982 undef $do_retry; return $req->[1]->($res);
683 --$self->{outstanding}; 983 }
684 $self->_scheduler;
685
686 $req->[1]->($res);
687 }]; 984 }];
688 985
689 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 986 send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);
690 } else {
691 # failure
692 $self->{id}{$req->[2]} = 1;
693 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
694 --$self->{outstanding};
695 $self->_scheduler;
696
697 $req->[1]->();
698 } 987 };
988
989 &$do_retry;
699} 990}
700 991
701sub _scheduler { 992sub _scheduler {
702 my ($self) = @_; 993 my ($self) = @_;
703 994
704 $NOW = time; 995 $NOW = time;
705 996
706 # first clear id reuse queue 997 # first clear id reuse queue
707 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] } 998 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
708 while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW; 999 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
709 1000
710 while ($self->{outstanding} < $self->{max_outstanding}) { 1001 while ($self->{outstanding} < $self->{max_outstanding}) {
1002
1003 if (@{ $self->{reuse_q} } >= 30000) {
1004 # we ran out of ID's, wait a bit
1005 $self->{reuse_to} ||= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
1006 delete $self->{reuse_to};
1007 $self->_scheduler;
1008 });
1009 last;
1010 }
1011
711 my $req = shift @{ $self->{queue} } 1012 my $req = shift @{ $self->{queue} }
712 or last; 1013 or last;
713 1014
714 while () { 1015 while () {
715 $req->[2] = int rand 65536; 1016 $req->[2] = int rand 65536;
716 last unless exists $self->{id}{$req->[2]}; 1017 last unless exists $self->{id}{$req->[2]};
717 } 1018 }
718 1019
1020 ++$self->{outstanding};
719 $self->{id}{$req->[2]} = 1; 1021 $self->{id}{$req->[2]} = 1;
720 substr $req->[0], 0, 2, pack "n", $req->[2]; 1022 substr $req->[0], 0, 2, pack "n", $req->[2];
721 1023
722 ++$self->{outstanding};
723 $self->_exec ($req, 0); 1024 $self->_exec ($req);
724 } 1025 }
725} 1026}
726 1027
727=item $resolver->request ($req, $cb->($res)) 1028=item $resolver->request ($req, $cb->($res))
728 1029
… …
748The callback will be invoked with a list of matching result records or 1049The callback will be invoked with a list of matching result records or
749none on any error or if the name could not be found. 1050none on any error or if the name could not be found.
750 1051
751CNAME chains (although illegal) are followed up to a length of 8. 1052CNAME chains (although illegal) are followed up to a length of 8.
752 1053
753Note that this resolver is just a stub resolver: it requires a nameserver 1054Note that this resolver is just a stub resolver: it requires a name server
754supporting recursive queries, will not do any recursive queries itself and 1055supporting recursive queries, will not do any recursive queries itself and
755is not secure when used against an untrusted name server. 1056is not secure when used against an untrusted name server.
756 1057
757The following options are supported: 1058The following options are supported:
758 1059
… …
834 my %atype = $opt{accept} 1135 my %atype = $opt{accept}
835 ? map +($_ => 1), @{ $opt{accept} } 1136 ? map +($_ => 1), @{ $opt{accept} }
836 : ($qtype => 1); 1137 : ($qtype => 1);
837 1138
838 # advance in searchlist 1139 # advance in searchlist
839 my $do_search; $do_search = sub { 1140 my ($do_search, $do_req);
1141
1142 $do_search = sub {
840 @search 1143 @search
841 or return $cb->(); 1144 or (undef $do_search), (undef $do_req), return $cb->();
842 1145
843 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1146 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
844 my $depth = 2; 1147 my $depth = 2;
845 1148
846 # advance in cname-chain 1149 # advance in cname-chain
847 my $do_req; $do_req = sub { 1150 $do_req = sub {
848 $self->request ({ 1151 $self->request ({
849 rd => 1, 1152 rd => 1,
850 qd => [[$name, $qtype, $class]], 1153 qd => [[$name, $qtype, $class]],
851 }, sub { 1154 }, sub {
852 my ($res) = @_ 1155 my ($res) = @_
… …
856 1159
857 while () { 1160 while () {
858 # results found? 1161 # results found?
859 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 1162 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
860 1163
861 return $cb->(@rr) 1164 (undef $do_search), (undef $do_req), return $cb->(@rr)
862 if @rr; 1165 if @rr;
863 1166
864 # see if there is a cname we can follow 1167 # see if there is a cname we can follow
865 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} }; 1168 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
866 1169
… …
887 }; 1190 };
888 1191
889 $do_search->(); 1192 $do_search->();
890} 1193}
891 1194
1195use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1196
8921; 11971;
893 1198
894=back 1199=back
895 1200
896=head1 AUTHOR 1201=head1 AUTHOR

Diff Legend

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