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

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

Diff Legend

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

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents): Revision 1.2 by root, Fri May 23 02:59:32 2008 UTC vs. Revision 1.32 by root, Mon May 26 02:18:41 2008 UTC

Diff Legend

Comparing AnyEvent/lib/AnyEvent/DNS.pm (file contents):
Revision 1.2 by root, Fri May 23 02:59:32 2008 UTC vs.
Revision 1.32 by root, Mon May 26 02:18:41 2008 UTC