1#!/usr/bin/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 IO::File; 15use IO::Socket; 16use Data::Dumper; 17use Net::DNS; 18use Net::DNS::Packet; 19use strict; 20 21# Ignore SIGPIPE so we won't fail if peer closes a TCP socket early 22local $SIG{PIPE} = 'IGNORE'; 23 24# Flush logged output after every line 25local $| = 1; 26 27my $server_addr = "10.53.0.8"; 28 29my $localport = int($ENV{'PORT'}); 30if (!$localport) { $localport = 5300; } 31 32my $udpsock = IO::Socket::INET->new(LocalAddr => "$server_addr", 33 LocalPort => $localport, Proto => "udp", Reuse => 1) or die "$!"; 34my $tcpsock = IO::Socket::INET->new(LocalAddr => "$server_addr", 35 LocalPort => $localport, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!"; 36 37print "listening on $server_addr:$localport.\n"; 38 39my $pidf = new IO::File "ans.pid", "w" or die "cannot open pid file: $!"; 40print $pidf "$$\n" or die "cannot write pid file: $!"; 41$pidf->close or die "cannot close pid file: $!";; 42sub rmpid { unlink "ans.pid"; exit 1; }; 43 44$SIG{INT} = \&rmpid; 45$SIG{TERM} = \&rmpid; 46 47sub handleUDP { 48 my ($buf) = @_; 49 my $request; 50 51 if ($Net::DNS::VERSION > 0.68) { 52 $request = new Net::DNS::Packet(\$buf, 0); 53 $@ and die $@; 54 } else { 55 my $err; 56 ($request, $err) = new Net::DNS::Packet(\$buf, 0); 57 $err and die $err; 58 } 59 60 my @questions = $request->question; 61 my $qname = $questions[0]->qname; 62 my $qtype = $questions[0]->qtype; 63 my $qclass = $questions[0]->qclass; 64 my $id = $request->header->id; 65 66 my $response = new Net::DNS::Packet($qname, $qtype, $qclass); 67 $response->header->qr(1); 68 $response->header->aa(1); 69 $response->header->tc(0); 70 $response->header->id($id); 71 72 # Responses to queries for no-questions/NS and ns.no-questions/A are 73 # _not_ malformed or truncated. 74 if ($qname eq "no-questions" && $qtype eq "NS") { 75 $response->push("answer", new Net::DNS::RR($qname . " 300 NS ns.no-questions")); 76 $response->push("additional", new Net::DNS::RR("ns.no-questions. 300 A 10.53.0.8")); 77 return $response->data; 78 } elsif ($qname eq "ns.no-questions") { 79 $response->push("answer", new Net::DNS::RR($qname . " 300 A 10.53.0.8")) 80 if ($qtype eq "A"); 81 return $response->data; 82 } elsif ($qname =~ /\.formerr-to-all$/) { 83 $response->header->rcode("FORMERR"); 84 return $response->data; 85 } 86 87 # don't use Net::DNS to construct the header only reply as early 88 # versions just get it completely wrong. 89 90 if ($qname eq "truncated.no-questions") { 91 # QR, AA, TC: forces TCP retry 92 return (pack("nnnnnn", $id, 0x8600, 0, 0, 0, 0)); 93 } elsif ($qname eq "tcpalso.no-questions") { 94 # QR, REFUSED: forces TCP retry 95 return (pack("nnnnnn", $id, 0x8205, 0, 0, 0, 0)); 96 } 97 # QR, AA 98 return (pack("nnnnnn", $id, 0x8400, 0, 0, 0, 0)); 99} 100 101sub handleTCP { 102 my ($buf) = @_; 103 my $request; 104 105 if ($Net::DNS::VERSION > 0.68) { 106 $request = new Net::DNS::Packet(\$buf, 0); 107 $@ and die $@; 108 } else { 109 my $err; 110 ($request, $err) = new Net::DNS::Packet(\$buf, 0); 111 $err and die $err; 112 } 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 @results = (); 121 my $response = new Net::DNS::Packet($qname, $qtype, $qclass); 122 123 $response->header->qr(1); 124 $response->header->aa(1); 125 $response->header->id($id); 126 $response->push("answer", new Net::DNS::RR("$qname 300 A 1.2.3.4")); 127 128 if ($qname eq "tcpalso.no-questions") { 129 # for this qname we also return a bad reply over TCP 130 # QR, REFUSED, no question section 131 push (@results, pack("nnnnnn", $id, 0x8005, 0, 0, 0, 0)); 132 } else { 133 push(@results, $response->data); 134 } 135 136 return \@results; 137} 138 139# Main 140my $rin; 141my $rout; 142for (;;) { 143 $rin = ''; 144 vec($rin, fileno($tcpsock), 1) = 1; 145 vec($rin, fileno($udpsock), 1) = 1; 146 147 select($rout = $rin, undef, undef, undef); 148 149 if (vec($rout, fileno($udpsock), 1)) { 150 printf "UDP request\n"; 151 my $buf; 152 $udpsock->recv($buf, 512); 153 my $result = handleUDP($buf); 154 my $num_chars = $udpsock->send($result); 155 print " Sent $num_chars bytes via UDP\n"; 156 } elsif (vec($rout, fileno($tcpsock), 1)) { 157 my $conn = $tcpsock->accept; 158 my $buf; 159 for (;;) { 160 my $lenbuf; 161 my $n = $conn->sysread($lenbuf, 2); 162 last unless $n == 2; 163 my $len = unpack("n", $lenbuf); 164 $n = $conn->sysread($buf, $len); 165 last unless $n == $len; 166 print "TCP request\n"; 167 my $result = handleTCP($buf); 168 foreach my $response (@$result) { 169 $len = length($response); 170 $n = $conn->syswrite(pack("n", $len), 2); 171 $n = $conn->syswrite($response, $len); 172 print " Sent: $n chars via TCP\n"; 173 } 174 } 175 $conn->close; 176 } 177} 178