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$
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
79my $server_addr = "10.53.0.4";
80
81my $udpsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
82   LocalPort => 5300, Proto => "udp", Reuse => 1) or die "$!";
83
84my $tcpsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
85   LocalPort => 5300, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!";
86
87print "listening on $server_addr:5300.\n";
88
89my $pidf = new IO::File "ans.pid", "w" or die "cannot open pid file: $!";
90print $pidf "$$\n" or die "cannot write pid file: $!";
91$pidf->close or die "cannot close pid file: $!";;
92sub rmpid { unlink "ans.pid"; exit 1; };
93
94$SIG{INT} = \&rmpid;
95$SIG{TERM} = \&rmpid;
96
97#my @answers = ();
98my @rules;
99sub handleUDP {
100        my ($buf) = @_;
101
102        my ($packet, $err) = new Net::DNS::Packet(\$buf, 0);
103        $err and die $err;
104
105        $packet->header->qr(1);
106        $packet->header->aa(1);
107
108        my @questions = $packet->question;
109        my $qname = $questions[0]->qname;
110        my $qtype = $questions[0]->qtype;
111
112        # get the existing signature if any, and clear the additional section
113        my $prev_tsig;
114        while (my $rr = $packet->pop("additional")) {
115                if ($rr->type eq "TSIG") {
116                        $prev_tsig = $rr;
117                }
118        }
119
120        my $r;
121        foreach $r (@rules) {
122                my $pattern = $r->{pattern};
123		my($dbtype, $key_name, $key_data) = split(/ /,$pattern);
124		print "[handleUDP] $dbtype, $key_name, $key_data \n";
125                if ("$qname $qtype" =~ /$dbtype/) {
126                        my $a;
127                        foreach $a (@{$r->{answer}}) {
128                                $packet->push("answer", $a);
129                        }
130			if(defined($key_name) && defined($key_data)) {
131				# Sign the packet
132				print "  Signing the response with " .
133                                      "$key_name/$key_data\n";
134                                my $tsig = Net::DNS::RR->
135                                        new("$key_name TSIG $key_data");
136
137                                # These kluges are necessary because Net::DNS
138                                # doesn't know how to sign responses.  We
139                                # clear compnames so that the TSIG key and
140                                # algorithm name won't be compressed, and
141                                # add one to arcount because the signing
142                                # function will attempt to decrement it,
143                                # which is incorrect in a response. Finally
144                                # we set request_mac to the previous digest.
145                                $packet->{"compnames"} = {};
146                                $packet->{"header"}{"arcount"} += 1;
147                                if (defined($prev_tsig)) {
148                                        my $rmac = pack('n H*',
149                                                $prev_tsig->mac_size,
150                                                $prev_tsig->mac);
151                                        $tsig->{"request_mac"} =
152                                                unpack("H*", $rmac);
153                                }
154
155				$packet->sign_tsig($tsig);
156			}
157                        last;
158                }
159        }
160        #$packet->print;
161
162        return $packet->data;
163}
164
165# namelen:
166# given a stream of data, reads a DNS-formatted name and returns its
167# total length, thus making it possible to skip past it.
168sub namelen {
169        my ($data) = @_;
170        my $len = 0;
171        my $label_len = 0;
172        do {
173                $label_len = unpack("c", $data);
174                $data = substr($data, $label_len + 1);
175                $len += $label_len + 1;
176        } while ($label_len != 0);
177        return ($len);
178}
179
180# packetlen:
181# given a stream of data, reads a DNS wire-format packet and returns
182# its total length, making it possible to skip past it.
183sub packetlen {
184        my ($data) = @_;
185        my $q;
186        my $rr;
187
188        my ($header, $offset) = Net::DNS::Header->parse(\$data);
189        for (1 .. $header->qdcount) {
190                ($q, $offset) = Net::DNS::Question->parse(\$data, $offset);
191        }
192        for (1 .. $header->ancount) {
193                ($rr, $offset) = Net::DNS::RR->parse(\$data, $offset);
194        }
195        for (1 .. $header->nscount) {
196                ($rr, $offset) = Net::DNS::RR->parse(\$data, $offset);
197        }
198        for (1 .. $header->arcount) {
199                ($rr, $offset) = Net::DNS::RR->parse(\$data, $offset);
200        }
201        return $offset;
202}
203
204# sign_tcp_continuation:
205# This is a hack to correct the problem that Net::DNS has no idea how
206# to sign multiple-message TCP responses.  Several data that are included
207# in the digest when signing a query or the first message of a response are
208# omitted when signing subsequent messages in a TCP stream.
209#
210# Net::DNS::Packet->sign_tsig() has the ability to use a custom signing
211# function (specified by calling Packet->sign_func()).  We use this
212# function as the signing function for TCP continuations, and it removes
213# the unwanted data from the digest before calling the default sign_hmac
214# function.
215sub sign_tcp_continuation {
216        my ($key, $data) = @_;
217
218        # copy out first two bytes: size of the previous MAC
219        my $rmacsize = unpack("n", $data);
220        $data = substr($data, 2);
221
222        # copy out previous MAC
223        my $rmac = substr($data, 0, $rmacsize);
224        $data = substr($data, $rmacsize);
225
226        # try parsing out the packet information
227        my $plen = packetlen($data);
228        my $pdata = substr($data, 0, $plen);
229        $data = substr($data, $plen);
230
231        # remove the keyname, ttl, class, and algorithm name
232        $data = substr($data, namelen($data));
233        $data = substr($data, 6);
234        $data = substr($data, namelen($data));
235
236        # preserve the TSIG data
237        my $tdata = substr($data, 0, 8);
238
239        # prepare a new digest and sign with it
240        $data = pack("n", $rmacsize) . $rmac . $pdata . $tdata;
241        return Net::DNS::RR::TSIG::sign_hmac($key, $data);
242}
243
244sub handleTCP {
245	my ($buf) = @_;
246
247	my ($packet, $err) = new Net::DNS::Packet(\$buf, 0);
248	$err and die $err;
249
250	$packet->header->qr(1);
251	$packet->header->aa(1);
252
253	my @questions = $packet->question;
254	my $qname = $questions[0]->qname;
255	my $qtype = $questions[0]->qtype;
256
257        # get the existing signature if any, and clear the additional section
258        my $prev_tsig;
259        my $signer;
260        while (my $rr = $packet->pop("additional")) {
261                if ($rr->type eq "TSIG") {
262                        $prev_tsig = $rr;
263                }
264        }
265
266	my @results = ();
267	my $count_these = 0;
268
269	my $r;
270	foreach $r (@rules) {
271		my $pattern = $r->{pattern};
272		my($dbtype, $key_name, $key_data) = split(/ /,$pattern);
273		print "[handleTCP] $dbtype, $key_name, $key_data \n";
274		if ("$qname $qtype" =~ /$dbtype/) {
275			$count_these++;
276			my $a;
277			foreach $a (@{$r->{answer}}) {
278				$packet->push("answer", $a);
279			}
280			if(defined($key_name) && defined($key_data)) {
281				# sign the packet
282				print "  Signing the data with " .
283                                      "$key_name/$key_data\n";
284
285                                my $tsig = Net::DNS::RR->
286                                        new("$key_name TSIG $key_data");
287
288                                # These kluges are necessary because Net::DNS
289                                # doesn't know how to sign responses.  We
290                                # clear compnames so that the TSIG key and
291                                # algorithm name won't be compressed, and
292                                # add one to arcount because the signing
293                                # function will attempt to decrement it,
294                                # which is incorrect in a response. Finally
295                                # we set request_mac to the previous digest.
296                                $packet->{"compnames"} = {};
297                                $packet->{"header"}{"arcount"} += 1;
298                                if (defined($prev_tsig)) {
299                                        my $rmac = pack('n H*',
300                                                $prev_tsig->mac_size,
301                                                $prev_tsig->mac);
302                                        $tsig->{"request_mac"} =
303                                                unpack("H*", $rmac);
304                                }
305
306                                $tsig->sign_func($signer) if defined($signer);
307				$packet->sign_tsig($tsig);
308                                $signer = \&sign_tcp_continuation;
309
310                                my $copy =
311                                        Net::DNS::Packet->new(\($packet->data));
312                                $prev_tsig = $copy->pop("additional");
313			}
314			#$packet->print;
315			push(@results,$packet->data);
316			$packet = new Net::DNS::Packet(\$buf, 0);
317			$packet->header->qr(1);
318			$packet->header->aa(1);
319		}
320	}
321	print " A total of $count_these patterns matched\n";
322	return \@results;
323}
324
325# Main
326my $rin;
327my $rout;
328for (;;) {
329	$rin = '';
330	vec($rin, fileno($tcpsock), 1) = 1;
331	vec($rin, fileno($udpsock), 1) = 1;
332
333	select($rout = $rin, undef, undef, undef);
334
335	if (vec($rout, fileno($udpsock), 1)) {
336		printf "UDP request\n";
337		my $buf;
338		$udpsock->recv($buf, 512);
339	} elsif (vec($rout, fileno($tcpsock), 1)) {
340		my $conn = $tcpsock->accept;
341		my $buf;
342		for (;;) {
343			my $lenbuf;
344			my $n = $conn->sysread($lenbuf, 2);
345			last unless $n == 2;
346			my $len = unpack("n", $lenbuf);
347			$n = $conn->sysread($buf, $len);
348		}
349		sleep(1);
350	}
351}
352