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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs. Revision 1.39 by root, Thu May 29 03:45:37 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.3 by root, Fri May 23 03:20:53 2008 UTC vs.
Revision 1.39 by root, Thu May 29 03:45:37 2008 UTC