861 lines
26 KiB
Perl
861 lines
26 KiB
Perl
package Net::DNS::Nameserver;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
our $VERSION = (qw$Id: Nameserver.pm 1813 2020-10-08 21:58:40Z willem $)[2];
|
|
|
|
|
|
=head1 NAME
|
|
|
|
Net::DNS::Nameserver - DNS server class
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Net::DNS::Nameserver;
|
|
|
|
my $nameserver = Net::DNS::Nameserver->new(
|
|
LocalAddr => ['::1' , '127.0.0.1'],
|
|
ZoneFile => "filename"
|
|
);
|
|
|
|
my $nameserver = Net::DNS::Nameserver->new(
|
|
LocalAddr => '10.1.2.3',
|
|
LocalPort => 53,
|
|
ReplyHandler => \&reply_handler
|
|
);
|
|
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Net::DNS::Nameserver offers a simple mechanism for instantiation of
|
|
customised DNS server objects intended to provide test responses to
|
|
queries emanating from a client resolver.
|
|
|
|
It is not, nor will it ever be, a general-purpose DNS nameserver
|
|
implementation.
|
|
|
|
See L</EXAMPLE> for an example.
|
|
|
|
=cut
|
|
|
|
use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.38; 1;'; ## no critic
|
|
require IO::Socket::INET unless USE_SOCKET_IP;
|
|
|
|
use integer;
|
|
use Carp;
|
|
use Net::DNS;
|
|
use Net::DNS::ZoneFile;
|
|
|
|
use IO::Socket;
|
|
use IO::Select;
|
|
|
|
use constant FORCE_IPv4 => 0;
|
|
|
|
use constant DEFAULT_ADDR => qw(::1 127.0.0.1);
|
|
use constant DEFAULT_PORT => 5353;
|
|
|
|
use constant STATE_ACCEPTED => 1;
|
|
use constant STATE_GOT_LENGTH => 2;
|
|
use constant STATE_SENDING => 3;
|
|
|
|
use constant PACKETSZ => 512;
|
|
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Constructor.
|
|
#------------------------------------------------------------------------------
|
|
|
|
sub new {
|
|
my ( $class, %self ) = @_;
|
|
my $self = bless \%self, $class;
|
|
if ( !exists $self{ReplyHandler} ) {
|
|
if ( my $handler = UNIVERSAL::can( $class, "ReplyHandler" ) ) {
|
|
$self{ReplyHandler} = sub { $handler->( $self, @_ ); };
|
|
}
|
|
}
|
|
croak 'No reply handler!' unless ref( $self{ReplyHandler} ) eq "CODE";
|
|
|
|
$self->ReadZoneFile( $self{ZoneFile} ) if exists $self{ZoneFile};
|
|
|
|
# local server addresses must also be accepted by a resolver
|
|
my $LocalAddr = $self{LocalAddr} || [DEFAULT_ADDR];
|
|
my $resolver = Net::DNS::Resolver->new( nameservers => $LocalAddr );
|
|
$resolver->force_v4(1) unless USE_SOCKET_IP;
|
|
$resolver->force_v4(1) if FORCE_IPv4;
|
|
my @localaddresses = $resolver->nameservers;
|
|
|
|
my $port = $self{LocalPort} || DEFAULT_PORT;
|
|
$self{Truncate} = 1 unless defined( $self{Truncate} );
|
|
$self{IdleTimeout} = 120 unless defined( $self{IdleTimeout} );
|
|
|
|
my @sock_tcp; # All the TCP sockets we will listen to.
|
|
my @sock_udp; # All the UDP sockets we will listen to.
|
|
|
|
# while we are here, print incomplete lines as they come along.
|
|
local $| = 1 if $self{Verbose};
|
|
|
|
foreach my $addr (@localaddresses) {
|
|
|
|
#--------------------------------------------------------------------------
|
|
# Create the TCP socket.
|
|
#--------------------------------------------------------------------------
|
|
|
|
print "\nCreating TCP socket $addr#$port - " if $self{Verbose};
|
|
|
|
my $sock_tcp = inet_new(
|
|
LocalAddr => $addr,
|
|
LocalPort => $port,
|
|
Listen => 64,
|
|
Proto => "tcp",
|
|
Reuse => 1,
|
|
Blocking => 0,
|
|
);
|
|
if ($sock_tcp) {
|
|
push @sock_tcp, $sock_tcp;
|
|
print "done.\n" if $self{Verbose};
|
|
} else {
|
|
carp "Couldn't create TCP socket: $!";
|
|
}
|
|
|
|
#--------------------------------------------------------------------------
|
|
# Create the UDP Socket.
|
|
#--------------------------------------------------------------------------
|
|
|
|
print "Creating UDP socket $addr#$port - " if $self{Verbose};
|
|
|
|
my $sock_udp = inet_new(
|
|
LocalAddr => $addr,
|
|
LocalPort => $port,
|
|
Proto => "udp",
|
|
);
|
|
|
|
if ($sock_udp) {
|
|
push @sock_udp, $sock_udp;
|
|
print "done.\n" if $self{Verbose};
|
|
} else {
|
|
carp "Couldn't create UDP socket: $!";
|
|
}
|
|
|
|
}
|
|
|
|
#--------------------------------------------------------------------------
|
|
# Create the Select object.
|
|
#--------------------------------------------------------------------------
|
|
|
|
my $select = $self{select} = IO::Select->new;
|
|
|
|
$select->add(@sock_tcp);
|
|
$select->add(@sock_udp);
|
|
|
|
return unless $select->count;
|
|
|
|
#--------------------------------------------------------------------------
|
|
# Return the object.
|
|
#--------------------------------------------------------------------------
|
|
|
|
return $self;
|
|
}
|
|
|
|
|
|
#------------------------------------------------------------------------------
|
|
# ReadZoneFile - Read zone file used by default reply handler
|
|
#------------------------------------------------------------------------------
|
|
|
|
sub ReadZoneFile {
|
|
my ( $self, $file ) = @_;
|
|
my $zonefile = Net::DNS::ZoneFile->new($file);
|
|
|
|
my $RRhash = $self->{RRhash} = {};
|
|
my $RRlist = [];
|
|
while ( my $rr = $zonefile->read ) {
|
|
my ($leaf) = $rr->{owner}->label;
|
|
push @{$RRhash->{lc $leaf}}, $rr;
|
|
|
|
# Warning: Nasty trick abusing SOA to reference zone RR list
|
|
if ( $rr->type eq 'SOA' ) { $RRlist = $rr->{RRlist} = [] }
|
|
else { push @$RRlist, $rr }
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
#------------------------------------------------------------------------------
|
|
# ReplyHandler - Default reply handler serving RRs from zone file
|
|
#------------------------------------------------------------------------------
|
|
|
|
sub ReplyHandler {
|
|
my ( $self, $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_;
|
|
my $opcode = $query->header->opcode;
|
|
my $rcode = 'NOERROR';
|
|
my @ans;
|
|
|
|
my $lcase = lc $qname; # assume $qclass always 'IN'
|
|
my ( $leaf, @tail ) = split /\./, $lcase;
|
|
my $RRhash = $self->{RRhash};
|
|
my $RRlist = $RRhash->{$leaf} || []; # hash, then linear search
|
|
my @match = grep { lc( $_->owner ) eq $lcase } @$RRlist;
|
|
|
|
if ( $qtype eq 'AXFR' ) {
|
|
my ($soa) = grep { $_->type eq 'SOA' } @match;
|
|
if ($soa) { push @ans, $soa, @{$soa->{RRlist}}, $soa }
|
|
else { $rcode = 'NOTAUTH' }
|
|
|
|
} else {
|
|
unless ( scalar(@match) ) {
|
|
my $wildcard = join '.', '*', @tail;
|
|
my $wildlist = $RRhash->{'*'} || [];
|
|
foreach ( grep { lc( $_->owner ) eq $wildcard } @$wildlist ) {
|
|
my $clone = bless {%$_}, ref($_);
|
|
$clone->owner($qname);
|
|
push @match, $clone;
|
|
}
|
|
$rcode = 'NXDOMAIN' unless @match;
|
|
}
|
|
@ans = grep { $_->type eq $qtype } @match;
|
|
}
|
|
|
|
return ( $rcode, \@ans, [], [], {aa => 1}, {} );
|
|
}
|
|
|
|
|
|
#------------------------------------------------------------------------------
|
|
# inet_new - Calls the constructor in the correct module for making sockets.
|
|
#------------------------------------------------------------------------------
|
|
|
|
sub inet_new {
|
|
return USE_SOCKET_IP ? IO::Socket::IP->new(@_) : IO::Socket::INET->new(@_);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# make_reply - Make a reply packet.
|
|
#------------------------------------------------------------------------------
|
|
|
|
sub make_reply {
|
|
my ( $self, $query, $peerhost, $conn ) = @_;
|
|
|
|
unless ($query) {
|
|
print "ERROR: invalid packet\n" if $self->{Verbose};
|
|
my $empty = Net::DNS::Packet->new(); # create empty reply packet
|
|
my $reply = $empty->reply();
|
|
$reply->header->rcode("FORMERR");
|
|
return $reply;
|
|
}
|
|
|
|
if ( $query->header->qr() ) {
|
|
print "ERROR: invalid packet (qr set), dropping\n" if $self->{Verbose};
|
|
return;
|
|
}
|
|
|
|
my $reply = $query->reply();
|
|
my $header = $reply->header;
|
|
my $headermask;
|
|
my $optionmask;
|
|
|
|
my $opcode = $query->header->opcode;
|
|
my $qdcount = $query->header->qdcount;
|
|
|
|
unless ($qdcount) {
|
|
$header->rcode("NOERROR");
|
|
|
|
} elsif ( $qdcount > 1 ) {
|
|
print "ERROR: qdcount $qdcount unsupported\n" if $self->{Verbose};
|
|
$header->rcode("FORMERR");
|
|
|
|
} else {
|
|
my ($qr) = $query->question;
|
|
my $qname = $qr->qname;
|
|
my $qtype = $qr->qtype;
|
|
my $qclass = $qr->qclass;
|
|
|
|
my $id = $query->header->id;
|
|
print "query $id : $qname $qclass $qtype\n" if $self->{Verbose};
|
|
|
|
my ( $rcode, $ans, $auth, $add );
|
|
my @arglist = ( $qname, $qclass, $qtype, $peerhost, $query, $conn );
|
|
|
|
if ( $opcode eq "QUERY" ) {
|
|
( $rcode, $ans, $auth, $add, $headermask, $optionmask ) =
|
|
&{$self->{ReplyHandler}}(@arglist);
|
|
|
|
} elsif ( $opcode eq "NOTIFY" ) { #RFC1996
|
|
if ( ref $self->{NotifyHandler} eq "CODE" ) {
|
|
( $rcode, $ans, $auth, $add, $headermask, $optionmask ) =
|
|
&{$self->{NotifyHandler}}(@arglist);
|
|
} else {
|
|
$rcode = "NOTIMP";
|
|
}
|
|
|
|
} elsif ( $opcode eq "UPDATE" ) { #RFC2136
|
|
if ( ref $self->{UpdateHandler} eq "CODE" ) {
|
|
( $rcode, $ans, $auth, $add, $headermask, $optionmask ) =
|
|
&{$self->{UpdateHandler}}(@arglist);
|
|
} else {
|
|
$rcode = "NOTIMP";
|
|
}
|
|
|
|
} else {
|
|
print "ERROR: opcode $opcode unsupported\n" if $self->{Verbose};
|
|
$rcode = "FORMERR";
|
|
}
|
|
|
|
if ( !defined($rcode) ) {
|
|
print "remaining silent\n" if $self->{Verbose};
|
|
return;
|
|
}
|
|
|
|
$header->rcode($rcode);
|
|
|
|
$reply->{answer} = [@$ans] if $ans;
|
|
$reply->{authority} = [@$auth] if $auth;
|
|
$reply->{additional} = [@$add] if $add;
|
|
}
|
|
|
|
while ( my ( $key, $value ) = each %{$headermask || {}} ) {
|
|
$header->$key($value);
|
|
}
|
|
|
|
while ( my ( $option, $value ) = each %{$optionmask || {}} ) {
|
|
$reply->edns->option( $option, $value );
|
|
}
|
|
|
|
$header->print if $self->{Verbose} && ( $headermask || $optionmask );
|
|
|
|
return $reply;
|
|
}
|
|
|
|
|
|
#------------------------------------------------------------------------------
|
|
# readfromtcp - read from a TCP client
|
|
#------------------------------------------------------------------------------
|
|
|
|
sub readfromtcp {
|
|
my ( $self, $sock ) = @_;
|
|
return -1 unless defined $self->{_tcp}{$sock};
|
|
my $peer = $self->{_tcp}{$sock}{peer};
|
|
my $buf;
|
|
my $charsread = $sock->sysread( $buf, 16384 );
|
|
$self->{_tcp}{$sock}{inbuffer} .= $buf;
|
|
$self->{_tcp}{$sock}{timeout} = time() + $self->{IdleTimeout}; # Reset idle timer
|
|
print "Received $charsread octets from $peer\n" if $self->{Verbose};
|
|
|
|
if ( $charsread == 0 ) { # 0 octets means socket has closed
|
|
print "Connection to $peer closed or lost.\n" if $self->{Verbose};
|
|
$self->{select}->remove($sock);
|
|
$sock->close();
|
|
delete $self->{_tcp}{$sock};
|
|
return $charsread;
|
|
}
|
|
return $charsread;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# tcp_connection - Handle a TCP connection.
|
|
#------------------------------------------------------------------------------
|
|
|
|
sub tcp_connection {
|
|
my ( $self, $sock ) = @_;
|
|
|
|
if ( not $self->{_tcp}{$sock} ) {
|
|
|
|
# We go here if we are called with a listener socket.
|
|
my $client = $sock->accept;
|
|
if ( not defined $client ) {
|
|
print "TCP connection closed by peer before we could accept it.\n" if $self->{Verbose};
|
|
return 0;
|
|
}
|
|
my $peerport = $client->peerport;
|
|
my $peerhost = $client->peerhost;
|
|
|
|
print "TCP connection from $peerhost:$peerport\n" if $self->{Verbose};
|
|
$client->blocking(0);
|
|
$self->{_tcp}{$client}{peer} = "tcp:" . $peerhost . ":" . $peerport;
|
|
$self->{_tcp}{$client}{state} = STATE_ACCEPTED;
|
|
$self->{_tcp}{$client}{socket} = $client;
|
|
$self->{_tcp}{$client}{timeout} = time() + $self->{IdleTimeout};
|
|
$self->{select}->add($client);
|
|
|
|
# After we accepted we will look at the socket again
|
|
# to see if there is any data there. ---Olaf
|
|
$self->loop_once(0);
|
|
} else {
|
|
|
|
# We go here if we are called with a client socket
|
|
my $peer = $self->{_tcp}{$sock}{peer};
|
|
|
|
if ( $self->{_tcp}{$sock}{state} == STATE_ACCEPTED ) {
|
|
if ( not $self->{_tcp}{$sock}{inbuffer} =~ s/^(..)//s ) {
|
|
return; # Still not 2 octets ready
|
|
}
|
|
my $msglen = unpack( "n", $1 );
|
|
print "$peer said his query contains $msglen octets\n" if $self->{Verbose};
|
|
$self->{_tcp}{$sock}{state} = STATE_GOT_LENGTH;
|
|
$self->{_tcp}{$sock}{querylength} = $msglen;
|
|
}
|
|
|
|
# Not elsif, because we might already have all the data
|
|
if ( $self->{_tcp}{$sock}{state} == STATE_GOT_LENGTH ) {
|
|
|
|
# return if not all data has been received yet.
|
|
return if $self->{_tcp}{$sock}{querylength} > length $self->{_tcp}{$sock}{inbuffer};
|
|
|
|
my $qbuf = substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} );
|
|
substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} ) = "";
|
|
my $query = Net::DNS::Packet->new( \$qbuf );
|
|
if ( my $err = $@ ) {
|
|
print "Error decoding query packet: $err\n" if $self->{Verbose};
|
|
undef $query; # force FORMERR reply
|
|
}
|
|
my $conn = {
|
|
sockhost => $sock->sockhost,
|
|
sockport => $sock->sockport,
|
|
peerhost => $sock->peerhost,
|
|
peerport => $sock->peerport
|
|
};
|
|
my $reply = $self->make_reply( $query, $sock->peerhost, $conn );
|
|
if ( not defined $reply ) {
|
|
print "I couldn't create a reply for $peer. Closing socket.\n"
|
|
if $self->{Verbose};
|
|
$self->{select}->remove($sock);
|
|
$sock->close();
|
|
delete $self->{_tcp}{$sock};
|
|
return;
|
|
}
|
|
my $reply_data = $reply->data(65535); # limit to one TCP envelope
|
|
warn "multi-packet TCP response not implemented" if $reply->header->tc;
|
|
my $len = length $reply_data;
|
|
$self->{_tcp}{$sock}{outbuffer} = pack( 'n a*', $len, $reply_data );
|
|
print "Queued TCP response (2 + $len octets) to $peer\n"
|
|
if $self->{Verbose};
|
|
|
|
# We are done.
|
|
$self->{_tcp}{$sock}{state} = STATE_SENDING;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# udp_connection - Handle a UDP connection.
|
|
#------------------------------------------------------------------------------
|
|
|
|
sub udp_connection {
|
|
my ( $self, $sock ) = @_;
|
|
|
|
my $buf = "";
|
|
|
|
$sock->recv( $buf, PACKETSZ );
|
|
my ( $peerhost, $peerport, $sockhost ) = ( $sock->peerhost, $sock->peerport, $sock->sockhost );
|
|
unless ( defined $peerhost && defined $peerport ) {
|
|
print "the Peer host and sock host appear to be undefined: bailing out of handling the UDP connection"
|
|
if $self->{Verbose};
|
|
return;
|
|
}
|
|
|
|
|
|
print "UDP connection from $peerhost:$peerport to $sockhost\n" if $self->{Verbose};
|
|
|
|
my $query = Net::DNS::Packet->new( \$buf );
|
|
if ( my $err = $@ ) {
|
|
print "Error decoding query packet: $err\n" if $self->{Verbose};
|
|
undef $query; # force FORMERR reply
|
|
}
|
|
my $conn = {
|
|
sockhost => $sock->sockhost,
|
|
sockport => $sock->sockport,
|
|
peerhost => $sock->peerhost,
|
|
peerport => $sock->peerport
|
|
};
|
|
my $reply = $self->make_reply( $query, $peerhost, $conn ) || return;
|
|
|
|
my $max_len = ( $query && $self->{Truncate} ) ? $query->edns->size : undef;
|
|
if ( $self->{Verbose} ) {
|
|
local $| = 1;
|
|
print "Maximum UDP size advertised by $peerhost#$peerport: $max_len\n" if $max_len;
|
|
print "Writing response - ";
|
|
print $sock->send( $reply->data($max_len) ) ? "done" : "failed: $!", "\n";
|
|
|
|
} else {
|
|
$sock->send( $reply->data($max_len) );
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
sub get_open_tcp {
|
|
my $self = shift;
|
|
return keys %{$self->{_tcp}};
|
|
}
|
|
|
|
|
|
#------------------------------------------------------------------------------
|
|
# loop_once - Just check "once" on sockets already set up
|
|
#------------------------------------------------------------------------------
|
|
|
|
# This function might not actually return immediately. If an AXFR request is
|
|
# coming in which will generate a huge reply, we will not relinquish control
|
|
# until our outbuffers are empty.
|
|
|
|
#
|
|
# NB this method may be subject to change and is therefore left 'undocumented'
|
|
#
|
|
|
|
sub loop_once {
|
|
my ( $self, $timeout ) = @_;
|
|
|
|
print ";loop_once called with timeout: " . ( defined($timeout) ? $timeout : "undefined" ) . "\n"
|
|
if $self->{Verbose} && $self->{Verbose} > 4;
|
|
foreach my $sock ( keys %{$self->{_tcp}} ) {
|
|
|
|
# There is TCP traffic to handle
|
|
$timeout = 0.1 if $self->{_tcp}{$sock}{outbuffer};
|
|
}
|
|
my @ready = $self->{select}->can_read($timeout);
|
|
|
|
foreach my $sock (@ready) {
|
|
my $protonum = $sock->protocol;
|
|
|
|
# This is a weird and nasty hack. Although not incorrect,
|
|
# I just don't know why ->protocol won't tell me the protocol
|
|
# on a connected socket. --robert
|
|
$protonum = getprotobyname('tcp') if not defined $protonum and $self->{_tcp}{$sock};
|
|
|
|
my $proto = getprotobynumber($protonum);
|
|
if ( !$proto ) {
|
|
print "ERROR: connection with unknown protocol\n"
|
|
if $self->{Verbose};
|
|
} elsif ( lc($proto) eq "tcp" ) {
|
|
|
|
$self->readfromtcp($sock)
|
|
&& $self->tcp_connection($sock);
|
|
} elsif ( lc($proto) eq "udp" ) {
|
|
$self->udp_connection($sock);
|
|
} else {
|
|
print "ERROR: connection with unsupported protocol $proto\n"
|
|
if $self->{Verbose};
|
|
}
|
|
}
|
|
my $now = time();
|
|
|
|
# Lets check if any of our TCP clients has pending actions.
|
|
# (outbuffer, timeout)
|
|
foreach my $s ( keys %{$self->{_tcp}} ) {
|
|
my $sock = $self->{_tcp}{$s}{socket};
|
|
if ( $self->{_tcp}{$s}{outbuffer} ) {
|
|
|
|
# If we have buffered output, then send as much as the OS will accept
|
|
# and wait with the rest
|
|
my $len = length $self->{_tcp}{$s}{outbuffer};
|
|
my $charssent = $sock->syswrite( $self->{_tcp}{$s}{outbuffer} ) || 0;
|
|
print "Sent $charssent of $len octets to ", $self->{_tcp}{$s}{peer}, ".\n"
|
|
if $self->{Verbose};
|
|
substr( $self->{_tcp}{$s}{outbuffer}, 0, $charssent ) = "";
|
|
if ( length $self->{_tcp}{$s}{outbuffer} == 0 ) {
|
|
delete $self->{_tcp}{$s}{outbuffer};
|
|
$self->{_tcp}{$s}{state} = STATE_ACCEPTED;
|
|
if ( length $self->{_tcp}{$s}{inbuffer} >= 2 ) {
|
|
|
|
# See if the client has send us enough data to process the
|
|
# next query.
|
|
# We do this here, because we only want to process (and buffer!!)
|
|
# a single query at a time, per client. If we allowed a STATE_SENDING
|
|
# client to have new requests processed. We could be easilier
|
|
# victims of DoS (client sending lots of queries and never reading
|
|
# from it's socket).
|
|
# Note that this does not disable serialisation on part of the
|
|
# client. The split second it should take for us to lookup the
|
|
# next query, is likely faster than the time it takes to
|
|
# send the response... well, unless it's a lot of tiny queries,
|
|
# in which case we will be generating an entire TCP packet per
|
|
# reply. --robert
|
|
$self->tcp_connection( $self->{_tcp}{$s}{socket} );
|
|
}
|
|
}
|
|
$self->{_tcp}{$s}{timeout} = time() + $self->{IdleTimeout};
|
|
} else {
|
|
|
|
# Get rid of idle clients.
|
|
my $timeout = $self->{_tcp}{$s}{timeout};
|
|
if ( $timeout - $now < 0 ) {
|
|
print $self->{_tcp}{$s}{peer}, " has been idle for too long and will be disconnected.\n"
|
|
if $self->{Verbose};
|
|
$self->{select}->remove($sock);
|
|
$sock->close();
|
|
delete $self->{_tcp}{$s};
|
|
}
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# main_loop - Main nameserver loop.
|
|
#------------------------------------------------------------------------------
|
|
|
|
sub main_loop {
|
|
my $self = shift;
|
|
|
|
while (1) {
|
|
print "Waiting for connections...\n" if $self->{Verbose};
|
|
|
|
# You really need an argument otherwise you'll be burning CPU.
|
|
$self->loop_once(10);
|
|
}
|
|
return;
|
|
}
|
|
|
|
|
|
1;
|
|
__END__
|
|
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 new
|
|
|
|
$nameserver = Net::DNS::Nameserver->new(
|
|
LocalAddr => ['::1' , '127.0.0.1'],
|
|
ZoneFile => "filename"
|
|
);
|
|
|
|
$nameserver = Net::DNS::Nameserver->new(
|
|
LocalAddr => '10.1.2.3',
|
|
LocalPort => 5353,
|
|
ReplyHandler => \&reply_handler,
|
|
Verbose => 1,
|
|
Truncate => 0
|
|
);
|
|
|
|
Returns a Net::DNS::Nameserver object, or undef if the object
|
|
could not be created.
|
|
|
|
Each instance is configured using the following optional arguments:
|
|
|
|
LocalAddr IP address on which to listen Defaults to loopback address
|
|
LocalPort Port on which to listen Defaults to 53
|
|
ZoneFile Name of file containing RRs
|
|
accessed using the default
|
|
reply-handling subroutine
|
|
ReplyHandler Reference to customised
|
|
reply-handling subroutine
|
|
NotifyHandler Reference to reply-handling
|
|
subroutine for queries with
|
|
opcode NOTIFY (RFC1996)
|
|
UpdateHandler Reference to reply-handling
|
|
subroutine for queries with
|
|
opcode UPDATE (RFC2136)
|
|
Verbose Report internal activity Defaults to 0 (off)
|
|
Truncate Truncates UDP packets that
|
|
are too big for the reply Defaults to 1 (on)
|
|
IdleTimeout TCP clients are disconnected
|
|
if they are idle longer than
|
|
this duration Defaults to 120 (secs)
|
|
|
|
The LocalAddr attribute may alternatively be specified as a list of IP
|
|
addresses to listen to.
|
|
If the IO::Socket::IP library package is available on the system
|
|
this may also include IPv6 addresses.
|
|
|
|
|
|
The ReplyHandler subroutine is passed the query name, query class,
|
|
query type and optionally an argument containing the peerhost, the
|
|
incoming query, and the name of the incoming socket (sockethost). It
|
|
must either return the response code and references to the answer,
|
|
authority, and additional sections of the response, or undef to leave
|
|
the query unanswered. Common response codes are:
|
|
|
|
NOERROR No error
|
|
FORMERR Format error
|
|
SERVFAIL Server failure
|
|
NXDOMAIN Non-existent domain (name doesn't exist)
|
|
NOTIMP Not implemented
|
|
REFUSED Query refused
|
|
|
|
For advanced usage it may also contain a headermask containing an
|
|
hashref with the settings for the C<aa>, C<ra>, and C<ad>
|
|
header bits. The argument is of the form
|
|
C<< { ad => 1, aa => 0, ra => 1 } >>.
|
|
|
|
EDNS options may be specified in a similar manner using optionmask
|
|
C<< { $optioncode => $value, $optionname => $value } >>.
|
|
|
|
|
|
See RFC 1035 and the IANA dns-parameters file for more information:
|
|
|
|
ftp://ftp.rfc-editor.org/in-notes/rfc1035.txt
|
|
http://www.isi.edu/in-notes/iana/assignments/dns-parameters
|
|
|
|
The nameserver will listen for both UDP and TCP connections. On
|
|
Unix-like systems, the program will probably have to run as root
|
|
to listen on the default port, 53. A non-privileged user should
|
|
be able to listen on ports 1024 and higher.
|
|
|
|
UDP reply truncation functionality was introduced in VERSION 830.
|
|
The size limit is determined by the EDNS0 size advertised in the query,
|
|
otherwise 512 is used.
|
|
If you want to do packet truncation yourself you should set C<Truncate>
|
|
to 0 and truncate the reply packet in the code of the ReplyHandler.
|
|
|
|
See L</EXAMPLE> for an example.
|
|
|
|
=head2 main_loop
|
|
|
|
$ns->main_loop;
|
|
|
|
Start accepting queries. Calling main_loop never returns.
|
|
|
|
|
|
=head2 loop_once
|
|
|
|
$ns->loop_once( [TIMEOUT_IN_SECONDS] );
|
|
|
|
Start accepting queries, but returns. If called without a parameter, the
|
|
call will not return until a request has been received (and replied to).
|
|
Otherwise, the parameter specifies the maximum time to wait for a request.
|
|
A zero timeout forces an immediate return if there is nothing to do.
|
|
|
|
Handling a request and replying obviously depends on the speed of
|
|
ReplyHandler. Assuming a fast ReplyHandler, loop_once should spend just a
|
|
fraction of a second, if called with a timeout value of 0.0 seconds. One
|
|
exception is when an AXFR has requested a huge amount of data that the OS
|
|
is not ready to receive in full. In that case, it will remain in a loop
|
|
(while servicing new requests) until the reply has been sent.
|
|
|
|
In case loop_once accepted a TCP connection it will immediately check if
|
|
there is data to be read from the socket. If not it will return and you
|
|
will have to call loop_once() again to check if there is any data waiting
|
|
on the socket to be processed. In most cases you will have to count on
|
|
calling "loop_once" twice.
|
|
|
|
A code fragment like:
|
|
|
|
$ns->loop_once(10);
|
|
while( $ns->get_open_tcp() ){
|
|
$ns->loop_once(0);
|
|
}
|
|
|
|
Would wait for 10 seconds for the initial connection and would then
|
|
process all TCP sockets until none is left.
|
|
|
|
|
|
=head2 get_open_tcp
|
|
|
|
In scalar context returns the number of TCP connections for which state
|
|
is maintained. In array context it returns IO::Socket objects, these could
|
|
be useful for troubleshooting but be careful using them.
|
|
|
|
|
|
=head1 EXAMPLE
|
|
|
|
The following example will listen on port 5353 and respond to all queries
|
|
for A records with the IP address 10.1.2.3. All other queries will be
|
|
answered with NXDOMAIN. Authority and additional sections are left empty.
|
|
The $peerhost variable catches the IP address of the peer host, so that
|
|
additional filtering on its basis may be applied.
|
|
|
|
#!/usr/bin/perl
|
|
|
|
use strict;
|
|
use warnings;
|
|
use Net::DNS::Nameserver;
|
|
|
|
sub reply_handler {
|
|
my ( $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_;
|
|
my ( $rcode, @ans, @auth, @add );
|
|
|
|
print "Received query from $peerhost to " . $conn->{sockhost} . "\n";
|
|
$query->print;
|
|
|
|
if ( $qtype eq "A" && $qname eq "foo.example.com" ) {
|
|
my ( $ttl, $rdata ) = ( 3600, "10.1.2.3" );
|
|
my $rr = Net::DNS::RR->new("$qname $ttl $qclass $qtype $rdata");
|
|
push @ans, $rr;
|
|
$rcode = "NOERROR";
|
|
} elsif ( $qname eq "foo.example.com" ) {
|
|
$rcode = "NOERROR";
|
|
|
|
} else {
|
|
$rcode = "NXDOMAIN";
|
|
}
|
|
|
|
# mark the answer as authoritative (by setting the 'aa' flag)
|
|
my $headermask = {aa => 1};
|
|
|
|
# specify EDNS options { option => value }
|
|
my $optionmask = {};
|
|
|
|
return ( $rcode, \@ans, \@auth, \@add, $headermask, $optionmask );
|
|
}
|
|
|
|
|
|
my $ns = Net::DNS::Nameserver->new(
|
|
LocalPort => 5353,
|
|
ReplyHandler => \&reply_handler,
|
|
Verbose => 1
|
|
) || die "couldn't create nameserver object\n";
|
|
|
|
|
|
$ns->main_loop;
|
|
|
|
|
|
=head1 BUGS
|
|
|
|
Limitations in perl 5.8.6 makes it impossible to guarantee that
|
|
replies to UDP queries from Net::DNS::Nameserver are sent from the
|
|
IP-address they were received on. This is a problem for machines with
|
|
multiple IP-addresses and causes violation of RFC2181 section 4.
|
|
Thus a UDP socket created listening to INADDR_ANY (all available
|
|
IP-addresses) will reply not necessarily with the source address being
|
|
the one to which the request was sent, but rather with the address that
|
|
the operating system chooses. This is also often called "the closest
|
|
address". This should really only be a problem on a server which has
|
|
more than one IP-address (besides localhost - any experience with IPv6
|
|
complications here, would be nice). If this is a problem for you, a
|
|
work-around would be to not listen to INADDR_ANY but to specify each
|
|
address that you want this module to listen on. A separate set of
|
|
sockets will then be created for each IP-address.
|
|
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c)2000 Michael Fuhr.
|
|
|
|
Portions Copyright (c)2002-2004 Chris Reinhardt.
|
|
|
|
Portions Copyright (c)2005 Robert Martin-Legene.
|
|
|
|
Portions Copyright (c)2005-2009 O.M, Kolkman, RIPE NCC.
|
|
|
|
Portions Copyright (c)2017 Dick Franks.
|
|
|
|
All rights reserved.
|
|
|
|
|
|
=head1 LICENSE
|
|
|
|
Permission to use, copy, modify, and distribute this software and its
|
|
documentation for any purpose and without fee is hereby granted, provided
|
|
that the above copyright notice appear in all copies and that both that
|
|
copyright notice and this permission notice appear in supporting
|
|
documentation, and that the name of the author not be used in advertising
|
|
or publicity pertaining to distribution of the software without specific
|
|
prior written permission.
|
|
|
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
|
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
|
THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
|
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
|
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
|
DEALINGS IN THE SOFTWARE.
|
|
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<perl>, L<Net::DNS>, L<Net::DNS::Resolver>, L<Net::DNS::Packet>,
|
|
L<Net::DNS::Update>, L<Net::DNS::Header>, L<Net::DNS::Question>,
|
|
L<Net::DNS::RR>, RFC 1035
|
|
|
|
=cut
|
|
|