ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/DNS.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.7 by root, Fri May 23 05:30:59 2008 UTC vs.
Revision 1.40 by root, Thu May 29 06:15:24 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 ();
26use AnyEvent::Handle (); 37use AnyEvent::Handle ();
38use AnyEvent::Util qw(AF_INET6);
27 39
28=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs) 40our $VERSION = '1.0';
29 41
30NOT YET IMPLEMENTED 42our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
31
32Tries to resolve the given nodename and service name into sockaddr
33structures usable to connect to this node and service in a
34protocol-independent way. It works similarly to the getaddrinfo posix
35function.
36
37Example:
38
39 AnyEvent::DNS::addr "google.com", "http", AF_UNSPEC, SOCK_STREAM, sub { ... };
40 43
41=item AnyEvent::DNS::a $domain, $cb->(@addrs) 44=item AnyEvent::DNS::a $domain, $cb->(@addrs)
42 45
43Tries to resolve the given domain to IPv4 address(es). 46Tries to resolve the given domain to IPv4 address(es).
47
48=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
49
50Tries to resolve the given domain to IPv6 address(es).
44 51
45=item AnyEvent::DNS::mx $domain, $cb->(@hostnames) 52=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
46 53
47Tries to resolve the given domain into a sorted (lower preference value 54Tries to resolve the given domain into a sorted (lower preference value
48first) list of domain names. 55first) list of domain names.
… …
58=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr) 65=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
59 66
60Tries to resolve the given service, protocol and domain name into a list 67Tries to resolve the given service, protocol and domain name into a list
61of service records. 68of service records.
62 69
63Each srv_rr is an arrayref with the following contents: 70Each srv_rr is an array reference with the following contents:
64C<[$priority, $weight, $transport, $target]>. 71C<[$priority, $weight, $transport, $target]>.
65 72
66They will be sorted with lowest priority, highest weight first (TODO: 73They will be sorted with lowest priority, highest weight first (TODO:
67should use the rfc algorithm to reorder same-priority records for weight). 74should use the RFC algorithm to reorder same-priority records for weight).
68 75
69Example: 76Example:
70 77
71 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 78 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
72 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 79 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
… …
74=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames) 81=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
75 82
76Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form) 83Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
77into it's hostname(s). 84into it's hostname(s).
78 85
79Requires the Socket6 module for IPv6 support.
80
81Example: 86Example:
82 87
83 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 88 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
84 # => f.root-servers.net 89 # => f.root-servers.net
85 90
… …
88Tries to resolve the given domain and passes all resource records found to 93Tries to resolve the given domain and passes all resource records found to
89the callback. 94the callback.
90 95
91=cut 96=cut
92 97
98sub MAX_PKT() { 4096 } # max packet size we advertise and accept
99
100sub DOMAIN_PORT() { 53 } # if this changes drop me a note
101
93sub resolver; 102sub resolver;
94 103
95sub a($$) { 104sub a($$) {
96 my ($domain, $cb) = @_; 105 my ($domain, $cb) = @_;
97 106
98 resolver->resolve ($domain => "a", sub { 107 resolver->resolve ($domain => "a", sub {
108 $cb->(map $_->[3], @_);
109 });
110}
111
112sub aaaa($$) {
113 my ($domain, $cb) = @_;
114
115 resolver->resolve ($domain => "aaaa", sub {
99 $cb->(map $_->[3], @_); 116 $cb->(map $_->[3], @_);
100 }); 117 });
101} 118}
102 119
103sub mx($$) { 120sub mx($$) {
… …
134} 151}
135 152
136sub ptr($$) { 153sub ptr($$) {
137 my ($ip, $cb) = @_; 154 my ($ip, $cb) = @_;
138 155
139 my $name; 156 $ip = AnyEvent::Socket::parse_address ($ip)
157 or return $cb->();
140 158
141 if (AnyEvent::Util::dotted_quad $ip) { 159 my $af = AnyEvent::Socket::address_family ($ip);
160
161 if ($af == AF_INET) {
142 $name = join ".", (reverse split /\./, $ip), "in-addr.arpa."; 162 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
163 } elsif ($af == AF_INET6) {
164 $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
143 } else { 165 } else {
144 require Socket6; 166 return $cb->();
145 $name = join ".",
146 (reverse split //,
147 unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
148 "ip6.arpa.";
149 } 167 }
150 168
151 resolver->resolve ($name => "ptr", sub { 169 resolver->resolve ($ip => "ptr", sub {
152 $cb->(map $_->[3], @_); 170 $cb->(map $_->[3], @_);
153 }); 171 });
154} 172}
155 173
156sub any($$) { 174sub any($$) {
157 my ($domain, $cb) = @_; 175 my ($domain, $cb) = @_;
158 176
159 resolver->resolve ($domain => "*", $cb); 177 resolver->resolve ($domain => "*", $cb);
160} 178}
161 179
180#################################################################################
181
182=back
183
162=head2 DNS EN-/DECODING FUNCTIONS 184=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
163 185
164=over 4 186=over 4
165 187
188=item $AnyEvent::DNS::EDNS0
189
190This variable decides whether dns_pack automatically enables EDNS0
191support. By default, this is disabled (C<0>), unless overridden by
192C<$ENV{PERL_ANYEVENT_EDNS0}>, but when set to C<1>, AnyEvent::DNS will use
193EDNS0 in all requests.
194
166=cut 195=cut
196
197our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
167 198
168our %opcode_id = ( 199our %opcode_id = (
169 query => 0, 200 query => 0,
170 iquery => 1, 201 iquery => 1,
171 status => 2, 202 status => 2,
… …
240); 271);
241 272
242our %class_str = reverse %class_id; 273our %class_str = reverse %class_id;
243 274
244# names MUST have a trailing dot 275# names MUST have a trailing dot
245sub _enc_qname($) { 276sub _enc_name($) {
246 pack "(C/a)*", (split /\./, shift), "" 277 pack "(C/a*)*", (split /\./, shift), ""
247} 278}
248 279
249sub _enc_qd() { 280sub _enc_qd() {
250 (_enc_qname $_->[0]) . pack "nn", 281 (_enc_name $_->[0]) . pack "nn",
251 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}), 282 ($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
252 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"}) 283 ($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] || "in"})
253} 284}
254 285
255sub _enc_rr() { 286sub _enc_rr() {
… …
309 + $rcode_id{$req->{rc}} * 0x0001, 340 + $rcode_id{$req->{rc}} * 0x0001,
310 341
311 scalar @{ $req->{qd} || [] }, 342 scalar @{ $req->{qd} || [] },
312 scalar @{ $req->{an} || [] }, 343 scalar @{ $req->{an} || [] },
313 scalar @{ $req->{ns} || [] }, 344 scalar @{ $req->{ns} || [] },
314 1 + scalar @{ $req->{ar} || [] }, # include EDNS0 option 345 $EDNS0 + scalar @{ $req->{ar} || [] }, # include EDNS0 option here
315 346
316 (join "", map _enc_qd, @{ $req->{qd} || [] }), 347 (join "", map _enc_qd, @{ $req->{qd} || [] }),
317 (join "", map _enc_rr, @{ $req->{an} || [] }), 348 (join "", map _enc_rr, @{ $req->{an} || [] }),
318 (join "", map _enc_rr, @{ $req->{ns} || [] }), 349 (join "", map _enc_rr, @{ $req->{ns} || [] }),
319 (join "", map _enc_rr, @{ $req->{ar} || [] }), 350 (join "", map _enc_rr, @{ $req->{ar} || [] }),
320 351
321 (pack "C nnNn", 0, 41, 4000, 0, 0) # EDNS0, 4k udp payload size 352 ($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0, 4kiB udp payload size
322} 353}
323 354
324our $ofs; 355our $ofs;
325our $pkt; 356our $pkt;
326 357
327# bitches 358# bitches
328sub _dec_qname { 359sub _dec_name {
329 my @res; 360 my @res;
330 my $redir; 361 my $redir;
331 my $ptr = $ofs; 362 my $ptr = $ofs;
332 my $cnt; 363 my $cnt;
333 364
334 while () { 365 while () {
335 return undef if ++$cnt >= 256; # to avoid DoS attacks 366 return undef if ++$cnt >= 256; # to avoid DoS attacks
336 367
337 my $len = ord substr $pkt, $ptr++, 1; 368 my $len = ord substr $pkt, $ptr++, 1;
338 369
339 if ($len & 0xc0) { 370 if ($len >= 0xc0) {
340 $ptr++; 371 $ptr++;
341 $ofs = $ptr if $ptr > $ofs; 372 $ofs = $ptr if $ptr > $ofs;
342 $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff; 373 $ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
343 } elsif ($len) { 374 } elsif ($len) {
344 push @res, substr $pkt, $ptr, $len; 375 push @res, substr $pkt, $ptr, $len;
… …
349 } 380 }
350 } 381 }
351} 382}
352 383
353sub _dec_qd { 384sub _dec_qd {
354 my $qname = _dec_qname; 385 my $qname = _dec_name;
355 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4; 386 my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
356 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc] 387 [$qname, $type_str{$qt} || $qt, $class_str{$qc} || $qc]
357} 388}
358 389
359our %dec_rr = ( 390our %dec_rr = (
360 1 => sub { Socket::inet_ntoa $_ }, # a 391 1 => sub { join ".", unpack "C4", $_ }, # a
361 2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns 392 2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
362 5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname 393 5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
363 6 => sub { 394 6 => sub {
364 local $ofs = $ofs - length; 395 local $ofs = $ofs - length;
365 my $mname = _dec_qname; 396 my $mname = _dec_name;
366 my $rname = _dec_qname; 397 my $rname = _dec_name;
367 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 398 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
368 }, # soa 399 }, # soa
369 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks 400 11 => sub { ((join ".", unpack "C4", $_), unpack "C a*", substr $_, 4) }, # wks
370 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 401 12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
371 13 => sub { unpack "C/a C/a", $_ }, # hinfo 402 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
372 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 403 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
373 16 => sub { unpack "(C/a)*", $_ }, # txt 404 16 => sub { unpack "(C/a*)*", $_ }, # txt
374 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 405 28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
375 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 406 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
376 99 => sub { unpack "(C/a)*", $_ }, # spf 407 99 => sub { unpack "(C/a*)*", $_ }, # spf
377); 408);
378 409
379sub _dec_rr { 410sub _dec_rr {
380 my $qname = _dec_qname; 411 my $name = _dec_name;
381 412
382 my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10; 413 my ($rt, $rc, $ttl, $rdlen) = unpack "nn N n", substr $pkt, $ofs; $ofs += 10;
383 local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen; 414 local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
384 415
385 [ 416 [
386 $qname, 417 $name,
387 $type_str{$rt} || $rt, 418 $type_str{$rt} || $rt,
388 $class_str{$rc} || $rc, 419 $class_str{$rc} || $rc,
389 ($dec_rr{$rt} || sub { $_ })->(), 420 ($dec_rr{$rt} || sub { $_ })->(),
390 ] 421 ]
391} 422}
… …
394 425
395Unpacks a DNS packet into a perl data structure. 426Unpacks a DNS packet into a perl data structure.
396 427
397Examples: 428Examples:
398 429
399 # a non-successful reply 430 # an unsuccessful reply
400 { 431 {
401 'qd' => [ 432 'qd' => [
402 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ] 433 [ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
403 ], 434 ],
404 'rc' => 'nxdomain', 435 'rc' => 'nxdomain',
… …
408 'uni-karlsruhe.de', 439 'uni-karlsruhe.de',
409 'soa', 440 'soa',
410 'in', 441 'in',
411 'netserv.rz.uni-karlsruhe.de', 442 'netserv.rz.uni-karlsruhe.de',
412 'hostmaster.rz.uni-karlsruhe.de', 443 'hostmaster.rz.uni-karlsruhe.de',
413 2008052201, 444 2008052201, 10800, 1800, 2592000, 86400
414 10800,
415 1800,
416 2592000,
417 86400
418 ] 445 ]
419 ], 446 ],
420 'tc' => '', 447 'tc' => '',
421 'ra' => 1, 448 'ra' => 1,
422 'qr' => 1, 449 'qr' => 1,
… …
488 515
489=back 516=back
490 517
491=head2 THE AnyEvent::DNS RESOLVER CLASS 518=head2 THE AnyEvent::DNS RESOLVER CLASS
492 519
493This is the class which deos the actual protocol work. 520This is the class which does the actual protocol work.
494 521
495=over 4 522=over 4
496 523
497=cut 524=cut
498 525
… …
518our $RESOLVER; 545our $RESOLVER;
519 546
520sub resolver() { 547sub resolver() {
521 $RESOLVER || do { 548 $RESOLVER || do {
522 $RESOLVER = new AnyEvent::DNS; 549 $RESOLVER = new AnyEvent::DNS;
523 $RESOLVER->load_resolv_conf; 550 $RESOLVER->os_config;
524 $RESOLVER 551 $RESOLVER
525 } 552 }
526} 553}
527 554
528=item $resolver = new AnyEvent::DNS key => value... 555=item $resolver = new AnyEvent::DNS key => value...
… …
533 560
534=over 4 561=over 4
535 562
536=item server => [...] 563=item server => [...]
537 564
538A list of server addressses (default C<v127.0.0.1>) in network format (4 565A list of server addresses (default: C<v127.0.0.1>) in network format (4
539octets for IPv4, 16 octets for IPv6 - not yet supported). 566octets for IPv4, 16 octets for IPv6 - not yet supported).
540 567
541=item timeout => [...] 568=item timeout => [...]
542 569
543A list of timeouts to use (also determines the number of retries). To make 570A list of timeouts to use (also determines the number of retries). To make
… …
554tries to resolve the name without any suffixes first. 581tries to resolve the name without any suffixes first.
555 582
556=item max_outstanding => $integer 583=item max_outstanding => $integer
557 584
558Most name servers do not handle many parallel requests very well. This option 585Most 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 586limits 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 587if you request more than this many requests, then the additional requests will be queued
561until some other requests have been resolved. 588until some other requests have been resolved.
562 589
590=item reuse => $seconds
591
592The number of seconds (default: C<300>) that a query id cannot be re-used
593after a timeout. If there as no time-out then query id's can be reused
594immediately.
595
563=back 596=back
564 597
565=cut 598=cut
566 599
567sub new { 600sub new {
568 my ($class, %arg) = @_; 601 my ($class, %arg) = @_;
569 602
603 # try to create a ipv4 and an ipv6 socket
604 # only fail when we cnanot create either
605
570 socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0 606 socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
571 or Carp::croak "socket: $!"; 607 socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
572 608
573 AnyEvent::Util::fh_nonblocking $fh, 1; 609 $fh4 || $fh6
610 or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
574 611
575 my $self = bless { 612 my $self = bless {
576 server => [v127.0.0.1], 613 server => [],
577 timeout => [2, 5, 5], 614 timeout => [2, 5, 5],
578 search => [], 615 search => [],
579 ndots => 1, 616 ndots => 1,
580 max_outstanding => 10, 617 max_outstanding => 10,
581 reuse => 300, # reuse id's after 5 minutes only, if possible 618 reuse => 300, # reuse id's after 5 minutes only, if possible
582 %arg, 619 %arg,
583 fh => $fh,
584 reuse_q => [], 620 reuse_q => [],
585 }, $class; 621 }, $class;
586 622
587 # search should default to gethostname's domain 623 # search should default to gethostname's domain
588 # but perl lacks a good posix module 624 # but perl lacks a good posix module
589 625
590 Scalar::Util::weaken (my $wself = $self); 626 Scalar::Util::weaken (my $wself = $self);
627
628 if ($fh4) {
629 AnyEvent::Util::fh_nonblocking $fh4, 1;
630 $self->{fh4} = $fh4;
591 $self->{rw} = AnyEvent->io (fh => $fh, poll => "r", cb => sub { $wself->_recv }); 631 $self->{rw4} = AnyEvent->io (fh => $fh4, poll => "r", cb => sub {
632 if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
633 $wself->_recv ($pkt, $peer);
634 }
635 });
636 }
637
638 if ($fh6) {
639 $self->{fh6} = $fh6;
640 AnyEvent::Util::fh_nonblocking $fh6, 1;
641 $self->{rw6} = AnyEvent->io (fh => $fh6, poll => "r", cb => sub {
642 if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
643 $wself->_recv ($pkt, $peer);
644 }
645 });
646 }
592 647
593 $self->_compile; 648 $self->_compile;
594 649
595 $self 650 $self
596} 651}
597 652
598=item $resolver->parse_resolv_conv ($string) 653=item $resolver->parse_resolv_conv ($string)
599 654
600Parses the given string a sif it were a F<resolv.conf> file. The following 655Parses the given string as if it were a F<resolv.conf> file. The following
601directives are supported: 656directives are supported (but not necessarily implemented).
602 657
603C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>, 658C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
604C<options> (C<timeout>, C<attempts>, C<ndots>). 659C<options> (C<timeout>, C<attempts>, C<ndots>).
605 660
606Everything else is silently ignored. 661Everything else is silently ignored.
… …
618 for (split /\n/, $resolvconf) { 673 for (split /\n/, $resolvconf) {
619 if (/^\s*#/) { 674 if (/^\s*#/) {
620 # comment 675 # comment
621 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) { 676 } elsif (/^\s*nameserver\s+(\S+)\s*$/i) {
622 my $ip = $1; 677 my $ip = $1;
623 if (AnyEvent::Util::dotted_quad $ip) { 678 if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
624 push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip; 679 push @{ $self->{server} }, $ipn;
625 } else { 680 } else {
626 warn "nameserver $ip invalid and ignored\n"; 681 warn "nameserver $ip invalid and ignored\n";
627 } 682 }
628 } elsif (/^\s*domain\s+(\S*)\s+$/i) { 683 } elsif (/^\s*domain\s+(\S*)\s+$/i) {
629 $self->{search} = [$1]; 684 $self->{search} = [$1];
… …
650 if $attempts; 705 if $attempts;
651 706
652 $self->_compile; 707 $self->_compile;
653} 708}
654 709
655=item $resolver->load_resolv_conf 710=item $resolver->os_config
656 711
657Tries to load and parse F</etc/resolv.conf>. If there will ever be windows 712Tries 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. 713egregious hacks on windows to force the DNS servers and searchlist out of the system.
659 714
660=cut 715=cut
661 716
662sub load_resolv_conf { 717sub os_config {
663 my ($self) = @_; 718 my ($self) = @_;
664 719
720 $self->{server} = [];
721 $self->{search} = [];
722
723 if (AnyEvent::WIN32 || $^O =~ /cygwin/i) {
724 no strict 'refs';
725
726 # there are many options to find the current nameservers etc. on windows
727 # all of them don't work consistently:
728 # - the registry thing needs separate code on win32 native vs. cygwin
729 # - the registry layout differs between windows versions
730 # - calling windows api functions doesn't work on cygwin
731 # - ipconfig uses locale-specific messages
732
733 # we use ipconfig parsing because, despite all it's brokenness,
734 # it seems most stable in practise.
735 # for good measure, we append a fallback nameserver to our list.
736
737 if (open my $fh, "ipconfig /all |") {
738 # parsing strategy: we go through the output and look for
739 # :-lines with DNS in them. everything in those is regarded as
740 # either a nameserver (if it parses as an ip address), or a suffix
741 # (all else).
742
743 my $dns;
744 while (<$fh>) {
745 if (s/^\s.*\bdns\b.*://i) {
746 $dns = 1;
747 } elsif (/^\S/ || /^\s[^:]{16,}: /) {
748 $dns = 0;
749 }
750 if ($dns && /^\s*(\S+)\s*$/) {
751 my $s = $1;
752 $s =~ s/%\d+(?!\S)//; # get rid of scope id
753 if (my $ipn = AnyEvent::Socket::parse_address ($s)) {
754 push @{ $self->{server} }, $ipn;
755 } else {
756 push @{ $self->{search} }, $s;
757 }
758 }
759 }
760
761 # always add one fallback server
762 push @{ $self->{server} }, $DNS_FALLBACK[rand @DNS_FALLBACK];
763
764 $self->_compile;
765 }
766 } else {
767 # try resolv.conf everywhere
768
665 open my $fh, "</etc/resolv.conf" 769 if (open my $fh, "</etc/resolv.conf") {
666 or return;
667
668 local $/; 770 local $/;
669 $self->parse_resolv_conf (<$fh>); 771 $self->parse_resolv_conf (<$fh>);
772 }
773 }
670} 774}
671 775
672sub _compile { 776sub _compile {
673 my $self = shift; 777 my $self = shift;
778
779 my %search; $self->{search} = [grep 0 < length, grep !$search{$_}++, @{ $self->{search} }];
780 my %server; $self->{server} = [grep 0 < length, grep !$server{$_}++, @{ $self->{server} }];
781
782 unless (@{ $self->{server} }) {
783 # use 127.0.0.1 by default, and one opendns nameserver as fallback
784 $self->{server} = [v127.0.0.1, $DNS_FALLBACK[rand @DNS_FALLBACK]];
785 }
674 786
675 my @retry; 787 my @retry;
676 788
677 for my $timeout (@{ $self->{timeout} }) { 789 for my $timeout (@{ $self->{timeout} }) {
678 for my $server (@{ $self->{server} }) { 790 for my $server (@{ $self->{server} }) {
… …
696 $NOW = time; 808 $NOW = time;
697 $id->[1]->($res); 809 $id->[1]->($res);
698} 810}
699 811
700sub _recv { 812sub _recv {
701 my ($self) = @_; 813 my ($self, $pkt, $peer) = @_;
702 814
703 while (my $peer = recv $self->{fh}, my $res, 4000, 0) { 815 # we ignore errors (often one gets port unreachable, but there is
816 # no good way to take advantage of that.
817
704 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 818 my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
705 819
706 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 820 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
707 821
708 $self->_feed ($res); 822 $self->_feed ($pkt);
823}
824
825sub _free_id {
826 my ($self, $id, $timeout) = @_;
827
828 if ($timeout) {
829 # we need to block the id for a while
830 $self->{id}{$id} = 1;
831 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
832 } else {
833 # we can quickly recycle the id
834 delete $self->{id}{$id};
709 } 835 }
710}
711 836
837 --$self->{outstanding};
838 $self->_scheduler;
839}
840
841# execute a single request, involves sending it with timeouts to multiple servers
712sub _exec { 842sub _exec {
713 my ($self, $req, $retry) = @_; 843 my ($self, $req) = @_;
714 844
845 my $retry; # of retries
846 my $do_retry;
847
848 $do_retry = sub {
715 if (my $retry_cfg = $self->{retry}[$retry]) { 849 my $retry_cfg = $self->{retry}[$retry++]
850 or do {
851 # failure
852 $self->_free_id ($req->[2], $retry > 1);
853 undef $do_retry; return $req->[1]->();
854 };
855
716 my ($server, $timeout) = @$retry_cfg; 856 my ($server, $timeout) = @$retry_cfg;
717 857
718 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub { 858 $self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
719 $NOW = time; 859 $NOW = time;
720 860
721 # timeout, try next 861 # timeout, try next
722 $self->_exec ($req, $retry + 1); 862 &$do_retry;
723 }), sub { 863 }), sub {
724 my ($res) = @_; 864 my ($res) = @_;
725 865
726 if ($res->{tc}) { 866 if ($res->{tc}) {
727 # success, but truncated, so use tcp 867 # success, but truncated, so use tcp
728 AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub { 868 AnyEvent::Socket::tcp_connect (AnyEvent::Socket::format_address ($server), DOMAIN_PORT, sub {
729 my ($fh) = @_ 869 my ($fh) = @_
730 or return $self->_exec ($req, $retry + 1); 870 or return &$do_retry;
731 871
732 my $handle = new AnyEvent::Handle 872 my $handle = new AnyEvent::Handle
733 fh => $fh, 873 fh => $fh,
734 on_error => sub { 874 on_error => sub {
735 # failure, try next 875 # failure, try next
736 $self->_exec ($req, $retry + 1); 876 &$do_retry;
737 }; 877 };
738 878
739 $handle->push_write (pack "n/a", $req->[0]); 879 $handle->push_write (pack "n/a", $req->[0]);
740 $handle->push_read_chunk (2, sub { 880 $handle->push_read (chunk => 2, sub {
741 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub { 881 $handle->unshift_read (chunk => (unpack "n", $_[1]), sub {
742 $self->_feed ($_[1]); 882 $self->_feed ($_[1]);
743 }); 883 });
744 }); 884 });
745 shutdown $fh, 1; 885 shutdown $fh, 1;
746 886
747 }, sub { $timeout }; 887 }, sub { $timeout });
748 888
749 } else { 889 } else {
750 # success 890 # success
751 $self->{id}{$req->[2]} = 1; 891 $self->_free_id ($req->[2], $retry > 1);
752 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 892 undef $do_retry; return $req->[1]->($res);
753 --$self->{outstanding};
754 $self->_scheduler;
755
756 $req->[1]->($res);
757 } 893 }
758 }]; 894 }];
895
896 my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
759 897
760 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 898 my $fh = AF_INET == Socket::sockaddr_family ($sa)
761 } else { 899 ? $self->{fh4} : $self->{fh6}
762 # failure 900 or return &$do_retry;
763 $self->{id}{$req->[2]} = 1;
764 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
765 --$self->{outstanding};
766 $self->_scheduler;
767 901
768 $req->[1]->(); 902 send $fh, $req->[0], 0, $sa;
769 } 903 };
904
905 &$do_retry;
770} 906}
771 907
772sub _scheduler { 908sub _scheduler {
773 my ($self) = @_; 909 my ($self) = @_;
774 910
775 $NOW = time; 911 $NOW = time;
776 912
777 # first clear id reuse queue 913 # first clear id reuse queue
778 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] } 914 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
779 while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW; 915 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
780 916
781 while ($self->{outstanding} < $self->{max_outstanding}) { 917 while ($self->{outstanding} < $self->{max_outstanding}) {
918
919 if (@{ $self->{reuse_q} } >= 30000) {
920 # we ran out of ID's, wait a bit
921 $self->{reuse_to} ||= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
922 delete $self->{reuse_to};
923 $self->_scheduler;
924 });
925 last;
926 }
927
782 my $req = shift @{ $self->{queue} } 928 my $req = shift @{ $self->{queue} }
783 or last; 929 or last;
784 930
785 while () { 931 while () {
786 $req->[2] = int rand 65536; 932 $req->[2] = int rand 65536;
787 last unless exists $self->{id}{$req->[2]}; 933 last unless exists $self->{id}{$req->[2]};
788 } 934 }
789 935
936 ++$self->{outstanding};
790 $self->{id}{$req->[2]} = 1; 937 $self->{id}{$req->[2]} = 1;
791 substr $req->[0], 0, 2, pack "n", $req->[2]; 938 substr $req->[0], 0, 2, pack "n", $req->[2];
792 939
793 ++$self->{outstanding};
794 $self->_exec ($req, 0); 940 $self->_exec ($req);
795 } 941 }
796} 942}
797 943
798=item $resolver->request ($req, $cb->($res)) 944=item $resolver->request ($req, $cb->($res))
799 945
… …
819The callback will be invoked with a list of matching result records or 965The callback will be invoked with a list of matching result records or
820none on any error or if the name could not be found. 966none on any error or if the name could not be found.
821 967
822CNAME chains (although illegal) are followed up to a length of 8. 968CNAME chains (although illegal) are followed up to a length of 8.
823 969
824Note that this resolver is just a stub resolver: it requires a nameserver 970Note that this resolver is just a stub resolver: it requires a name server
825supporting recursive queries, will not do any recursive queries itself and 971supporting recursive queries, will not do any recursive queries itself and
826is not secure when used against an untrusted name server. 972is not secure when used against an untrusted name server.
827 973
828The following options are supported: 974The following options are supported:
829 975
… …
905 my %atype = $opt{accept} 1051 my %atype = $opt{accept}
906 ? map +($_ => 1), @{ $opt{accept} } 1052 ? map +($_ => 1), @{ $opt{accept} }
907 : ($qtype => 1); 1053 : ($qtype => 1);
908 1054
909 # advance in searchlist 1055 # advance in searchlist
910 my $do_search; $do_search = sub { 1056 my ($do_search, $do_req);
1057
1058 $do_search = sub {
911 @search 1059 @search
912 or return $cb->(); 1060 or (undef $do_search), (undef $do_req), return $cb->();
913 1061
914 (my $name = lc "$qname." . shift @search) =~ s/\.$//; 1062 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
915 my $depth = 2; 1063 my $depth = 2;
916 1064
917 # advance in cname-chain 1065 # advance in cname-chain
918 my $do_req; $do_req = sub { 1066 $do_req = sub {
919 $self->request ({ 1067 $self->request ({
920 rd => 1, 1068 rd => 1,
921 qd => [[$name, $qtype, $class]], 1069 qd => [[$name, $qtype, $class]],
922 }, sub { 1070 }, sub {
923 my ($res) = @_ 1071 my ($res) = @_
… …
927 1075
928 while () { 1076 while () {
929 # results found? 1077 # results found?
930 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 1078 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
931 1079
932 return $cb->(@rr) 1080 (undef $do_search), (undef $do_req), return $cb->(@rr)
933 if @rr; 1081 if @rr;
934 1082
935 # see if there is a cname we can follow 1083 # see if there is a cname we can follow
936 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} }; 1084 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
937 1085
… …
958 }; 1106 };
959 1107
960 $do_search->(); 1108 $do_search->();
961} 1109}
962 1110
1111use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1112
9631; 11131;
964 1114
965=back 1115=back
966 1116
967=head1 AUTHOR 1117=head1 AUTHOR

Diff Legend

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