ans.pl 4.94 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174
#!/usr/bin/perl
#
# Copyright (C) Internet Systems Consortium, Inc. ("ISC")
#
# This Source Code Form is subject to the terms of the Mozilla Public
# License, v. 2.0. If a copy of the MPL was not distributed with this
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
#
# See the COPYRIGHT file distributed with this work for additional
# information regarding copyright ownership.

# This is a TCP-only DNS server whose aim is to facilitate testing how dig
# copes with prematurely closed TCP connections.
#
# This server can be configured (through a separate control socket) with a
# series of responses to send for subsequent incoming TCP DNS queries.  Only
# one query is handled before closing each connection.  In order to keep things
# simple, the server is not equipped with any mechanism for handling malformed
# queries.
#
# Available response types are defined in the %response_types hash in the
# getAnswerSection() function below.  Each RR returned is generated dynamically
# based on the QNAME found in the incoming query.

use IO::File;
use Net::DNS;
use Net::DNS::Packet;

use strict;

# Ignore SIGPIPE so we won't fail if peer closes a TCP socket early
local $SIG{PIPE} = 'IGNORE';

# Flush logged output after every line
local $| = 1;

my $server_addr = "10.53.0.5";
if (@ARGV > 0) {
	$server_addr = @ARGV[0];
}

my $mainport = int($ENV{'PORT'});
if (!$mainport) { $mainport = 5300; }
my $ctrlport = int($ENV{'EXTRAPORT1'});
if (!$ctrlport) { $ctrlport = 5301; }

my $ctlsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
   LocalPort => $ctrlport, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!";

my $tcpsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
   LocalPort => $mainport, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!";

my $pidf = new IO::File "ans.pid", "w" or die "cannot open pid file: $!";
print $pidf "$$\n" or die "cannot write pid file: $!";
$pidf->close or die "cannot close pid file: $!";;
sub rmpid { unlink "ans.pid"; exit 1; };

$SIG{INT} = \&rmpid;
$SIG{TERM} = \&rmpid;

my @response_sequence = ("complete_axfr");
my $connection_counter = 0;

# Return the next answer type to send, incrementing the connection counter and
# making sure the latter does not exceed the size of the array holding the
# configured response sequence.
sub getNextResponseType {
	my $response_type = $response_sequence[$connection_counter];

	$connection_counter++;
	$connection_counter %= scalar(@response_sequence);

	return $response_type;
}

# Return an array of resource records comprising the answer section of a given
# response type.
sub getAnswerSection {
	my ($response_type, $qname) = @_;

	my %response_types = (
		no_response => [],

		partial_axfr => [
			Net::DNS::RR->new("$qname 300 IN SOA . . 0 0 0 0 300"),
			Net::DNS::RR->new("$qname NS ."),
		],

		complete_axfr => [
			Net::DNS::RR->new("$qname 300 IN SOA . . 0 0 0 0 300"),
			Net::DNS::RR->new("$qname NS ."),
			Net::DNS::RR->new("$qname 300 IN SOA . . 0 0 0 0 300"),
		],
	);

	return $response_types{$response_type};
}


# Generate a Net::DNS::Packet containing the response to send on the current
# TCP connection.  If the answer section of the response is determined to be
# empty, no data will be sent on the connection at all (immediate EOF).
sub generateResponse {
	my ($buf) = @_;
	my $request;

	if ($Net::DNS::VERSION > 0.68) {
		$request = new Net::DNS::Packet(\$buf, 0);
		$@ and die $@;
	} else {
		my $err;
		($request, $err) = new Net::DNS::Packet(\$buf, 0);
		$err and die $err;
	}

	my @questions = $request->question;
	my $qname = $questions[0]->qname;
	my $qtype = $questions[0]->qtype;
	my $qclass = $questions[0]->qclass;
	my $id = $request->header->id;

	my $packet = new Net::DNS::Packet($qname, $qtype, $qclass);
	$packet->header->qr(1);
	$packet->header->aa(1);
	$packet->header->id($id);

	my $response_type = getNextResponseType();
	my $answers = getAnswerSection($response_type, $qname);
	for my $rr (@$answers) {
		$packet->push("answer", $rr);
	}

	print "    Sending \"$response_type\" response\n";

	return $packet->data if @$answers;
}

my $rin;
my $rout;
for (;;) {
	$rin = '';
	vec($rin, fileno($ctlsock), 1) = 1;
	vec($rin, fileno($tcpsock), 1) = 1;

	select($rout = $rin, undef, undef, undef);

	if (vec($rout, fileno($ctlsock), 1)) {
		my $conn = $ctlsock->accept;
		@response_sequence = split(' ', $conn->getline);
		$connection_counter = 0;
		print "Response sequence set to: @response_sequence\n";
		$conn->close;
	} elsif (vec($rout, fileno($tcpsock), 1)) {
		my $buf;
		my $lenbuf;
		my $conn = $tcpsock->accept;
		my $n = $conn->sysread($lenbuf, 2);
		die unless $n == 2;
		my $len = unpack("n", $lenbuf);
		$n = $conn->sysread($buf, $len);
		die unless $n == $len;
		print "TCP request\n";
		my $response = generateResponse($buf);
		if ($response) {
			$len = length($response);
			$n = $conn->syswrite(pack("n", $len), 2);
			$n = $conn->syswrite($response, $len);
			print "    Sent: $n chars via TCP\n";
		} else {
			print "    No response sent\n";
		}
		$conn->close;
	}
}