home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Nameserver.pm < prev    next >
Encoding:
Perl POD Document  |  2004-01-09  |  10.8 KB  |  401 lines
  1. package Net::DNS::Nameserver;
  2. #
  3. # $Id: Nameserver.pm,v 2.101 2003/12/30 22:45:39 ctriv Exp $
  4. #
  5.  
  6. use Net::DNS;
  7. use IO::Socket;
  8. use IO::Select;
  9. use Carp qw(cluck);
  10.  
  11. use strict;
  12. use vars qw($VERSION);
  13.  
  14. $VERSION = (qw$Revision: 2.101 $)[1];
  15.  
  16. use constant DEFAULT_ADDR => INADDR_ANY;
  17. use constant DEFAULT_PORT => 53;
  18.  
  19. #------------------------------------------------------------------------------
  20. # Constructor.
  21. #------------------------------------------------------------------------------
  22.  
  23. sub new {
  24.     my ($class, %self) = @_;
  25.  
  26.     my $addr = $self{"LocalAddr"} || inet_ntoa(DEFAULT_ADDR);
  27.     my $port = $self{"LocalPort"} || DEFAULT_PORT;
  28.  
  29.     if (!$self{"ReplyHandler"} || !ref($self{"ReplyHandler"})) {
  30.         cluck "No reply handler!";
  31.         return;
  32.     }
  33.  
  34.     #--------------------------------------------------------------------------
  35.     # Create the TCP socket.
  36.     #--------------------------------------------------------------------------
  37.  
  38.     print "creating TCP socket..." if $self{"Verbose"};
  39.  
  40.     my $sock_tcp = IO::Socket::INET->new(
  41.         LocalAddr => $addr,
  42.         LocalPort => $port,
  43.         Listen      => 5,
  44.         Proto      => "tcp",
  45.         Reuse      => 1,
  46.     );
  47.  
  48.     if (!$sock_tcp) {
  49.         cluck "couldn't create TCP socket: $!";
  50.         return;
  51.     }
  52.  
  53.     print "done.\n" if $self{"Verbose"};
  54.  
  55.     #--------------------------------------------------------------------------
  56.     # Create the UDP Socket.
  57.     #--------------------------------------------------------------------------
  58.  
  59.     print "creating UDP socket..." if $self{"Verbose"};
  60.  
  61.     my $sock_udp = IO::Socket::INET->new(
  62.         LocalAddr => $addr,
  63.         LocalPort => $port,
  64.         Proto => "udp",
  65.     );
  66.  
  67.     if (!$sock_udp) {
  68.         cluck "couldn't create UDP socket: $!";
  69.         return;
  70.     }
  71.  
  72.     print "done.\n" if $self{"Verbose"};
  73.  
  74.  
  75.     #--------------------------------------------------------------------------
  76.     # Create the Select object.
  77.     #--------------------------------------------------------------------------
  78.  
  79.     $self{"select"} = IO::Select->new;
  80.     $self{"select"}->add($sock_tcp);
  81.     $self{"select"}->add($sock_udp);
  82.  
  83.     #--------------------------------------------------------------------------
  84.     # Return the object.
  85.     #--------------------------------------------------------------------------
  86.  
  87.     my $self = bless \%self, $class;
  88.     return $self;
  89. }
  90.  
  91. #------------------------------------------------------------------------------
  92. # make_reply - Make a reply packet.
  93. #------------------------------------------------------------------------------
  94.  
  95. sub make_reply {
  96.     my ($self, $query, $peerhost) = @_;
  97.     
  98.     my $reply;
  99.     my $headermask;
  100.     
  101.     if (not $query) {
  102.         print "ERROR: invalid packet\n" if $self->{"Verbose"};
  103.         $reply = Net::DNS::Packet->new("", "ANY", "ANY");
  104.         $reply->header->rcode("FORMERR");
  105.         
  106.         return $reply;
  107.     }
  108.     
  109.     if ($query->header->qr()) {
  110.         print "ERROR: invalid packet (qr was set, dropping)\n" if $self->{"Verbose"};
  111.         return;
  112.     }
  113.  
  114.     
  115.     my $qr = ($query->question)[0];
  116.     
  117.     my $qname  = $qr ? $qr->qname  : "";
  118.     my $qclass = $qr ? $qr->qclass : "ANY";
  119.     my $qtype  = $qr ? $qr->qtype  : "ANY";
  120.     
  121.     $reply = Net::DNS::Packet->new($qname, $qclass, $qtype);
  122.     
  123.     if ($query->header->opcode eq "QUERY") {
  124.         if ($query->header->qdcount == 1) {
  125.             print "query ", $query->header->id,
  126.             ": ($qname, $qclass, $qtype)..." if $self->{"Verbose"};
  127.             
  128.             my ($rcode, $ans, $auth, $add);
  129.             
  130.             ($rcode, $ans, $auth, $add, $headermask) =
  131.                 &{$self->{"ReplyHandler"}}($qname, $qclass, $qtype, $peerhost, $query);
  132.             
  133.             print "$rcode\n" if $self->{"Verbose"};
  134.             
  135.             $reply->header->rcode($rcode);
  136.             
  137.             $reply->push("answer",       @$ans)  if $ans;
  138.             $reply->push("authority",  @$auth) if $auth;
  139.             $reply->push("additional", @$add)  if $add;
  140.         } else {
  141.             print "ERROR: qdcount ", $query->header->qdcount,
  142.                 "unsupported\n" if $self->{"Verbose"};
  143.             $reply->header->rcode("FORMERR");
  144.         }
  145.     } else {
  146.         print "ERROR: opcode ", $query->header->opcode, " unsupported\n"
  147.             if $self->{"Verbose"};
  148.         $reply->header->rcode("FORMERR");
  149.     }
  150.  
  151.     
  152.     
  153.     if (!defined ($headermask)) {
  154.         $reply->header->ra(1);
  155.         $reply->header->ad(0);
  156.     } else {
  157.         $reply->header->aa(1) if $headermask->{'aa'};
  158.         $reply->header->ra(1) if $headermask->{'ra'};
  159.         $reply->header->ad(1) if $headermask->{'ad'};
  160.     }
  161.     
  162.     
  163.     $reply->header->qr(1);
  164.     $reply->header->cd($query->header->cd);
  165.     $reply->header->rd($query->header->rd);    
  166.     $reply->header->id($query->header->id);
  167.     
  168.     
  169.     $reply->header->print if $self->{"Verbose"} && defined $headermask;
  170.     
  171.     return $reply;
  172. }
  173.  
  174. #------------------------------------------------------------------------------
  175. # tcp_connection - Handle a TCP connection.
  176. #------------------------------------------------------------------------------
  177.  
  178. sub tcp_connection {
  179.     my ($self, $sock) = @_;
  180.     my $peerhost = $sock->peerhost;
  181.  
  182.     print "TCP connection from ", $sock->peerhost, ":", $sock->peerport, "\n"
  183.       if $self->{"Verbose"};
  184.         
  185.     while (1) {
  186.         my $buf;
  187.         print "reading message length..." if $self->{"Verbose"};
  188.         $sock->read($buf, 2) or last;
  189.         print "done\n" if $self->{"Verbose"};
  190.  
  191.         my ($msglen) = unpack("n", $buf);
  192.         print "expecting $msglen bytes..." if $self->{"Verbose"};
  193.         $sock->read($buf, $msglen);
  194.         print "got ", length($buf), " bytes\n" if $self->{"Verbose"};
  195.  
  196.         my $query = Net::DNS::Packet->new(\$buf);
  197.         
  198.         my $reply = $self->make_reply($query, $peerhost) || last;
  199.         my $reply_data = $reply->data;
  200.  
  201.         print "writing response..." if $self->{"Verbose"};
  202.         $sock->write(pack("n", length($reply_data)) . $reply_data);
  203.         print "done\n" if $self->{"Verbose"};
  204.     }
  205.  
  206.     print "closing connection..." if $self->{"Verbose"};
  207.     $sock->close;
  208.     print "done\n" if $self->{"Verbose"};
  209. }
  210.  
  211. #------------------------------------------------------------------------------
  212. # udp_connection - Handle a UDP connection.
  213. #------------------------------------------------------------------------------
  214.  
  215. sub udp_connection {
  216.     my ($self, $sock) = @_;
  217.  
  218.     my $buf = "";
  219.     my $peer_sockaddr         = $sock->recv($buf, &Net::DNS::PACKETSZ);
  220.     my ($peerport, $peeraddr) = sockaddr_in($peer_sockaddr);
  221.     my $peerhost              = inet_ntoa($peeraddr);
  222.  
  223.     print "UDP connection from $peerhost:$peerport\n" if $self->{"Verbose"};
  224.  
  225.     my $query = Net::DNS::Packet->new(\$buf);
  226.  
  227.     my $reply = $self->make_reply($query, $peerhost) || return;
  228.     my $reply_data = $reply->data;
  229.  
  230.     print "writing response..." if $self->{"Verbose"};
  231.     $sock->send($reply_data) or die "send: $!";
  232.     print "done\n" if $self->{"Verbose"};
  233. }
  234.  
  235. #------------------------------------------------------------------------------
  236. # main_loop - Main nameserver loop.
  237. #------------------------------------------------------------------------------
  238.  
  239. sub main_loop {
  240.     my $self = shift;
  241.  
  242.     local $| = 1;
  243.  
  244.     while (1) {
  245.         print "waiting for connections..." if $self->{"Verbose"};
  246.         my @ready = $self->{"select"}->can_read;
  247.     
  248.         foreach my $sock (@ready) {
  249.             my $proto = getprotobynumber($sock->protocol);
  250.     
  251.             if (!$proto) {
  252.                 print "ERROR: connection with unknown protocol\n"
  253.                     if $self->{"Verbose"};
  254.             } elsif (lc($proto) eq "tcp") {
  255.                 my $client = $sock->accept;
  256.                 $self->tcp_connection($client);
  257.             } elsif (lc($proto) eq "udp") {
  258.                 $self->udp_connection($sock);
  259.             } else {
  260.                 print "ERROR: connection with unsupported protocol $proto\n"
  261.                     if $self->{"Verbose"};
  262.             }
  263.         }
  264.     }
  265. }
  266.  
  267. 1;
  268.  
  269. __END__
  270.  
  271. =head1 NAME
  272.  
  273. Net::DNS::Nameserver - DNS server class
  274.  
  275. =head1 SYNOPSIS
  276.  
  277. C<use Net::DNS::Nameserver;>
  278.  
  279. =head1 DESCRIPTION
  280.  
  281. Instances of the C<Net::DNS::Nameserver> class represent simple DNS server
  282. objects.  See L</EXAMPLE> for an example.
  283.  
  284. =head1 METHODS
  285.  
  286. =head2 new
  287.  
  288.  my $ns = Net::DNS::Nameserver->new(
  289.     LocalAddr     => "10.1.2.3",
  290.     LocalPort     => "5353",
  291.     ReplyHandler => \&reply_handler,
  292.     Verbose         => 1
  293.  );
  294.  
  295. Creates a nameserver object.  Attributes are:
  296.  
  297.   LocalAddr        IP address on which to listen.    Defaults to INADDR_ANY.
  298.   LocalPort        Port on which to listen.  Defaults to 53.
  299.   ReplyHandler    Reference to reply-handling subroutine.     Required.
  300.   Verbose        Print info about received queries.    Defaults to 0 (off).
  301.  
  302. The ReplyHandler subroutine is passed the query name, query class,
  303. query type and optionally an argument containing header bit settings
  304. (see below).  It must return the response code and references to the
  305. answer, authority, and additional sections of the response.  Common
  306. response codes are:
  307.  
  308.   NOERROR    No error
  309.   FORMERR    Format error
  310.   SERVFAIL    Server failure
  311.   NXDOMAIN    Non-existent domain (name doesn't exist)
  312.   NOTIMP    Not implemented
  313.   REFUSED    Query refused
  314.  
  315. For advanced usage there is an optional argument containing an
  316. hashref with the settings for the C<aa>, C<ra>, and C<ad> 
  317. header bits. The argument is of the form 
  318. C<< { ad => 1, aa => 0, ra => 1 } >>. 
  319.  
  320.  
  321. See RFC 1035 and the IANA dns-parameters file for more information:
  322.  
  323.   ftp://ftp.rfc-editor.org/in-notes/rfc1035.txt
  324.   http://www.isi.edu/in-notes/iana/assignments/dns-parameters
  325.  
  326. The nameserver will listen for both UDP and TCP connections.  On
  327. Unix-like systems, the program will probably have to run as root
  328. to listen on the default port, 53.    A non-privileged user should
  329. be able to listen on ports 1024 and higher.
  330.  
  331. Returns a Net::DNS::Nameserver object, or undef if the object
  332. couldn't be created.
  333.  
  334. See L</EXAMPLE> for an example.
  335.  
  336. =head2 main_loop
  337.  
  338.     $ns->main_loop;
  339.  
  340. Start accepting queries.
  341.  
  342. =head1 EXAMPLE
  343.  
  344. The following example will listen on port 5353 and respond to all queries
  345. for A records with the IP address 10.1.2.3.     All other queries will be
  346. answered with NXDOMAIN.     Authority and additional sections are left empty.
  347. The $peerhost variable catches the IP address of the peer host, so that
  348. additional filtering on its basis may be applied.
  349.  
  350.  #!/usr/bin/perl 
  351.  
  352.  use Net::DNS;
  353.  use strict;
  354.  use warnings;
  355.  
  356.  sub reply_handler {
  357.      my ($qname, $qclass, $qtype, $peerhost) = @_;
  358.      my ($rcode, @ans, @auth, @add);
  359.      
  360.      if ($qtype eq "A") {
  361.          my ($ttl, $rdata) = (3600, "10.1.2.3");
  362.          push @ans, Net::DNS::RR->new("$qname $ttl $qclass $qtype $rdata");
  363.          $rcode = "NOERROR";
  364.      } else {
  365.          $rcode = "NXDOMAIN";
  366.      }
  367.      
  368.      # mark the answer as authoritive (by setting the 'aa' flag
  369.      return ($rcode, \@ans, \@auth, \@add, { aa => 1 });
  370.  }
  371.  
  372.  my $ns = Net::DNS::Nameserver->new(
  373.      LocalPort    => 5353,
  374.      ReplyHandler => \&reply_handler,
  375.      Verbose      => 1,
  376.  ) || die "couldn't create nameserver object\n";
  377.  
  378.  $ns->main_loop;
  379.  
  380. =head1 BUGS
  381.  
  382. Net::DNS::Nameserver objects can handle only one query at a time.
  383.  
  384. =head1 COPYRIGHT
  385.  
  386. Copyright (c) 1997-2002 Michael Fuhr. 
  387.  
  388. Portions Copyright (c) 2002-2003 Chris Reinhardt.
  389.  
  390. All rights reserved.  This program is free software; you may redistribute
  391. it and/or modify it under the same terms as Perl itself.
  392.  
  393. =head1 SEE ALSO
  394.  
  395. L<perl(1)>, L<Net::DNS>, L<Net::DNS::Resolver>, L<Net::DNS::Packet>,
  396. L<Net::DNS::Update>, L<Net::DNS::Header>, L<Net::DNS::Question>,
  397. L<Net::DNS::RR>, RFC 1035
  398.  
  399. =cut
  400.  
  401.