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

Diff Legend

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