1#!/usr/bin/perl -w 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# Don't respond if the "norespond" file exists; otherwise respond to 16# any A or AAAA query. 17# 18 19use IO::File; 20use IO::Socket; 21use Net::DNS; 22use Net::DNS::Packet; 23 24my $localport = int($ENV{'PORT'}); 25if (!$localport) { $localport = 5300; } 26 27my $sock = IO::Socket::INET->new(LocalAddr => "10.53.0.4", 28 LocalPort => $localport, Proto => "udp") or die "$!"; 29 30my $pidf = new IO::File "ans.pid", "w" or die "cannot open pid file: $!"; 31print $pidf "$$\n" or die "cannot write pid file: $!"; 32$pidf->close or die "cannot close pid file: $!"; 33sub rmpid { unlink "ans.pid"; exit 1; }; 34 35$SIG{INT} = \&rmpid; 36$SIG{TERM} = \&rmpid; 37 38for (;;) { 39 $sock->recv($buf, 512); 40 41 print "**** request from " , $sock->peerhost, " port ", $sock->peerport, "\n"; 42 43 my $packet; 44 45 if ($Net::DNS::VERSION > 0.68) { 46 $packet = new Net::DNS::Packet(\$buf, 0); 47 $@ and die $@; 48 } else { 49 my $err; 50 ($packet, $err) = new Net::DNS::Packet(\$buf, 0); 51 $err and die $err; 52 } 53 54 print "REQUEST:\n"; 55 $packet->print; 56 57 $packet->header->qr(1); 58 59 my @questions = $packet->question; 60 my $qname = $questions[0]->qname; 61 my $qtype = $questions[0]->qtype; 62 63 my $donotrespond = 0; 64 65 if (-e 'norespond') { 66 $donotrespond = 1; 67 } else { 68 $packet->header->aa(1); 69 if ($qtype eq "A") { 70 $packet->push("answer", 71 new Net::DNS::RR($qname . 72 " 300 A 192.0.2.1")); 73 } elsif ($qtype eq "AAAA") { 74 $packet->push("answer", 75 new Net::DNS::RR($qname . 76 " 300 AAAA 2001:db8:beef::1")); 77 } 78 } 79 80 if ($donotrespond == 0) { 81 if (index($qname, "latency") == 0) { 82 # 50ms latency 83 select(undef, undef, undef, 0.05); 84 } 85 $sock->send($packet->data); 86 print "RESPONSE:\n"; 87 $packet->print; 88 print "\n"; 89 } 90} 91