~ubuntu-branches/ubuntu/trusty/libnet-dns-perl/trusty-proposed
» Revision
6
: lib/Net/DNS/Nameserver.pm
« back to all changes in this revision
Viewing changes to lib/Net/DNS/Nameserver.pm
- browse files at revision 6
- compare with another revision
- download diff
- download tarball
- view history from revision 6
- Committer: Bazaar Package Importer
- Author(s): Florian Hinzmann
- Date: 2006-03-31 18:51:36 UTC
- mfrom: (1.1.4 upstream)
- Revision ID: james.westby@ubuntu.com-20060331185136-gpxyhfnnnt9f9b1n
Tags: 0.57-1
New upstream release.
- files added:
- lib/Net/DNS/RR/SPF.pm
- files modified:
- Changes
added
removed
lib/Net/DNS/Nameserver.pm
1
1
package Net::DNS::Nameserver;
2
2
#
3
# $Id: Nameserver.pm 460 2005-07-15 19:18:22Z olaf $
3
# $Id: Nameserver.pm 535 2005-12-13 12:08:13Z olaf $
4
4
#
5
5
6
7
BEGIN {
8
eval { require bytes; }
9
}
10
11
12
6
use Net::DNS;
13
7
use IO::Socket;
14
8
use IO::Socket::INET;
22
16
$DEFAULT_PORT
23
17
);
24
18
25
$VERSION = (qw$LastChangedRevision: 460 $)[1];
19
use constant STATE_ACCEPTED => 1;
20
use constant STATE_GOT_LENGTH => 2;
21
use constant STATE_SENDING => 3;
22
use Net::IP qw(ip_is_ipv4 ip_is_ipv6 ip_normalize);
23
24
$VERSION = (qw$LastChangedRevision: 535 $)[1];
26
25
27
26
#@DEFAULT_ADDR is set in the BEGIN block
28
27
$DEFAULT_PORT=53;
64
63
return;
65
64
}
66
65
67
68
66
my $addr;
69
67
my $port;
70
68
74
72
75
73
my @localaddresses = @{$self{"LocalAddr"}};
76
74
77
78
79
75
my @sock_tcp; # All the TCP sockets we will listen to.
80
76
my @sock_udp; # All the UDP sockets we will listen to.
81
77
78
# while we are here, print incomplete lines as they come along.
79
local $| = 1 if $self{"Verbose"};
80
82
81
foreach my $localaddress (@localaddresses){
83
print "Dealing with $localaddress...\n" if $self{"Verbose"};
84
85
my $sock_tcp ;
86
82
83
$port = $self{"LocalPort"} || $DEFAULT_PORT;
84
87
85
if ($has_inet6){
88
89
86
$addr = $localaddress;
90
$port = $self{"LocalPort"} || $DEFAULT_PORT;
91
92
93
#--------------------------------------------------------------------------
94
# Create the IPv4/IPv6 ONLY TCP socket.
95
#--------------------------------------------------------------------------
87
}else{
88
$addr = $localaddress || inet_ntoa($DEFAULT_ADDR[0]);
89
}
90
91
# If not, it will do DNS lookups trying to resolve it as a hostname
92
# We could also just set it to undef?
93
94
$addr = inet_ntoa($addr) unless (ip_is_ipv4($addr) || ip_is_ipv6($addr));
95
96
# Pretty IP-addresses, if they are otherwise binary.
97
my $addrname = $addr;
98
$addrname = inet_ntoa($addrname) unless $addrname =~ /^[\w\.:\-]+$/;
99
100
print "Setting up listening sockets for $addrname...\n" if $self{"Verbose"};
101
102
print "Creating TCP socket for $addrname - " if $self{"Verbose"};
103
104
#--------------------------------------------------------------------------
105
# Create the TCP socket.
106
#--------------------------------------------------------------------------
96
107
97
print "creating TCP socket for $localaddress" if $self{"Verbose"};
98
99
$sock_tcp = IO::Socket::INET6->new(
108
my $sock_tcp = inet_new(
100
109
LocalAddr => $addr,
101
110
LocalPort => $port,
102
Listen => 5,
111
Listen => 64,
103
112
Proto => "tcp",
104
113
Reuse => 1,
105
114
);
106
107
108
109
if (! $sock_tcp) {
110
cluck "couldn't create TCP socket: $!";
111
return;
112
}
113
push @sock_tcp, $sock_tcp;
114
print "done.\n" if $self{"Verbose"};
115
116
117
}else{
118
$addr = $localaddress || inet_ntoa($DEFAULT_ADDR[0]);
119
$port = $self{"LocalPort"} || $DEFAULT_PORT;
120
121
122
#--------------------------------------------------------------------------
123
# Create the IPv4 ONLY TCP socket.
124
#--------------------------------------------------------------------------
125
126
print "creating TCP socket for $localaddress" if $self{"Verbose"};
127
128
129
$sock_tcp = IO::Socket::INET->new(
130
LocalAddr => $addr,
131
LocalPort => $port,
132
Listen => 5,
133
Proto => "tcp",
134
Reuse => 1,
135
);
136
137
138
if (! $sock_tcp) {
139
cluck "couldn't create TCP socket: $!";
140
return;
141
}
142
push @sock_tcp, $sock_tcp;
143
print "done.\n" if $self{"Verbose"};
144
145
146
115
if (! $sock_tcp) {
116
cluck "Couldn't create TCP socket: $!";
117
return;
147
118
}
148
149
119
push @sock_tcp, $sock_tcp;
120
print "done.\n" if $self{"Verbose"};
150
121
151
122
#--------------------------------------------------------------------------
152
123
# Create the UDP Socket.
153
124
#--------------------------------------------------------------------------
154
125
155
print "creating UDP socket..." if $self{"Verbose"};
126
print "Creating UDP socket for $addrname - " if $self{"Verbose"};
156
127
157
my $sock_udp;
158
if ($has_inet6){
159
$sock_udp = IO::Socket::INET6->new(
128
my $sock_udp = inet_new(
160
129
LocalAddr => $addr,
161
130
LocalPort => $port,
162
131
Proto => "udp",
163
132
);
164
133
165
}else{
166
$sock_udp = IO::Socket::INET->new(
167
LocalAddr => $addr,
168
LocalPort => $port,
169
Proto => "udp",
170
);
171
}
172
134
if (!$sock_udp) {
173
cluck "couldn't create UDP socket: $!";
135
cluck "Couldn't create UDP socket: $!";
174
136
return;
175
137
}
176
177
178
print "done.\n" if $self{"Verbose"};
179
138
push @sock_udp, $sock_udp;
139
print "done.\n" if $self{"Verbose"};
180
140
}
181
141
182
142
#--------------------------------------------------------------------------
202
162
}
203
163
204
164
#------------------------------------------------------------------------------
165
# inet_new - Calls the constructor in the correct module for making sockets.
166
#------------------------------------------------------------------------------
167
168
sub inet_new {
169
if ($has_inet6) {
170
return IO::Socket::INET6->new(@_);
171
} else {
172
return IO::Socket::INET->new(@_);
173
}
174
}
175
176
#------------------------------------------------------------------------------
205
177
# make_reply - Make a reply packet.
206
178
#------------------------------------------------------------------------------
207
179
236
208
if ($query->header->opcode eq "QUERY") {
237
209
if ($query->header->qdcount == 1) {
238
210
print "query ", $query->header->id,
239
": ($qname, $qclass, $qtype)..." if $self->{"Verbose"};
211
": ($qname, $qclass, $qtype) - " if $self->{"Verbose"};
240
212
241
213
my ($rcode, $ans, $auth, $add);
242
214
285
257
}
286
258
287
259
#------------------------------------------------------------------------------
260
# readfromtcp - read from a TCP client
261
#------------------------------------------------------------------------------
262
263
sub readfromtcp {
264
my ($self, $sock) = @_;
265
return -1 unless defined $self->{"_tcp"}{$sock};
266
my $peer = $self->{"_tcp"}{$sock}{"peer"};
267
my $charsread = $sock->sysread(
268
$self->{"_tcp"}{$sock}{"inbuffer"},
269
16384);
270
$self->{"_tcp"}{$sock}{"timeout"} = time()+120; # Reset idle timer
271
print "Received $charsread octets from $peer\n" if $self->{"Verbose"};
272
if ($charsread == 0) { # 0 octets means socket has closed
273
print "Connection to $peer closed or lost.\n" if $self->{"Verbose"};
274
$self->{"select"}->remove($sock);
275
$sock->close();
276
delete $self->{"_tcp"}{$sock};
277
return $charsread;
278
}
279
return $charsread;
280
}
281
282
#------------------------------------------------------------------------------
288
283
# tcp_connection - Handle a TCP connection.
289
284
#------------------------------------------------------------------------------
290
285
291
286
sub tcp_connection {
292
287
my ($self, $sock) = @_;
293
my $peerhost = $sock->peerhost;
294
295
print "TCP connection from ", $sock->peerhost, ":", $sock->peerport, "\n"
296
if $self->{"Verbose"};
297
298
while (1) {
299
my $buf;
300
print "reading message length..." if $self->{"Verbose"};
301
$sock->read($buf, 2) or last;
302
print "done\n" if $self->{"Verbose"};
303
304
my ($msglen) = unpack("n", $buf);
305
print "expecting $msglen bytes..." if $self->{"Verbose"};
306
$sock->read($buf, $msglen);
307
print "got ", length($buf), " bytes\n" if $self->{"Verbose"};
308
309
my $query = Net::DNS::Packet->new(\$buf);
310
311
my $reply = $self->make_reply($query, $peerhost) || last;
312
my $reply_data = $reply->data;
313
314
print "writing response..." if $self->{"Verbose"};
315
$sock->write(pack("n", length($reply_data)) . $reply_data);
316
print "done\n" if $self->{"Verbose"};
288
289
if (not $self->{"_tcp"}{$sock}) {
290
# We go here if we are called with a listener socket.
291
my $client = $sock->accept;
292
if (not defined $client) {
293
print "TCP connection closed by peer before we could accept it.\n" if $self->{"Verbose"};
294
return 0;
295
}
296
my $peerport= $client->peerport;
297
my $peerhost = $client->peerhost;
298
299
print "TCP connection from $peerhost:$peerport\n" if $self->{"Verbose"};
300
$client->blocking(0);
301
$self->{"_tcp"}{$client}{"peer"} = "tcp:".$peerhost.":".$peerport;
302
$self->{"_tcp"}{$client}{"state"} = STATE_ACCEPTED;
303
$self->{"_tcp"}{$client}{"socket"} = $client;
304
$self->{"_tcp"}{$client}{"timeout"} = time()+120;
305
$self->{"select"}->add($client);
306
# After we accepted we will look at the socket again
307
# to see if there is any data there. ---Olaf
308
$self->loop_once(0);
309
} else {
310
# We go here if we are called with a client socket
311
my $peer = $self->{"_tcp"}{$sock}{"peer"};
312
313
if ($self->{"_tcp"}{$sock}{"state"} == STATE_ACCEPTED) {
314
if (not $self->{"_tcp"}{$sock}{"inbuffer"} =~ s/^(..)//s) {
315
return; # Still not 2 octets ready
316
}
317
my $msglen = unpack("n", $1);
318
print "Removed 2 octets from the input buffer from $peer.\n".
319
"$peer said his query contains $msglen octets.\n"
320
if $self->{"Verbose"};
321
$self->{"_tcp"}{$sock}{"state"} = STATE_GOT_LENGTH;
322
$self->{"_tcp"}{$sock}{"querylength"} = $msglen;
323
}
324
# Not elsif, because we might already have all the data
325
if ($self->{"_tcp"}{$sock}{"state"} == STATE_GOT_LENGTH) {
326
# return if not all data has been received yet.
327
return if $self->{"_tcp"}{$sock}{"querylength"} > length $self->{"_tcp"}{$sock}{"inbuffer"};
328
329
my $qbuf = substr($self->{"_tcp"}{$sock}{"inbuffer"}, 0, $self->{"_tcp"}{$sock}{"querylength"});
330
substr($self->{"_tcp"}{$sock}{"inbuffer"}, 0, $self->{"_tcp"}{$sock}{"querylength"}) = "";
331
my $query = Net::DNS::Packet->new(\$qbuf);
332
my $reply = $self->make_reply($query, $sock->peerhost);
333
if (not defined $reply) {
334
print "I couldn't create a reply for $peer. Closing socket.\n"
335
if $self->{"Verbose"};
336
$self->{"select"}->remove($sock);
337
$sock->close();
338
delete $self->{"_tcp"}{$sock};
339
return;
340
}
341
my $reply_data = $reply->data;
342
my $len = length $reply_data;
343
$self->{"_tcp"}{$sock}{"outbuffer"} = pack("n", $len) . $reply_data;
344
print "Queued ",
345
length $self->{"_tcp"}{$sock}{"outbuffer"},
346
" octets to $peer\n"
347
if $self->{"Verbose"};
348
# We are done.
349
$self->{"_tcp"}{$sock}{"state"} = STATE_SENDING;
350
}
317
351
}
318
319
print "closing connection..." if $self->{"Verbose"};
320
$sock->close;
321
print "done\n" if $self->{"Verbose"};
322
352
}
323
353
324
354
#------------------------------------------------------------------------------
330
360
331
361
my $buf = "";
332
362
333
my ($peerhost,$peerport);
334
335
363
$sock->recv($buf, &Net::DNS::PACKETSZ);
364
my ($peerhost,$peerport) = ($sock->peerhost, $sock->peerport);
336
365
337
print "UDP connection from ", $sock->peerhost, ":", $sock->peerport, "\n"
338
if $self->{"Verbose"};
339
340
print "UDP connection from $peerhost:$peerport\n" if $self->{"Verbose"};
366
print "UDP connection from $peerhost:$peerport\n" if $self->{"Verbose"};
341
367
342
368
my $query = Net::DNS::Packet->new(\$buf);
343
369
344
370
my $reply = $self->make_reply($query, $peerhost) || return;
345
371
my $reply_data = $reply->data;
346
372
347
print "writing response..." if $self->{"Verbose"};
373
local $| = 1 if $self->{"Verbose"};
374
print "Writing response - " if $self->{"Verbose"};
375
# die() ?!?? I think we need something better. --robert
348
376
$sock->send($reply_data) or die "send: $!";
349
377
print "done\n" if $self->{"Verbose"};
350
378
}
351
379
380
381
sub get_open_tcp {
382
my $self=shift;
383
return keys %{$self->{"_tcp"}};
384
}
385
386
387
#------------------------------------------------------------------------------
388
# loop_once - Just check "once" on sockets already set up
389
#------------------------------------------------------------------------------
390
391
# This function might not actually return immediately. If an AXFR request is
392
# coming in which will generate a huge reply, we will not relinquish control
393
# until our outbuffers are empty.
394
395
#
396
# NB this method may be subject to change and is therefore left 'undocumented'
397
#
398
399
sub loop_once {
400
my ($self, $timeout) = @_;
401
$timeout=0 unless defined($timeout);
402
print ";loop_once called with $timeout \n" if $self->{"Verbose"} >4;
403
foreach my $sock (keys %{$self->{"_tcp"}}) {
404
$timeout = 0.1 if $self->{"_tcp"}{$sock}{"outbuffer"};
405
}
406
my @ready = $self->{"select"}->can_read($timeout);
407
408
foreach my $sock (@ready) {
409
my $protonum = $sock->protocol;
410
# This is a weird and nasty hack. Although not incorrect,
411
# I just don't know why ->protocol won't tell me the protocol
412
# on a connected socket. --robert
413
$protonum = getprotobyname('tcp') if not defined $protonum and $self->{"_tcp"}{$sock};
414
415
my $proto = getprotobynumber($protonum);
416
if (!$proto) {
417
print "ERROR: connection with unknown protocol\n"
418
if $self->{"Verbose"};
419
} elsif (lc($proto) eq "tcp") {
420
421
$self->readfromtcp($sock) &&
422
$self->tcp_connection($sock);
423
} elsif (lc($proto) eq "udp") {
424
$self->udp_connection($sock);
425
} else {
426
print "ERROR: connection with unsupported protocol $proto\n"
427
if $self->{"Verbose"};
428
}
429
}
430
my $now = time();
431
# Lets check if any of our TCP clients has pending actions.
432
# (outbuffer, timeout)
433
foreach my $s (keys %{$self->{"_tcp"}}) {
434
my $sock = $self->{"_tcp"}{$s}{"socket"};
435
if ($self->{"_tcp"}{$s}{"outbuffer"}) {
436
# If we have buffered output, then send as much as the OS will accept
437
# and wait with the rest
438
my $len = length $self->{"_tcp"}{$s}{"outbuffer"};
439
my $charssent = $sock->syswrite($self->{"_tcp"}{$s}{"outbuffer"});
440
print "Sent $charssent of $len octets to ",$self->{"_tcp"}{$s}{"peer"},".\n"
441
if $self->{"Verbose"};
442
substr($self->{"_tcp"}{$s}{"outbuffer"}, 0, $charssent) = "";
443
if (length $self->{"_tcp"}{$s}{"outbuffer"} == 0) {
444
delete $self->{"_tcp"}{$s}{"outbuffer"};
445
$self->{"_tcp"}{$s}{"state"} = STATE_ACCEPTED;
446
if (length $self->{"_tcp"}{$s}{"inbuffer"} >= 2) {
447
# See if the client has send us enough data to process the
448
# next query.
449
# We do this here, because we only want to process (and buffer!!)
450
# a single query at a time, per client. If we allowed a STATE_SENDING
451
# client to have new requests processed. We could be easilier
452
# victims of DoS (client sending lots of queries and never reading
453
# from it's socket).
454
# Note that this does not disable serialisation on part of the
455
# client. The split second it should take for us to lookip the
456
# next query, is likely faster than the time it takes to
457
# send the response... well, unless it's a lot of tiny queries,
458
# in which case we will be generating an entire TCP packet per
459
# reply. --robert
460
$self->tcp_connection($self->{"_tcp"}{"socket"});
461
}
462
}
463
$self->{"_tcp"}{$s}{"timeout"} = time()+120;
464
} else {
465
# Get rid of idle clients.
466
my $timeout = $self->{"_tcp"}{$s}{"timeout"};
467
if ($timeout - $now < 0) {
468
print $self->{"_tcp"}{$s}{"peer"}," has been idle for too long and will be disconnected.\n"
469
if $self->{"Verbose"};
470
$self->{"select"}->remove($sock);
471
$sock->close();
472
delete $self->{"_tcp"}{$s};
473
}
474
}
475
}
476
}
477
352
478
#------------------------------------------------------------------------------
353
479
# main_loop - Main nameserver loop.
354
480
#------------------------------------------------------------------------------
355
481
356
482
sub main_loop {
357
my $self = shift;
358
359
local $| = 1;
360
361
while (1) {
362
print "waiting for connections..." if $self->{"Verbose"};
363
my @ready = $self->{"select"}->can_read;
364
365
foreach my $sock (@ready) {
366
my $proto = getprotobynumber($sock->protocol);
367
368
if (!$proto) {
369
print "ERROR: connection with unknown protocol\n"
370
if $self->{"Verbose"};
371
} elsif (lc($proto) eq "tcp") {
372
my $client = $sock->accept;
373
$self->tcp_connection($client);
374
} elsif (lc($proto) eq "udp") {
375
$self->udp_connection($sock);
376
} else {
377
print "ERROR: connection with unsupported protocol $proto\n"
378
if $self->{"Verbose"};
379
}
380
}
381
}
483
my $self = shift;
484
485
while (1) {
486
print "Waiting for connections...\n" if $self->{"Verbose"};
487
# You really need an argument otherwise you'll be burning
488
# CPU.
489
$self->loop_once(10);
490
}
382
491
}
383
492
384
493
1;
395
504
396
505
=head1 DESCRIPTION
397
506
398
Instances of the C<Net::DNS::Nameserver> class represent simple DNS server
507
Instances of the C<Net::DNS::Nameserver> class represent DNS server
399
508
objects. See L</EXAMPLE> for an example.
400
509
401
510
=head1 METHODS
429
538
430
539
431
540
The LocalAddr attribute may alternatively be specified as a list of IP
432
addresses to liten to.
541
addresses to listen to.
433
542
434
543
If IO::Socket::INET6 and Socket6 are available on the system you can
435
544
also list IPv6 addresses and the default is '0' (listen on all interfaces on
474
583
475
584
$ns->main_loop;
476
585
477
Start accepting queries.
586
Start accepting queries. Calling main_loop never returns.
587
588
=cut
589
590
#####
591
#
592
# The functionality might change. Left "undocumented" for now.
593
#
594
=head2 loop_once
595
596
$ns->loop_once( [TIMEOUT_IN_SECONDS] );
597
598
Start accepting queries, but returns. If called without a parameter,
599
the call will not return until a request has been received (and
600
replied to). If called with a number, that number specifies how many
601
seconds (even fractional) to maximum wait before returning. If called
602
with 0 it will return immediately unless there's something to do.
603
604
Handling a request and replying obviously depends on the speed of
605
ReplyHandler. Assuming ReplyHandler is super fast, loop_once should spend
606
just a fraction of a second, if called with a timeout value of 0 seconds.
607
One exception is when an AXFR has requested a huge amount of data that
608
the OS is not ready to receive in full. In that case, it will keep
609
running through a loop (while servicing new requests) until the reply
610
has been sent.
611
612
In case loop_once accepted a TCP connection it will immediatly check
613
if there is data to be read from the socket. If not it will return and
614
you will have to call loop_once() again to check if there is any data
615
waiting on the socket to be processed. In most cases you will have to
616
count on calling "loop_once" twice.
617
618
A code fragment like:
619
$ns->loop_once(10);
620
while( $ns->get_open_tcp() ){
621
$ns->loop_once(0);
622
}
623
624
Would wait for 10 seconds for the initial connection and would then
625
process all TCP sockets until none is left.
626
627
=head2 get_open_tcp
628
629
In scalar context returns the number of TCP connections for which state
630
is maintained. In array context it returns IO::Socket objects, these could
631
be useful for troubleshooting but be careful using them.
478
632
479
633
=head1 EXAMPLE
480
634
486
640
487
641
#!/usr/bin/perl
488
642
489
use Net::DNS;
643
use Net::DNS::Nameserver;
490
644
use strict;
491
645
use warnings;
492
646
494
648
my ($qname, $qclass, $qtype, $peerhost) = @_;
495
649
my ($rcode, @ans, @auth, @add);
496
650
497
if ($qtype eq "A") {
651
if ($qtype eq "A" && qname eq "foo.example.com" ) {
498
652
my ($ttl, $rdata) = (3600, "10.1.2.3");
499
653
push @ans, Net::DNS::RR->new("$qname $ttl $qclass $qtype $rdata");
500
654
$rcode = "NOERROR";
501
} else {
502
$rcode = "NXDOMAIN";
655
}elsif( qname eq "foo.example.com" ) {
656
$rcode = "NOERROR";
657
658
}else{
659
$rcode = "NXDOMAIN";
503
660
}
504
661
505
662
# mark the answer as authoritive (by setting the 'aa' flag
511
668
ReplyHandler => \&reply_handler,
512
669
Verbose => 1,
513
670
) || die "couldn't create nameserver object\n";
514
671
515
672
$ns->main_loop;
516
673
517
674
=head1 BUGS
518
675
519
Net::DNS::Nameserver objects can handle only one query at a time.
520
521
676
Limitations in perl 5.8.6 makes it impossible to guarantee that
522
677
replies to UDP queries from Net::DNS::Nameserver are sent from the
523
678
IP-address they were received on. This is a problem for machines with
524
679
multiple IP-addresses and causes violation of RFC2181 section 4.
525
680
Thus a UDP socket created listening to INADDR_ANY (all available
681
IP-addresses) will reply not necessarily with the source address being
682
the one to which the request was sent, but rather with the address that
683
the operating system choses. This is also often called "the closest
684
address". This should really only be a problem on a server which has
685
more than one IP-address (besides localhost - any experience with IPv6
686
complications here, would be nice). If this is a problem for you, a
687
work-around would be to not listen to INADDR_ANY but to specify each
688
address that you want this module to listen on. A seperate set of
689
sockets will then be created for each IP-address.
526
690
527
691
=head1 COPYRIGHT
528
692
532
696
533
697
Portions Copyright (c) 2005 O.M, Kolkman, RIPE NCC.
534
698
535
699
Portions Copyright (c) 2005 Robert Martin-Legene.
536
700
537
701
All rights reserved. This program is free software; you may redistribute
538
702
it and/or modify it under the same terms as Perl itself.
544
708
L<Net::DNS::RR>, RFC 1035
545
709
546
710
=cut
547
Loggerhead is a web-based interface for Breezy
Version: 2.0.1