external/bsd/bind/dist/bin/tests/system/ixfr/ans2/ans.pl

   1 #!/usr/bin/perl
   2 #
   3 # Copyright (C) 2004, 2007  Internet Systems Consortium, Inc. ("ISC")
   4 # Copyright (C) 2001  Internet Software Consortium.
   5 #
   6 # Permission to use, copy, modify, and/or distribute this software for any
   7 # purpose with or without fee is hereby granted, provided that the above
   8 # copyright notice and this permission notice appear in all copies.
   9 #
  10 # THE SOFTWARE IS PROVIDED "AS IS" AND ISC DISCLAIMS ALL WARRANTIES WITH
  11 # REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
  12 # AND FITNESS.  IN NO EVENT SHALL ISC BE LIABLE FOR ANY SPECIAL, DIRECT,
  13 # INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  14 # LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  15 # OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  16 # PERFORMANCE OF THIS SOFTWARE.
  17
  18 # Id: ans.pl,v 1.6 2007/09/24 04:13:25 marka Exp
  19
  20 #
  21 # This is the name server from hell.  It provides canned
  22 # responses based on pattern matching the queries, and
  23 # can be reprogrammed on-the-fly over a TCP connection.
  24 #
  25 # The server listens for control connections on port 5301.
  26 # A control connection is a TCP stream of lines like
  27 #
  28 #  /pattern/
  29 #  name ttl type rdata
  30 #  name ttl type rdata
  31 #  ...
  32 #  /pattern/
  33 #  name ttl type rdata
  34 #  name ttl type rdata
  35 #  ...
  36 #
  37 # There can be any number of patterns, each associated
  38 # with any number of response RRs.  Each pattern is a
  39 # Perl regular expression.
  40 #
  41 # Each incoming query is converted into a string of the form
  42 # "qname qtype" (the printable query domain name, space,
  43 # printable query type) and matched against each pattern.
  44 #
  45 # The first pattern matching the query is selected, and
  46 # the RR following the pattern line are sent in the
  47 # answer section of the response.
  48 #
  49 # Each new control connection causes the current set of
  50 # patterns and responses to be cleared before adding new
  51 # ones.
  52 #
  53 # The server handles UDP and TCP queries.  Zone transfer
  54 # responses work, but must fit in a single 64 k message.
  55 #
  56
  57 use IO::File;
  58 use IO::Socket;
  59 use Net::DNS;
  60 use Net::DNS::Packet;
  61
  62 my $ctlsock = IO::Socket::INET->new(LocalAddr => "10.53.0.2",
  63    LocalPort => 5301, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!";
  64
  65 my $udpsock = IO::Socket::INET->new(LocalAddr => "10.53.0.2",
  66    LocalPort => 5300, Proto => "udp", Reuse => 1) or die "$!";
  67
  68 my $tcpsock = IO::Socket::INET->new(LocalAddr => "10.53.0.2",
  69    LocalPort => 5300, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!";
  70
  71 my $pidf = new IO::File "ans.pid", "w" or die "cannot open pid file: $!";
  72 print $pidf "$$\n" or die "cannot write pid file: $!";
  73 $pidf->close or die "cannot close pid file: $!";;
  74 sub rmpid { unlink "ans.pid"; exit 1; };
  75
  76 $SIG{INT} = \&rmpid;
  77 $SIG{TERM} = \&rmpid;
  78
  79 my @answers = ();
  80
  81 sub handle {
  82         my ($buf) = @_;
  83
  84         my ($packet, $err) = new Net::DNS::Packet(\$buf, 0);
  85         $err and die $err;
  86
  87         $packet->header->qr(1);
  88         $packet->header->aa(1);
  89
  90         my @questions = $packet->question;
  91         my $qname = $questions[0]->qname;
  92         my $qtype = $questions[0]->qtype;
  93
  94         my $r;
  95         foreach $r (@rules) {
  96                 my $pattern = $r->{pattern};
  97                 warn "match $qname $qtype == $pattern";
  98                 if ("$qname $qtype" =~ /$pattern/) {
  99                         my $a;
 100                         foreach $a (@{$r->{answer}}) {
 101                                 $packet->push("answer", $a);
 102                         }
 103                         last;
 104                 }
 105         }
 106
 107         # $packet->print;
 108
 109         return $packet->data;
 110 }
 111
 112 for (;;) {
 113         $rin = '';
 114         vec($rin, fileno($ctlsock), 1) = 1;
 115         vec($rin, fileno($tcpsock), 1) = 1;
 116         vec($rin, fileno($udpsock), 1) = 1;
 117
 118         select($rout = $rin, undef, undef, undef);
 119
 120         if (vec($rout, fileno($ctlsock), 1)) {
 121                 warn "ctl conn";
 122                 my $conn = $ctlsock->accept;
 123                 @rules = ();
 124                 while (my $line = $conn->getline) {
 125                         chomp $line;
 126                         if ($line =~ m!^/(.*)/$!) {
 127                                 $rule = { pattern => $1, answer => [] };
 128                                 push(@rules, $rule);
 129                         } else {
 130                                 push(@{$rule->{answer}},
 131                                      new Net::DNS::RR($line));
 132                         }
 133
 134                 }
 135                 $conn->close;
 136         } elsif (vec($rout, fileno($udpsock), 1)) {
 137                 printf "UDP request\n";
 138                 $udpsock->recv($buf, 512);
 139                 $response = handle($buf);
 140                 $udpsock->send($response);
 141         } elsif (vec($rout, fileno($tcpsock), 1)) {
 142                 my $conn = $tcpsock->accept;
 143                 for (;;) {
 144                         printf "TCP request\n";
 145                         my $n = $conn->sysread($lenbuf, 2);
 146                         last unless $n == 2;
 147                         my $len = unpack("n", $lenbuf);
 148                         $n = $conn->sysread($buf, $len);
 149                         last unless $n == $len;
 150                         $response = handle($buf);
 151                         $len = length($response);
 152                         $n = $conn->syswrite(pack("n", $len), 2);
 153                         $n = $conn->syswrite($response, $len);
 154                 }
 155                 $conn->close;
 156         }
 157 }