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.6 by root, Fri May 23 05:16:57 2008 UTC

… …
21 21
22no warnings; 22no warnings;
23use strict; 23use strict;
24 24
25use AnyEvent::Util (); 25use AnyEvent::Util ();
26use AnyEvent::Handle ();
26 27
27=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs) 28=item AnyEvent::DNS::addr $node, $service, $family, $type, $cb->(@addrs)
28 29
29NOT YET IMPLEMENTED 30NOT YET IMPLEMENTED
30 31
… …
79 80
80Example: 81Example:
81 82
82 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 83 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
83 # => f.root-servers.net 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.
84 90
85=cut 91=cut
86 92
87sub resolver; 93sub resolver;
88 94
… …
145 resolver->resolve ($name => "ptr", sub { 151 resolver->resolve ($name => "ptr", sub {
146 $cb->(map $_->[3], @_); 152 $cb->(map $_->[3], @_);
147 }); 153 });
148} 154}
149 155
156sub any($$) {
157 my ($domain, $cb) = @_;
158
159 resolver->resolve ($domain => "*", $cb);
160}
161
150=head2 DNS EN-/DECODING FUNCTIONS 162=head2 DNS EN-/DECODING FUNCTIONS
151 163
152=over 4 164=over 4
153 165
154=cut 166=cut
155 167
156our %opcode_id = ( 168our %opcode_id = (
157 query => 0, 169 query => 0,
158 iquery => 1, 170 iquery => 1,
159 status => 2, 171 status => 2,
172 notify => 4,
173 update => 5,
160 map +($_ => $_), 3..15 174 map +($_ => $_), 3, 6..15
161); 175);
162 176
163our %opcode_str = reverse %opcode_id; 177our %opcode_str = reverse %opcode_id;
164 178
165our %rcode_id = ( 179our %rcode_id = (
166 noerror => 0, 180 noerror => 0,
167 formerr => 1, 181 formerr => 1,
168 servfail => 2, 182 servfail => 2,
169 nxdomain => 3, 183 nxdomain => 3,
170 notimp => 4, 184 notimp => 4,
171 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]
172 map +($_ => $_), 6..15 198 map +($_ => $_), 11..15
173); 199);
174 200
175our %rcode_str = reverse %rcode_id; 201our %rcode_str = reverse %rcode_id;
176 202
177our %type_id = ( 203our %type_id = (
… …
191 minfo => 14, 217 minfo => 14,
192 mx => 15, 218 mx => 15,
193 txt => 16, 219 txt => 16,
194 aaaa => 28, 220 aaaa => 28,
195 srv => 33, 221 srv => 33,
222 opt => 41,
223 spf => 99,
224 tkey => 249,
225 tsig => 250,
226 ixfr => 251,
196 axfr => 252, 227 axfr => 252,
197 mailb => 253, 228 mailb => 253,
198 "*" => 255, 229 "*" => 255,
199); 230);
200 231
201our %type_str = reverse %type_id; 232our %type_str = reverse %type_id;
202 233
203our %class_id = ( 234our %class_id = (
204 in => 1, 235 in => 1,
205 ch => 3, 236 ch => 3,
206 hs => 4, 237 hs => 4,
238 none => 254,
207 "*" => 255, 239 "*" => 255,
208); 240);
209 241
210our %class_str = reverse %class_id; 242our %class_str = reverse %class_id;
211 243
212# names MUST have a trailing dot 244# names MUST have a trailing dot
… …
247 qr => 1, 279 qr => 1,
248 aa => 0, 280 aa => 0,
249 tc => 0, 281 tc => 0,
250 rd => 0, 282 rd => 0,
251 ra => 0, 283 ra => 0,
284 ad => 0,
285 cd => 0,
252 286
253 qd => [@rr], # query section 287 qd => [@rr], # query section
254 an => [@rr], # answer section 288 an => [@rr], # answer section
255 ns => [@rr], # authority section 289 ns => [@rr], # authority section
256 ar => [@rr], # additional records section 290 ar => [@rr], # additional records section
… …
268 + $opcode_id{$req->{op}} * 0x0800 302 + $opcode_id{$req->{op}} * 0x0800
269 + ! !$req->{aa} * 0x0400 303 + ! !$req->{aa} * 0x0400
270 + ! !$req->{tc} * 0x0200 304 + ! !$req->{tc} * 0x0200
271 + ! !$req->{rd} * 0x0100 305 + ! !$req->{rd} * 0x0100
272 + ! !$req->{ra} * 0x0080 306 + ! !$req->{ra} * 0x0080
307 + ! !$req->{ad} * 0x0020
308 + ! !$req->{cd} * 0x0010
273 + $rcode_id{$req->{rc}} * 0x0001, 309 + $rcode_id{$req->{rc}} * 0x0001,
274 310
275 scalar @{ $req->{qd} || [] }, 311 scalar @{ $req->{qd} || [] },
276 scalar @{ $req->{an} || [] }, 312 scalar @{ $req->{an} || [] },
277 scalar @{ $req->{ns} || [] }, 313 scalar @{ $req->{ns} || [] },
… …
328 my $rname = _dec_qname; 364 my $rname = _dec_qname;
329 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs) 365 ($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
330 }, # soa 366 }, # soa
331 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks 367 11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks
332 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr 368 12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
333 13 => sub { unpack "C/a C/a", $_ }, 369 13 => sub { unpack "C/a C/a", $_ }, # hinfo
334 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx 370 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
335 16 => sub { unpack "C/a", $_ }, # txt 371 16 => sub { unpack "(C/a)*", $_ }, # txt
336 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa 372 28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa
337 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv 373 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
374 99 => sub { unpack "(C/a)*", $_ }, # spf
338); 375);
339 376
340sub _dec_rr { 377sub _dec_rr {
341 my $qname = _dec_qname; 378 my $qname = _dec_qname;
342 379
… …
431 qr => ! ! ($flags & 0x8000), 468 qr => ! ! ($flags & 0x8000),
432 aa => ! ! ($flags & 0x0400), 469 aa => ! ! ($flags & 0x0400),
433 tc => ! ! ($flags & 0x0200), 470 tc => ! ! ($flags & 0x0200),
434 rd => ! ! ($flags & 0x0100), 471 rd => ! ! ($flags & 0x0100),
435 ra => ! ! ($flags & 0x0080), 472 ra => ! ! ($flags & 0x0080),
473 ad => ! ! ($flags & 0x0020),
474 cd => ! ! ($flags & 0x0010),
436 op => $opcode_str{($flags & 0x001e) >> 11}, 475 op => $opcode_str{($flags & 0x001e) >> 11},
437 rc => $rcode_str{($flags & 0x000f)}, 476 rc => $rcode_str{($flags & 0x000f)},
438 477
439 qd => [map _dec_qd, 1 .. $qd], 478 qd => [map _dec_qd, 1 .. $qd],
440 an => [map _dec_rr, 1 .. $an], 479 an => [map _dec_rr, 1 .. $an],
… …
484 } 523 }
485} 524}
486 525
487=item $resolver = new AnyEvent::DNS key => value... 526=item $resolver = new AnyEvent::DNS key => value...
488 527
489Creates and returns a new resolver. It only supports UDP, so make sure 528Creates and returns a new resolver.
490your answer sections fit into a DNS packet.
491 529
492The following options are supported: 530The following options are supported:
493 531
494=over 4 532=over 4
495 533
… …
641 } 679 }
642 680
643 $self->{retry} = \@retry; 681 $self->{retry} = \@retry;
644} 682}
645 683
684sub _feed {
685 my ($self, $res) = @_;
686
687 $res = dns_unpack $res
688 or return;
689
690 my $id = $self->{id}{$res->{id}};
691
692 return unless ref $id;
693
694 $NOW = time;
695 $id->[1]->($res);
696}
697
646sub _recv { 698sub _recv {
647 my ($self) = @_; 699 my ($self) = @_;
648 700
649 while (my $peer = recv $self->{fh}, my $res, 1024, 0) { 701 while (my $peer = recv $self->{fh}, my $res, 1024, 0) {
650 my ($port, $host) = Socket::unpack_sockaddr_in $peer; 702 my ($port, $host) = Socket::unpack_sockaddr_in $peer;
651 703
652 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; 704 return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
653 705
654 $res = dns_unpack $res 706 $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 } 707 }
664} 708}
665 709
666sub _exec { 710sub _exec {
667 my ($self, $req, $retry) = @_; 711 my ($self, $req, $retry) = @_;
… …
675 # timeout, try next 719 # timeout, try next
676 $self->_exec ($req, $retry + 1); 720 $self->_exec ($req, $retry + 1);
677 }), sub { 721 }), sub {
678 my ($res) = @_; 722 my ($res) = @_;
679 723
724 if ($res->{tc}) {
725 # success, but truncated, so use tcp
726 AnyEvent::Util::tcp_connect +(Socket::inet_ntoa $server), 53, sub {
727 my ($fh) = @_
728 or return $self->_exec ($req, $retry + 1);
729
730 my $handle = new AnyEvent::Handle
731 fh => $fh,
732 on_error => sub {
733 # failure, try next
734 $self->_exec ($req, $retry + 1);
735 };
736
737 $handle->push_write (pack "n/a", $req->[0]);
738 $handle->push_read_chunk (2, sub {
739 $handle->unshift_read_chunk ((unpack "n", $_[1]), sub {
740 $self->_feed ($_[1]);
741 });
742 });
743 shutdown $fh, 1;
744
745 }, sub { $timeout };
746
747 } else {
680 # success 748 # success
681 $self->{id}{$req->[2]} = 1; 749 $self->{id}{$req->[2]} = 1;
682 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]]; 750 push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
683 --$self->{outstanding}; 751 --$self->{outstanding};
684 $self->_scheduler; 752 $self->_scheduler;
685 753
686 $req->[1]->($res); 754 $req->[1]->($res);
755 }
687 }]; 756 }];
688 757
689 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server; 758 send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;
690 } else { 759 } else {
691 # failure 760 # failure

Diff Legend

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