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 14# 15# Ad hoc name server 16# 17 18use IO::File; 19use IO::Socket; 20use Net::DNS; 21use Net::DNS::Packet; 22 23# Ignore SIGPIPE so we won't fail if peer closes a TCP socket early 24local $SIG{PIPE} = 'IGNORE'; 25 26# Flush logged output after every line 27local $| = 1; 28 29my $localport = int($ENV{'PORT'}); 30if (!$localport) { $localport = 5300; } 31 32my $server_addr = "10.53.0.3"; 33 34my $udpsock = IO::Socket::INET->new(LocalAddr => "$server_addr", 35 LocalPort => $localport, Proto => "udp", Reuse => 1) or die "$!"; 36my $tcpsock = IO::Socket::INET->new(LocalAddr => "$server_addr", 37 LocalPort => $localport, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!"; 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 handleQuery { 48 my $buf = shift; 49 my $packet; 50 51 if ($Net::DNS::VERSION > 0.68) { 52 $packet = new Net::DNS::Packet(\$buf, 0); 53 $@ and die $@; 54 } else { 55 my $err; 56 ($packet, $err) = new Net::DNS::Packet(\$buf, 0); 57 $err and die $err; 58 } 59 60 print "REQUEST:\n"; 61 $packet->print; 62 63 $packet->header->qr(1); 64 $packet->header->aa(1); 65 66 my @questions = $packet->question; 67 my $qname = $questions[0]->qname; 68 my $qtype = $questions[0]->qtype; 69 70 if ($qname eq "example.net" && $qtype eq "NS") { 71 $packet->push("answer", new Net::DNS::RR($qname . " 300 NS ns.example.net")); 72 $packet->push("additional", new Net::DNS::RR("ns.example.net 300 A 10.53.0.3")); 73 } elsif ($qname eq "ns.example.net") { 74 $packet->push("answer", new Net::DNS::RR($qname . " 300 A 10.53.0.3")); 75 } elsif ($qname eq "nodata.example.net") { 76 # Do not add a SOA RRset. 77 } elsif ($qname eq "noresponse.example.net") { 78 # Do not response. 79 print "RESPONSE:\n"; 80 return ""; 81 } elsif ($qname eq "nxdomain.example.net") { 82 # Do not add a SOA RRset. 83 $packet->header->rcode(NXDOMAIN); 84 } elsif ($qname eq "www.example.net") { 85 # Data for address/alias filtering. 86 if ($qtype eq "A") { 87 $packet->push("answer", new Net::DNS::RR($qname . " 300 A 192.0.2.1")); 88 } elsif ($qtype eq "AAAA") { 89 $packet->push("answer", new Net::DNS::RR($qname . " 300 AAAA 2001:db8:beef::1")); 90 } 91 } elsif ($qname eq "badcname.example.net") { 92 $packet->push("answer", 93 new Net::DNS::RR($qname . 94 " 300 CNAME badcname.example.org")); 95 } elsif (($qname eq "baddname.example.net" || $qname eq "gooddname.example.net") && $qtype eq "NS") { 96 $packet->push("authority", new Net::DNS::RR("example.net IN SOA (1 2 3 4 5)")) 97 } elsif ($qname eq "foo.baddname.example.net") { 98 $packet->push("answer", 99 new Net::DNS::RR("baddname.example.net" . 100 " 300 DNAME baddname.example.org")); 101 } elsif ($qname eq "foo.gooddname.example.net") { 102 $packet->push("answer", 103 new Net::DNS::RR("gooddname.example.net" . 104 " 300 DNAME gooddname.example.org")); 105 } elsif ($qname eq "goodcname.example.net") { 106 $packet->push("answer", 107 new Net::DNS::RR($qname . 108 " 300 CNAME goodcname.example.org")); 109 } elsif ($qname =~ /^longcname/) { 110 $cname = $qname =~ s/longcname/longcnamex/r; 111 $packet->push("answer", new Net::DNS::RR($qname . " 300 CNAME " . $cname)); 112 } elsif ($qname =~ /^nodata\.example\.net$/i) { 113 $packet->header->aa(1); 114 } elsif ($qname =~ /^nxdomain\.example\.net$/i) { 115 $packet->header->aa(1); 116 $packet->header->rcode(NXDOMAIN); 117 } elsif ($qname =~ /lame\.example\.org/) { 118 $packet->header->ad(0); 119 $packet->header->aa(0); 120 $packet->push("authority", new Net::DNS::RR("lame.example.org 300 NS ns.lame.example.org")); 121 $packet->push("additional", new Net::DNS::RR("ns.lame.example.org 300 A 10.53.0.3")); 122 } elsif ($qname eq "large-referral.example.net") { 123 for (my $i = 1; $i < 1000; $i++) { 124 $packet->push("authority", new Net::DNS::RR("large-referral.example.net 300 NS ns" . $i . ".fake.redirect.com")); 125 } 126 # No glue records 127 } elsif ($qname eq "foo.bar.sub.tld1") { 128 $packet->push("answer", new Net::DNS::RR("$qname 300 TXT baz")); 129 } elsif ($qname eq "cname.sub.example.org") { 130 $packet->push("answer", 131 new Net::DNS::RR($qname . 132 " 300 CNAME ok.sub.example.org")); 133 } elsif ($qname eq "ok.sub.example.org") { 134 $packet->push("answer", 135 new Net::DNS::RR($qname . " 300 A 192.0.2.1")); 136 } elsif ($qname eq "www.dname.sub.example.org") { 137 $packet->push("answer", 138 new Net::DNS::RR("dname.sub.example.org" . 139 " 300 DNAME ok.sub.example.org")); 140 } elsif ($qname eq "www.ok.sub.example.org") { 141 $packet->push("answer", 142 new Net::DNS::RR($qname . " 300 A 192.0.2.1")); 143 } elsif ($qname eq "foo.glue-in-answer.example.org") { 144 $packet->push("answer", new Net::DNS::RR($qname . " 300 A 192.0.2.1")); 145 } elsif ($qname eq "ns.example.net") { 146 $packet->push("answer", 147 new Net::DNS::RR($qname . 148 " 300 A 10.53.0.3")); 149 } elsif ($qname =~ /\.partial-formerr/) { 150 $packet->push("answer", 151 new Net::DNS::RR($qname . " 1 A 10.53.0.3")); 152 } elsif ($qname eq "gl6412") { 153 if ($qtype eq "SOA") { 154 $packet->push("answer", 155 new Net::DNS::RR($qname . " 300 SOA . . 0 0 0 0 0")); 156 } elsif ($qtype eq "NS") { 157 $packet->push("answer", 158 new Net::DNS::RR($qname . " 300 NS ns2" . $qname)); 159 $packet->push("answer", 160 new Net::DNS::RR($qname . " 300 NS ns3" . $qname)); 161 } else { 162 $packet->push("authority", 163 new Net::DNS::RR($qname . " 300 SOA . . 0 0 0 0 0")); 164 } 165 } elsif ($qname eq "a.gl6412" || $qname eq "a.a.gl6412") { 166 $packet->push("authority", 167 new Net::DNS::RR($qname . " 300 SOA . . 0 0 0 0 0")); 168 } elsif ($qname eq "ns2.gl6412") { 169 if ($qtype eq "A") { 170 $packet->push("answer", 171 new Net::DNS::RR($qname . " 300 A 10.53.0.2")); 172 } else { 173 $packet->push("authority", 174 new Net::DNS::RR($qname . " 300 SOA . . 0 0 0 0 0")); 175 } 176 } elsif ($qname eq "ns3.gl6412") { 177 if ($qtype eq "A") { 178 $packet->push("answer", 179 new Net::DNS::RR($qname . " 300 A 10.53.0.3")); 180 } else { 181 $packet->push("authority", 182 new Net::DNS::RR($qname . " 300 SOA . . 0 0 0 0 0")); 183 } 184 } else { 185 $packet->push("answer", new Net::DNS::RR("www.example.com 300 A 1.2.3.4")); 186 } 187 188 print "RESPONSE:\n"; 189 $packet->print; 190 191 return $packet->data; 192} 193 194# Main 195my $rin; 196my $rout; 197for (;;) { 198 $rin = ''; 199 vec($rin, fileno($tcpsock), 1) = 1; 200 vec($rin, fileno($udpsock), 1) = 1; 201 202 select($rout = $rin, undef, undef, undef); 203 204 if (vec($rout, fileno($udpsock), 1)) { 205 printf "UDP request\n"; 206 my $buf; 207 $udpsock->recv($buf, 512); 208 my $result = handleQuery($buf); 209 my $num_chars = $udpsock->send($result); 210 print " Sent $num_chars bytes via UDP\n"; 211 } elsif (vec($rout, fileno($tcpsock), 1)) { 212 my $conn = $tcpsock->accept; 213 my $buf; 214 for (;;) { 215 my $lenbuf; 216 my $n = $conn->sysread($lenbuf, 2); 217 last unless $n == 2; 218 my $len = unpack("n", $lenbuf); 219 $n = $conn->sysread($buf, $len); 220 last unless $n == $len; 221 print "TCP request\n"; 222 my $result = handleQuery($buf); 223 $len = length($result); 224 if ($len != 0) { 225 $conn->syswrite(pack("n", $len), 2); 226 $n = $conn->syswrite($result, $len); 227 } else { 228 $n = 0; 229 } 230 print " Sent: $n chars via TCP\n"; 231 } 232 $conn->close; 233 } 234} 235