1package Net::DNS::Nameserver; 2 3use strict; 4use warnings; 5 6our $VERSION = (qw$Id: Nameserver.pm 1841 2021-06-23 20:34:28Z willem $)[2]; 7 8 9=head1 NAME 10 11Net::DNS::Nameserver - DNS server class 12 13=head1 SYNOPSIS 14 15 use Net::DNS::Nameserver; 16 17 my $nameserver = Net::DNS::Nameserver->new( 18 LocalAddr => ['::1' , '127.0.0.1'], 19 ZoneFile => "filename" 20 ); 21 22 my $nameserver = Net::DNS::Nameserver->new( 23 LocalAddr => '10.1.2.3', 24 LocalPort => 5353, 25 ReplyHandler => \&reply_handler 26 ); 27 28 29=head1 DESCRIPTION 30 31Net::DNS::Nameserver offers a simple mechanism for instantiation of 32customised DNS server objects intended to provide test responses to 33queries emanating from a client resolver. 34 35It is not, nor will it ever be, a general-purpose DNS nameserver 36implementation. 37 38See L</EXAMPLE> for an example. 39 40=cut 41 42use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.38; 1;'; ## no critic 43require IO::Socket::INET unless USE_SOCKET_IP; 44 45use integer; 46use Carp; 47use Net::DNS; 48use Net::DNS::ZoneFile; 49 50use IO::Socket; 51use IO::Select; 52 53use constant FORCE_IPv4 => 0; 54 55use constant DEFAULT_ADDR => qw(::1 127.0.0.1); 56use constant DEFAULT_PORT => 5353; 57 58use constant STATE_ACCEPTED => 1; 59use constant STATE_GOT_LENGTH => 2; 60use constant STATE_SENDING => 3; 61 62use constant PACKETSZ => 512; 63 64 65#------------------------------------------------------------------------------ 66# Constructor. 67#------------------------------------------------------------------------------ 68 69sub new { 70 my ( $class, %self ) = @_; 71 my $self = bless \%self, $class; 72 if ( !exists $self{ReplyHandler} ) { 73 if ( my $handler = UNIVERSAL::can( $class, "ReplyHandler" ) ) { 74 $self{ReplyHandler} = sub { $handler->( $self, @_ ); }; 75 } 76 } 77 croak 'No reply handler!' unless ref( $self{ReplyHandler} ) eq "CODE"; 78 79 $self->ReadZoneFile( $self{ZoneFile} ) if exists $self{ZoneFile}; 80 81 # local server addresses must also be accepted by a resolver 82 my $LocalAddr = $self{LocalAddr} || [DEFAULT_ADDR]; 83 my $resolver = Net::DNS::Resolver->new( nameservers => $LocalAddr ); 84 $resolver->force_v4(1) unless USE_SOCKET_IP; 85 $resolver->force_v4(1) if FORCE_IPv4; 86 my @localaddresses = $resolver->nameservers; 87 88 my $port = $self{LocalPort} || DEFAULT_PORT; 89 $self{Truncate} = 1 unless defined( $self{Truncate} ); 90 $self{IdleTimeout} = 120 unless defined( $self{IdleTimeout} ); 91 92 my @sock_tcp; # All the TCP sockets we will listen to. 93 my @sock_udp; # All the UDP sockets we will listen to. 94 95 # while we are here, print incomplete lines as they come along. 96 local $| = 1 if $self{Verbose}; 97 98 foreach my $addr (@localaddresses) { 99 100 #-------------------------------------------------------------------------- 101 # Create the TCP socket. 102 #-------------------------------------------------------------------------- 103 104 print "\nCreating TCP socket $addr#$port - " if $self{Verbose}; 105 106 my $sock_tcp = inet_new( 107 LocalAddr => $addr, 108 LocalPort => $port, 109 Listen => 64, 110 Proto => "tcp", 111 Reuse => 1, 112 Blocking => 0, 113 ); 114 if ($sock_tcp) { 115 push @sock_tcp, $sock_tcp; 116 print "done.\n" if $self{Verbose}; 117 } else { 118 carp "Couldn't create TCP socket: $!"; 119 } 120 121 #-------------------------------------------------------------------------- 122 # Create the UDP Socket. 123 #-------------------------------------------------------------------------- 124 125 print "Creating UDP socket $addr#$port - " if $self{Verbose}; 126 127 my $sock_udp = inet_new( 128 LocalAddr => $addr, 129 LocalPort => $port, 130 Proto => "udp", 131 ); 132 133 if ($sock_udp) { 134 push @sock_udp, $sock_udp; 135 print "done.\n" if $self{Verbose}; 136 } else { 137 carp "Couldn't create UDP socket: $!"; 138 } 139 140 } 141 142 #-------------------------------------------------------------------------- 143 # Create the Select object. 144 #-------------------------------------------------------------------------- 145 146 my $select = $self{select} = IO::Select->new; 147 148 $select->add(@sock_tcp); 149 $select->add(@sock_udp); 150 151 return unless $select->count; 152 153 #-------------------------------------------------------------------------- 154 # Return the object. 155 #-------------------------------------------------------------------------- 156 157 return $self; 158} 159 160 161#------------------------------------------------------------------------------ 162# ReadZoneFile - Read zone file used by default reply handler 163#------------------------------------------------------------------------------ 164 165sub ReadZoneFile { 166 my ( $self, $file ) = @_; 167 my $zonefile = Net::DNS::ZoneFile->new($file); 168 169 my $RRhash = $self->{RRhash} = {}; 170 my $RRlist = []; 171 while ( my $rr = $zonefile->read ) { 172 my ($leaf) = $rr->{owner}->label; 173 push @{$RRhash->{lc $leaf}}, $rr; 174 175 # Warning: Nasty trick abusing SOA to reference zone RR list 176 if ( $rr->type eq 'SOA' ) { $RRlist = $rr->{RRlist} = [] } 177 else { push @$RRlist, $rr } 178 } 179 return; 180} 181 182 183#------------------------------------------------------------------------------ 184# ReplyHandler - Default reply handler serving RRs from zone file 185#------------------------------------------------------------------------------ 186 187sub ReplyHandler { 188 my ( $self, $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; 189 my $opcode = $query->header->opcode; 190 my $rcode = 'NOERROR'; 191 my @ans; 192 193 my $lcase = lc $qname; # assume $qclass always 'IN' 194 my ( $leaf, @tail ) = split /\./, $lcase; 195 my $RRhash = $self->{RRhash}; 196 my $RRlist = $RRhash->{$leaf} || []; # hash, then linear search 197 my @match = grep { lc( $_->owner ) eq $lcase } @$RRlist; 198 199 if ( $qtype eq 'AXFR' ) { 200 my ($soa) = grep { $_->type eq 'SOA' } @match; 201 if ($soa) { push @ans, $soa, @{$soa->{RRlist}}, $soa } 202 else { $rcode = 'NOTAUTH' } 203 204 } else { 205 unless ( scalar(@match) ) { 206 my $wildcard = join '.', '*', @tail; 207 my $wildlist = $RRhash->{'*'} || []; 208 foreach ( grep { lc( $_->owner ) eq $wildcard } @$wildlist ) { 209 my $clone = bless {%$_}, ref($_); 210 $clone->owner($qname); 211 push @match, $clone; 212 } 213 $rcode = 'NXDOMAIN' unless @match; 214 } 215 @ans = grep { $_->type eq $qtype } @match; 216 } 217 218 return ( $rcode, \@ans, [], [], {aa => 1}, {} ); 219} 220 221 222#------------------------------------------------------------------------------ 223# inet_new - Calls the constructor in the correct module for making sockets. 224#------------------------------------------------------------------------------ 225 226sub inet_new { 227 return USE_SOCKET_IP ? IO::Socket::IP->new(@_) : IO::Socket::INET->new(@_); 228} 229 230#------------------------------------------------------------------------------ 231# make_reply - Make a reply packet. 232#------------------------------------------------------------------------------ 233 234sub make_reply { 235 my ( $self, $query, $peerhost, $conn ) = @_; 236 237 unless ($query) { 238 print "ERROR: invalid packet\n" if $self->{Verbose}; 239 my $empty = Net::DNS::Packet->new(); # create empty reply packet 240 my $reply = $empty->reply(); 241 $reply->header->rcode("FORMERR"); 242 return $reply; 243 } 244 245 if ( $query->header->qr() ) { 246 print "ERROR: invalid packet (qr set), dropping\n" if $self->{Verbose}; 247 return; 248 } 249 250 my $reply = $query->reply(); 251 my $header = $reply->header; 252 my $headermask; 253 my $optionmask; 254 255 my $opcode = $query->header->opcode; 256 my $qdcount = $query->header->qdcount; 257 258 unless ($qdcount) { 259 $header->rcode("NOERROR"); 260 261 } elsif ( $qdcount > 1 ) { 262 print "ERROR: qdcount $qdcount unsupported\n" if $self->{Verbose}; 263 $header->rcode("FORMERR"); 264 265 } else { 266 my ($qr) = $query->question; 267 my $qname = $qr->qname; 268 my $qtype = $qr->qtype; 269 my $qclass = $qr->qclass; 270 271 my $id = $query->header->id; 272 print "query $id : $qname $qclass $qtype\n" if $self->{Verbose}; 273 274 my ( $rcode, $ans, $auth, $add ); 275 my @arglist = ( $qname, $qclass, $qtype, $peerhost, $query, $conn ); 276 277 if ( $opcode eq "QUERY" ) { 278 ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = 279 &{$self->{ReplyHandler}}(@arglist); 280 281 } elsif ( $opcode eq "NOTIFY" ) { #RFC1996 282 if ( ref $self->{NotifyHandler} eq "CODE" ) { 283 ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = 284 &{$self->{NotifyHandler}}(@arglist); 285 } else { 286 $rcode = "NOTIMP"; 287 } 288 289 } elsif ( $opcode eq "UPDATE" ) { #RFC2136 290 if ( ref $self->{UpdateHandler} eq "CODE" ) { 291 ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = 292 &{$self->{UpdateHandler}}(@arglist); 293 } else { 294 $rcode = "NOTIMP"; 295 } 296 297 } else { 298 print "ERROR: opcode $opcode unsupported\n" if $self->{Verbose}; 299 $rcode = "FORMERR"; 300 } 301 302 if ( !defined($rcode) ) { 303 print "remaining silent\n" if $self->{Verbose}; 304 return; 305 } 306 307 $header->rcode($rcode); 308 309 $reply->{answer} = [@$ans] if $ans; 310 $reply->{authority} = [@$auth] if $auth; 311 $reply->{additional} = [@$add] if $add; 312 } 313 314 while ( my ( $key, $value ) = each %{$headermask || {}} ) { 315 $header->$key($value); 316 } 317 318 while ( my ( $option, $value ) = each %{$optionmask || {}} ) { 319 $reply->edns->option( $option, $value ); 320 } 321 322 $header->print if $self->{Verbose} && ( $headermask || $optionmask ); 323 324 return $reply; 325} 326 327 328#------------------------------------------------------------------------------ 329# readfromtcp - read from a TCP client 330#------------------------------------------------------------------------------ 331 332sub readfromtcp { 333 my ( $self, $sock ) = @_; 334 return -1 unless defined $self->{_tcp}{$sock}; 335 my $peer = $self->{_tcp}{$sock}{peer}; 336 my $buf; 337 my $charsread = $sock->sysread( $buf, 16384 ); 338 $self->{_tcp}{$sock}{inbuffer} .= $buf; 339 $self->{_tcp}{$sock}{timeout} = time() + $self->{IdleTimeout}; # Reset idle timer 340 print "Received $charsread octets from $peer\n" if $self->{Verbose}; 341 342 if ( $charsread == 0 ) { # 0 octets means socket has closed 343 print "Connection to $peer closed or lost.\n" if $self->{Verbose}; 344 $self->{select}->remove($sock); 345 $sock->close(); 346 delete $self->{_tcp}{$sock}; 347 return $charsread; 348 } 349 return $charsread; 350} 351 352#------------------------------------------------------------------------------ 353# tcp_connection - Handle a TCP connection. 354#------------------------------------------------------------------------------ 355 356sub tcp_connection { 357 my ( $self, $sock ) = @_; 358 359 if ( not $self->{_tcp}{$sock} ) { 360 361 # We go here if we are called with a listener socket. 362 my $client = $sock->accept; 363 if ( not defined $client ) { 364 print "TCP connection closed by peer before we could accept it.\n" if $self->{Verbose}; 365 return 0; 366 } 367 my $peerport = $client->peerport; 368 my $peerhost = $client->peerhost; 369 370 print "TCP connection from $peerhost:$peerport\n" if $self->{Verbose}; 371 $client->blocking(0); 372 $self->{_tcp}{$client}{peer} = "tcp:" . $peerhost . ":" . $peerport; 373 $self->{_tcp}{$client}{state} = STATE_ACCEPTED; 374 $self->{_tcp}{$client}{socket} = $client; 375 $self->{_tcp}{$client}{timeout} = time() + $self->{IdleTimeout}; 376 $self->{select}->add($client); 377 378 # After we accepted we will look at the socket again 379 # to see if there is any data there. ---Olaf 380 $self->loop_once(0); 381 } else { 382 383 # We go here if we are called with a client socket 384 my $peer = $self->{_tcp}{$sock}{peer}; 385 386 if ( $self->{_tcp}{$sock}{state} == STATE_ACCEPTED ) { 387 if ( not $self->{_tcp}{$sock}{inbuffer} =~ s/^(..)//s ) { 388 return; # Still not 2 octets ready 389 } 390 my $msglen = unpack( "n", $1 ); 391 print "$peer said his query contains $msglen octets\n" if $self->{Verbose}; 392 $self->{_tcp}{$sock}{state} = STATE_GOT_LENGTH; 393 $self->{_tcp}{$sock}{querylength} = $msglen; 394 } 395 396 # Not elsif, because we might already have all the data 397 if ( $self->{_tcp}{$sock}{state} == STATE_GOT_LENGTH ) { 398 399 # return if not all data has been received yet. 400 return if $self->{_tcp}{$sock}{querylength} > length $self->{_tcp}{$sock}{inbuffer}; 401 402 my $qbuf = substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} ); 403 substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} ) = ""; 404 my $query = Net::DNS::Packet->new( \$qbuf ); 405 if ( my $err = $@ ) { 406 print "Error decoding query packet: $err\n" if $self->{Verbose}; 407 undef $query; # force FORMERR reply 408 } 409 my $conn = { 410 sockhost => $sock->sockhost, 411 sockport => $sock->sockport, 412 peerhost => $sock->peerhost, 413 peerport => $sock->peerport 414 }; 415 my $reply = $self->make_reply( $query, $sock->peerhost, $conn ); 416 if ( not defined $reply ) { 417 print "I couldn't create a reply for $peer. Closing socket.\n" 418 if $self->{Verbose}; 419 $self->{select}->remove($sock); 420 $sock->close(); 421 delete $self->{_tcp}{$sock}; 422 return; 423 } 424 my $reply_data = $reply->data(65535); # limit to one TCP envelope 425 warn "multi-packet TCP response not implemented" if $reply->header->tc; 426 my $len = length $reply_data; 427 $self->{_tcp}{$sock}{outbuffer} = pack( 'n a*', $len, $reply_data ); 428 print "Queued TCP response (2 + $len octets) to $peer\n" 429 if $self->{Verbose}; 430 431 # We are done. 432 $self->{_tcp}{$sock}{state} = STATE_SENDING; 433 } 434 } 435 return; 436} 437 438#------------------------------------------------------------------------------ 439# udp_connection - Handle a UDP connection. 440#------------------------------------------------------------------------------ 441 442sub udp_connection { 443 my ( $self, $sock ) = @_; 444 445 my $buf = ""; 446 447 $sock->recv( $buf, PACKETSZ ); 448 my ( $peerhost, $peerport, $sockhost ) = ( $sock->peerhost, $sock->peerport, $sock->sockhost ); 449 unless ( defined $peerhost && defined $peerport ) { 450 print "the Peer host and sock host appear to be undefined: bailing out of handling the UDP connection" 451 if $self->{Verbose}; 452 return; 453 } 454 455 456 print "UDP connection from $peerhost:$peerport to $sockhost\n" if $self->{Verbose}; 457 458 my $query = Net::DNS::Packet->new( \$buf ); 459 if ( my $err = $@ ) { 460 print "Error decoding query packet: $err\n" if $self->{Verbose}; 461 undef $query; # force FORMERR reply 462 } 463 my $conn = { 464 sockhost => $sock->sockhost, 465 sockport => $sock->sockport, 466 peerhost => $sock->peerhost, 467 peerport => $sock->peerport 468 }; 469 my $reply = $self->make_reply( $query, $peerhost, $conn ) || return; 470 471 my $max_len = ( $query && $self->{Truncate} ) ? $query->edns->size : undef; 472 if ( $self->{Verbose} ) { 473 local $| = 1; 474 print "Maximum UDP size advertised by $peerhost#$peerport: $max_len\n" if $max_len; 475 print "Writing response - "; 476 print $sock->send( $reply->data($max_len) ) ? "done" : "failed: $!", "\n"; 477 478 } else { 479 $sock->send( $reply->data($max_len) ); 480 } 481 return; 482} 483 484 485sub get_open_tcp { 486 my $self = shift; 487 return keys %{$self->{_tcp}}; 488} 489 490 491#------------------------------------------------------------------------------ 492# loop_once - Just check "once" on sockets already set up 493#------------------------------------------------------------------------------ 494 495# This function might not actually return immediately. If an AXFR request is 496# coming in which will generate a huge reply, we will not relinquish control 497# until our outbuffers are empty. 498 499# 500# NB this method may be subject to change and is therefore left 'undocumented' 501# 502 503sub loop_once { 504 my ( $self, $timeout ) = @_; 505 506 print ";loop_once called with timeout: " . ( defined($timeout) ? $timeout : "undefined" ) . "\n" 507 if $self->{Verbose} && $self->{Verbose} > 4; 508 foreach my $sock ( keys %{$self->{_tcp}} ) { 509 510 # There is TCP traffic to handle 511 $timeout = 0.1 if $self->{_tcp}{$sock}{outbuffer}; 512 } 513 my @ready = $self->{select}->can_read($timeout); 514 515 foreach my $sock (@ready) { 516 my $protonum = $sock->protocol; 517 518 # This is a weird and nasty hack. Although not incorrect, 519 # I just don't know why ->protocol won't tell me the protocol 520 # on a connected socket. --robert 521 $protonum = getprotobyname('tcp') if not defined $protonum and $self->{_tcp}{$sock}; 522 523 my $proto = getprotobynumber($protonum); 524 if ( !$proto ) { 525 print "ERROR: connection with unknown protocol\n" 526 if $self->{Verbose}; 527 } elsif ( lc($proto) eq "tcp" ) { 528 529 $self->readfromtcp($sock) 530 && $self->tcp_connection($sock); 531 } elsif ( lc($proto) eq "udp" ) { 532 $self->udp_connection($sock); 533 } else { 534 print "ERROR: connection with unsupported protocol $proto\n" 535 if $self->{Verbose}; 536 } 537 } 538 my $now = time(); 539 540 # Lets check if any of our TCP clients has pending actions. 541 # (outbuffer, timeout) 542 foreach my $s ( keys %{$self->{_tcp}} ) { 543 my $sock = $self->{_tcp}{$s}{socket}; 544 if ( $self->{_tcp}{$s}{outbuffer} ) { 545 546 # If we have buffered output, then send as much as the OS will accept 547 # and wait with the rest 548 my $len = length $self->{_tcp}{$s}{outbuffer}; 549 my $charssent = $sock->syswrite( $self->{_tcp}{$s}{outbuffer} ) || 0; 550 print "Sent $charssent of $len octets to ", $self->{_tcp}{$s}{peer}, ".\n" 551 if $self->{Verbose}; 552 substr( $self->{_tcp}{$s}{outbuffer}, 0, $charssent ) = ""; 553 if ( length $self->{_tcp}{$s}{outbuffer} == 0 ) { 554 delete $self->{_tcp}{$s}{outbuffer}; 555 $self->{_tcp}{$s}{state} = STATE_ACCEPTED; 556 if ( length $self->{_tcp}{$s}{inbuffer} >= 2 ) { 557 558 # See if the client has send us enough data to process the 559 # next query. 560 # We do this here, because we only want to process (and buffer!!) 561 # a single query at a time, per client. If we allowed a STATE_SENDING 562 # client to have new requests processed. We could be easilier 563 # victims of DoS (client sending lots of queries and never reading 564 # from it's socket). 565 # Note that this does not disable serialisation on part of the 566 # client. The split second it should take for us to lookup the 567 # next query, is likely faster than the time it takes to 568 # send the response... well, unless it's a lot of tiny queries, 569 # in which case we will be generating an entire TCP packet per 570 # reply. --robert 571 $self->tcp_connection( $self->{_tcp}{$s}{socket} ); 572 } 573 } 574 $self->{_tcp}{$s}{timeout} = time() + $self->{IdleTimeout}; 575 } else { 576 577 # Get rid of idle clients. 578 my $timeout = $self->{_tcp}{$s}{timeout}; 579 if ( $timeout - $now < 0 ) { 580 print $self->{_tcp}{$s}{peer}, " has been idle for too long and will be disconnected.\n" 581 if $self->{Verbose}; 582 $self->{select}->remove($sock); 583 $sock->close(); 584 delete $self->{_tcp}{$s}; 585 } 586 } 587 } 588 return; 589} 590 591#------------------------------------------------------------------------------ 592# main_loop - Main nameserver loop. 593#------------------------------------------------------------------------------ 594 595sub main_loop { 596 my $self = shift; 597 598 while (1) { 599 print "Waiting for connections...\n" if $self->{Verbose}; 600 601 # You really need an argument otherwise you'll be burning CPU. 602 $self->loop_once(10); 603 } 604 return; 605} 606 607 6081; 609__END__ 610 611 612=head1 METHODS 613 614=head2 new 615 616 $nameserver = Net::DNS::Nameserver->new( 617 LocalAddr => ['::1' , '127.0.0.1'], 618 ZoneFile => "filename" 619 ); 620 621 $nameserver = Net::DNS::Nameserver->new( 622 LocalAddr => '10.1.2.3', 623 LocalPort => 5353, 624 ReplyHandler => \&reply_handler, 625 Verbose => 1, 626 Truncate => 0 627 ); 628 629Returns a Net::DNS::Nameserver object, or undef if the object 630could not be created. 631 632Each instance is configured using the following optional arguments: 633 634 LocalAddr IP address on which to listen Defaults to loopback address 635 LocalPort Port on which to listen Defaults to 5353 636 ZoneFile Name of file containing RRs 637 accessed using the default 638 reply-handling subroutine 639 ReplyHandler Reference to customised 640 reply-handling subroutine 641 NotifyHandler Reference to reply-handling 642 subroutine for queries with 643 opcode NOTIFY (RFC1996) 644 UpdateHandler Reference to reply-handling 645 subroutine for queries with 646 opcode UPDATE (RFC2136) 647 Verbose Report internal activity Defaults to 0 (off) 648 Truncate Truncates UDP packets that 649 are too big for the reply Defaults to 1 (on) 650 IdleTimeout TCP clients are disconnected 651 if they are idle longer than 652 this duration Defaults to 120 (secs) 653 654The LocalAddr attribute may alternatively be specified as a list of IP 655addresses to listen to. 656If the IO::Socket::IP library package is available on the system 657this may also include IPv6 addresses. 658 659 660The ReplyHandler subroutine is passed the query name, query class, 661query type and optionally an argument containing the peerhost, the 662incoming query, and the name of the incoming socket (sockethost). It 663must either return the response code and references to the answer, 664authority, and additional sections of the response, or undef to leave 665the query unanswered. Common response codes are: 666 667 NOERROR No error 668 FORMERR Format error 669 SERVFAIL Server failure 670 NXDOMAIN Non-existent domain (name doesn't exist) 671 NOTIMP Not implemented 672 REFUSED Query refused 673 674For advanced usage it may also contain a headermask containing an 675hashref with the settings for the C<aa>, C<ra>, and C<ad> 676header bits. The argument is of the form 677C<< { ad => 1, aa => 0, ra => 1 } >>. 678 679EDNS options may be specified in a similar manner using optionmask 680C<< { $optioncode => $value, $optionname => $value } >>. 681 682 683See RFC 1035 and the IANA dns-parameters file for more information: 684 685 ftp://ftp.rfc-editor.org/in-notes/rfc1035.txt 686 http://www.isi.edu/in-notes/iana/assignments/dns-parameters 687 688The nameserver will listen for both UDP and TCP connections. 689On Unix-like systems, unprivileged users are denied access to ports below 1024. 690 691UDP reply truncation functionality was introduced in VERSION 830. 692The size limit is determined by the EDNS0 size advertised in the query, 693otherwise 512 is used. 694If you want to do packet truncation yourself you should set C<Truncate> 695to 0 and truncate the reply packet in the code of the ReplyHandler. 696 697See L</EXAMPLE> for an example. 698 699=head2 main_loop 700 701 $ns->main_loop; 702 703Start accepting queries. Calling main_loop never returns. 704 705 706=head2 loop_once 707 708 $ns->loop_once( [TIMEOUT_IN_SECONDS] ); 709 710Start accepting queries, but returns. If called without a parameter, the 711call will not return until a request has been received (and replied to). 712Otherwise, the parameter specifies the maximum time to wait for a request. 713A zero timeout forces an immediate return if there is nothing to do. 714 715Handling a request and replying obviously depends on the speed of 716ReplyHandler. Assuming a fast ReplyHandler, loop_once should spend just a 717fraction of a second, if called with a timeout value of 0.0 seconds. One 718exception is when an AXFR has requested a huge amount of data that the OS 719is not ready to receive in full. In that case, it will remain in a loop 720(while servicing new requests) until the reply has been sent. 721 722In case loop_once accepted a TCP connection it will immediately check if 723there is data to be read from the socket. If not it will return and you 724will have to call loop_once() again to check if there is any data waiting 725on the socket to be processed. In most cases you will have to count on 726calling "loop_once" twice. 727 728A code fragment like: 729 730 $ns->loop_once(10); 731 while( $ns->get_open_tcp() ){ 732 $ns->loop_once(0); 733 } 734 735Would wait for 10 seconds for the initial connection and would then 736process all TCP sockets until none is left. 737 738 739=head2 get_open_tcp 740 741In scalar context returns the number of TCP connections for which state 742is maintained. In array context it returns IO::Socket objects, these could 743be useful for troubleshooting but be careful using them. 744 745 746=head1 EXAMPLE 747 748The following example will listen on port 5353 and respond to all queries 749for A records with the IP address 10.1.2.3. All other queries will be 750answered with NXDOMAIN. Authority and additional sections are left empty. 751The $peerhost variable catches the IP address of the peer host, so that 752additional filtering on its basis may be applied. 753 754 #!/usr/bin/perl 755 756 use strict; 757 use warnings; 758 use Net::DNS::Nameserver; 759 760 sub reply_handler { 761 my ( $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; 762 my ( $rcode, @ans, @auth, @add ); 763 764 print "Received query from $peerhost to " . $conn->{sockhost} . "\n"; 765 $query->print; 766 767 if ( $qtype eq "A" && $qname eq "foo.example.com" ) { 768 my ( $ttl, $rdata ) = ( 3600, "10.1.2.3" ); 769 my $rr = Net::DNS::RR->new("$qname $ttl $qclass $qtype $rdata"); 770 push @ans, $rr; 771 $rcode = "NOERROR"; 772 } elsif ( $qname eq "foo.example.com" ) { 773 $rcode = "NOERROR"; 774 775 } else { 776 $rcode = "NXDOMAIN"; 777 } 778 779 # mark the answer as authoritative (by setting the 'aa' flag) 780 my $headermask = {aa => 1}; 781 782 # specify EDNS options { option => value } 783 my $optionmask = {}; 784 785 return ( $rcode, \@ans, \@auth, \@add, $headermask, $optionmask ); 786 } 787 788 789 my $ns = Net::DNS::Nameserver->new( 790 LocalPort => 5353, 791 ReplyHandler => \&reply_handler, 792 Verbose => 1 793 ) || die "couldn't create nameserver object\n"; 794 795 796 $ns->main_loop; 797 798 799=head1 BUGS 800 801Limitations in perl make it impossible to guarantee that replies to 802UDP queries from Net::DNS::Nameserver are sent from the IP-address 803to which the query was directed. This is a problem for machines with 804multiple IP-addresses and causes violation of RFC2181 section 4. 805Thus a UDP socket created listening to INADDR_ANY (all available 806IP-addresses) will reply not necessarily with the source address being 807the one to which the request was sent, but rather with the address that 808the operating system chooses. This is also often called "the closest 809address". This should really only be a problem on a server which has 810more than one IP-address (besides localhost - any experience with IPv6 811complications here, would be nice). If this is a problem for you, a 812work-around would be to not listen to INADDR_ANY but to specify each 813address that you want this module to listen on. A separate set of 814sockets will then be created for each IP-address. 815 816 817=head1 COPYRIGHT 818 819Copyright (c)2000 Michael Fuhr. 820 821Portions Copyright (c)2002-2004 Chris Reinhardt. 822 823Portions Copyright (c)2005 Robert Martin-Legene. 824 825Portions Copyright (c)2005-2009 O.M, Kolkman, RIPE NCC. 826 827Portions Copyright (c)2017 Dick Franks. 828 829All rights reserved. 830 831 832=head1 LICENSE 833 834Permission to use, copy, modify, and distribute this software and its 835documentation for any purpose and without fee is hereby granted, provided 836that the above copyright notice appear in all copies and that both that 837copyright notice and this permission notice appear in supporting 838documentation, and that the name of the author not be used in advertising 839or publicity pertaining to distribution of the software without specific 840prior written permission. 841 842THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 843IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 844FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 845THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 846LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 847FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 848DEALINGS IN THE SOFTWARE. 849 850 851=head1 SEE ALSO 852 853L<perl>, L<Net::DNS>, L<Net::DNS::Resolver>, L<Net::DNS::Packet>, 854L<Net::DNS::Update>, L<Net::DNS::Header>, L<Net::DNS::Question>, 855L<Net::DNS::RR>, RFC 1035 856 857=cut 858 859