[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.26 by root, Sat May 24 18:50:40 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", sub { $cv->send (@_) };
		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
27	use AnyEvent::Util ();	34	use AnyEvent::Handle ();
		35
		36	=item AnyEvent::DNS::addr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
		37
		38	Tries to resolve the given nodename and service name into protocol families
		39	and sockaddr structures usable to connect to this node and service in a
		40	protocol-independent way. It works remotely similar to the getaddrinfo
		41	posix function.
		42
		43	C<$node> is either an IPv4 or IPv6 address or a hostname, C<$service> is
		44	either a service name (port name from F</etc/services>) or a numerical
		45	port number. If both C<$node> and C<$service> are names, then SRV records
		46	will be consulted to find the real service, otherwise they will be
		47	used as-is. If you know that the service name is not in your services
		48	database, then you can specify the service in the format C<name=port>
		49	(e.g. C<http=80>).
		50
		51	C<$proto> must be a protocol name, currently C<tcp>, C<udp> or
		52	C<sctp>. The default is C<tcp>.
		53
		54	C<$family> must be either C<0> (meaning any protocol is OK), C<4> (use
		55	only IPv4) or C<6> (use only IPv6). This setting might be influenced by
		56	C<$ENV{PERL_ANYEVENT_PROTOCOLS}>.
		57
		58	C<$type> must be C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_SEQPACKET> (or
		59	C<undef> in which case it gets automatically chosen).
		60
		61	The callback will receive zero or more array references that contain
		62	C<$family, $type, $proto> for use in C<socket> and a binary
		63	C<$sockaddr> for use in C<connect> (or C<bind>).
		64
		65	The application should try these in the order given.
		66
		67	Example:
		68
		69	AnyEvent::DNS::addr "google.com", "http", 0, undef, undef, sub { ... };
		70
		71	=item AnyEvent::DNS::a $domain, $cb->(@addrs)
		72
		73	Tries to resolve the given domain to IPv4 address(es).
		74
		75	=item AnyEvent::DNS::aaaa $domain, $cb->(@addrs)
		76
		77	Tries to resolve the given domain to IPv6 address(es).
		78
		79	=item AnyEvent::DNS::mx $domain, $cb->(@hostnames)
		80
		81	Tries to resolve the given domain into a sorted (lower preference value
		82	first) list of domain names.
		83
		84	=item AnyEvent::DNS::ns $domain, $cb->(@hostnames)
		85
		86	Tries to resolve the given domain name into a list of name servers.
		87
		88	=item AnyEvent::DNS::txt $domain, $cb->(@hostnames)
		89
		90	Tries to resolve the given domain name into a list of text records.
		91
		92	=item AnyEvent::DNS::srv $service, $proto, $domain, $cb->(@srv_rr)
		93
		94	Tries to resolve the given service, protocol and domain name into a list
		95	of service records.
		96
		97	Each srv_rr is an array reference with the following contents:
		98	C<[$priority, $weight, $transport, $target]>.
		99
		100	They will be sorted with lowest priority, highest weight first (TODO:
		101	should use the RFC algorithm to reorder same-priority records for weight).
		102
		103	Example:
		104
		105	AnyEvent::DNS::srv "sip", "udp", "schmorp.de", sub { ...
		106	# @_ = ( [10, 10, 5060, "sip1.schmorp.de" ] )
		107
		108	=item AnyEvent::DNS::ptr $ipv4_or_6, $cb->(@hostnames)
		109
		110	Tries to reverse-resolve the given IPv4 or IPv6 address (in textual form)
		111	into it's hostname(s).
		112
		113	Example:
		114
		115	AnyEvent::DNS::ptr "2001:500:2f::f", sub { print shift };
		116	# => f.root-servers.net
		117
		118	=item AnyEvent::DNS::any $domain, $cb->(@rrs)
		119
		120	Tries to resolve the given domain and passes all resource records found to
		121	the callback.
		122
		123	=cut
		124
		125	sub resolver;
		126
		127	sub a($$) {
		128	my ($domain, $cb) = @_;
		129
		130	resolver->resolve ($domain => "a", sub {
		131	$cb->(map $_->[3], @_);
		132	});
		133	}
		134
		135	sub aaaa($$) {
		136	my ($domain, $cb) = @_;
		137
		138	resolver->resolve ($domain => "aaaa", sub {
		139	$cb->(map $_->[3], @_);
		140	});
		141	}
		142
		143	sub mx($$) {
		144	my ($domain, $cb) = @_;
		145
		146	resolver->resolve ($domain => "mx", sub {
		147	$cb->(map $_->[4], sort { $a->[3] <=> $b->[3] } @_);
		148	});
		149	}
		150
		151	sub ns($$) {
		152	my ($domain, $cb) = @_;
		153
		154	resolver->resolve ($domain => "ns", sub {
		155	$cb->(map $_->[3], @_);
		156	});
		157	}
		158
		159	sub txt($$) {
		160	my ($domain, $cb) = @_;
		161
		162	resolver->resolve ($domain => "txt", sub {
		163	$cb->(map $_->[3], @_);
		164	});
		165	}
		166
		167	sub srv($$$$) {
		168	my ($service, $proto, $domain, $cb) = @_;
		169
		170	# todo, ask for any and check glue records
		171	resolver->resolve ("_$service._$proto.$domain" => "srv", sub {
		172	$cb->(map [@$_[3,4,5,6]], sort { $a->[3] <=> $b->[3] \|\| $b->[4] <=> $a->[4] } @_);
		173	});
		174	}
		175
		176	sub ptr($$) {
		177	my ($ip, $cb) = @_;
		178
		179	$ip = AnyEvent::Socket::parse_ip ($ip)
		180	or return $cb->();
		181
		182	if (4 == length $ip) {
		183	$ip = join ".", (reverse split /\./, $ip), "in-addr.arpa.";
		184	} else {
		185	$ip = join ".", (reverse split //, unpack "H*", $ip), "ip6.arpa.";
		186	}
		187
		188	resolver->resolve ($ip => "ptr", sub {
		189	$cb->(map $_->[3], @_);
		190	});
		191	}
		192
		193	sub any($$) {
		194	my ($domain, $cb) = @_;
		195
		196	resolver->resolve ($domain => "*", $cb);
		197	}
		198
		199	#############################################################################
		200
		201	sub addr($$$$$$) {
		202	my ($node, $service, $proto, $family, $type, $cb) = @_;
		203
		204	unless (&AnyEvent::Socket::AF_INET6) {
		205	$family != 6
		206	or return $cb->();
		207
		208	$family \|\|= 4;
		209	}
		210
		211	$cb->() if $family == 4 && !$AnyEvent::PROTOCOL{ipv4};
		212	$cb->() if $family == 6 && !$AnyEvent::PROTOCOL{ipv6};
		213
		214	$family \|\|=4 unless $AnyEvent::PROTOCOL{ipv6};
		215	$family \|\|=6 unless $AnyEvent::PROTOCOL{ipv4};
		216
		217	$proto \|\|= "tcp";
		218	$type \|\|= $proto eq "udp" ? Socket::SOCK_DGRAM : Socket::SOCK_STREAM;
		219
		220	my $proton = (getprotobyname $proto)[2]
		221	or Carp::croak "$proto: protocol unknown";
		222
		223	my $port;
		224
		225	if ($service =~ /^(\S+)=(\d+)$/) {
		226	($service, $port) = ($1, $2);
		227	} elsif ($service =~ /^\d+$/) {
		228	($service, $port) = (undef, $service);
		229	} else {
		230	$port = (getservbyname $service, $proto)[2]
		231	or Carp::croak "$service/$proto: service unknown";
		232	}
		233
		234	my @target = [$node, $port];
		235
		236	# resolve a records / provide sockaddr structures
		237	my $resolve = sub {
		238	my @res;
		239	my $cv = AnyEvent->condvar (cb => sub {
		240	$cb->(
		241	map $_->[2],
		242	sort {
		243	$AnyEvent::PROTOCOL{$a->[1]} <=> $AnyEvent::PROTOCOL{$b->[1]}
		244	or $a->[0] <=> $b->[0]
		245	}
		246	@res
		247	)
		248	});
		249
		250	$cv->begin;
		251	for my $idx (0 .. $#target) {
		252	my ($node, $port) = @{ $target[$idx] };
		253
		254	if (my $noden = AnyEvent::Socket::parse_ip ($node)) {
		255	if (4 == length $noden && $family != 6) {
		256	push @res, [$idx, "ipv4", [Socket::AF_INET, $type, $proton,
		257	AnyEvent::Socket::pack_sockaddr ($port, $noden)]]
		258	}
		259
		260	if (16 == length $noden && $family != 4) {
		261	push @res, [$idx, "ipv6", [&AnyEvent::Socket::AF_INET6, $type, $proton,
		262	AnyEvent::Socket::pack_sockaddr ( $port, $noden)]]
		263	}
		264	} else {
		265	# ipv4
		266	if ($family != 6) {
		267	$cv->begin;
		268	a $node, sub {
		269	push @res, [$idx, "ipv4", [Socket::AF_INET, $type, $proton,
		270	AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv4 ($_))]]
		271	for @_;
		272	$cv->end;
		273	};
		274	}
		275
		276	# ipv6
		277	if ($family != 4) {
		278	$cv->begin;
		279	aaaa $node, sub {
		280	push @res, [$idx, "ipv6", [&AnyEvent::Socket::AF_INET6, $type, $proton,
		281	AnyEvent::Socket::pack_sockaddr ($port, AnyEvent::Socket::parse_ipv6 ($_))]]
		282	for @_;
		283	$cv->end;
		284	};
		285	}
		286	}
		287	}
		288	$cv->end;
		289	};
		290
		291	# try srv records, if applicable
		292	if ($node eq "localhost") {
		293	@target = (["127.0.0.1", $port], ["::1", $port]);
		294	&$resolve;
		295	} elsif (defined $service && !AnyEvent::Socket::parse_ip ($node)) {
		296	srv $service, $proto, $node, sub {
		297	my (@srv) = @_;
		298
		299	# no srv records, continue traditionally
		300	@srv
		301	or return &$resolve;
		302
		303	# only srv record has "." => abort
		304	$srv[0][2] ne "." \|\| $#srv
		305	or return $cb->();
		306
		307	# use srv records then
		308	@target = map ["$_->[3].", $_->[2]],
		309	grep $_->[3] ne ".",
		310	@srv;
		311
		312	&$resolve;
		313	};
		314	} else {
		315	&$resolve;
		316	}
		317	}
		318
		319	#############################################################################
28		320
29	=back	321	=back
30		322
31	=head2 DNS EN-/DECODING FUNCTIONS	323	=head2 LOW-LEVEL DNS EN-/DECODING FUNCTIONS
32		324
33	=over 4	325	=over 4
34		326
		327	=item $AnyEvent::DNS::EDNS0
		328
		329	This variable decides whether dns_pack automatically enables EDNS0
		330	support. By default, this is disabled (C<0>), unless overridden by
		331	C<$ENV{PERL_ANYEVENT_EDNS0>), but when set to C<1>, AnyEvent::DNS will use
		332	EDNS0 in all requests.
		333
35	=cut	334	=cut
		335
		336	our $EDNS0 = $ENV{PERL_ANYEVENT_EDNS0} * 1; # set to 1 to enable (partial) edns0
36		337
37	our %opcode_id = (	338	our %opcode_id = (
38	query => 0,	339	query => 0,
39	iquery => 1,	340	iquery => 1,
40	status => 2,	341	status => 2,
		342	notify => 4,
		343	update => 5,
41	map +($_ => $_), 3..15	344	map +($_ => $_), 3, 6..15
42	);	345	);
43		346
44	our %opcode_str = reverse %opcode_id;	347	our %opcode_str = reverse %opcode_id;
45		348
46	our %rcode_id = (	349	our %rcode_id = (
47	ok => 0,	350	noerror => 0,
48	formerr => 1,	351	formerr => 1,
49	servfail => 2,	352	servfail => 2,
50	nxdomain => 3,	353	nxdomain => 3,
51	notimp => 4,	354	notimp => 4,
52	refused => 5,	355	refused => 5,
		356	yxdomain => 6, # Name Exists when it should not [RFC 2136]
		357	yxrrset => 7, # RR Set Exists when it should not [RFC 2136]
		358	nxrrset => 8, # RR Set that should exist does not [RFC 2136]
		359	notauth => 9, # Server Not Authoritative for zone [RFC 2136]
		360	notzone => 10, # Name not contained in zone [RFC 2136]
		361	# EDNS0 16 BADVERS Bad OPT Version [RFC 2671]
		362	# EDNS0 16 BADSIG TSIG Signature Failure [RFC 2845]
		363	# EDNS0 17 BADKEY Key not recognized [RFC 2845]
		364	# EDNS0 18 BADTIME Signature out of time window [RFC 2845]
		365	# EDNS0 19 BADMODE Bad TKEY Mode [RFC 2930]
		366	# EDNS0 20 BADNAME Duplicate key name [RFC 2930]
		367	# EDNS0 21 BADALG Algorithm not supported [RFC 2930]
53	map +($_ => $_), 6..15	368	map +($_ => $_), 11..15
54	);	369	);
55		370
56	our %rcode_str = reverse %rcode_id;	371	our %rcode_str = reverse %rcode_id;
57		372
58	our %type_id = (	373	our %type_id = (
…		…
72	minfo => 14,	387	minfo => 14,
73	mx => 15,	388	mx => 15,
74	txt => 16,	389	txt => 16,
75	aaaa => 28,	390	aaaa => 28,
76	srv => 33,	391	srv => 33,
		392	opt => 41,
		393	spf => 99,
		394	tkey => 249,
		395	tsig => 250,
		396	ixfr => 251,
77	axfr => 252,	397	axfr => 252,
78	mailb => 253,	398	mailb => 253,
79	"*" => 255,	399	"*" => 255,
80	);	400	);
81		401
82	our %type_str = reverse %type_id;	402	our %type_str = reverse %type_id;
83		403
84	our %class_id = (	404	our %class_id = (
85	in => 1,	405	in => 1,
86	ch => 3,	406	ch => 3,
87	hs => 4,	407	hs => 4,
		408	none => 254,
88	"*" => 255,	409	"*" => 255,
89	);	410	);
90		411
91	our %class_str = reverse %class_id;	412	our %class_str = reverse %class_id;
92		413
93	# names MUST have a trailing dot	414	# names MUST have a trailing dot
…		…
128	qr => 1,	449	qr => 1,
129	aa => 0,	450	aa => 0,
130	tc => 0,	451	tc => 0,
131	rd => 0,	452	rd => 0,
132	ra => 0,	453	ra => 0,
		454	ad => 0,
		455	cd => 0,
133		456
134	qd => [@rr], # query section	457	qd => [@rr], # query section
135	an => [@rr], # answer section	458	an => [@rr], # answer section
136	ns => [@rr], # authority section	459	ns => [@rr], # authority section
137	ar => [@rr], # additional records section	460	ar => [@rr], # additional records section
…		…
140	=cut	463	=cut
141		464
142	sub dns_pack($) {	465	sub dns_pack($) {
143	my ($req) = @_;	466	my ($req) = @_;
144		467
145	pack "nn nnnn a* a* a* a*",	468	pack "nn nnnn a* a* a* a* a*",
146	$req->{id},	469	$req->{id},
147		470
148	! !$req->{qr} * 0x8000	471	! !$req->{qr} * 0x8000
149	+ $opcode_id{$req->{op}} * 0x0800	472	+ $opcode_id{$req->{op}} * 0x0800
150	+ ! !$req->{aa} * 0x0400	473	+ ! !$req->{aa} * 0x0400
151	+ ! !$req->{tc} * 0x0200	474	+ ! !$req->{tc} * 0x0200
152	+ ! !$req->{rd} * 0x0100	475	+ ! !$req->{rd} * 0x0100
153	+ ! !$req->{ra} * 0x0080	476	+ ! !$req->{ra} * 0x0080
		477	+ ! !$req->{ad} * 0x0020
		478	+ ! !$req->{cd} * 0x0010
154	+ $rcode_id{$req->{rc}} * 0x0001,	479	+ $rcode_id{$req->{rc}} * 0x0001,
155		480
156	scalar @{ $req->{qd} \|\| [] },	481	scalar @{ $req->{qd} \|\| [] },
157	scalar @{ $req->{an} \|\| [] },	482	scalar @{ $req->{an} \|\| [] },
158	scalar @{ $req->{ns} \|\| [] },	483	scalar @{ $req->{ns} \|\| [] },
159	scalar @{ $req->{ar} \|\| [] },	484	$EDNS0 + scalar @{ $req->{ar} \|\| [] }, # include EDNS0 option here
160		485
161	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),	486	(join "", map _enc_qd, @{ $req->{qd} \|\| [] }),
162	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),	487	(join "", map _enc_rr, @{ $req->{an} \|\| [] }),
163	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),	488	(join "", map _enc_rr, @{ $req->{ns} \|\| [] }),
164	(join "", map _enc_rr, @{ $req->{ar} \|\| [] });	489	(join "", map _enc_rr, @{ $req->{ar} \|\| [] }),
		490
		491	($EDNS0 ? pack "C nnNn", 0, 41, 4096, 0, 0 : "") # EDNS0, 4kiB udp payload size
165	}	492	}
166		493
167	our $ofs;	494	our $ofs;
168	our $pkt;	495	our $pkt;
169		496
…		…
198	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;	525	my ($qt, $qc) = unpack "nn", substr $pkt, $ofs; $ofs += 4;
199	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]	526	[$qname, $type_str{$qt} \|\| $qt, $class_str{$qc} \|\| $qc]
200	}	527	}
201		528
202	our %dec_rr = (	529	our %dec_rr = (
203	1 => sub { Socket::inet_ntoa $_ }, # a	530	1 => sub { join ".", unpack "C4" }, # a
204	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns	531	2 => sub { local $ofs = $ofs - length; _dec_qname }, # ns
205	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname	532	5 => sub { local $ofs = $ofs - length; _dec_qname }, # cname
206	6 => sub {	533	6 => sub {
207	local $ofs = $ofs - length;	534	local $ofs = $ofs - length;
208	my $mname = _dec_qname;	535	my $mname = _dec_qname;
209	my $rname = _dec_qname;	536	my $rname = _dec_qname;
210	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)	537	($mname, $rname, unpack "NNNNN", substr $pkt, $ofs)
211	}, # soa	538	}, # soa
212	11 => sub { ((Socket::inet_aton substr $_, 0, 4), unpack "C a*", substr $_, 4) }, # wks	539	11 => sub { ((join ".", unpack "C4"), unpack "C a*", substr $_, 4) }, # wks
213	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr	540	12 => sub { local $ofs = $ofs - length; _dec_qname }, # ptr
214	13 => sub { unpack "C/a C/a", $_ },	541	13 => sub { unpack "C/a C/a", $_ }, # hinfo
215	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx	542	15 => sub { local $ofs = $ofs + 2 - length; ((unpack "n", $_), _dec_qname) }, # mx
216	16 => sub { unpack "C/a", $_ }, # txt	543	16 => sub { unpack "(C/a)*", $_ }, # txt
217	28 => sub { sprintf "%04x:%04x:%04x:%04x:%04x:%04x:%04x:%04x", unpack "n8" }, # aaaa	544	28 => sub { AnyEvent::Socket::format_ip ($_) }, # aaaa
218	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv	545	33 => sub { local $ofs = $ofs + 6 - length; ((unpack "nnn", $_), _dec_qname) }, # srv
		546	99 => sub { unpack "(C/a)*", $_ }, # spf
219	);	547	);
220		548
221	sub _dec_rr {	549	sub _dec_rr {
222	my $qname = _dec_qname;	550	my $qname = _dec_qname;
223		551
…		…
236		564
237	Unpacks a DNS packet into a perl data structure.	565	Unpacks a DNS packet into a perl data structure.
238		566
239	Examples:	567	Examples:
240		568
241	# a non-successful reply	569	# an unsuccessful reply
242	{	570	{
243	'qd' => [	571	'qd' => [
244	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]	572	[ 'ruth.plan9.de.mach.uni-karlsruhe.de', '*', 'in' ]
245	],	573	],
246	'rc' => 'nxdomain',	574	'rc' => 'nxdomain',
…		…
250	'uni-karlsruhe.de',	578	'uni-karlsruhe.de',
251	'soa',	579	'soa',
252	'in',	580	'in',
253	'netserv.rz.uni-karlsruhe.de',	581	'netserv.rz.uni-karlsruhe.de',
254	'hostmaster.rz.uni-karlsruhe.de',	582	'hostmaster.rz.uni-karlsruhe.de',
255	2008052201,	583	2008052201, 10800, 1800, 2592000, 86400
256	10800,
257	1800,
258	2592000,
259	86400
260	]	584	]
261	],	585	],
262	'tc' => '',	586	'tc' => '',
263	'ra' => 1,	587	'ra' => 1,
264	'qr' => 1,	588	'qr' => 1,
…		…
312	qr => ! ! ($flags & 0x8000),	636	qr => ! ! ($flags & 0x8000),
313	aa => ! ! ($flags & 0x0400),	637	aa => ! ! ($flags & 0x0400),
314	tc => ! ! ($flags & 0x0200),	638	tc => ! ! ($flags & 0x0200),
315	rd => ! ! ($flags & 0x0100),	639	rd => ! ! ($flags & 0x0100),
316	ra => ! ! ($flags & 0x0080),	640	ra => ! ! ($flags & 0x0080),
		641	ad => ! ! ($flags & 0x0020),
		642	cd => ! ! ($flags & 0x0010),
317	op => $opcode_str{($flags & 0x001e) >> 11},	643	op => $opcode_str{($flags & 0x001e) >> 11},
318	rc => $rcode_str{($flags & 0x000f)},	644	rc => $rcode_str{($flags & 0x000f)},
319		645
320	qd => [map _dec_qd, 1 .. $qd],	646	qd => [map _dec_qd, 1 .. $qd],
321	an => [map _dec_rr, 1 .. $an],	647	an => [map _dec_rr, 1 .. $an],
…		…
328		654
329	=back	655	=back
330		656
331	=head2 THE AnyEvent::DNS RESOLVER CLASS	657	=head2 THE AnyEvent::DNS RESOLVER CLASS
332		658
333	This is the class which deos the actual protocol work.	659	This is the class which does the actual protocol work.
334		660
335	=over 4	661	=over 4
336		662
337	=cut	663	=cut
338		664
…		…
358	our $RESOLVER;	684	our $RESOLVER;
359		685
360	sub resolver() {	686	sub resolver() {
361	$RESOLVER \|\| do {	687	$RESOLVER \|\| do {
362	$RESOLVER = new AnyEvent::DNS;	688	$RESOLVER = new AnyEvent::DNS;
363	$RESOLVER->load_resolv_conf;	689	$RESOLVER->os_config;
364	$RESOLVER	690	$RESOLVER
365	}	691	}
366	}	692	}
367		693
368	=item $resolver = new AnyEvent::DNS key => value...	694	=item $resolver = new AnyEvent::DNS key => value...
369		695
370	Creates and returns a new resolver. It only supports UDP, so make sure	696	Creates and returns a new resolver.
371	your answer sections fit into a DNS packet.
372		697
373	The following options are supported:	698	The following options are supported:
374		699
375	=over 4	700	=over 4
376		701
377	=item server => [...]	702	=item server => [...]
378		703
379	A list of server addressses (default C<v127.0.0.1>) in network format (4	704	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).	705	octets for IPv4, 16 octets for IPv6 - not yet supported).
381		706
382	=item timeout => [...]	707	=item timeout => [...]
383		708
384	A list of timeouts to use (also determines the number of retries). To make	709	A list of timeouts to use (also determines the number of retries). To make
…		…
395	tries to resolve the name without any suffixes first.	720	tries to resolve the name without any suffixes first.
396		721
397	=item max_outstanding => $integer	722	=item max_outstanding => $integer
398		723
399	Most name servers do not handle many parallel requests very well. This option	724	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	725	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	726	if you request more than this many requests, then the additional requests will be queued
402	until some other requests have been resolved.	727	until some other requests have been resolved.
		728
		729	=item reuse => $seconds
		730
		731	The number of seconds (default: C<300>) that a query id cannot be re-used
		732	after a timeout. If there as no time-out then query id's can be reused
		733	immediately.
403		734
404	=back	735	=back
405		736
406	=cut	737	=cut
407		738
…		…
436	$self	767	$self
437	}	768	}
438		769
439	=item $resolver->parse_resolv_conv ($string)	770	=item $resolver->parse_resolv_conv ($string)
440		771
441	Parses the given string a sif it were a F<resolv.conf> file. The following	772	Parses the given string as if it were a F<resolv.conf> file. The following
442	directives are supported:	773	directives are supported (but not necessarily implemented).
443		774
444	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,	775	C<#>-style comments, C<nameserver>, C<domain>, C<search>, C<sortlist>,
445	C<options> (C<timeout>, C<attempts>, C<ndots>).	776	C<options> (C<timeout>, C<attempts>, C<ndots>).
446		777
447	Everything else is silently ignored.	778	Everything else is silently ignored.
…		…
459	for (split /\n/, $resolvconf) {	790	for (split /\n/, $resolvconf) {
460	if (/^\s*#/) {	791	if (/^\s*#/) {
461	# comment	792	# comment
462	} elsif (/^\snameserver\s+(\S+)\s$/i) {	793	} elsif (/^\snameserver\s+(\S+)\s$/i) {
463	my $ip = $1;	794	my $ip = $1;
464	if (AnyEvent::Util::dotted_quad $ip) {	795	if (my $ipn = AnyEvent::Socket::parse_ip ($ip)) {
465	push @{ $self->{server} }, AnyEvent::Util::socket_inet_aton $ip;	796	push @{ $self->{server} }, $ipn;
466	} else {	797	} else {
467	warn "nameserver $ip invalid and ignored\n";	798	warn "nameserver $ip invalid and ignored\n";
468	}	799	}
469	} elsif (/^\sdomain\s+(\S)\s+$/i) {	800	} elsif (/^\sdomain\s+(\S)\s+$/i) {
470	$self->{search} = [$1];	801	$self->{search} = [$1];
…		…
491	if $attempts;	822	if $attempts;
492		823
493	$self->_compile;	824	$self->_compile;
494	}	825	}
495		826
496	=item $resolver->load_resolv_conf	827	=item $resolver->os_config
497		828
498	Tries to load and parse F</etc/resolv.conf>. If there will ever be windows	829	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.	830	egregious hacks on windows to force the DNS servers and searchlist out of the system.
500		831
501	=cut	832	=cut
502		833
503	sub load_resolv_conf {	834	sub os_config {
504	my ($self) = @_;	835	my ($self) = @_;
505		836
		837	if ($^O =~ /mswin32\|cygwin/i) {
		838	# yeah, it suxx... lets hope DNS is DNS in all locales
		839
		840	if (open my $fh, "ipconfig /all \|") {
		841	delete $self->{server};
		842	delete $self->{search};
		843
		844	while (<$fh>) {
		845	# first DNS.* is suffix list
		846	if (/^\s*DNS/) {
		847	while (/\s+([[:alnum:].\-]+)\s*$/) {
		848	push @{ $self->{search} }, $1;
		849	$_ = <$fh>;
		850	}
		851	last;
		852	}
		853	}
		854
		855	while (<$fh>) {
		856	# second DNS.* is server address list
		857	if (/^\s*DNS/) {
		858	while (/\s+(\d+\.\d+\.\d+\.\d+)\s*$/) {
		859	my $ipn = AnyEvent::Socket::parse_ip ("$1"); # "" is necessary here, apparently
		860	push @{ $self->{server} }, $ipn
		861	if $ipn;
		862	$_ = <$fh>;
		863	}
		864	last;
		865	}
		866	}
		867
		868	$self->_compile;
		869	}
		870	} else {
		871	# try resolv.conf everywhere
		872
506	open my $fh, "</etc/resolv.conf"	873	if (open my $fh, "</etc/resolv.conf") {
507	or return;
508
509	local $/;	874	local $/;
510	$self->parse_resolv_conf (<$fh>);	875	$self->parse_resolv_conf (<$fh>);
		876	}
		877	}
511	}	878	}
512		879
513	sub _compile {	880	sub _compile {
514	my $self = shift;	881	my $self = shift;
515		882
…		…
522	}	889	}
523		890
524	$self->{retry} = \@retry;	891	$self->{retry} = \@retry;
525	}	892	}
526		893
		894	sub _feed {
		895	my ($self, $res) = @_;
		896
		897	$res = dns_unpack $res
		898	or return;
		899
		900	my $id = $self->{id}{$res->{id}};
		901
		902	return unless ref $id;
		903
		904	$NOW = time;
		905	$id->[1]->($res);
		906	}
		907
527	sub _recv {	908	sub _recv {
528	my ($self) = @_;	909	my ($self) = @_;
529		910
530	while (my $peer = recv $self->{fh}, my $res, 1024, 0) {	911	while (my $peer = recv $self->{fh}, my $res, 4096, 0) {
531	my ($port, $host) = Socket::unpack_sockaddr_in $peer;	912	my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
532		913
533	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };	914	return unless $port == 53 && grep $_ eq $host, @{ $self->{server} };
534		915
535	$res = dns_unpack $res	916	$self->_feed ($res);
536	or return;
537
538	my $id = $self->{id}{$res->{id}};
539
540	return unless ref $id;
541
542	$NOW = time;
543	$id->[1]->($res);
544	}	917	}
545	}	918	}
546		919
		920	sub _free_id {
		921	my ($self, $id, $timeout) = @_;
		922
		923	if ($timeout) {
		924	# we need to block the id for a while
		925	$self->{id}{$id} = 1;
		926	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $id];
		927	} else {
		928	# we can quickly recycle the id
		929	delete $self->{id}{$id};
		930	}
		931
		932	--$self->{outstanding};
		933	$self->_scheduler;
		934	}
		935
		936	# execute a single request, involves sending it with timeouts to multiple servers
547	sub _exec {	937	sub _exec {
548	my ($self, $req, $retry) = @_;	938	my ($self, $req) = @_;
549		939
		940	my $retry; # of retries
		941	my $do_retry;
		942
		943	$do_retry = sub {
550	if (my $retry_cfg = $self->{retry}[$retry]) {	944	my $retry_cfg = $self->{retry}[$retry++]
		945	or do {
		946	# failure
		947	$self->_free_id ($req->[2], $retry > 1);
		948	undef $do_retry; return $req->[1]->();
		949	};
		950
551	my ($server, $timeout) = @$retry_cfg;	951	my ($server, $timeout) = @$retry_cfg;
552		952
553	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {	953	$self->{id}{$req->[2]} = [AnyEvent->timer (after => $timeout, cb => sub {
554	$NOW = time;	954	$NOW = time;
555		955
556	# timeout, try next	956	# timeout, try next
557	$self->_exec ($req, $retry + 1);	957	&$do_retry;
558	}), sub {	958	}), sub {
559	my ($res) = @_;	959	my ($res) = @_;
560		960
		961	if ($res->{tc}) {
		962	# success, but truncated, so use tcp
		963	AnyEvent::Socket::tcp_connect ((Socket::inet_ntoa $server), 53, sub {
		964	my ($fh) = @_
		965	or return &$do_retry;
		966
		967	my $handle = new AnyEvent::Handle
		968	fh => $fh,
		969	on_error => sub {
		970	# failure, try next
		971	&$do_retry;
		972	};
		973
		974	$handle->push_write (pack "n/a", $req->[0]);
		975	$handle->push_read_chunk (2, sub {
		976	$handle->unshift_read_chunk ((unpack "n", $_[1]), sub {
		977	$self->_feed ($_[1]);
		978	});
		979	});
		980	shutdown $fh, 1;
		981
		982	}, sub { $timeout });
		983
		984	} else {
561	# success	985	# success
562	$self->{id}{$req->[2]} = 1;	986	$self->_free_id ($req->[2], $retry > 1);
563	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];	987	undef $do_retry; return $req->[1]->($res);
564	--$self->{outstanding};	988	}
565	$self->_scheduler;
566
567	$req->[1]->($res);
568	}];	989	}];
569		990
570	send $self->{fh}, $req->[0], 0, Socket::pack_sockaddr_in 53, $server;	991	send $self->{fh}, $req->[0], 0, AnyEvent::Socket::pack_sockaddr (53, $server);
571	} else {
572	# failure
573	$self->{id}{$req->[2]} = 1;
574	push @{ $self->{reuse_q} }, [$NOW + $self->{reuse}, $req->[2]];
575	--$self->{outstanding};
576	$self->_scheduler;
577
578	$req->[1]->();
579	}	992	};
		993
		994	&$do_retry;
580	}	995	}
581		996
582	sub _scheduler {	997	sub _scheduler {
583	my ($self) = @_;	998	my ($self) = @_;
584		999
585	$NOW = time;	1000	$NOW = time;
586		1001
587	# first clear id reuse queue	1002	# first clear id reuse queue
588	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }	1003	delete $self->{id}{ (shift @{ $self->{reuse_q} })->[1] }
589	while @{ $self->{reuse_q} } && $self->{reuse_q}[0] <= $NOW;	1004	while @{ $self->{reuse_q} } && $self->{reuse_q}[0][0] <= $NOW;
590		1005
591	while ($self->{outstanding} < $self->{max_outstanding}) {	1006	while ($self->{outstanding} < $self->{max_outstanding}) {
		1007
		1008	if (@{ $self->{reuse_q} } >= 30000) {
		1009	# we ran out of ID's, wait a bit
		1010	$self->{reuse_to} \|\|= AnyEvent->timer (after => $self->{reuse_q}[0][0] - $NOW, cb => sub {
		1011	delete $self->{reuse_to};
		1012	$self->_scheduler;
		1013	});
		1014	last;
		1015	}
		1016
592	my $req = shift @{ $self->{queue} }	1017	my $req = shift @{ $self->{queue} }
593	or last;	1018	or last;
594		1019
595	while () {	1020	while () {
596	$req->[2] = int rand 65536;	1021	$req->[2] = int rand 65536;
597	last unless exists $self->{id}{$req->[2]};	1022	last unless exists $self->{id}{$req->[2]};
598	}	1023	}
599		1024
		1025	++$self->{outstanding};
600	$self->{id}{$req->[2]} = 1;	1026	$self->{id}{$req->[2]} = 1;
601	substr $req->[0], 0, 2, pack "n", $req->[2];	1027	substr $req->[0], 0, 2, pack "n", $req->[2];
602		1028
603	++$self->{outstanding};
604	$self->_exec ($req, 0);	1029	$self->_exec ($req);
605	}	1030	}
606	}	1031	}
607		1032
608	=item $resolver->request ($req, $cb->($res))	1033	=item $resolver->request ($req, $cb->($res))
609		1034
…		…
629	The callback will be invoked with a list of matching result records or	1054	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.	1055	none on any error or if the name could not be found.
631		1056
632	CNAME chains (although illegal) are followed up to a length of 8.	1057	CNAME chains (although illegal) are followed up to a length of 8.
633		1058
634	Note that this resolver is just a stub resolver: it requires a nameserver	1059	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	1060	supporting recursive queries, will not do any recursive queries itself and
636	is not secure when used against an untrusted name server.	1061	is not secure when used against an untrusted name server.
637		1062
638	The following options are supported:	1063	The following options are supported:
639		1064
…		…
715	my %atype = $opt{accept}	1140	my %atype = $opt{accept}
716	? map +($_ => 1), @{ $opt{accept} }	1141	? map +($_ => 1), @{ $opt{accept} }
717	: ($qtype => 1);	1142	: ($qtype => 1);
718		1143
719	# advance in searchlist	1144	# advance in searchlist
720	my $do_search; $do_search = sub {	1145	my ($do_search, $do_req);
		1146
		1147	$do_search = sub {
721	@search	1148	@search
722	or return $cb->();	1149	or (undef $do_search), (undef $do_req), return $cb->();
723		1150
724	(my $name = "$qname." . shift @search) =~ s/\.$//;	1151	(my $name = lc "$qname." . shift @search) =~ s/\.$//;
725	my $depth = 2;	1152	my $depth = 2;
726		1153
727	# advance in cname-chain	1154	# advance in cname-chain
728	my $do_req; $do_req = sub {	1155	$do_req = sub {
729	$self->request ({	1156	$self->request ({
730	rd => 1,	1157	rd => 1,
731	qd => [[$name, $qtype, $class]],	1158	qd => [[$name, $qtype, $class]],
732	}, sub {	1159	}, sub {
733	my ($res) = @_	1160	my ($res) = @_
…		…
735		1162
736	my $cname;	1163	my $cname;
737		1164
738	while () {	1165	while () {
739	# results found?	1166	# results found?
740	my @rr = grep $_->[0] eq $name && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };	1167	my @rr = grep $name eq lc $_->[0] && ($atype{"*"} \|\| $atype{$_->[1]}), @{ $res->{an} };
741		1168
742	return $cb->(@rr)	1169	(undef $do_search), (undef $do_req), return $cb->(@rr)
743	if @rr;	1170	if @rr;
744		1171
745	# see if there is a cname we can follow	1172	# see if there is a cname we can follow
746	my @rr = grep $_->[0] eq $name && $_->[1] eq "cname", @{ $res->{an} };	1173	my @rr = grep $name eq lc $_->[0] && $_->[1] eq "cname", @{ $res->{an} };
747		1174
748	if (@rr) {	1175	if (@rr) {
749	$depth--	1176	$depth--
750	or return $do_search->(); # cname chain too long	1177	or return $do_search->(); # cname chain too long
751		1178
…		…
768	};	1195	};
769		1196
770	$do_search->();	1197	$do_search->();
771	}	1198	}
772		1199
		1200	use AnyEvent::Socket (); # circular dependency, so do not import anything and do it at the end
		1201
773	1;	1202	1;
774		1203
775	=back	1204	=back
776		1205
777	=head1 AUTHOR	1206	=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.26 by root, Sat May 24 18:50:40 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.26 by root, Sat May 24 18:50:40 2008 UTC