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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.1 by root, Fri May 23 02:47:50 2008 UTC vs. Revision 1.38 by root, Thu May 29 01:46:56 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.1 by root, Fri May 23 02:47:50 2008 UTC vs.
Revision 1.38 by root, Thu May 29 01:46:56 2008 UTC