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.8 by root, Fri May 23 05:34:32 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 ();
26use AnyEvent::Handle (); 29use AnyEvent::Handle ();
27 30
28=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], ...)
29 32
30NOT YET IMPLEMENTED
31
32Tries to resolve the given nodename and service name into sockaddr 33Tries to resolve the given nodename and service name into protocol families
33structures usable to connect to this node and service in a 34and sockaddr structures usable to connect to this node and service in a
34protocol-independent way. It works similarly to the getaddrinfo posix 35protocol-independent way. It works remotely similar to the getaddrinfo
35function. 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.
36 61
37Example: 62Example:
38 63
39 AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... }; 64 AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
40 65
41=item AnyEvent::DNS::a $domain, $cb->(@addrs) 66=item AnyEvent::DNS::a $domain, $cb->(@addrs)
42 67
43Tries 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).
44 73
45=item AnyEvent::DNS::mx $domain, $cb->(@hostnames) 74=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
46 75
47Tries to resolve the given domain into a sorted (lower preference value 76Tries to resolve the given domain into a sorted (lower preference value
48first) list of domain names. 77first) list of domain names.
… …
58=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 87=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
59 88
60Tries 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
61of service records. 90of service records.
62 91
63Each srv_rr is an arrayref with the following contents: 92Each srv_rr is an array reference with the following contents:
64C<[$priority, $weight, $transport, $target]>. 93C<[$priority, $weight, $transport, $target]>.
65 94
66They will be sorted with lowest priority, highest weight first (TODO: 95They will be sorted with lowest priority, highest weight first (TODO:
67should use the rfc algorithm to reorder same-priority records for weight). 96should use the RFC algorithm to reorder same-priority records for weight).
68 97
69Example: 98Example:
70 99
71 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 100 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
72 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 101 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
… …
74=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames) 103=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
75 104
76Tries 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)
77into it's hostname(s). 106into it's hostname(s).
78 107
79Requires the Socket6 module for IPv6 support.
80
81Example: 108Example:
82 109
83 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 110 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
84 # => f.root-servers.net 111 # => f.root-servers.net
85 112
… …
94 121
95sub a($$) { 122sub a($$) {
96 my ($domain, $cb) = @_; 123 my ($domain, $cb) = @_;
97 124
98 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 {
99 $cb->(map $_->[3], @_); 134 $cb->(map $_->[3], @_);
100 }); 135 });
101} 136}
102 137
103sub mx($$) { 138sub mx($$) {
… …
134} 169}
135 170
136sub ptr($$) { 171sub ptr($$) {
137 my ($ip, $cb) = @_; 172 my ($ip, $cb) = @_;
138 173
139 my $name; 174 $ip = AnyEvent::Socket::parse_ip ($ip)
175 or return $cb->();
140 176
141 if (AnyEvent::Util::dotted_quad $ip) { 177 if (4 == length $ip) {
142 $name = join ".", (reverse split /\./, $ip), "in-addr.arpa."; 178 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
143 } else { 179 } else {
144 require Socket6; 180 $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 } 181 }
150 182
151 resolver->resolve ($name => "ptr", sub { 183 resolver->resolve ($ip => "ptr", sub {
152 $cb->(map $_->[3], @_); 184 $cb->(map $_->[3], @_);
153 }); 185 });
154} 186}
155 187
156sub any($$) { 188sub any($$) {
157 my ($domain, $cb) = @_; 189 my ($domain, $cb) = @_;
158 190
159 resolver->resolve ($domain => "*", $cb); 191 resolver->resolve ($domain => "*", $cb);
160} 192}
161 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
162=head2 DNS EN-/DECODING FUNCTIONS 318=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
163 319
164=over 4 320=over 4
165 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
166=cut 329=cut
330
331our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
167 332
168our %opcode_id = ( 333our %opcode_id = (
169 query => 0, 334 query => 0,
170 iquery => 1, 335 iquery => 1,
171 status => 2, 336 status => 2,
… …
309 + $rcode_id{$req->{rc}} * 0x0001, 474 + $rcode_id{$req->{rc}} * 0x0001,
310 475
311 scalar @{ $req->{qd} || [] }, 476 scalar @{ $req->{qd} || [] },
312 scalar @{ $req->{an} || [] }, 477 scalar @{ $req->{an} || [] },
313 scalar @{ $req->{ns} || [] }, 478 scalar @{ $req->{ns} || [] },
314 scalar @{ $req->{ar} || [] }, # include EDNS0 option here 479 $EDNS0 + scalar @{ $req->{ar} || [] }, # include EDNS0 option here
315 480
316 (join "", map _enc_qd, @{ $req->{qd} || [] }), 481 (join "", map _enc_qd, @{ $req->{qd} || [] }),
317 (join "", map _enc_rr, @{ $req->{an} || [] }), 482 (join "", map _enc_rr, @{ $req->{an} || [] }),
318 (join "", map _enc_rr, @{ $req->{ns} || [] }), 483 (join "", map _enc_rr, @{ $req->{ns} || [] }),
319 (join "", map _enc_rr, @{ $req->{ar} || [] }), 484 (join "", map _enc_rr, @{ $req->{ar} || [] }),
320 485
321 # (pack "C nnNn", 0, 41, 4000, 0, 0) # EDNS0, 4k udp payload size 486 ($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size
322} 487}
323 488
324our $ofs; 489our $ofs;
325our $pkt; 490our $pkt;
326 491
… …
355 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 520 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
356 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 521 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
357} 522}
358 523
359our %dec_rr = ( 524our %dec_rr = (
360 1 => sub { Socket::inet_ntoa $_ }, # a 525 1 => sub { join ".", unpack "C4" }, # a
361 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 526 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
362 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 527 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
363 6 => sub { 528 6 => sub {
364 local $ofs = $ofs - length; 529 local $ofs = $ofs - length;
365 my $mname = _dec_qname; 530 my $mname = _dec_qname;
366 my $rname = _dec_qname; 531 my $rname = _dec_qname;
367 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 532 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
368 }, # soa 533 }, # soa
369 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
370 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 535 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
371 13 => sub { unpack "C/a C/a", $_ }, # hinfo 536 13 => sub { unpack "C/a C/a", $_ }, # hinfo
372 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
373 16 => sub { unpack "(C/a)*", $_ }, # txt 538 16 => sub { unpack "(C/a)*", $_ }, # txt
374 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 539 28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
375 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
376 99 => sub { unpack "(C/a)*", $_ }, # spf 541 99 => sub { unpack "(C/a)*", $_ }, # spf
377); 542);
378 543
379sub _dec_rr { 544sub _dec_rr {
… …
394 559
395Unpacks a DNS packet into a perl data structure. 560Unpacks a DNS packet into a perl data structure.
396 561
397Examples: 562Examples:
398 563
399 # a non-successful reply 564 # an unsuccessful reply
400 { 565 {
401 'qd' => [ 566 'qd' => [
402 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] 567 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
403 ], 568 ],
404 'rc' => 'nxdomain', 569 'rc' => 'nxdomain',
… …
408 'uni-karlsruhe.de', 573 'uni-karlsruhe.de',
409 'soa', 574 'soa',
410 'in', 575 'in',
411 'netserv.rz.uni-karlsruhe.de', 576 'netserv.rz.uni-karlsruhe.de',
412 'hostmaster.rz.uni-karlsruhe.de', 577 'hostmaster.rz.uni-karlsruhe.de',
413 2008052201, 578 2008052201, 10800, 1800, 2592000, 86400
414 10800,
415 1800,
416 2592000,
417 86400
418 ] 579 ]
419 ], 580 ],
420 'tc' => '', 581 'tc' => '',
421 'ra' => 1, 582 'ra' => 1,
422 'qr' => 1, 583 'qr' => 1,
… …
488 649
489=back 650=back
490 651
491=head2 THE AnyEvent::DNS RESOLVER CLASS 652=head2 THE AnyEvent::DNS RESOLVER CLASS
492 653
493This is the class which deos the actual protocol work. 654This is the class which does the actual protocol work.
494 655
495=over 4 656=over 4
496 657
497=cut 658=cut
498 659
… …
518our $RESOLVER; 679our $RESOLVER;
519 680
520sub resolver() { 681sub resolver() {
521 $RESOLVER || do { 682 $RESOLVER || do {
522 $RESOLVER = new AnyEvent::DNS; 683 $RESOLVER = new AnyEvent::DNS;
523 $RESOLVER->load_resolv_conf; 684 $RESOLVER->os_config;
524 $RESOLVER 685 $RESOLVER
525 } 686 }
526} 687}
527 688
528=item $resolver = new AnyEvent::DNS key => value... 689=item $resolver = new AnyEvent::DNS key => value...
… …
533 694
534=over 4 695=over 4
535 696
536=item server => [...] 697=item server => [...]
537 698
538A 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
539octets for IPv4, 16 octets for IPv6 - not yet supported). 700octets for IPv4, 16 octets for IPv6 - not yet supported).
540 701
541=item timeout => [...] 702=item timeout => [...]
542 703
543A 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
… …
554tries to resolve the name without any suffixes first. 715tries to resolve the name without any suffixes first.
555 716
556=item max_outstanding => $integer 717=item max_outstanding => $integer
557 718
558Most 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
559limits 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
560if 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
561until 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.
562 729
563=back 730=back
564 731
565=cut 732=cut
566 733
… …
595 $self 762 $self
596} 763}
597 764
598=item $resolver->parse_resolv_conv ($string) 765=item $resolver->parse_resolv_conv ($string)
599 766
600Parses 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
601directives are supported: 768directives are supported (but not necessarily implemented).
602 769
603C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 770C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
604C<options> (C<timeout>, C<attempts>, C<ndots>). 771C<options> (C<timeout>, C<attempts>, C<ndots>).
605 772
606Everything else is silently ignored. 773Everything else is silently ignored.
… …
618 for (split /\n/, $resolvconf) { 785 for (split /\n/, $resolvconf) {
619 if (/^\s*#/) { 786 if (/^\s*#/) {
620 # comment 787 # comment
621 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { 788 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
622 my $ip = $1; 789 my $ip = $1;
623 if (AnyEvent::Util::dotted_quad $ip) { 790 if (my $ipn = AnyEvent::Socket::parse_ip ($ip)) {
624 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; 791 push @{ $self->{server} }, $ipn;
625 } else { 792 } else {
626 warn "nameserver $ip invalid and ignored\n"; 793 warn "nameserver $ip invalid and ignored\n";
627 } 794 }
628 } elsif (/^\s*domain\s+(\S*)\s+$/i) { 795 } elsif (/^\s*domain\s+(\S*)\s+$/i) {
629 $self->{search} = [$1]; 796 $self->{search} = [$1];
… …
650 if $attempts; 817 if $attempts;
651 818
652 $self->_compile; 819 $self->_compile;
653} 820}
654 821
655=item $resolver->load_resolv_conf 822=item $resolver->os_config
656 823
657Tries 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
658support, 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.
659 826
660=cut 827=cut
661 828
662sub load_resolv_conf { 829sub os_config {
663 my ($self) = @_; 830 my ($self) = @_;
664 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
665 open my $fh, "</etc/resolv.conf" 868 if (open my $fh, "</etc/resolv.conf") {
666 or return;
667
668 local $/; 869 local $/;
669 $self->parse_resolv_conf (<$fh>); 870 $self->parse_resolv_conf (<$fh>);
871 }
872 }
670} 873}
671 874
672sub _compile { 875sub _compile {
673 my $self = shift; 876 my $self = shift;
674 877
… …
698} 901}
699 902
700sub _recv { 903sub _recv {
701 my ($self) = @_; 904 my ($self) = @_;
702 905
703 while (my $peer = recv $self->{fh}, my $res, 4000, 0) { 906 while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
704 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 907 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
705 908
706 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 909 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
707 910
708 $self->_feed ($res); 911 $self->_feed ($res);
709 } 912 }
710} 913}
711 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
712sub _exec { 932sub _exec {
713 my ($self, $req, $retry) = @_; 933 my ($self, $req) = @_;
714 934
935 my $retry; # of retries
936 my $do_retry;
937
938 $do_retry = sub {
715 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
716 my ($server, $timeout) = @$retry_cfg; 946 my ($server, $timeout) = @$retry_cfg;
717 947
718 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 948 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
719 $NOW = time; 949 $NOW = time;
720 950
721 # timeout, try next 951 # timeout, try next
722 $self->_exec ($req, $retry + 1); 952 &$do_retry;
723 }), sub { 953 }), sub {
724 my ($res) = @_; 954 my ($res) = @_;
725 955
726 if ($res->{tc}) { 956 if ($res->{tc}) {
727 # success, but truncated, so use tcp 957 # success, but truncated, so use tcp
728 AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub { 958 AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
729 my ($fh) = @_ 959 my ($fh) = @_
730 or return $self->_exec ($req, $retry + 1); 960 or return &$do_retry;
731 961
732 my $handle = new AnyEvent::Handle 962 my $handle = new AnyEvent::Handle
733 fh => $fh, 963 fh => $fh,
734 on_error => sub { 964 on_error => sub {
735 # failure, try next 965 # failure, try next
736 $self->_exec ($req, $retry + 1); 966 &$do_retry;
737 }; 967 };
738 968
739 $handle->push_write (pack "n/a", $req->[0]); 969 $handle->push_write (pack "n/a", $req->[0]);
740 $handle->push_read_chunk (2, sub { 970 $handle->push_read_chunk (2, sub {
741 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { 971 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub {
742 $self->_feed ($_[1]); 972 $self->_feed ($_[1]);
743 }); 973 });
744 }); 974 });
745 shutdown $fh, 1; 975 shutdown $fh, 1;
746 976
747 }, sub { $timeout }; 977 }, sub { $timeout });
748 978
749 } else { 979 } else {
750 # success 980 # success
751 $self->{id}{$req->[2]} = 1; 981 $self->_free_id ($req->[2], $retry > 1);
752 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 982 undef $do_retry; return $req->[1]->($res);
753 --$self->{outstanding};
754 $self->_scheduler;
755
756 $req->[1]->($res);
757 } 983 }
758 }]; 984 }];
759 985
760 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);
761 } else {
762 # failure
763 $self->{id}{$req->[2]} = 1;
764 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
765 --$self->{outstanding};
766 $self->_scheduler;
767
768 $req->[1]->();
769 } 987 };
988
989 &$do_retry;
770} 990}
771 991
772sub _scheduler { 992sub _scheduler {
773 my ($self) = @_; 993 my ($self) = @_;
774 994
775 $NOW = time; 995 $NOW = time;
776 996
777 # first clear id reuse queue 997 # first clear id reuse queue
778 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] } 998 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
779 while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW; 999 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
780 1000
781 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
782 my $req = shift @{ $self->{queue} } 1012 my $req = shift @{ $self->{queue} }
783 or last; 1013 or last;
784 1014
785 while () { 1015 while () {
786 $req->[2] = int rand 65536; 1016 $req->[2] = int rand 65536;
787 last unless exists $self->{id}{$req->[2]}; 1017 last unless exists $self->{id}{$req->[2]};
788 } 1018 }
789 1019
1020 ++$self->{outstanding};
790 $self->{id}{$req->[2]} = 1; 1021 $self->{id}{$req->[2]} = 1;
791 substr $req->[0], 0, 2, pack "n", $req->[2]; 1022 substr $req->[0], 0, 2, pack "n", $req->[2];
792 1023
793 ++$self->{outstanding};
794 $self->_exec ($req, 0); 1024 $self->_exec ($req);
795 } 1025 }
796} 1026}
797 1027
798=item $resolver->request ($req, $cb->($res)) 1028=item $resolver->request ($req, $cb->($res))
799 1029
… …
819The 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
820none on any error or if the name could not be found. 1050none on any error or if the name could not be found.
821 1051
822CNAME chains (although illegal) are followed up to a length of 8. 1052CNAME chains (although illegal) are followed up to a length of 8.
823 1053
824Note 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
825supporting recursive queries, will not do any recursive queries itself and 1055supporting recursive queries, will not do any recursive queries itself and
826is not secure when used against an untrusted name server. 1056is not secure when used against an untrusted name server.
827 1057
828The following options are supported: 1058The following options are supported:
829 1059
… …
905 my %atype = $opt{accept} 1135 my %atype = $opt{accept}
906 ? map +($_ => 1), @{ $opt{accept} } 1136 ? map +($_ => 1), @{ $opt{accept} }
907 : ($qtype => 1); 1137 : ($qtype => 1);
908 1138
909 # advance in searchlist 1139 # advance in searchlist
910 my $do_search; $do_search = sub { 1140 my ($do_search, $do_req);
1141
1142 $do_search = sub {
911 @search 1143 @search
912 or return $cb->(); 1144 or (undef $do_search), (undef $do_req), return $cb->();
913 1145
914 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1146 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
915 my $depth = 2; 1147 my $depth = 2;
916 1148
917 # advance in cname-chain 1149 # advance in cname-chain
918 my $do_req; $do_req = sub { 1150 $do_req = sub {
919 $self->request ({ 1151 $self->request ({
920 rd => 1, 1152 rd => 1,
921 qd => [[$name, $qtype, $class]], 1153 qd => [[$name, $qtype, $class]],
922 }, sub { 1154 }, sub {
923 my ($res) = @_ 1155 my ($res) = @_
… …
927 1159
928 while () { 1160 while () {
929 # results found? 1161 # results found?
930 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} };
931 1163
932 return $cb->(@rr) 1164 (undef $do_search), (undef $do_req), return $cb->(@rr)
933 if @rr; 1165 if @rr;
934 1166
935 # see if there is a cname we can follow 1167 # see if there is a cname we can follow
936 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} };
937 1169
… …
958 }; 1190 };
959 1191
960 $do_search->(); 1192 $do_search->();
961} 1193}
962 1194
1195use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1196
9631; 11971;
964 1198
965=back 1199=back
966 1200
967=head1 AUTHOR 1201=head1 AUTHOR

Diff Legend

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