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.3 by root, Fri May 23 03:20:53 2008 UTC vs.
Revision 1.9 by root, Fri May 23 06:02:16 2008 UTC

… …
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
14=head2 CONVENIENCE FUNCTIONS 14=head2 CONVENIENCE FUNCTIONS
15 15
16# none yet
17
18=over 4 16=over 4
19 17
20=cut 18=cut
21 19
22package AnyEvent::DNS; 20package AnyEvent::DNS;
23 21
24no warnings; 22no warnings;
25use strict; 23use strict;
26 24
27use AnyEvent::Util (); 25use AnyEvent::Util ();
26use AnyEvent::Handle ();
28 27
29=back 28=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)
29
30NOT YET IMPLEMENTED
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
41=item AnyEvent::DNS::a $domain, $cb->(@addrs)
42
43Tries to resolve the given domain to IPv4 address(es).
44
45=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
46
47Tries to resolve the given domain into a sorted (lower preference value
48first) list of domain names.
49
50=item AnyEvent::DNS::ns $domain, $cb->(@hostnames)
51
52Tries to resolve the given domain name into a list of name servers.
53
54=item AnyEvent::DNS::txt $domain, $cb->(@hostnames)
55
56Tries to resolve the given domain name into a list of text records.
57
58=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
59
60Tries to resolve the given service, protocol and domain name into a list
61of service records.
62
63Each srv_rr is an arrayref with the following contents:
64C<[$priority, $weight, $transport, $target]>.
65
66They will be sorted with lowest priority, highest weight first (TODO:
67should use the rfc algorithm to reorder same-priority records for weight).
68
69Example:
70
71 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
72 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
73
74=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
75
76Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
77into it's hostname(s).
78
79Requires the Socket6 module for IPv6 support.
80
81Example:
82
83 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
84 # => f.root-servers.net
85
86=item AnyEvent::DNS::any $domain, $cb->(@rrs)
87
88Tries to resolve the given domain and passes all resource records found to
89the callback.
90
91=cut
92
93sub resolver;
94
95sub a($$) {
96 my ($domain, $cb) = @_;
97
98 resolver->resolve ($domain => "a", sub {
99 $cb->(map $_->[3], @_);
100 });
101}
102
103sub mx($$) {
104 my ($domain, $cb) = @_;
105
106 resolver->resolve ($domain => "mx", sub {
107 $cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
108 });
109}
110
111sub ns($$) {
112 my ($domain, $cb) = @_;
113
114 resolver->resolve ($domain => "ns", sub {
115 $cb->(map $_->[3], @_);
116 });
117}
118
119sub txt($$) {
120 my ($domain, $cb) = @_;
121
122 resolver->resolve ($domain => "txt", sub {
123 $cb->(map $_->[3], @_);
124 });
125}
126
127sub srv($$$$) {
128 my ($service, $proto, $domain, $cb) = @_;
129
130 # todo, ask for any and check glue records
131 resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
132 $cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] || $b->[4] <=> $a->[4] } @_);
133 });
134}
135
136sub ptr($$) {
137 my ($ip, $cb) = @_;
138
139 my $name;
140
141 if (AnyEvent::Util::dotted_quad $ip) {
142 $name = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
143 } else {
144 require Socket6;
145 $name = join ".",
146 (reverse split //,
147 unpack "H*", Socket6::inet_pton (Socket::AF_INET6, $ip)),
148 "ip6.arpa.";
149 }
150
151 resolver->resolve ($name => "ptr", sub {
152 $cb->(map $_->[3], @_);
153 });
154}
155
156sub any($$) {
157 my ($domain, $cb) = @_;
158
159 resolver->resolve ($domain => "*", $cb);
160}
30 161
31=head2 DNS EN-/DECODING FUNCTIONS 162=head2 DNS EN-/DECODING FUNCTIONS
32 163
33=over 4 164=over 4
34 165
… …
36 167
37our %opcode_id = ( 168our %opcode_id = (
38 query => 0, 169 query => 0,
39 iquery => 1, 170 iquery => 1,
40 status => 2, 171 status => 2,
172 notify => 4,
173 update => 5,
41 map +($_ => $_), 3..15 174 map +($_ => $_), 3, 6..15
42); 175);
43 176
44our %opcode_str = reverse %opcode_id; 177our %opcode_str = reverse %opcode_id;
45 178
46our %rcode_id = ( 179our %rcode_id = (
47 ok => 0, 180 noerror => 0,
48 formerr => 1, 181 formerr => 1,
49 servfail => 2, 182 servfail => 2,
50 nxdomain => 3, 183 nxdomain => 3,
51 notimp => 4, 184 notimp => 4,
52 refused => 5, 185 refused => 5,
186 yxdomain => 6, # Name Exists when it should not [RFC 2136]
187 yxrrset => 7, # RR Set Exists when it should not [RFC 2136]
188 nxrrset => 8, # RR Set that should exist does not [RFC 2136]
189 notauth => 9, # Server Not Authoritative for zone [RFC 2136]
190 notzone => 10, # Name not contained in zone [RFC 2136]
191# EDNS0 16 BADVERS Bad OPT Version [RFC 2671]
192# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845]
193# EDNS0 17 BADKEY Key not recognized [RFC 2845]
194# EDNS0 18 BADTIME Signature out of time window [RFC 2845]
195# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930]
196# EDNS0 20 BADNAME Duplicate key name [RFC 2930]
197# EDNS0 21 BADALG Algorithm not supported [RFC 2930]
53 map +($_ => $_), 6..15 198 map +($_ => $_), 11..15
54); 199);
55 200
56our %rcode_str = reverse %rcode_id; 201our %rcode_str = reverse %rcode_id;
57 202
58our %type_id = ( 203our %type_id = (
… …
72 minfo => 14, 217 minfo => 14,
73 mx => 15, 218 mx => 15,
74 txt => 16, 219 txt => 16,
75 aaaa => 28, 220 aaaa => 28,
76 srv => 33, 221 srv => 33,
222 opt => 41,
223 spf => 99,
224 tkey => 249,
225 tsig => 250,
226 ixfr => 251,
77 axfr => 252, 227 axfr => 252,
78 mailb => 253, 228 mailb => 253,
79 "*" => 255, 229 "*" => 255,
80); 230);
81 231
82our %type_str = reverse %type_id; 232our %type_str = reverse %type_id;
83 233
84our %class_id = ( 234our %class_id = (
85 in => 1, 235 in => 1,
86 ch => 3, 236 ch => 3,
87 hs => 4, 237 hs => 4,
238 none => 254,
88 "*" => 255, 239 "*" => 255,
89); 240);
90 241
91our %class_str = reverse %class_id; 242our %class_str = reverse %class_id;
92 243
93# names MUST have a trailing dot 244# names MUST have a trailing dot
… …
128 qr => 1, 279 qr => 1,
129 aa => 0, 280 aa => 0,
130 tc => 0, 281 tc => 0,
131 rd => 0, 282 rd => 0,
132 ra => 0, 283 ra => 0,
284 ad => 0,
285 cd => 0,
133 286
134 qd => [@rr], # query section 287 qd => [@rr], # query section
135 an => [@rr], # answer section 288 an => [@rr], # answer section
136 ns => [@rr], # authority section 289 ns => [@rr], # authority section
137 ar => [@rr], # additional records section 290 ar => [@rr], # additional records section
… …
140=cut 293=cut
141 294
142sub dns_pack($) { 295sub dns_pack($) {
143 my ($req) = @_; 296 my ($req) = @_;
144 297
145 pack "nn nnnn a* a* a* a*", 298 pack "nn nnnn a* a* a* a* a*",
146 $req->{id}, 299 $req->{id},
147 300
148 ! !$req->{qr} * 0x8000 301 ! !$req->{qr} * 0x8000
149 + $opcode_id{$req->{op}} * 0x0800 302 + $opcode_id{$req->{op}} * 0x0800
150 + ! !$req->{aa} * 0x0400 303 + ! !$req->{aa} * 0x0400
151 + ! !$req->{tc} * 0x0200 304 + ! !$req->{tc} * 0x0200
152 + ! !$req->{rd} * 0x0100 305 + ! !$req->{rd} * 0x0100
153 + ! !$req->{ra} * 0x0080 306 + ! !$req->{ra} * 0x0080
307 + ! !$req->{ad} * 0x0020
308 + ! !$req->{cd} * 0x0010
154 + $rcode_id{$req->{rc}} * 0x0001, 309 + $rcode_id{$req->{rc}} * 0x0001,
155 310
156 scalar @{ $req->{qd} || [] }, 311 scalar @{ $req->{qd} || [] },
157 scalar @{ $req->{an} || [] }, 312 scalar @{ $req->{an} || [] },
158 scalar @{ $req->{ns} || [] }, 313 scalar @{ $req->{ns} || [] },
159 scalar @{ $req->{ar} || [] }, 314 scalar @{ $req->{ar} || [] }, # include EDNS0 option here
160 315
161 (join "", map _enc_qd, @{ $req->{qd} || [] }), 316 (join "", map _enc_qd, @{ $req->{qd} || [] }),
162 (join "", map _enc_rr, @{ $req->{an} || [] }), 317 (join "", map _enc_rr, @{ $req->{an} || [] }),
163 (join "", map _enc_rr, @{ $req->{ns} || [] }), 318 (join "", map _enc_rr, @{ $req->{ns} || [] }),
164 (join "", map _enc_rr, @{ $req->{ar} || [] }); 319 (join "", map _enc_rr, @{ $req->{ar} || [] }),
320
321 # (pack "C nnNn", 0, 41, 4096, 0, 0) # EDNS0, 4kiB udp payload size
165} 322}
166 323
167our $ofs; 324our $ofs;
168our $pkt; 325our $pkt;
169 326
… …
209 my $rname = _dec_qname; 366 my $rname = _dec_qname;
210 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 367 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
211 }, # soa 368 }, # soa
212 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks 369 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks
213 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 370 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
214 13 => sub { unpack "C/a C/a", $_ }, 371 13 => sub { unpack "C/a C/a", $_ }, # hinfo
215 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 372 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
216 16 => sub { unpack "C/a", $_ }, # txt 373 16 => sub { unpack "(C/a)*", $_ }, # txt
217 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 374 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa
218 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 375 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
376 99 => sub { unpack "(C/a)*", $_ }, # spf
219); 377);
220 378
221sub _dec_rr { 379sub _dec_rr {
222 my $qname = _dec_qname; 380 my $qname = _dec_qname;
223 381
… …
312 qr => ! ! ($flags & 0x8000), 470 qr => ! ! ($flags & 0x8000),
313 aa => ! ! ($flags & 0x0400), 471 aa => ! ! ($flags & 0x0400),
314 tc => ! ! ($flags & 0x0200), 472 tc => ! ! ($flags & 0x0200),
315 rd => ! ! ($flags & 0x0100), 473 rd => ! ! ($flags & 0x0100),
316 ra => ! ! ($flags & 0x0080), 474 ra => ! ! ($flags & 0x0080),
475 ad => ! ! ($flags & 0x0020),
476 cd => ! ! ($flags & 0x0010),
317 op => $opcode_str{($flags & 0x001e) >> 11}, 477 op => $opcode_str{($flags & 0x001e) >> 11},
318 rc => $rcode_str{($flags & 0x000f)}, 478 rc => $rcode_str{($flags & 0x000f)},
319 479
320 qd => [map _dec_qd, 1 .. $qd], 480 qd => [map _dec_qd, 1 .. $qd],
321 an => [map _dec_rr, 1 .. $an], 481 an => [map _dec_rr, 1 .. $an],
… …
365 } 525 }
366} 526}
367 527
368=item $resolver = new AnyEvent::DNS key => value... 528=item $resolver = new AnyEvent::DNS key => value...
369 529
370Creates and returns a new resolver. It only supports UDP, so make sure 530Creates and returns a new resolver.
371your answer sections fit into a DNS packet.
372 531
373The following options are supported: 532The following options are supported:
374 533
375=over 4 534=over 4
376 535
… …
522 } 681 }
523 682
524 $self->{retry} = \@retry; 683 $self->{retry} = \@retry;
525} 684}
526 685
686sub _feed {
687 my ($self, $res) = @_;
688
689 $res = dns_unpack $res
690 or return;
691
692 my $id = $self->{id}{$res->{id}};
693
694 return unless ref $id;
695
696 $NOW = time;
697 $id->[1]->($res);
698}
699
527sub _recv { 700sub _recv {
528 my ($self) = @_; 701 my ($self) = @_;
529 702
530 while (my $peer = recv $self->{fh}, my $res, 1024, 0) { 703 while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
531 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 704 my ($port, $host) = Socket::unpack_sockaddr_in $peer;
532 705
533 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 706 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
534 707
535 $res = dns_unpack $res 708 $self->_feed ($res);
536 or return;
537
538 my $id = $self->{id}{$res->{id}};
539
540 return unless ref $id;
541
542 $NOW = time;
543 $id->[1]->($res);
544 } 709 }
545} 710}
546 711
547sub _exec { 712sub _exec {
548 my ($self, $req, $retry) = @_; 713 my ($self, $req, $retry) = @_;
… …
556 # timeout, try next 721 # timeout, try next
557 $self->_exec ($req, $retry + 1); 722 $self->_exec ($req, $retry + 1);
558 }), sub { 723 }), sub {
559 my ($res) = @_; 724 my ($res) = @_;
560 725
726 if ($res->{tc}) {
727 # success, but truncated, so use tcp
728 AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub {
729 my ($fh) = @_
730 or return $self->_exec ($req, $retry + 1);
731
732 my $handle = new AnyEvent::Handle
733 fh => $fh,
734 on_error => sub {
735 # failure, try next
736 $self->_exec ($req, $retry + 1);
737 };
738
739 $handle->push_write (pack "n/a", $req->[0]);
740 $handle->push_read_chunk (2, sub {
741 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub {
742 $self->_feed ($_[1]);
743 });
744 });
745 shutdown $fh, 1;
746
747 }, sub { $timeout };
748
749 } else {
561 # success 750 # success
562 $self->{id}{$req->[2]} = 1; 751 $self->{id}{$req->[2]} = 1;
563 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 752 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
564 --$self->{outstanding}; 753 --$self->{outstanding};
565 $self->_scheduler; 754 $self->_scheduler;
566 755
567 $req->[1]->($res); 756 $req->[1]->($res);
757 }
568 }]; 758 }];
569 759
570 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 760 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;
571 } else { 761 } else {
572 # failure 762 # failure
… …
719 # advance in searchlist 909 # advance in searchlist
720 my $do_search; $do_search = sub { 910 my $do_search; $do_search = sub {
721 @search 911 @search
722 or return $cb->(); 912 or return $cb->();
723 913
724 (my $name = "$qname." . shift @search) =~ s/\.$//; 914 (my $name = lc "$qname." . shift @search) =~ s/\.$//;
725 my $depth = 2; 915 my $depth = 2;
726 916
727 # advance in cname-chain 917 # advance in cname-chain
728 my $do_req; $do_req = sub { 918 my $do_req; $do_req = sub {
729 $self->request ({ 919 $self->request ({
… …
735 925
736 my $cname; 926 my $cname;
737 927
738 while () { 928 while () {
739 # results found? 929 # results found?
740 my @rr = grep $_->[0] eq $name && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} }; 930 my @rr = grep $name eq lc $_->[0] && ($atype{"*"} || $atype{$_->[1]}), @{ $res->{an} };
741 931
742 return $cb->(@rr) 932 return $cb->(@rr)
743 if @rr; 933 if @rr;
744 934
745 # see if there is a cname we can follow 935 # see if there is a cname we can follow
746 my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} }; 936 my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
747 937
748 if (@rr) { 938 if (@rr) {
749 $depth-- 939 $depth--
750 or return $do_search->(); # cname chain too long 940 or return $do_search->(); # cname chain too long
751 941

Diff Legend

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