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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.2 by root, Fri May 23 02:59:32 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	# none yet
17
18	=over 4	25	=over 4
19		26
20	=cut	27	=cut
21		28
22	package AnyEvent::DNS;	29	package AnyEvent::DNS;
23		30
		31	no warnings;
24	use strict;	32	use strict;
25		33
		34	use Socket qw(AF_INET SOCK_DGRAM SOCK_STREAM);
		35
26	use AnyEvent::Util ();	36	use AnyEvent ();
		37	use AnyEvent::Handle ();
		38	use AnyEvent::Util qw(AF_INET6);
		39
		40	our $VERSION = '1.0';
		41
		42	our @DNS_FALLBACK = (v208.67.220.220, v208.67.222.222);
		43
		44	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
		45
		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).
		51
		52	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
		53
		54	Tries to resolve the given domain into a sorted (lower preference value
		55	first) list of domain names.
		56
		57	=item AnyEvent::DNS::ns $domain, $cb->(@hostnames)
		58
		59	Tries to resolve the given domain name into a list of name servers.
		60
		61	=item AnyEvent::DNS::txt $domain, $cb->(@hostnames)
		62
		63	Tries to resolve the given domain name into a list of text records.
		64
		65	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
		66
		67	Tries to resolve the given service, protocol and domain name into a list
		68	of service records.
		69
		70	Each srv_rr is an array reference with the following contents:
		71	C<[$priority, $weight, $transport, $target]>.
		72
		73	They will be sorted with lowest priority, highest weight first (TODO:
		74	should use the RFC algorithm to reorder same-priority records for weight).
		75
		76	Example:
		77
		78	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
		79	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
		80
		81	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
		82
		83	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
		84	into it's hostname(s).
		85
		86	Example:
		87
		88	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
		89	# => f.root-servers.net
		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
		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
		101
		102	sub resolver;
		103
		104	sub a($$) {
		105	my ($domain, $cb) = @_;
		106
		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 {
		116	$cb->(map $_->[3], @_);
		117	});
		118	}
		119
		120	sub mx($$) {
		121	my ($domain, $cb) = @_;
		122
		123	resolver->resolve ($domain => "mx", sub {
		124	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
		125	});
		126	}
		127
		128	sub ns($$) {
		129	my ($domain, $cb) = @_;
		130
		131	resolver->resolve ($domain => "ns", sub {
		132	$cb->(map $_->[3], @_);
		133	});
		134	}
		135
		136	sub txt($$) {
		137	my ($domain, $cb) = @_;
		138
		139	resolver->resolve ($domain => "txt", sub {
		140	$cb->(map $_->[3], @_);
		141	});
		142	}
		143
		144	sub srv($$$$) {
		145	my ($service, $proto, $domain, $cb) = @_;
		146
		147	# todo, ask for any and check glue records
		148	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
		149	$cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] \|\| $b->[4] <=> $a->[4] } @_);
		150	});
		151	}
		152
		153	sub ptr($$) {
		154	my ($ip, $cb) = @_;
		155
		156	$ip = AnyEvent::Socket::parse_address ($ip)
		157	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
		169	resolver->resolve ($ip => "ptr", sub {
		170	$cb->(map $_->[3], @_);
		171	});
		172	}
		173
		174	sub any($$) {
		175	my ($domain, $cb) = @_;
		176
		177	resolver->resolve ($domain => "*", $cb);
		178	}
		179
		180	#################################################################################
27		181
28	=back	182	=back
29		183
30	=head2 DNS EN-/DECODING FUNCTIONS	184	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
31		185
32	=over 4	186	=over 4
33		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
34	=cut	195	=cut
		196
		197	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
35		198
36	our %opcode_id = (	199	our %opcode_id = (
37	query => 0,	200	query => 0,
38	iquery => 1,	201	iquery => 1,
39	status => 2,	202	status => 2,
		203	notify => 4,
		204	update => 5,
40	map +($_ => $_), 3..15	205	map +($_ => $_), 3, 6..15
41	);	206	);
42		207
43	our %opcode_str = reverse %opcode_id;	208	our %opcode_str = reverse %opcode_id;
44		209
45	our %rcode_id = (	210	our %rcode_id = (
46	ok => 0,	211	noerror => 0,
47	formerr => 1,	212	formerr => 1,
48	servfail => 2,	213	servfail => 2,
49	nxdomain => 3,	214	nxdomain => 3,
50	notimp => 4,	215	notimp => 4,
51	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]
52	map +($_ => $_), 6..15	229	map +($_ => $_), 11..15
53	);	230	);
54		231
55	our %rcode_str = reverse %rcode_id;	232	our %rcode_str = reverse %rcode_id;
56		233
57	our %type_id = (	234	our %type_id = (
…		…
71	minfo => 14,	248	minfo => 14,
72	mx => 15,	249	mx => 15,
73	txt => 16,	250	txt => 16,
74	aaaa => 28,	251	aaaa => 28,
75	srv => 33,	252	srv => 33,
		253	opt => 41,
		254	spf => 99,
		255	tkey => 249,
		256	tsig => 250,
		257	ixfr => 251,
76	axfr => 252,	258	axfr => 252,
77	mailb => 253,	259	mailb => 253,
78	"*" => 255,	260	"*" => 255,
79	);	261	);
80		262
81	our %type_str = reverse %type_id;	263	our %type_str = reverse %type_id;
82		264
83	our %class_id = (	265	our %class_id = (
84	in => 1,	266	in => 1,
85	ch => 3,	267	ch => 3,
86	hs => 4,	268	hs => 4,
		269	none => 254,
87	"*" => 255,	270	"*" => 255,
88	);	271	);
89		272
90	our %class_str = reverse %class_id;	273	our %class_str = reverse %class_id;
91		274
92	# names MUST have a trailing dot	275	# names MUST have a trailing dot
93	sub _enc_qname($) {	276	sub _enc_name($) {
94	pack "(C/a)*", (split /\./, shift), ""	277	pack "(C/a)", (split /\./, shift), ""
95	}	278	}
96		279
97	sub _enc_qd() {	280	sub _enc_qd() {
98	(_enc_qname $_->[0]) . pack "nn",	281	(_enc_name $_->[0]) . pack "nn",
99	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),	282	($_->[1] > 0 ? $_->[1] : $type_id {$_->[1]}),
100	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})	283	($_->[2] > 0 ? $_->[2] : $class_id{$_->[2] \|\| "in"})
101	}	284	}
102		285
103	sub _enc_rr() {	286	sub _enc_rr() {
…		…
127	qr => 1,	310	qr => 1,
128	aa => 0,	311	aa => 0,
129	tc => 0,	312	tc => 0,
130	rd => 0,	313	rd => 0,
131	ra => 0,	314	ra => 0,
		315	ad => 0,
		316	cd => 0,
132		317
133	qd => [@rr], # query section	318	qd => [@rr], # query section
134	an => [@rr], # answer section	319	an => [@rr], # answer section
135	ns => [@rr], # authority section	320	ns => [@rr], # authority section
136	ar => [@rr], # additional records section	321	ar => [@rr], # additional records section
…		…
139	=cut	324	=cut
140		325
141	sub dns_pack($) {	326	sub dns_pack($) {
142	my ($req) = @_;	327	my ($req) = @_;
143		328
144	pack "nn nnnn a* a* a* a*",	329	pack "nn nnnn a* a* a* a* a*",
145	$req->{id},	330	$req->{id},
146		331
147	! !$req->{qr} * 0x8000	332	! !$req->{qr} * 0x8000
148	+ $opcode_id{$req->{op}} * 0x0800	333	+ $opcode_id{$req->{op}} * 0x0800
149	+ ! !$req->{aa} * 0x0400	334	+ ! !$req->{aa} * 0x0400
150	+ ! !$req->{tc} * 0x0200	335	+ ! !$req->{tc} * 0x0200
151	+ ! !$req->{rd} * 0x0100	336	+ ! !$req->{rd} * 0x0100
152	+ ! !$req->{ra} * 0x0080	337	+ ! !$req->{ra} * 0x0080
		338	+ ! !$req->{ad} * 0x0020
		339	+ ! !$req->{cd} * 0x0010
153	+ $rcode_id{$req->{rc}} * 0x0001,	340	+ $rcode_id{$req->{rc}} * 0x0001,
154		341
155	scalar @{ $req->{qd} \|\| [] },	342	scalar @{ $req->{qd} \|\| [] },
156	scalar @{ $req->{an} \|\| [] },	343	scalar @{ $req->{an} \|\| [] },
157	scalar @{ $req->{ns} \|\| [] },	344	scalar @{ $req->{ns} \|\| [] },
158	scalar @{ $req->{ar} \|\| [] },	345	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here
159		346
160	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	347	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
161	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	348	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
162	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	349	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
163	(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
164	}	353	}
165		354
166	our $ofs;	355	our $ofs;
167	our $pkt;	356	our $pkt;
168		357
169	# bitches	358	# bitches
170	sub _dec_qname {	359	sub _dec_name {
171	my @res;	360	my @res;
172	my $redir;	361	my $redir;
173	my $ptr = $ofs;	362	my $ptr = $ofs;
174	my $cnt;	363	my $cnt;
175		364
176	while () {	365	while () {
177	return undef if ++$cnt >= 256; # to avoid DoS attacks	366	return undef if ++$cnt >= 256; # to avoid DoS attacks
178		367
179	my $len = ord substr $pkt, $ptr++, 1;	368	my $len = ord substr $pkt, $ptr++, 1;
180		369
181	if ($len & 0xc0) {	370	if ($len >= 0xc0) {
182	$ptr++;	371	$ptr++;
183	$ofs = $ptr if $ptr > $ofs;	372	$ofs = $ptr if $ptr > $ofs;
184	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;	373	$ptr = (unpack "n", substr $pkt, $ptr - 2, 2) & 0x3fff;
185	} elsif ($len) {	374	} elsif ($len) {
186	push @res, substr $pkt, $ptr, $len;	375	push @res, substr $pkt, $ptr, $len;
…		…
191	}	380	}
192	}	381	}
193	}	382	}
194		383
195	sub _dec_qd {	384	sub _dec_qd {
196	my $qname = _dec_qname;	385	my $qname = _dec_name;
197	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	386	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
198	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	387	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
199	}	388	}
200		389
201	our %dec_rr = (	390	our %dec_rr = (
202	1 => sub { Socket::inet_ntoa $_ }, # a	391	1 => sub { join ".", unpack "C4", $_ }, # a
203	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	392	2 => sub { local $ofs = $ofs - length; _dec_name }, # ns
204	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	393	5 => sub { local $ofs = $ofs - length; _dec_name }, # cname
205	6 => sub {	394	6 => sub {
206	local $ofs = $ofs - length;	395	local $ofs = $ofs - length;
207	my $mname = _dec_qname;	396	my $mname = _dec_name;
208	my $rname = _dec_qname;	397	my $rname = _dec_name;
209	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	398	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
210	}, # soa	399	}, # soa
211	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
212	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	401	12 => sub { local $ofs = $ofs - length; _dec_name }, # ptr
213	13 => sub { unpack "C/a C/a", $_ },	402	13 => sub { unpack "C/a* C/a*", $_ }, # hinfo
214	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
215	16 => sub { unpack "C/a", $_ }, # txt	404	16 => sub { unpack "(C/a)", $_ }, # txt
216	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	405	28 => sub { AnyEvent::Socket::format_address ($_) }, # aaaa
217	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
218	);	408	);
219		409
220	sub _dec_rr {	410	sub _dec_rr {
221	my $qname = _dec_qname;	411	my $name = _dec_name;
222		412
223	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;
224	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;	414	local $_ = substr $pkt, $ofs, $rdlen; $ofs += $rdlen;
225		415
226	[	416	[
227	$qname,	417	$name,
228	$type_str{$rt} \|\| $rt,	418	$type_str{$rt} \|\| $rt,
229	$class_str{$rc} \|\| $rc,	419	$class_str{$rc} \|\| $rc,
230	($dec_rr{$rt} \|\| sub { $_ })->(),	420	($dec_rr{$rt} \|\| sub { $_ })->(),
231	]	421	]
232	}	422	}
…		…
235		425
236	Unpacks a DNS packet into a perl data structure.	426	Unpacks a DNS packet into a perl data structure.
237		427
238	Examples:	428	Examples:
239		429
240	# a non-successful reply	430	# an unsuccessful reply
241	{	431	{
242	'qd' => [	432	'qd' => [
243	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	433	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
244	],	434	],
245	'rc' => 'nxdomain',	435	'rc' => 'nxdomain',
…		…
249	'uni-karlsruhe.de',	439	'uni-karlsruhe.de',
250	'soa',	440	'soa',
251	'in',	441	'in',
252	'netserv.rz.uni-karlsruhe.de',	442	'netserv.rz.uni-karlsruhe.de',
253	'hostmaster.rz.uni-karlsruhe.de',	443	'hostmaster.rz.uni-karlsruhe.de',
254	2008052201,	444	2008052201, 10800, 1800, 2592000, 86400
255	10800,
256	1800,
257	2592000,
258	86400
259	]	445	]
260	],	446	],
261	'tc' => '',	447	'tc' => '',
262	'ra' => 1,	448	'ra' => 1,
263	'qr' => 1,	449	'qr' => 1,
…		…
311	qr => ! ! ($flags & 0x8000),	497	qr => ! ! ($flags & 0x8000),
312	aa => ! ! ($flags & 0x0400),	498	aa => ! ! ($flags & 0x0400),
313	tc => ! ! ($flags & 0x0200),	499	tc => ! ! ($flags & 0x0200),
314	rd => ! ! ($flags & 0x0100),	500	rd => ! ! ($flags & 0x0100),
315	ra => ! ! ($flags & 0x0080),	501	ra => ! ! ($flags & 0x0080),
		502	ad => ! ! ($flags & 0x0020),
		503	cd => ! ! ($flags & 0x0010),
316	op => $opcode_str{($flags & 0x001e) >> 11},	504	op => $opcode_str{($flags & 0x001e) >> 11},
317	rc => $rcode_str{($flags & 0x000f)},	505	rc => $rcode_str{($flags & 0x000f)},
318		506
319	qd => [map _dec_qd, 1 .. $qd],	507	qd => [map _dec_qd, 1 .. $qd],
320	an => [map _dec_rr, 1 .. $an],	508	an => [map _dec_rr, 1 .. $an],
…		…
327		515
328	=back	516	=back
329		517
330	=head2 THE AnyEvent::DNS RESOLVER CLASS	518	=head2 THE AnyEvent::DNS RESOLVER CLASS
331		519
332	This is the class which deos the actual protocol work.	520	This is the class which does the actual protocol work.
333		521
334	=over 4	522	=over 4
335		523
336	=cut	524	=cut
337		525
…		…
357	our $RESOLVER;	545	our $RESOLVER;
358		546
359	sub resolver() {	547	sub resolver() {
360	$RESOLVER \|\| do {	548	$RESOLVER \|\| do {
361	$RESOLVER = new AnyEvent::DNS;	549	$RESOLVER = new AnyEvent::DNS;
362	$RESOLVER->load_resolv_conf;	550	$RESOLVER->os_config;
363	$RESOLVER	551	$RESOLVER
364	}	552	}
365	}	553	}
366		554
367	=item $resolver = new AnyEvent::DNS key => value...	555	=item $resolver = new AnyEvent::DNS key => value...
368		556
369	Creates and returns a new resolver. It only supports UDP, so make sure	557	Creates and returns a new resolver.
370	your answer sections fit into a DNS packet.
371		558
372	The following options are supported:	559	The following options are supported:
373		560
374	=over 4	561	=over 4
375		562
376	=item server => [...]	563	=item server => [...]
377		564
378	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
379	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).
380		568
381	=item timeout => [...]	569	=item timeout => [...]
382		570
383	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
384	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,
…		…
394	tries to resolve the name without any suffixes first.	582	tries to resolve the name without any suffixes first.
395		583
396	=item max_outstanding => $integer	584	=item max_outstanding => $integer
397		585
398	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
399	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
400	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
401	until some other requests have been resolved.	589	until some other requests have been resolved.
402		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
403	=back	597	=back
404		598
405	=cut	599	=cut
406		600
407	sub new {	601	sub new {
408	my ($class, %arg) = @_;	602	my ($class, %arg) = @_;
409		603
		604	# try to create a ipv4 and an ipv6 socket
		605	# only fail when we cnanot create either
		606
410	socket my $fh, &Socket::AF_INET, &Socket::SOCK_DGRAM, 0	607	socket my $fh4, AF_INET , &Socket::SOCK_DGRAM, 0;
411	or Carp::croak "socket: $!";	608	socket my $fh6, AF_INET6, &Socket::SOCK_DGRAM, 0;
412		609
413	AnyEvent::Util::fh_nonblocking $fh, 1;	610	$fh4 \|\| $fh6
		611	or Carp::croak "unable to create either an IPv6 or an IPv4 socket";
414		612
415	my $self = bless {	613	my $self = bless {
416	server => [v127.0.0.1],	614	server => [],
417	timeout => [2, 5, 5],	615	timeout => [2, 5, 5],
418	search => [],	616	search => [],
419	ndots => 1,	617	ndots => 1,
420	max_outstanding => 10,	618	max_outstanding => 10,
421	reuse => 300, # reuse id's after 5 minutes only, if possible	619	reuse => 300, # reuse id's after 5 minutes only, if possible
422	%arg,	620	%arg,
423	fh => $fh,
424	reuse_q => [],	621	reuse_q => [],
425	}, $class;	622	}, $class;
426		623
427	# search should default to gethostname's domain	624	# search should default to gethostname's domain
428	# but perl lacks a good posix module	625	# but perl lacks a good posix module
429		626
430	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;
431	$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	}
432		648
433	$self->_compile;	649	$self->_compile;
434		650
435	$self	651	$self
436	}	652	}
437		653
438	=item $resolver->parse_resolv_conv ($string)	654	=item $resolver->parse_resolv_conv ($string)
439		655
440	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
441	directives are supported:	657	directives are supported (but not necessarily implemented).
442		658
443	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	659	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
444	C<options> (C<timeout>, C<attempts>, C<ndots>).	660	C<options> (C<timeout>, C<attempts>, C<ndots>).
445		661
446	Everything else is silently ignored.	662	Everything else is silently ignored.
…		…
458	for (split /\n/, $resolvconf) {	674	for (split /\n/, $resolvconf) {
459	if (/^\s*#/) {	675	if (/^\s*#/) {
460	# comment	676	# comment
461	} elsif (/^\snameserver\s+(\S+)\s$/i) {	677	} elsif (/^\snameserver\s+(\S+)\s$/i) {
462	my $ip = $1;	678	my $ip = $1;
463	if (AnyEvent::Util::dotted_quad $ip) {	679	if (my $ipn = AnyEvent::Socket::parse_address ($ip)) {
464	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	680	push @{ $self->{server} }, $ipn;
465	} else {	681	} else {
466	warn "nameserver $ip invalid and ignored\n";	682	warn "nameserver $ip invalid and ignored\n";
467	}	683	}
468	} elsif (/^\sdomain\s+(\S)\s+$/i) {	684	} elsif (/^\sdomain\s+(\S)\s+$/i) {
469	$self->{search} = [$1];	685	$self->{search} = [$1];
…		…
490	if $attempts;	706	if $attempts;
491		707
492	$self->_compile;	708	$self->_compile;
493	}	709	}
494		710
495	=item $resolver->load_resolv_conf	711	=item $resolver->os_config
496		712
497	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
498	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.
499		715
500	=cut	716	=cut
501		717
502	sub load_resolv_conf {	718	sub os_config {
503	my ($self) = @_;	719	my ($self) = @_;
504		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
505	open my $fh, "</etc/resolv.conf"	770	if (open my $fh, "</etc/resolv.conf") {
506	or return;
507
508	local $/;	771	local $/;
509	$self->parse_resolv_conf (<$fh>);	772	$self->parse_resolv_conf (<$fh>);
		773	}
		774	}
510	}	775	}
511		776
512	sub _compile {	777	sub _compile {
513	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	}
514		787
515	my @retry;	788	my @retry;
516		789
517	for my $timeout (@{ $self->{timeout} }) {	790	for my $timeout (@{ $self->{timeout} }) {
518	for my $server (@{ $self->{server} }) {	791	for my $server (@{ $self->{server} }) {
…		…
521	}	794	}
522		795
523	$self->{retry} = \@retry;	796	$self->{retry} = \@retry;
524	}	797	}
525		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
526	sub _recv {	813	sub _recv {
527	my ($self) = @_;	814	my ($self, $pkt, $peer) = @_;
528		815
529	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
530	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	819	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
531		820
532	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	821	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
533		822
534	$res = AnyEvent::DNS::dns_unpack $res	823	$self->_feed ($pkt);
535	or return;	824	}
536		825
537	my $id = $self->{id}{$res->{id}};	826	sub _free_id {
		827	my ($self, $id, $timeout) = @_;
538		828
539	return unless ref $id;	829	if ($timeout) {
540		830	# we need to block the id for a while
541	$NOW = time;	831	$self->{id}{$id} = 1;
542	$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};
543	}	836	}
544	}
545		837
		838	--$self->{outstanding};
		839	$self->_scheduler;
		840	}
		841
		842	# execute a single request, involves sending it with timeouts to multiple servers
546	sub _exec {	843	sub _exec {
547	my ($self, $req, $retry) = @_;	844	my ($self, $req) = @_;
548		845
		846	my $retry; # of retries
		847	my $do_retry;
		848
		849	$do_retry = sub {
549	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
550	my ($server, $timeout) = @$retry_cfg;	857	my ($server, $timeout) = @$retry_cfg;
551		858
552	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	859	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
553	$NOW = time;	860	$NOW = time;
554		861
555	# timeout, try next	862	# timeout, try next
556	$self->_exec ($req, $retry + 1);	863	&$do_retry;
557	}), sub {	864	}), sub {
558	my ($res) = @_;	865	my ($res) = @_;
559		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 {
560	# success	891	# success
561	$self->{id}{$req->[2]} = 1;	892	$self->_free_id ($req->[2], $retry > 1);
562	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	893	undef $do_retry; return $req->[1]->($res);
563	--$self->{outstanding};	894	}
564	$self->_scheduler;
565
566	$req->[1]->($res);
567	}];	895	}];
		896
		897	my $sa = AnyEvent::Socket::pack_sockaddr (DOMAIN_PORT, $server);
568		898
569	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	899	my $fh = AF_INET == Socket::sockaddr_family ($sa)
570	} else {	900	? $self->{fh4} : $self->{fh6}
571	# failure	901	or return &$do_retry;
572	$self->{id}{$req->[2]} = 1;
573	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
574	--$self->{outstanding};
575	$self->_scheduler;
576		902
577	$req->[1]->();	903	send $fh, $req->[0], 0, $sa;
578	}	904	};
		905
		906	&$do_retry;
579	}	907	}
580		908
581	sub _scheduler {	909	sub _scheduler {
582	my ($self) = @_;	910	my ($self) = @_;
583		911
584	$NOW = time;	912	$NOW = time;
585		913
586	# first clear id reuse queue	914	# first clear id reuse queue
587	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	915	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
588	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	916	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
589		917
590	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
591	my $req = shift @{ $self->{queue} }	929	my $req = shift @{ $self->{queue} }
592	or last;	930	or last;
593		931
594	while () {	932	while () {
595	$req->[2] = int rand 65536;	933	$req->[2] = int rand 65536;
596	last unless exists $self->{id}{$req->[2]};	934	last unless exists $self->{id}{$req->[2]};
597	}	935	}
598		936
		937	++$self->{outstanding};
599	$self->{id}{$req->[2]} = 1;	938	$self->{id}{$req->[2]} = 1;
600	substr $req->[0], 0, 2, pack "n", $req->[2];	939	substr $req->[0], 0, 2, pack "n", $req->[2];
601		940
602	++$self->{outstanding};
603	$self->_exec ($req, 0);	941	$self->_exec ($req);
604	}	942	}
605	}	943	}
606		944
607	=item $resolver->request ($req, $cb->($res))	945	=item $resolver->request ($req, $cb->($res))
608		946
609	Sends a single request (a hash-ref formated as specified for	947	Sends a single request (a hash-ref formated as specified for
610	C<AnyEvent::DNS::dns_pack>) to the configured nameservers including	948	C<dns_pack>) to the configured nameservers including
611	retries. Calls the callback with the decoded response packet if a reply	949	retries. Calls the callback with the decoded response packet if a reply
612	was received, or no arguments on timeout.	950	was received, or no arguments on timeout.
613		951
614	=cut	952	=cut
615		953
616	sub request($$) {	954	sub request($$) {
617	my ($self, $req, $cb) = @_;	955	my ($self, $req, $cb) = @_;
618		956
619	push @{ $self->{queue} }, [(AnyEvent::DNS::dns_pack $req), $cb];	957	push @{ $self->{queue} }, [dns_pack $req, $cb];
620	$self->_scheduler;	958	$self->_scheduler;
621	}	959	}
622		960
623	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))	961	=item $resolver->resolve ($qname, $qtype, %options, $cb->($rcode, @rr))
624		962
…		…
627		965
628	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
629	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.
630		968
631	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.
		970
		971	Note that this resolver is just a stub resolver: it requires a name server
		972	supporting recursive queries, will not do any recursive queries itself and
		973	is not secure when used against an untrusted name server.
632		974
633	The following options are supported:	975	The following options are supported:
634		976
635	=over 4	977	=over 4
636		978
…		…
710	my %atype = $opt{accept}	1052	my %atype = $opt{accept}
711	? map +($_ => 1), @{ $opt{accept} }	1053	? map +($_ => 1), @{ $opt{accept} }
712	: ($qtype => 1);	1054	: ($qtype => 1);
713		1055
714	# advance in searchlist	1056	# advance in searchlist
715	my $do_search; $do_search = sub {	1057	my ($do_search, $do_req);
		1058
		1059	$do_search = sub {
716	@search	1060	@search
717	or return $cb->();	1061	or (undef $do_search), (undef $do_req), return $cb->();
718		1062
719	(my $name = "$qname." . shift @search) =~ s/\.$//;	1063	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
720	my $depth = 2;	1064	my $depth = 2;
721		1065
722	# advance in cname-chain	1066	# advance in cname-chain
723	my $do_req; $do_req = sub {	1067	$do_req = sub {
724	$self->request ({	1068	$self->request ({
725	rd => 1,	1069	rd => 1,
726	qd => [[$name, $qtype, $class]],	1070	qd => [[$name, $qtype, $class]],
727	}, sub {	1071	}, sub {
728	my ($res) = @_	1072	my ($res) = @_
…		…
730		1074
731	my $cname;	1075	my $cname;
732		1076
733	while () {	1077	while () {
734	# results found?	1078	# results found?
735	my @rr = grep $_->[0] eq $name && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1079	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
736		1080
737	return $cb->(@rr)	1081	(undef $do_search), (undef $do_req), return $cb->(@rr)
738	if @rr;	1082	if @rr;
739		1083
740	# see if there is a cname we can follow	1084	# see if there is a cname we can follow
741	my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} };	1085	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
742		1086
743	if (@rr) {	1087	if (@rr) {
744	$depth--	1088	$depth--
745	or return $do_search->(); # cname chain too long	1089	or return $do_search->(); # cname chain too long
746		1090
…		…
763	};	1107	};
764		1108
765	$do_search->();	1109	$do_search->();
766	}	1110	}
767		1111
		1112	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1113
768	1;	1114	1;
769		1115
770	=back	1116	=back
771		1117
772	=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.2 by root, Fri May 23 02:59:32 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.2 by root, Fri May 23 02:59:32 2008 UTC vs.
Revision 1.41 by root, Thu May 29 06:17:03 2008 UTC