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.42 by root, Thu May 29 06:17:52 2008 UTC vs.
Revision 1.51 by root, Fri May 30 05:56:20 2008 UTC

… …
14=head1 DESCRIPTION 14=head1 DESCRIPTION
15 15
16This module offers both a number of DNS convenience functions as well 16This module offers both a number of DNS convenience functions as well
17as a fully asynchronous and high-performance pure-perl stub resolver. 17as a fully asynchronous and high-performance pure-perl stub resolver.
18 18
19The stub resolver supports DNS over UDP, optional EDNS0 support for up to 19The stub resolver supports DNS over IPv4 and IPv6, UDP and TCP, optional
204kiB datagrams and automatically falls back to virtual circuit mode for 20EDNS0 support for up to 4kiB datagrams and automatically falls back to
21large responses. 21virtual circuit mode for large responses.
22 22
23=head2 CONVENIENCE FUNCTIONS 23=head2 CONVENIENCE FUNCTIONS
24 24
25=over 4 25=over 4
26 26
… …
68of service records. 68of service records.
69 69
70Each srv_rr is an array reference with the following contents: 70Each srv_rr is an array reference with the following contents:
71C<[$priority, $weight, $transport, $target]>. 71C<[$priority, $weight, $transport, $target]>.
72 72
73They will be sorted with lowest priority, highest weight first (TODO: 73They will be sorted with lowest priority first, then randomly
74should use the RFC algorithm to reorder same-priority records for weight). 74distributed by weight as per RFC 2782.
75 75
76Example: 76Example:
77 77
78 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ... 78 AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
79 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] ) 79 # @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
80 80
81=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames) 81=item AnyEvent::DNS::ptr $domain, $cb->(@hostnames)
82
83Tries to make a PTR lookup on the given domain. See C<reverse_lookup>
84and C<reverse_verify> if you want to resolve an IP address to a hostname
85instead.
86
87=item AnyEvent::DNS::any $domain, $cb->(@rrs)
88
89Tries to resolve the given domain and passes all resource records found to
90the callback.
91
92=item AnyEvent::DNS::reverse_lookup $ipv4_or_6, $cb->(@hostnames)
82 93
83Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form) 94Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
84into it's hostname(s). 95into it's hostname(s). Handles V4MAPPED and V4COMPAT IPv6 addresses
96transparently.
97
98=item AnyEvent::DNS::reverse_verify $ipv4_or_6, $cb->(@hostnames)
99
100The same as C<reverse_lookup>, but does forward-lookups to verify that
101the resolved hostnames indeed point to the address, which makes spoofing
102harder.
103
104If you want to resolve an address into a hostname, this is the preferred
105method: The DNS records could still change, but at least this function
106verified that the hostname, at one point in the past, pointed at the IP
107address you originally resolved.
85 108
86Example: 109Example:
87 110
88 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift }; 111 AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
89 # => f.root-servers.net 112 # => f.root-servers.net
90
91=item AnyEvent::DNS::any $domain, $cb->(@rrs)
92
93Tries to resolve the given domain and passes all resource records found to
94the callback.
95 113
96=cut 114=cut
97 115
98sub MAX_PKT() { 4096 } # max packet size we advertise and accept 116sub MAX_PKT() { 4096 } # max packet size we advertise and accept
99 117
… …
144sub srv($$$$) { 162sub srv($$$$) {
145 my ($service, $proto, $domain, $cb) = @_; 163 my ($service, $proto, $domain, $cb) = @_;
146 164
147 # todo, ask for any and check glue records 165 # todo, ask for any and check glue records
148 resolver->resolve ("_$service._$proto.$domain" => "srv", sub { 166 resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
149 $cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] || $b->[4] <=> $a->[4] } @_); 167 my @res;
168
169 # classify by priority
170 my %pri;
171 push @{ $pri{$_->[3]} }, [ @$_[3,4,5,6] ]
172 for @_;
173
174 # order by priority
175 for my $pri (sort { $a->[0] <=> $b->[0] } keys %pri) {
176 # order by weight
177 my @rr = sort { $a->[1] <=> $b->[1] } @{ delete $pri{$pri} };
178
179 my $sum; $sum += $_->[1] for @rr;
180
181 while (@rr) {
182 my $w = int rand $sum + 1;
183 for (0 .. $#rr) {
184 if (($w -= $rr[$_][1]) <= 0) {
185 $sum -= $rr[$_][1];
186 push @res, splice @rr, $_, 1, ();
187 last;
188 }
189 }
190 }
191 }
192
193 $cb->(@res);
150 }); 194 });
151} 195}
152 196
153sub ptr($$) { 197sub ptr($$) {
198 my ($domain, $cb) = @_;
199
200 resolver->resolve ($domain => "ptr", sub {
201 $cb->(map $_->[3], @_);
202 });
203}
204
205sub any($$) {
206 my ($domain, $cb) = @_;
207
208 resolver->resolve ($domain => "*", $cb);
209}
210
211# convert textual ip address into reverse lookup form
212sub _munge_ptr($) {
213 my $ipn = $_[0]
214 or return;
215
216 my $ptr;
217
218 my $af = AnyEvent::Socket::address_family ($ipn);
219
220 if ($af == AF_INET6) {
221 $ipn = substr $ipn, 0, 16; # anticipate future expansion
222
223 # handle v4mapped and v4compat
224 if ($ipn =~ s/^\x00{10}(?:\xff\xff|\x00\x00)//) {
225 $af = AF_INET;
226 } else {
227 $ptr = join ".", (reverse split //, unpack "H32", $ipn), "ip6.arpa.";
228 }
229 }
230
231 if ($af == AF_INET) {
232 $ptr = join ".", (reverse unpack "C4", $ipn), "in-addr.arpa.";
233 }
234
235 $ptr
236}
237
238sub reverse_lookup($$) {
154 my ($ip, $cb) = @_; 239 my ($ip, $cb) = @_;
155 240
156 $ip = AnyEvent::Socket::parse_address ($ip) 241 $ip = _munge_ptr AnyEvent::Socket::parse_address ($ip)
157 or return $cb->(); 242 or return $cb->();
158
159 my $af = AnyEvent::Socket::address_family ($ip);
160
161 if ($af == AF_INET) {
162 $ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
163 } elsif ($af == AF_INET6) {
164 $ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
165 } else {
166 return $cb->();
167 }
168 243
169 resolver->resolve ($ip => "ptr", sub { 244 resolver->resolve ($ip => "ptr", sub {
170 $cb->(map $_->[3], @_); 245 $cb->(map $_->[3], @_);
171 }); 246 });
172} 247}
173 248
174sub any($$) { 249sub reverse_verify($$) {
175 my ($domain, $cb) = @_; 250 my ($ip, $cb) = @_;
251
252 my $ipn = AnyEvent::Socket::parse_address ($ip)
253 or return $cb->();
176 254
177 resolver->resolve ($domain => "*", $cb); 255 my $af = AnyEvent::Socket::address_family ($ipn);
256
257 my @res;
258 my $cnt;
259
260 my $ptr = _munge_ptr $ipn
261 or return $cb->();
262
263 $ip = AnyEvent::Socket::format_address ($ipn); # normalise into the same form
264
265 ptr $ptr, sub {
266 for my $name (@_) {
267 ++$cnt;
268
269 # () around AF_INET to work around bug in 5.8
270 resolver->resolve ($name => ($af == (AF_INET) ? "a" : "aaaa"), sub {
271 for (@_) {
272 push @res, $name
273 if $_->[3] eq $ip;
274 }
275 $cb->(@res) unless --$cnt;
276 });
277 }
278
279 $cb->() unless $cnt;
280 };
178} 281}
179 282
180################################################################################# 283#################################################################################
181 284
182=back 285=back
… …
248 minfo => 14, 351 minfo => 14,
249 mx => 15, 352 mx => 15,
250 txt => 16, 353 txt => 16,
251 aaaa => 28, 354 aaaa => 28,
252 srv => 33, 355 srv => 33,
356 naptr => 35, # rfc2915
253 opt => 41, 357 opt => 41,
254 spf => 99, 358 spf => 99,
255 tkey => 249, 359 tkey => 249,
256 tsig => 250, 360 tsig => 250,
257 ixfr => 251, 361 ixfr => 251,
… …
270 "*" => 255, 374 "*" => 255,
271); 375);
272 376
273our %class_str = reverse %class_id; 377our %class_str = reverse %class_id;
274 378
275# names MUST have a trailing dot
276sub _enc_name($) { 379sub _enc_name($) {
277 pack "(C/a*)*", (split /\./, shift), "" 380 pack "(C/a*)*", (split /\./, shift), ""
278} 381}
279 382
280sub _enc_qd() { 383sub _enc_qd() {
… …
287 die "encoding of resource records is not supported"; 390 die "encoding of resource records is not supported";
288} 391}
289 392
290=item $pkt = AnyEvent::DNS::dns_pack $dns 393=item $pkt = AnyEvent::DNS::dns_pack $dns
291 394
292Packs a perl data structure into a DNS packet. Reading RFC1034 is strongly 395Packs a perl data structure into a DNS packet. Reading RFC 1035 is strongly
293recommended, then everything will be totally clear. Or maybe not. 396recommended, then everything will be totally clear. Or maybe not.
294 397
295Resource records are not yet encodable. 398Resource records are not yet encodable.
296 399
297Examples: 400Examples:
… …
340 + $rcode_id{$req->{rc}} * 0x0001, 443 + $rcode_id{$req->{rc}} * 0x0001,
341 444
342 scalar @{ $req->{qd} || [] }, 445 scalar @{ $req->{qd} || [] },
343 scalar @{ $req->{an} || [] }, 446 scalar @{ $req->{an} || [] },
344 scalar @{ $req->{ns} || [] }, 447 scalar @{ $req->{ns} || [] },
345 $EDNS0 + scalar @{ $req->{ar} || [] }, # include EDNS0 option here 448 $EDNS0 + scalar @{ $req->{ar} || [] }, # EDNS0 option included here
346 449
347 (join "", map _enc_qd, @{ $req->{qd} || [] }), 450 (join "", map _enc_qd, @{ $req->{qd} || [] }),
348 (join "", map _enc_rr, @{ $req->{an} || [] }), 451 (join "", map _enc_rr, @{ $req->{an} || [] }),
349 (join "", map _enc_rr, @{ $req->{ns} || [] }), 452 (join "", map _enc_rr, @{ $req->{ns} || [] }),
350 (join "", map _enc_rr, @{ $req->{ar} || [] }), 453 (join "", map _enc_rr, @{ $req->{ar} || [] }),
351 454
352 ($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0, 4kiB udp payload size 455 ($EDNS0 ? pack "C nnNn", 0, 41, MAX_PKT, 0, 0 : "") # EDNS0 option
353} 456}
354 457
355our $ofs; 458our $ofs;
356our $pkt; 459our $pkt;
357 460
… …
402 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo 505 13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
403 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx 506 15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_name) }, # mx
404 16 => sub { unpack "(C/a*)*", $_ }, # txt 507 16 => sub { unpack "(C/a*)*", $_ }, # txt
405 28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa 508 28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
406 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv 509 33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_name) }, # srv
510 35 => sub { # naptr
511 my ($order, $preference, $flags, $service, $regexp, $offset) = unpack "nn C/a* C/a* C/a* .", $_;
512 local $ofs = $ofs + $offset - length;
513 ($order, $preference, $flags, $service, $regexp, _dec_name)
514 },
407 99 => sub { unpack "(C/a*)*", $_ }, # spf 515 99 => sub { unpack "(C/a*)*", $_ }, # spf
408); 516);
409 517
410sub _dec_rr { 518sub _dec_rr {
411 my $name = _dec_name; 519 my $name = _dec_name;
… …
581The number of dots (default: C<1>) that a name must have so that the resolver 689The number of dots (default: C<1>) that a name must have so that the resolver
582tries to resolve the name without any suffixes first. 690tries to resolve the name without any suffixes first.
583 691
584=item max_outstanding => $integer 692=item max_outstanding => $integer
585 693
586Most name servers do not handle many parallel requests very well. This option 694Most name servers do not handle many parallel requests very well. This
587limits the number of outstanding requests to C<$n> (default: C<10>), that means 695option limits the number of outstanding requests to C<$integer>
588if you request more than this many requests, then the additional requests will be queued 696(default: C<10>), that means if you request more than this many requests,
589until some other requests have been resolved. 697then the additional requests will be queued until some other requests have
698been resolved.
590 699
591=item reuse => $seconds 700=item reuse => $seconds
592 701
593The number of seconds (default: C<300>) that a query id cannot be re-used 702The number of seconds (default: C<300>) that a query id cannot be re-used
594after a timeout. If there as no time-out then query id's can be reused 703after a timeout. If there as no time-out then query id's can be reused
… …
907} 1016}
908 1017
909sub _scheduler { 1018sub _scheduler {
910 my ($self) = @_; 1019 my ($self) = @_;
911 1020
1021 no strict 'refs';
1022
912 $NOW = time; 1023 $NOW = time;
913 1024
914 # first clear id reuse queue 1025 # first clear id reuse queue
915 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] } 1026 delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
916 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW; 1027 while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
… …
924 $self->_scheduler; 1035 $self->_scheduler;
925 }); 1036 });
926 last; 1037 last;
927 } 1038 }
928 1039
929 my $req = shift @{ $self->{queue} } 1040 if (my $req = shift @{ $self->{queue} }) {
930 or last; 1041 # found a request in the queue, execute it
931
932 while () { 1042 while () {
933 $req->[2] = int rand 65536; 1043 $req->[2] = int rand 65536;
934 last unless exists $self->{id}{$req->[2]}; 1044 last unless exists $self->{id}{$req->[2]};
1045 }
1046
1047 ++$self->{outstanding};
1048 $self->{id}{$req->[2]} = 1;
1049 substr $req->[0], 0, 2, pack "n", $req->[2];
1050
1051 $self->_exec ($req);
1052
1053 } elsif (my $cb = shift @{ $self->{wait} }) {
1054 # found a wait_for_slot callback, call that one first
1055 $cb->($self);
1056
1057 } else {
1058 # nothing to do, just exit
1059 last;
935 } 1060 }
936
937 ++$self->{outstanding};
938 $self->{id}{$req->[2]} = 1;
939 substr $req->[0], 0, 2, pack "n", $req->[2];
940
941 $self->_exec ($req);
942 } 1061 }
943} 1062}
944 1063
945=item $resolver->request ($req, $cb->($res)) 1064=item $resolver->request ($req, $cb->($res))
946 1065
… …
958 $self->_scheduler; 1077 $self->_scheduler;
959} 1078}
960 1079
961=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr)) 1080=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
962 1081
963Queries the DNS for the given domain name C<$qname> of type C<$qtype> (a 1082Queries the DNS for the given domain name C<$qname> of type C<$qtype>.
964qtype of "*" is supported and means "any"). 1083
1084A C<$qtype> is either a numerical query type (e.g. C<1> for A recods) or
1085a lowercase name (you have to look at the source to see which aliases are
1086supported, but all types from RFC 1035, C<aaaa>, C<srv>, C<spf> and a few
1087more are known to this module). A qtype of "*" is supported and means
1088"any" record type.
965 1089
966The callback will be invoked with a list of matching result records or 1090The callback will be invoked with a list of matching result records or
967none on any error or if the name could not be found. 1091none on any error or if the name could not be found.
968 1092
969CNAME chains (although illegal) are followed up to a length of 8. 1093CNAME chains (although illegal) are followed up to a length of 8.
1094
1095The callback will be invoked with an result code in string form (noerror,
1096formerr, servfail, nxdomain, notimp, refused and so on), or numerical
1097form if the result code is not supported. The remaining arguments are
1098arraryefs of the form C<[$name, $type, $class, @data>], where C<$name> is
1099the domain name, C<$type> a type string or number, C<$class> a class name
1100and @data is resource-record-dependent data. For C<a> records, this will
1101be the textual IPv4 addresses, for C<ns> or C<cname> records this will be
1102a domain name, for C<txt> records these are all the strings and so on.
1103
1104All types mentioned in RFC 1035, C<aaaa>, C<srv> and C<spf> are
1105decoded. All resource records not known to this module will just return
1106the raw C<rdata> field as fourth entry.
970 1107
971Note that this resolver is just a stub resolver: it requires a name server 1108Note that this resolver is just a stub resolver: it requires a name server
972supporting recursive queries, will not do any recursive queries itself and 1109supporting recursive queries, will not do any recursive queries itself and
973is not secure when used against an untrusted name server. 1110is not secure when used against an untrusted name server.
974 1111
… …
985 1122
986=item accept => [$type...] 1123=item accept => [$type...]
987 1124
988Lists the acceptable result types: only result types in this set will be 1125Lists the acceptable result types: only result types in this set will be
989accepted and returned. The default includes the C<$qtype> and nothing 1126accepted and returned. The default includes the C<$qtype> and nothing
990else. 1127else. If this list includes C<cname>, then CNAME-chains will not be
1128followed (because you asked for the CNAME record).
991 1129
992=item class => "class" 1130=item class => "class"
993 1131
994Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for 1132Specify the query class ("in" for internet, "ch" for chaosnet and "hs" for
995hesiod are the only ones making sense). The default is "in", of course. 1133hesiod are the only ones making sense). The default is "in", of course.
996 1134
997=back 1135=back
998 1136
999Examples: 1137Examples:
1000 1138
1001 $res->resolve ("ruth.plan9.de", "a", sub { 1139 # full example, you can paste this into perl:
1002 warn Dumper [@_]; 1140 use Data::Dumper;
1003 }); 1141 use AnyEvent::DNS;
1142 AnyEvent::DNS::resolver->resolve (
1143 "google.com", "*", my $cv = AnyEvent->condvar);
1144 warn Dumper [$cv->recv];
1004 1145
1146 # shortened result:
1005 [ 1147 # [
1148 # [ 'google.com', 'soa', 'in', 'ns1.google.com', 'dns-admin.google.com',
1149 # 2008052701, 7200, 1800, 1209600, 300 ],
1006 [ 1150 # [
1007 'ruth.schmorp.de', 1151 # 'google.com', 'txt', 'in',
1008 'a', 1152 # 'v=spf1 include:_netblocks.google.com ~all'
1009 'in', 1153 # ],
1010 '129.13.162.95' 1154 # [ 'google.com', 'a', 'in', '64.233.187.99' ],
1155 # [ 'google.com', 'mx', 'in', 10, 'smtp2.google.com' ],
1156 # [ 'google.com', 'ns', 'in', 'ns2.google.com' ],
1011 ] 1157 # ]
1158
1159 # resolve a records:
1160 $res->resolve ("ruth.plan9.de", "a", sub { warn Dumper [@_] });
1161
1162 # result:
1163 # [
1164 # [ 'ruth.schmorp.de', 'a', 'in', '129.13.162.95' ]
1012 ] 1165 # ]
1013 1166
1167 # resolve any records, but return only a and aaaa records:
1014 $res->resolve ("test1.laendle", "*", 1168 $res->resolve ("test1.laendle", "*",
1015 accept => ["a", "aaaa"], 1169 accept => ["a", "aaaa"],
1016 sub { 1170 sub {
1017 warn Dumper [@_]; 1171 warn Dumper [@_];
1018 } 1172 }
1019 ); 1173 );
1020 1174
1021 [ 1175 # result:
1022 [ 1176 # [
1023 'test1.laendle', 1177 # [ 'test1.laendle', 'a', 'in', '10.0.0.255' ],
1024 'a', 1178 # [ 'test1.laendle', 'aaaa', 'in', '3ffe:1900:4545:0002:0240:0000:0000:f7e1' ]
1025 'in',
1026 '10.0.0.255'
1027 ],
1028 [
1029 'test1.laendle',
1030 'aaaa',
1031 'in',
1032 '3ffe:1900:4545:0002:0240:0000:0000:f7e1'
1033 ] 1179 # ]
1034 ]
1035 1180
1036=cut 1181=cut
1037 1182
1038sub resolve($%) { 1183sub resolve($%) {
1039 my $cb = pop; 1184 my $cb = pop;
… …
1107 }; 1252 };
1108 1253
1109 $do_search->(); 1254 $do_search->();
1110} 1255}
1111 1256
1257=item $resolver->wait_for_slot ($cb->($resolver))
1258
1259Wait until a free request slot is available and call the callback with the
1260resolver object.
1261
1262A request slot is used each time a request is actually sent to the
1263nameservers: There are never more than C<max_outstanding> of them.
1264
1265Although you can submit more requests (they will simply be queued until
1266a request slot becomes available), sometimes, usually for rate-limiting
1267purposes, it is useful to instead wait for a slot before generating the
1268request (or simply to know when the request load is low enough so one can
1269submit requests again).
1270
1271This is what this method does: The callback will be called when submitting
1272a DNS request will not result in that request being queued. The callback
1273may or may not generate any requests in response.
1274
1275Note that the callback will only be invoked when the request queue is
1276empty, so this does not play well if somebody else keeps the request queue
1277full at all times.
1278
1279=cut
1280
1281sub wait_for_slot {
1282 my ($self, $cb) = @_;
1283
1284 push @{ $self->{wait} }, $cb;
1285 $self->_scheduler;
1286}
1287
1112use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end 1288use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
1113 1289
11141; 12901;
1115 1291
1116=back 1292=back

Diff Legend

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