1#!/usr/bin/env perl
2
3# Copyright (C) Internet Systems Consortium, Inc. ("ISC")
4#
5# SPDX-License-Identifier: MPL-2.0
6#
7# This Source Code Form is subject to the terms of the Mozilla Public
8# License, v. 2.0.  If a copy of the MPL was not distributed with this
9# file, you can obtain one at https://mozilla.org/MPL/2.0/.
10#
11# See the COPYRIGHT file distributed with this work for additional
12# information regarding copyright ownership.
13
14use strict;
15use warnings;
16
17use IO::File;
18use IO::Socket;
19use Net::DNS;
20
21my $localaddr = "10.53.0.4";
22my $limit = getlimit();
23my $no_more_waiting = 0;
24my @delayed_response;
25my $timeout;
26
27my $localport = int($ENV{'PORT'});
28if (!$localport) { $localport = 5300; }
29
30my $udpsock = IO::Socket::INET->new(LocalAddr => "$localaddr",
31   LocalPort => $localport, Proto => "udp", Reuse => 1) or die "$!";
32
33my $pidf = new IO::File "ans.pid", "w" or die "cannot open pid file: $!";
34print $pidf "$$\n" or die "cannot write pid file: $!";
35$pidf->close or die "cannot close pid file: $!";
36sub rmpid { unlink "ans.pid"; exit 1; };
37
38$SIG{INT} = \&rmpid;
39$SIG{TERM} = \&rmpid;
40
41my $count = 0;
42my $send_response = 1;
43
44sub getlimit {
45    if ( -e "ans.limit") {
46	open(FH, "<", "ans.limit");
47	my $line = <FH>;
48	chomp $line;
49	close FH;
50	if ($line =~ /^\d+$/) {
51	    return $line;
52	}
53    }
54
55    return 0;
56}
57
58# If $wait == 0 is returned, returned reply will be sent immediately.
59# If $wait == 1 is returned, sending the returned reply might be delayed; see
60# comments inside handle_UDP() for details.
61sub reply_handler {
62    my ($qname, $qclass, $qtype) = @_;
63    my ($rcode, @ans, @auth, @add, $wait);
64
65    print ("request: $qname/$qtype\n");
66    STDOUT->flush();
67
68    $wait = 0;
69    $count += 1;
70
71    if ($qname eq "count" ) {
72	if ($qtype eq "TXT") {
73	    my ($ttl, $rdata) = (0, "$count");
74	    my $rr = new Net::DNS::RR("$qname $ttl $qclass $qtype $rdata");
75	    push @ans, $rr;
76	    print ("\tcount: $count\n");
77	}
78	$rcode = "NOERROR";
79    } elsif ($qname eq "reset" ) {
80	$count = 0;
81	$send_response = 1;
82	$limit = getlimit();
83	$rcode = "NOERROR";
84	print ("\tlimit: $limit\n");
85    } elsif ($qname eq "direct.example.org" ) {
86	if ($qtype eq "A") {
87	    my ($ttl, $rdata) = (3600, $localaddr);
88	    my $rr = new Net::DNS::RR("$qname $ttl $qclass $qtype $rdata");
89	    push @ans, $rr;
90	    print ("\twait=$wait ans: $qname $ttl $qclass $qtype $rdata\n");
91	}
92	$rcode = "NOERROR";
93    } elsif ($qname eq "indirect1.example.org" ||
94	     $qname eq "indirect2.example.org" ||
95	     $qname eq "indirect3.example.org" ||
96	     $qname eq "indirect4.example.org" ||
97	     $qname eq "indirect5.example.org" ||
98	     $qname eq "indirect6.example.org" ||
99	     $qname eq "indirect7.example.org" ||
100	     $qname eq "indirect8.example.org") {
101	if ($qtype eq "A") {
102	    my ($ttl, $rdata) = (3600, $localaddr);
103	    my $rr = new Net::DNS::RR("$qname $ttl $qclass $qtype $rdata");
104	    push @ans, $rr;
105	    print ("\twait=$wait ans: $qname $ttl $qclass $qtype $rdata\n");
106	}
107	$rcode = "NOERROR";
108    } elsif ($qname =~ /^ns1\.(\d+)\.example\.org$/) {
109	my $next = $1 + 1;
110	$wait = 1;
111	if ($limit == 0) {
112	    my $rr = new Net::DNS::RR("$1.example.org 86400 $qclass NS ns1.$next.example.org");
113	    push @auth, $rr;
114	    print ("\twait=$wait auth: $1.example.org 86400 $qclass NS ns1.$next.example.org\n");
115	} else {
116	    $send_response = 1;
117	    if ($qtype eq "A") {
118		my ($ttl, $rdata) = (3600, $localaddr);
119		my $rr = new Net::DNS::RR("$qname $ttl $qclass $qtype $rdata");
120		print("\tresponse: $qname $ttl $qclass $qtype $rdata\n");
121		push @ans, $rr;
122	    }
123	}
124	$rcode = "NOERROR";
125    } elsif ($qname eq "direct.example.net" ) {
126        if ($qtype eq "A") {
127            my ($ttl, $rdata) = (3600, $localaddr);
128            my $rr = new Net::DNS::RR("$qname $ttl $qclass $qtype $rdata");
129            push @ans, $rr;
130	    print ("\twait=$wait ans: $qname $ttl $qclass $qtype $rdata\n");
131        }
132        $rcode = "NOERROR";
133    } elsif( $qname =~ /^ns1\.(\d+)\.example\.net$/ ) {
134        my $next = ($1 + 1) * 16;
135        for (my $i = 1; $i < 16; $i++) {
136            my $s = $next + $i;
137            my $rr = new Net::DNS::RR("$1.example.net 86400 $qclass NS ns1.$s.example.net");
138            push @auth, $rr;
139	    print ("\twait=$wait auth: $1.example.net 86400 $qclass NS ns1.$s.example.net\n");
140            $rr = new Net::DNS::RR("ns1.$s.example.net 86400 $qclass A 10.53.0.7");
141	    print ("\twait=$wait add: ns1.$s.example.net 86400 $qclass A 10.53.0.7\n");
142            push @add, $rr;
143        }
144        $rcode = "NOERROR";
145    } else {
146	$rcode = "NXDOMAIN";
147	    print ("\twait=$wait NXDOMAIN\n");
148    }
149
150    return ($rcode, \@ans, \@auth, \@add, $wait);
151}
152
153sub handleUDP {
154	my ($buf, $peer) = @_;
155	my ($request, $rcode, $ans, $auth, $add, $wait);
156
157	$request = new Net::DNS::Packet(\$buf, 0);
158	$@ and die $@;
159
160	my ($question) = $request->question;
161	my $qname = $question->qname;
162	my $qclass = $question->qclass;
163	my $qtype = $question->qtype;
164
165	($rcode, $ans, $auth, $add, $wait) = reply_handler($qname, $qclass, $qtype);
166
167	my $reply = $request->reply();
168
169	$reply->header->rcode($rcode);
170	$reply->header->aa(@$ans ? 1 : 0);
171	$reply->header->id($request->header->id);
172	$reply->{answer} = $ans if $ans;
173	$reply->{authority} = $auth if $auth;
174	$reply->{additional} = $add if $add;
175
176	if ($wait) {
177		# reply_handler() asked us to delay sending this reply until
178		# another reply with $wait == 1 is generated or a timeout
179		# occurs.
180		if (@delayed_response) {
181			# A delayed reply is already queued, so we can now send
182			# both the delayed reply and the current reply.
183			send_delayed_response();
184			return $reply;
185		} elsif ($no_more_waiting) {
186			# It was determined before that there is no point in
187			# waiting for "accompanying" queries.  Thus, send the
188			# current reply immediately.
189			return $reply;
190		} else {
191			# No delayed reply is queued and the client is expected
192			# to send an "accompanying" query shortly.  Do not send
193			# the current reply right now, just save it for later
194			# and wait for an "accompanying" query to be received.
195			@delayed_response = ($reply, $peer);
196			$timeout = 0.5;
197			return;
198		}
199	} else {
200		# Send reply immediately.
201		return $reply;
202	}
203}
204
205sub send_delayed_response {
206	my ($reply, $peer) = @delayed_response;
207	# Truncation to 512 bytes is required for triggering "NS explosion" on
208	# builds without IPv6 support
209	$udpsock->send($reply->data(512), 0, $peer);
210	undef @delayed_response;
211	undef $timeout;
212	print ("send_delayed_response\n");
213}
214
215# Main
216my $rin;
217my $rout;
218for (;;) {
219	$rin = '';
220	vec($rin, fileno($udpsock), 1) = 1;
221
222	select($rout = $rin, undef, undef, $timeout);
223
224	if (vec($rout, fileno($udpsock), 1)) {
225		my ($buf, $peer, $reply);
226		$udpsock->recv($buf, 512);
227		$peer = $udpsock->peername();
228		$reply = handleUDP($buf, $peer);
229		# Truncation to 512 bytes is required for triggering "NS
230		# explosion" on builds without IPv6 support
231		$udpsock->send($reply->data(512), 0, $peer) if $reply;
232	} else {
233		# An "accompanying" query was expected to come in, but did not.
234		# Assume the client never sends "accompanying" queries to
235		# prevent pointlessly waiting for them ever again.
236		$no_more_waiting = 1;
237		# Send the delayed reply to the query which caused us to wait.
238		send_delayed_response();
239	}
240}
241