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 23my $localport = int($ENV{'PORT'}); 24if (!$localport) { $localport = 5300; } 25 26my $sock = IO::Socket::INET->new(LocalAddr => "10.53.0.2", 27 LocalPort => $localport, Proto => "udp") or die "$!"; 28 29my $pidf = new IO::File "ans.pid", "w" or die "cannot open pid file: $!"; 30print $pidf "$$\n" or die "cannot write pid file: $!"; 31$pidf->close or die "cannot close pid file: $!"; 32sub rmpid { unlink "ans.pid"; exit 1; }; 33 34$SIG{INT} = \&rmpid; 35$SIG{TERM} = \&rmpid; 36 37for (;;) { 38 $sock->recv($buf, 512); 39 40 print "**** request from " , $sock->peerhost, " port ", $sock->peerport, "\n"; 41 42 my $packet; 43 44 if ($Net::DNS::VERSION > 0.68) { 45 $packet = new Net::DNS::Packet(\$buf, 0); 46 $@ and die $@; 47 } else { 48 my $err; 49 ($packet, $err) = new Net::DNS::Packet(\$buf, 0); 50 $err and die $err; 51 } 52 53 print "REQUEST:\n"; 54 $packet->print; 55 56 $packet->header->qr(1); 57 58 my @questions = $packet->question; 59 my $qname = $questions[0]->qname; 60 my $qtype = $questions[0]->qtype; 61 62 if ($qname eq "com" && $qtype eq "NS") { 63 $packet->header->aa(1); 64 $packet->push("answer", new Net::DNS::RR("com 300 NS a.root-servers.nil.")); 65 } elsif ($qname eq "example.com" && $qtype eq "NS") { 66 $packet->header->aa(1); 67 $packet->push("answer", new Net::DNS::RR("example.com 300 NS a.root-servers.nil.")); 68 } elsif ($qname eq "cname1.example.com") { 69 # Data for the "cname + other data / 1" test 70 $packet->push("answer", new Net::DNS::RR("cname1.example.com 300 CNAME cname1.example.com")); 71 $packet->push("answer", new Net::DNS::RR("cname1.example.com 300 A 1.2.3.4")); 72 } elsif ($qname eq "cname2.example.com") { 73 # Data for the "cname + other data / 2" test: same RRs in opposite order 74 $packet->push("answer", new Net::DNS::RR("cname2.example.com 300 A 1.2.3.4")); 75 $packet->push("answer", new Net::DNS::RR("cname2.example.com 300 CNAME cname2.example.com")); 76 } elsif ($qname =~ /redirect\.com/) { 77 $packet->push("authority", new Net::DNS::RR("redirect.com 300 NS ns.redirect.com")); 78 $packet->push("additional", new Net::DNS::RR("ns.redirect.com 300 A 10.53.0.6")); 79 } elsif ($qname =~ /\.tld1/) { 80 $packet->push("authority", new Net::DNS::RR("tld1 300 NS ns.tld1")); 81 $packet->push("additional", new Net::DNS::RR("ns.tld1 300 A 10.53.0.6")); 82 } elsif ($qname =~ /\.tld2/) { 83 $packet->push("authority", new Net::DNS::RR("tld2 300 NS ns.tld2")); 84 $packet->push("additional", new Net::DNS::RR("ns.tld2 300 A 10.53.0.7")); 85 } elsif ($qname eq "org" && $qtype eq "NS") { 86 $packet->header->aa(1); 87 $packet->push("answer", new Net::DNS::RR("org 300 NS a.root-servers.nil.")); 88 } elsif ($qname eq "example.org" && $qtype eq "NS") { 89 $packet->header->aa(1); 90 $packet->push("answer", new Net::DNS::RR("example.org 300 NS a.root-servers.nil.")); 91 } elsif (($qname eq "baddname.example.org" || $qname eq "gooddname.example.org") && $qtype eq "NS") { 92 $packet->header->aa(1); 93 $packet->push("answer", new Net::DNS::RR("example.org 300 NS a.root-servers.nil.")); 94 } elsif ($qname eq "www.example.org" || 95 $qname eq "badcname.example.org" || 96 $qname eq "goodcname.example.org" || 97 $qname eq "foo.baddname.example.org" || 98 $qname eq "foo.gooddname.example.org") { 99 # Data for address/alias filtering. 100 $packet->header->aa(1); 101 if ($qtype eq "A") { 102 $packet->push("answer", 103 new Net::DNS::RR($qname . 104 " 300 A 192.0.2.1")); 105 } elsif ($qtype eq "AAAA") { 106 $packet->push("answer", 107 new Net::DNS::RR($qname . 108 " 300 AAAA 2001:db8:beef::1")); 109 } 110 } elsif ($qname eq "net" && $qtype eq "NS") { 111 $packet->header->aa(1); 112 $packet->push("answer", new Net::DNS::RR("net 300 NS a.root-servers.nil.")); 113 } elsif ($qname =~ /example\.net/) { 114 $packet->push("authority", new Net::DNS::RR("example.net 300 NS ns.example.net")); 115 $packet->push("additional", new Net::DNS::RR("ns.example.net 300 A 10.53.0.3")); 116 } elsif ($qname =~ /sub\.example\.org/) { 117 # Data for CNAME/DNAME filtering. The final answers are 118 # expected to be accepted regardless of the filter setting. 119 $packet->push("authority", new Net::DNS::RR("sub.example.org 300 NS ns.sub.example.org")); 120 $packet->push("additional", new Net::DNS::RR("ns.sub.example.org 300 A 10.53.0.3")); 121 } elsif ($qname =~ /glue-in-answer\.example\.org/) { 122 $packet->push("answer", new Net::DNS::RR("ns.glue-in-answer.example.org 300 A 10.53.0.3")); 123 $packet->push("authority", new Net::DNS::RR("glue-in-answer.example.org 300 NS ns.glue-in-answer.example.org")); 124 $packet->push("additional", new Net::DNS::RR("ns.glue-in-answer.example.org 300 A 10.53.0.3")); 125 } elsif ($qname =~ /\.broken/ || $qname =~ /^broken/) { 126 # Delegation to broken TLD. 127 $packet->push("authority", new Net::DNS::RR("broken 300 NS ns.broken")); 128 $packet->push("additional", new Net::DNS::RR("ns.broken 300 A 10.53.0.4")); 129 } else { 130 # Data for the "bogus referrals" test 131 $packet->push("authority", new Net::DNS::RR("below.www.example.com 300 NS ns.below.www.example.com")); 132 $packet->push("additional", new Net::DNS::RR("ns.below.www.example.com 300 A 10.53.0.3")); 133 } 134 135 $sock->send($packet->data); 136 137 print "RESPONSE:\n"; 138 $packet->print; 139 print "\n"; 140} 141