[ViewVC] Diff of: cvs/AnyEvent/lib/AnyEvent/DNS.pm

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.41 by root, Thu May 29 06:17:03 2008 UTC

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs. Revision 1.41 by root, Thu May 29 06:17:03 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.4 by root, Fri May 23 04:10:40 2008 UTC vs.
Revision 1.41 by root, Thu May 29 06:17:03 2008 UTC