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

   1 #!/usr/bin/perl
   2 #
   3 # Copyright (C) 2011, 2012, 2014  Internet Systems Consortium, Inc. ("ISC")
   4 #
   5 # Permission to use, copy, modify, and/or distribute this software for any
   6 # purpose with or without fee is hereby granted, provided that the above
   7 # copyright notice and this permission notice appear in all copies.
   8 #
   9 # THE SOFTWARE IS PROVIDED "AS IS" AND ISC DISCLAIMS ALL WARRANTIES WITH
  10 # REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
  11 # AND FITNESS.  IN NO EVENT SHALL ISC BE LIABLE FOR ANY SPECIAL, DIRECT,
  12 # INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  13 # LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  14 # OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  15 # PERFORMANCE OF THIS SOFTWARE.
  16
  17 # Id: ans.pl,v 1.6 2012/02/22 23:47:34 tbox Exp
  18
  19 #
  20 # This is the name server from hell.  It provides canned
  21 # responses based on pattern matching the queries, and
  22 # can be reprogrammed on-the-fly over a TCP connection.
  23 #
  24 # The server listens for control connections on port 5301.
  25 # A control connection is a TCP stream of lines like
  26 #
  27 #  /pattern/
  28 #  name ttl type rdata
  29 #  name ttl type rdata
  30 #  ...
  31 #  /pattern/
  32 #  name ttl type rdata
  33 #  name ttl type rdata
  34 #  ...
  35 #
  36 # There can be any number of patterns, each associated
  37 # with any number of response RRs.  Each pattern is a
  38 # Perl regular expression.
  39 #
  40 # Each incoming query is converted into a string of the form
  41 # "qname qtype" (the printable query domain name, space,
  42 # printable query type) and matched against each pattern.
  43 #
  44 # The first pattern matching the query is selected, and
  45 # the RR following the pattern line are sent in the
  46 # answer section of the response.
  47 #
  48 # Each new control connection causes the current set of
  49 # patterns and responses to be cleared before adding new
  50 # ones.
  51 #
  52 # The server handles UDP and TCP queries.  Zone transfer
  53 # responses work, but must fit in a single 64 k message.
  54 #
  55 # Now you can add TSIG, just specify key/key data with:
  56 #
  57 #  /pattern <key> <key_data>/
  58 #  name ttl type rdata
  59 #  name ttl type rdata
  60 #
  61 #  Note that this data will still be sent with any request for
  62 #  pattern, only this data will be signed. Currently, this is only
  63 #  done for TCP.
  64
  65
  66 use IO::File;
  67 use IO::Socket;
  68 use Data::Dumper;
  69 use Net::DNS;
  70 use Net::DNS::Packet;
  71 use strict;
  72
  73 # Ignore SIGPIPE so we won't fail if peer closes a TCP socket early
  74 local $SIG{PIPE} = 'IGNORE';
  75
  76 # Flush logged output after every line
  77 local $| = 1;
  78
  79 # We default to listening on 10.53.0.2 for historical reasons
  80 # XXX: we should also be able to specify IPv6
  81 my $server_addr = "10.53.0.2";
  82 if (@ARGV > 0) {
  83         $server_addr = @ARGV[0];
  84 }
  85
  86 # XXX: we should also be able to set the port numbers to listen on.
  87 my $ctlsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
  88    LocalPort => 5301, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!";
  89
  90 my $udpsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
  91    LocalPort => 5300, Proto => "udp", Reuse => 1) or die "$!";
  92
  93 my $tcpsock = IO::Socket::INET->new(LocalAddr => "$server_addr",
  94    LocalPort => 5300, Proto => "tcp", Listen => 5, Reuse => 1) or die "$!";
  95
  96 print "listening on $server_addr:5300,5301.\n";
  97 print "Using Net::DNS $Net::DNS::VERSION\n";
  98
  99 my $pidf = new IO::File "ans.pid", "w" or die "cannot open pid file: $!";
 100 print $pidf "$$\n" or die "cannot write pid file: $!";
 101 $pidf->close or die "cannot close pid file: $!";;
 102 sub rmpid { unlink "ans.pid"; exit 1; };
 103
 104 $SIG{INT} = \&rmpid;
 105 $SIG{TERM} = \&rmpid;
 106
 107 #my @answers = ();
 108 my @rules;
 109 sub handleUDP {
 110         my ($buf) = @_;
 111         my $request;
 112
 113         if ($Net::DNS::VERSION > 0.68) {
 114                 $request = new Net::DNS::Packet(\$buf, 0);
 115                 $@ and die $@;
 116         } else {
 117                 my $err;
 118                 ($request, $err) = new Net::DNS::Packet(\$buf, 0);
 119                 $err and die $err;
 120         }
 121
 122         my @questions = $request->question;
 123         my $qname = $questions[0]->qname;
 124         my $qtype = $questions[0]->qtype;
 125         my $qclass = $questions[0]->qclass;
 126         my $id = $request->header->id;
 127
 128         my $packet = new Net::DNS::Packet($qname, $qtype, $qclass);
 129         $packet->header->qr(1);
 130         $packet->header->aa(1);
 131         $packet->header->id($id);
 132
 133         # get the existing signature if any, and clear the additional section
 134         my $prev_tsig;
 135         while (my $rr = $request->pop("additional")) {
 136                 $prev_tsig = $rr if ($rr->type eq "TSIG");
 137         }
 138
 139         my $r;
 140         foreach $r (@rules) {
 141                 my $pattern = $r->{pattern};
 142                 my($dbtype, $key_name, $key_data) = split(/ /,$pattern);
 143                 print "[handleUDP] $dbtype, $key_name, $key_data \n";
 144                 if ("$qname $qtype" =~ /$dbtype/) {
 145                         my $a;
 146                         foreach $a (@{$r->{answer}}) {
 147                                 $packet->push("answer", $a);
 148                         }
 149                         if(defined($key_name) && defined($key_data)) {
 150                                 my $tsig;
 151                                 # Sign the packet
 152                                 print "  Signing the response with " .
 153                                       "$key_name/$key_data\n";
 154
 155                                 if ($Net::DNS::VERSION < 0.69) {
 156                                         $tsig = Net::DNS::RR->new(
 157                                                    "$key_name TSIG $key_data");
 158                                 } else {
 159                                         $tsig = Net::DNS::RR->new(
 160                                                         name => $key_name,
 161                                                         type => 'TSIG',
 162                                                         key  => $key_data);
 163                                 }
 164
 165                                 # These kluges are necessary because Net::DNS
 166                                 # doesn't know how to sign responses.  We
 167                                 # clear compnames so that the TSIG key and
 168                                 # algorithm name won't be compressed, and
 169                                 # add one to arcount because the signing
 170                                 # function will attempt to decrement it,
 171                                 # which is incorrect in a response. Finally
 172                                 # we set request_mac to the previous digest.
 173                                 $packet->{"compnames"} = {}
 174                                         if ($Net::DNS::VERSION < 0.70);
 175                                 $packet->{"header"}{"arcount"} += 1
 176                                         if ($Net::DNS::VERSION < 0.70);
 177                                 if (defined($prev_tsig)) {
 178                                         if ($Net::DNS::VERSION < 0.73) {
 179                                                 my $rmac = pack('n H*',
 180                                                         length($prev_tsig->mac)/2,
 181                                                         $prev_tsig->mac);
 182                                                 $tsig->{"request_mac"} =
 183                                                         unpack("H*", $rmac);
 184                                         } else {
 185                                                 $tsig->request_mac(
 186                                                          $prev_tsig->mac);
 187                                         }
 188                                 }
 189
 190                                 $packet->sign_tsig($tsig);
 191                         }
 192                         last;
 193                 }
 194         }
 195         #$packet->print;
 196
 197         return $packet->data;
 198 }
 199
 200 # namelen:
 201 # given a stream of data, reads a DNS-formatted name and returns its
 202 # total length, thus making it possible to skip past it.
 203 sub namelen {
 204         my ($data) = @_;
 205         my $len = 0;
 206         my $label_len = 0;
 207         do {
 208                 $label_len = unpack("c", $data);
 209                 $data = substr($data, $label_len + 1);
 210                 $len += $label_len + 1;
 211         } while ($label_len != 0);
 212         return ($len);
 213 }
 214
 215 # packetlen:
 216 # given a stream of data, reads a DNS wire-format packet and returns
 217 # its total length, making it possible to skip past it.
 218 sub packetlen {
 219         my ($data) = @_;
 220         my $q;
 221         my $rr;
 222         my $header;
 223         my $offset;
 224
 225         #
 226         # decode/encode were introduced in Net::DNS 0.68
 227         # parse is no longer a method and calling it here makes perl croak.
 228         #
 229         my $decode = 0;
 230         $decode = 1 if ($Net::DNS::VERSION >= 0.68);
 231
 232         if ($decode) {
 233                 ($header, $offset) = Net::DNS::Header->decode(\$data);
 234         } else {
 235                 ($header, $offset) = Net::DNS::Header->parse(\$data);
 236         }
 237
 238         for (1 .. $header->qdcount) {
 239                 if ($decode) {
 240                         ($q, $offset) =
 241                                  Net::DNS::Question->decode(\$data, $offset);
 242                 } else {
 243                         ($q, $offset) =
 244                                  Net::DNS::Question->parse(\$data, $offset);
 245                 }
 246         }
 247         for (1 .. $header->ancount) {
 248                 if ($decode) {
 249                         ($q, $offset) = Net::DNS::RR->decode(\$data, $offset);
 250                 } else {
 251                         ($q, $offset) = Net::DNS::RR->parse(\$data, $offset);
 252                 }
 253         }
 254         for (1 .. $header->nscount) {
 255                 if ($decode) {
 256                         ($q, $offset) = Net::DNS::RR->decode(\$data, $offset);
 257                 } else {
 258                         ($q, $offset) = Net::DNS::RR->parse(\$data, $offset);
 259                 }
 260         }
 261         for (1 .. $header->arcount) {
 262                 if ($decode) {
 263                         ($q, $offset) = Net::DNS::RR->decode(\$data, $offset);
 264                 } else {
 265                         ($q, $offset) = Net::DNS::RR->parse(\$data, $offset);
 266                 }
 267         }
 268         return $offset;
 269 }
 270
 271 # sign_tcp_continuation:
 272 # This is a hack to correct the problem that Net::DNS has no idea how
 273 # to sign multiple-message TCP responses.  Several data that are included
 274 # in the digest when signing a query or the first message of a response are
 275 # omitted when signing subsequent messages in a TCP stream.
 276 #
 277 # Net::DNS::Packet->sign_tsig() has the ability to use a custom signing
 278 # function (specified by calling Packet->sign_func()).  We use this
 279 # function as the signing function for TCP continuations, and it removes
 280 # the unwanted data from the digest before calling the default sign_hmac
 281 # function.
 282 sub sign_tcp_continuation {
 283         my ($key, $data) = @_;
 284
 285         # copy out first two bytes: size of the previous MAC
 286         my $rmacsize = unpack("n", $data);
 287         $data = substr($data, 2);
 288
 289         # copy out previous MAC
 290         my $rmac = substr($data, 0, $rmacsize);
 291         $data = substr($data, $rmacsize);
 292
 293         # try parsing out the packet information
 294         my $plen = packetlen($data);
 295         my $pdata = substr($data, 0, $plen);
 296         $data = substr($data, $plen);
 297
 298         # remove the keyname, ttl, class, and algorithm name
 299         $data = substr($data, namelen($data));
 300         $data = substr($data, 6);
 301         $data = substr($data, namelen($data));
 302
 303         # preserve the TSIG data
 304         my $tdata = substr($data, 0, 8);
 305
 306         # prepare a new digest and sign with it
 307         $data = pack("n", $rmacsize) . $rmac . $pdata . $tdata;
 308         return Net::DNS::RR::TSIG::sign_hmac($key, $data);
 309 }
 310
 311 sub handleTCP {
 312         my ($buf) = @_;
 313         my $request;
 314
 315         if ($Net::DNS::VERSION > 0.68) {
 316                 $request = new Net::DNS::Packet(\$buf, 0);
 317                 $@ and die $@;
 318         } else {
 319                 my $err;
 320                 ($request, $err) = new Net::DNS::Packet(\$buf, 0);
 321                 $err and die $err;
 322         }
 323
 324         my @questions = $request->question;
 325         my $qname = $questions[0]->qname;
 326         my $qtype = $questions[0]->qtype;
 327         my $qclass = $questions[0]->qclass;
 328         my $id = $request->header->id;
 329
 330         my $opaque;
 331
 332         my $packet = new Net::DNS::Packet($qname, $qtype, $qclass);
 333         $packet->header->qr(1);
 334         $packet->header->aa(1);
 335         $packet->header->id($id);
 336
 337         # get the existing signature if any, and clear the additional section
 338         my $prev_tsig;
 339         my $signer;
 340         my $continuation = 0;
 341         if ($Net::DNS::VERSION < 0.81) {
 342                 while (my $rr = $request->pop("additional")) {
 343                         if ($rr->type eq "TSIG") {
 344                                 $prev_tsig = $rr;
 345                         }
 346                 }
 347         }
 348
 349         my @results = ();
 350         my $count_these = 0;
 351
 352         my $r;
 353         foreach $r (@rules) {
 354                 my $pattern = $r->{pattern};
 355                 my($dbtype, $key_name, $key_data) = split(/ /,$pattern);
 356                 print "[handleTCP] $dbtype, $key_name, $key_data \n";
 357                 if ("$qname $qtype" =~ /$dbtype/) {
 358                         $count_these++;
 359                         my $a;
 360                         foreach $a (@{$r->{answer}}) {
 361                                 $packet->push("answer", $a);
 362                         }
 363                         if (defined($key_name) && defined($key_data)) {
 364                                 my $tsig;
 365                                 # sign the packet
 366                                 print "  Signing the data with " .
 367                                       "$key_name/$key_data\n";
 368
 369                                 if ($Net::DNS::VERSION < 0.69) {
 370                                         $tsig = Net::DNS::RR->new(
 371                                                    "$key_name TSIG $key_data");
 372                                 } elsif ($Net::DNS::VERSION >= 0.81 &&
 373                                          $continuation) {
 374                                 } elsif ($Net::DNS::VERSION >= 0.75 &&
 375                                          $continuation) {
 376                                         $tsig = $prev_tsig;
 377                                 } else {
 378                                         $tsig = Net::DNS::RR->new(
 379                                                         name => $key_name,
 380                                                         type => 'TSIG',
 381                                                         key  => $key_data);
 382                                 }
 383
 384                                 # These kluges are necessary because Net::DNS
 385                                 # doesn't know how to sign responses.  We
 386                                 # clear compnames so that the TSIG key and
 387                                 # algorithm name won't be compressed, and
 388                                 # add one to arcount because the signing
 389                                 # function will attempt to decrement it,
 390                                 # which is incorrect in a response. Finally
 391                                 # we set request_mac to the previous digest.
 392                                 $packet->{"compnames"} = {}
 393                                         if ($Net::DNS::VERSION < 0.70);
 394                                 $packet->{"header"}{"arcount"} += 1
 395                                         if ($Net::DNS::VERSION < 0.70);
 396                                 if (defined($prev_tsig)) {
 397                                         if ($Net::DNS::VERSION < 0.73) {
 398                                                 my $rmac = pack('n H*',
 399                                                         length($prev_tsig->mac)/2,
 400                                                         $prev_tsig->mac);
 401                                                 $tsig->{"request_mac"} =
 402                                                         unpack("H*", $rmac);
 403                                         } elsif ($Net::DNS::VERSION < 0.81) {
 404                                                 $tsig->request_mac(
 405                                                          $prev_tsig->mac);
 406                                         }
 407                                 }
 408
 409                                 $tsig->sign_func($signer) if defined($signer);
 410                                 $tsig->continuation($continuation) if
 411                                          ($Net::DNS::VERSION >= 0.71 &&
 412                                           $Net::DNS::VERSION <= 0.74 );
 413                                 if ($Net::DNS::VERSION < 0.81) {
 414                                         $packet->sign_tsig($tsig);
 415                                 } elsif ($continuation) {
 416                                         $opaque = $packet->sign_tsig($opaque);
 417                                 } else {
 418                                         $opaque = $packet->sign_tsig($request);
 419                                 }
 420                                 $signer = \&sign_tcp_continuation
 421                                         if ($Net::DNS::VERSION < 0.70);
 422                                 $continuation = 1;
 423
 424                                 my $copy =
 425                                         Net::DNS::Packet->new(\($packet->data));
 426                                 $prev_tsig = $copy->pop("additional");
 427                         }
 428                         #$packet->print;
 429                         push(@results,$packet->data);
 430                         $packet = new Net::DNS::Packet($qname, $qtype, $qclass);
 431                         $packet->header->qr(1);
 432                         $packet->header->aa(1);
 433                         $packet->header->id($id);
 434                 }
 435         }
 436         print " A total of $count_these patterns matched\n";
 437         return \@results;
 438 }
 439
 440 # Main
 441 my $rin;
 442 my $rout;
 443 for (;;) {
 444         $rin = '';
 445         vec($rin, fileno($ctlsock), 1) = 1;
 446         vec($rin, fileno($tcpsock), 1) = 1;
 447         vec($rin, fileno($udpsock), 1) = 1;
 448
 449         select($rout = $rin, undef, undef, undef);
 450
 451         if (vec($rout, fileno($ctlsock), 1)) {
 452                 warn "ctl conn";
 453                 my $conn = $ctlsock->accept;
 454                 my $rule = ();
 455                 @rules = ();
 456                 while (my $line = $conn->getline) {
 457                         chomp $line;
 458                         if ($line =~ m!^/(.*)/$!) {
 459                                 $rule = { pattern => $1, answer => [] };
 460                                 push(@rules, $rule);
 461                         } else {
 462                                 push(@{$rule->{answer}},
 463                                      new Net::DNS::RR($line));
 464                         }
 465                 }
 466                 $conn->close;
 467                 #print Dumper(@rules);
 468                 #print "+=+=+ $rules[0]->{'pattern'}\n";
 469                 #print "+=+=+ $rules[0]->{'answer'}->[0]->{'rname'}\n";
 470                 #print "+=+=+ $rules[0]->{'answer'}->[0]\n";
 471         } elsif (vec($rout, fileno($udpsock), 1)) {
 472                 printf "UDP request\n";
 473                 my $buf;
 474                 $udpsock->recv($buf, 512);
 475                 my $result = handleUDP($buf);
 476                 my $num_chars = $udpsock->send($result);
 477                 print "  Sent $num_chars bytes via UDP\n";
 478         } elsif (vec($rout, fileno($tcpsock), 1)) {
 479                 my $conn = $tcpsock->accept;
 480                 my $buf;
 481                 for (;;) {
 482                         my $lenbuf;
 483                         my $n = $conn->sysread($lenbuf, 2);
 484                         last unless $n == 2;
 485                         my $len = unpack("n", $lenbuf);
 486                         $n = $conn->sysread($buf, $len);
 487                         last unless $n == $len;
 488                         print "TCP request\n";
 489                         my $result = handleTCP($buf);
 490                         foreach my $response (@$result) {
 491                                 $len = length($response);
 492                                 $n = $conn->syswrite(pack("n", $len), 2);
 493                                 $n = $conn->syswrite($response, $len);
 494                                 print "    Sent: $n chars via TCP\n";
 495                         }
 496                 }
 497                 $conn->close;
 498         }
 499 }