1#!/usr/bin/perl
2#
3# Copyright (C) 2011, 2012  Internet Systems Consortium, Inc. ("ISC")
4#
5# Permission to use, copy, modify, and/or distribute this software for any
6# purpose with or without fee is hereby granted, provided that the above
7# copyright notice and this permission notice appear in all copies.
8#
9# THE SOFTWARE IS PROVIDED "AS IS" AND ISC DISCLAIMS ALL WARRANTIES WITH
10# REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
11# AND FITNESS.  IN NO EVENT SHALL ISC BE LIABLE FOR ANY SPECIAL, DIRECT,
12# INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
13# LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
14# OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
15# PERFORMANCE OF THIS SOFTWARE.
16
17# $Id: ans.pl,v 1.2.2.6 2012/02/22 23:46:35 tbox Exp $
18
19#
20# This is the name server from hell.  It provides canned
21# responses based on pattern matching the queries, and
22# can be reprogrammed on-the-fly over a TCP connection.
23#
24# The server listens for control connections on port 5301.
25# A control connection is a TCP stream of lines like
26#
27#  /pattern/
28#  name ttl type rdata
29#  name ttl type rdata
30#  ...
31#  /pattern/
32#  name ttl type rdata
33#  name ttl type rdata
34#  ...
35#
36# There can be any number of patterns, each associated
37# with any number of response RRs.  Each pattern is a
38# Perl regular expression.
39#
40# Each incoming query is converted into a string of the form
41# "qname qtype" (the printable query domain name, space,
42# printable query type) and matched against each pattern.
43#
44# The first pattern matching the query is selected, and
45# the RR following the pattern line are sent in the
46# answer section of the response.
47#
48# Each new control connection causes the current set of
49# patterns and responses to be cleared before adding new
50# ones.
51#
52# The server handles UDP and TCP queries.  Zone transfer
53# responses work, but must fit in a single 64 k message.
54#
55# Now you can add TSIG, just specify key/key data with:
56#
57#  /pattern <key> <key_data>/
58#  name ttl type rdata
59#  name ttl type rdata
60#
61#  Note that this data will still be sent with any request for
62#  pattern, only this data will be signed. Currently, this is only
63#  done for TCP.
64
65
66use IO::File;
67use IO::Socket;
68use Data::Dumper;
69use Net::DNS;
70use Net::DNS::Packet;
71use strict;
72
73# Ignore SIGPIPE so we won't fail if peer closes a TCP socket early
74local $SIG{PIPE} = 'IGNORE';
75
76# Flush logged output after every line
77local $| = 1;
78
79# We default to listening on 10.53.0.2 for historical reasons
80# XXX: we should also be able to specify IPv6
81my $server_addr = "10.53.0.2";
82if (@ARGV > 0) {
83	$server_addr = @ARGV[0];
84}
85
86# XXX: we should also be able to set the port numbers to listen on.
87my $ctlsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
88   LocalPort => 5301, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!";
89
90my $udpsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
91   LocalPort => 5300, Proto => "udp", Reuse => 1) or die "$!";
92
93my $tcpsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
94   LocalPort => 5300, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!";
95
96print "listening on $server_addr:5300,5301.\n";
97
98my $pidf = new IO::File "ans.pid", "w" or die "cannot open pid file: $!";
99print $pidf "$$\n" or die "cannot write pid file: $!";
100$pidf->close or die "cannot close pid file: $!";;
101sub rmpid { unlink "ans.pid"; exit 1; };
102
103$SIG{INT} = \&rmpid;
104$SIG{TERM} = \&rmpid;
105
106#my @answers = ();
107my @rules;
108sub handleUDP {
109	my ($buf) = @_;
110
111	my ($request, $err) = new Net::DNS::Packet(\$buf, 0);
112	$err and die $err;
113
114	my @questions = $request->question;
115	my $qname = $questions[0]->qname;
116	my $qtype = $questions[0]->qtype;
117	my $qclass = $questions[0]->qclass;
118	my $id = $request->header->id;
119
120	my $packet = new Net::DNS::Packet($qname, $qtype, $qclass);
121	$packet->header->qr(1);
122	$packet->header->aa(1);
123	$packet->header->id($id);
124
125	# get the existing signature if any, and clear the additional section
126	my $prev_tsig;
127	while (my $rr = $request->pop("additional")) {
128		if ($rr->type eq "TSIG") {
129			$prev_tsig = $rr;
130		}
131	}
132
133	my $r;
134	foreach $r (@rules) {
135		my $pattern = $r->{pattern};
136		my($dbtype, $key_name, $key_data) = split(/ /,$pattern);
137		print "[handleUDP] $dbtype, $key_name, $key_data \n";
138		if ("$qname $qtype" =~ /$dbtype/) {
139			my $a;
140			foreach $a (@{$r->{answer}}) {
141				$packet->push("answer", $a);
142			}
143			if(defined($key_name) && defined($key_data)) {
144				# Sign the packet
145				print "  Signing the response with " .
146				      "$key_name/$key_data\n";
147				my $tsig = Net::DNS::RR->
148					new("$key_name TSIG $key_data");
149
150				# These kluges are necessary because Net::DNS
151				# doesn't know how to sign responses.  We
152				# clear compnames so that the TSIG key and
153				# algorithm name won't be compressed, and
154				# add one to arcount because the signing
155				# function will attempt to decrement it,
156				# which is incorrect in a response. Finally
157				# we set request_mac to the previous digest.
158				$packet->{"compnames"} = {};
159				$packet->{"header"}{"arcount"} += 1;
160				if (defined($prev_tsig)) {
161					my $rmac = pack('n H*',
162						$prev_tsig->mac_size,
163						$prev_tsig->mac);
164					$tsig->{"request_mac"} =
165						unpack("H*", $rmac);
166				}
167
168				$packet->sign_tsig($tsig);
169			}
170			last;
171		}
172	}
173	#$packet->print;
174
175	return $packet->data;
176}
177
178# namelen:
179# given a stream of data, reads a DNS-formatted name and returns its
180# total length, thus making it possible to skip past it.
181sub namelen {
182	my ($data) = @_;
183	my $len = 0;
184	my $label_len = 0;
185	do {
186		$label_len = unpack("c", $data);
187		$data = substr($data, $label_len + 1);
188		$len += $label_len + 1;
189	} while ($label_len != 0);
190	return ($len);
191}
192
193# packetlen:
194# given a stream of data, reads a DNS wire-format packet and returns
195# its total length, making it possible to skip past it.
196sub packetlen {
197	my ($data) = @_;
198	my $q;
199	my $rr;
200	my $header;
201	my $offset;
202
203	#
204	# decode/encode were introduced in Net::DNS 0.68
205	# parse is no longer a method and calling it here makes perl croak.
206	#
207	my $decode = 0;
208	$decode = 1 if ($Net::DNS::VERSION >= 0.68);
209
210	if ($decode) {
211		($header, $offset) = Net::DNS::Header->decode(\$data);
212	} else {
213		($header, $offset) = Net::DNS::Header->parse(\$data);
214	}
215
216	for (1 .. $header->qdcount) {
217		if ($decode) {
218			($q, $offset) =
219				 Net::DNS::Question->decode(\$data, $offset);
220		} else {
221			($q, $offset) =
222				 Net::DNS::Question->parse(\$data, $offset);
223		}
224	}
225	for (1 .. $header->ancount) {
226		if ($decode) {
227			($q, $offset) = Net::DNS::RR->decode(\$data, $offset);
228		} else {
229			($q, $offset) = Net::DNS::RR->parse(\$data, $offset);
230		}
231	}
232	for (1 .. $header->nscount) {
233		if ($decode) {
234			($q, $offset) = Net::DNS::RR->decode(\$data, $offset);
235		} else {
236			($q, $offset) = Net::DNS::RR->parse(\$data, $offset);
237		}
238	}
239	for (1 .. $header->arcount) {
240		if ($decode) {
241			($q, $offset) = Net::DNS::RR->decode(\$data, $offset);
242		} else {
243			($q, $offset) = Net::DNS::RR->parse(\$data, $offset);
244		}
245	}
246	return $offset;
247}
248
249# sign_tcp_continuation:
250# This is a hack to correct the problem that Net::DNS has no idea how
251# to sign multiple-message TCP responses.  Several data that are included
252# in the digest when signing a query or the first message of a response are
253# omitted when signing subsequent messages in a TCP stream.
254#
255# Net::DNS::Packet->sign_tsig() has the ability to use a custom signing
256# function (specified by calling Packet->sign_func()).  We use this
257# function as the signing function for TCP continuations, and it removes
258# the unwanted data from the digest before calling the default sign_hmac
259# function.
260sub sign_tcp_continuation {
261	my ($key, $data) = @_;
262
263	# copy out first two bytes: size of the previous MAC
264	my $rmacsize = unpack("n", $data);
265	$data = substr($data, 2);
266
267	# copy out previous MAC
268	my $rmac = substr($data, 0, $rmacsize);
269	$data = substr($data, $rmacsize);
270
271	# try parsing out the packet information
272	my $plen = packetlen($data);
273	my $pdata = substr($data, 0, $plen);
274	$data = substr($data, $plen);
275
276	# remove the keyname, ttl, class, and algorithm name
277	$data = substr($data, namelen($data));
278	$data = substr($data, 6);
279	$data = substr($data, namelen($data));
280
281	# preserve the TSIG data
282	my $tdata = substr($data, 0, 8);
283
284	# prepare a new digest and sign with it
285	$data = pack("n", $rmacsize) . $rmac . $pdata . $tdata;
286	return Net::DNS::RR::TSIG::sign_hmac($key, $data);
287}
288
289sub handleTCP {
290	my ($buf) = @_;
291
292	my ($request, $err) = new Net::DNS::Packet(\$buf, 0);
293	$err and die $err;
294
295	my @questions = $request->question;
296	my $qname = $questions[0]->qname;
297	my $qtype = $questions[0]->qtype;
298	my $qclass = $questions[0]->qclass;
299	my $id = $request->header->id;
300
301	my $packet = new Net::DNS::Packet($qname, $qtype, $qclass);
302	$packet->header->qr(1);
303	$packet->header->aa(1);
304	$packet->header->id($id);
305
306	# get the existing signature if any, and clear the additional section
307	my $prev_tsig;
308	my $signer;
309	while (my $rr = $request->pop("additional")) {
310		if ($rr->type eq "TSIG") {
311			$prev_tsig = $rr;
312		}
313	}
314
315	my @results = ();
316	my $count_these = 0;
317
318	my $r;
319	foreach $r (@rules) {
320		my $pattern = $r->{pattern};
321		my($dbtype, $key_name, $key_data) = split(/ /,$pattern);
322		print "[handleTCP] $dbtype, $key_name, $key_data \n";
323		if ("$qname $qtype" =~ /$dbtype/) {
324			$count_these++;
325			my $a;
326			foreach $a (@{$r->{answer}}) {
327				$packet->push("answer", $a);
328			}
329			if(defined($key_name) && defined($key_data)) {
330				# sign the packet
331				print "  Signing the data with " .
332				      "$key_name/$key_data\n";
333
334				my $tsig = Net::DNS::RR->
335					new("$key_name TSIG $key_data");
336
337				# These kluges are necessary because Net::DNS
338				# doesn't know how to sign responses.  We
339				# clear compnames so that the TSIG key and
340				# algorithm name won't be compressed, and
341				# add one to arcount because the signing
342				# function will attempt to decrement it,
343				# which is incorrect in a response. Finally
344				# we set request_mac to the previous digest.
345				$packet->{"compnames"} = {};
346				$packet->{"header"}{"arcount"} += 1;
347				if (defined($prev_tsig)) {
348					my $rmac = pack('n H*',
349						$prev_tsig->mac_size,
350						$prev_tsig->mac);
351					$tsig->{"request_mac"} =
352						unpack("H*", $rmac);
353				}
354
355				$tsig->sign_func($signer) if defined($signer);
356				$packet->sign_tsig($tsig);
357				$signer = \&sign_tcp_continuation;
358
359				my $copy =
360					Net::DNS::Packet->new(\($packet->data));
361				$prev_tsig = $copy->pop("additional");
362			}
363			#$packet->print;
364			push(@results,$packet->data);
365			$packet = new Net::DNS::Packet($qname, $qtype, $qclass);
366			$packet->header->qr(1);
367			$packet->header->aa(1);
368			$packet->header->id($id);
369		}
370	}
371	print " A total of $count_these patterns matched\n";
372	return \@results;
373}
374
375# Main
376my $rin;
377my $rout;
378for (;;) {
379	$rin = '';
380	vec($rin, fileno($ctlsock), 1) = 1;
381	vec($rin, fileno($tcpsock), 1) = 1;
382	vec($rin, fileno($udpsock), 1) = 1;
383
384	select($rout = $rin, undef, undef, undef);
385
386	if (vec($rout, fileno($ctlsock), 1)) {
387		warn "ctl conn";
388		my $conn = $ctlsock->accept;
389		my $rule = ();
390		@rules = ();
391		while (my $line = $conn->getline) {
392			chomp $line;
393			if ($line =~ m!^/(.*)/$!) {
394				$rule = { pattern => $1, answer => [] };
395				push(@rules, $rule);
396			} else {
397				push(@{$rule->{answer}},
398				     new Net::DNS::RR($line));
399			}
400		}
401		$conn->close;
402		#print Dumper(@rules);
403		#print "+=+=+ $rules[0]->{'pattern'}\n";
404		#print "+=+=+ $rules[0]->{'answer'}->[0]->{'rname'}\n";
405		#print "+=+=+ $rules[0]->{'answer'}->[0]\n";
406	} elsif (vec($rout, fileno($udpsock), 1)) {
407		printf "UDP request\n";
408		my $buf;
409		$udpsock->recv($buf, 512);
410		my $result = handleUDP($buf);
411		my $num_chars = $udpsock->send($result);
412		print "  Sent $num_chars bytes via UDP\n";
413	} elsif (vec($rout, fileno($tcpsock), 1)) {
414		my $conn = $tcpsock->accept;
415		my $buf;
416		for (;;) {
417			my $lenbuf;
418			my $n = $conn->sysread($lenbuf, 2);
419			last unless $n == 2;
420			my $len = unpack("n", $lenbuf);
421			$n = $conn->sysread($buf, $len);
422			last unless $n == $len;
423			print "TCP request\n";
424			my $result = handleTCP($buf);
425			foreach my $response (@$result) {
426				$len = length($response);
427				$n = $conn->syswrite(pack("n", $len), 2);
428				$n = $conn->syswrite($response, $len);
429				print "    Sent: $n chars via TCP\n";
430			}
431		}
432		$conn->close;
433	}
434}
435