File Coverage

blib/lib/Net/DNS/Nameserver/Trivial.pm
Criterion Covered Total %
statement 63 261 24.1
branch 0 94 0.0
condition 0 64 0.0
subroutine 21 28 75.0
pod 2 2 100.0
total 86 449 19.1


line stmt bran cond sub pod time code
1             package Net::DNS::Nameserver::Trivial;
2              
3 1     1   219614 use vars qw($VERSION);
  1         3  
  1         94  
4              
5             $VERSION = 0.302;
6             #---------------
7              
8 1     1   7 use strict;
  1         2  
  1         24  
9 1     1   15 use warnings;
  1         8  
  1         34  
10             #-----------------------------------------------------------------------
11 1     1   5 use Net::IP::XS;
  1         2  
  1         59  
12 1     1   7 use Net::DNS;
  1         2  
  1         116  
13 1     1   7 use Net::DNS::Nameserver;
  1         2  
  1         24  
14              
15 1     1   18 use Log::Tiny;
  1         3  
  1         40  
16 1     1   6 use List::MoreUtils qw(uniq);
  1         3  
  1         30  
17 1     1   906 use Cache::FastMmap;
  1         9  
  1         41  
18 1     1   5 use Regexp::IPv6 qw($IPv6_re);
  1         4  
  1         176  
19             #=======================================================================
20 1     1   9 use constant A => q/A/;
  1         2  
  1         86  
21 1     1   6 use constant A6 => q/A6/;
  1         2  
  1         66  
22 1     1   7 use constant IN => q/IN/;
  1         2  
  1         76  
23 1     1   6 use constant NS => q/NS/;
  1         12  
  1         52  
24 1     1   6 use constant MX => q/MX/;
  1         27  
  1         60  
25 1     1   7 use constant TTL => 86400;
  1         17  
  1         60  
26 1     1   6 use constant PTR => q/PTR/;
  1         3  
  1         55  
27 1     1   6 use constant SOA => q/SOA/;
  1         2  
  1         64  
28 1     1   6 use constant AAAA => q/AAAA/;
  1         3  
  1         51  
29 1     1   6 use constant CNAME => q/CNAME/;
  1         2  
  1         55  
30 1     1   7 use constant AXFR => q/AXFR/;
  1         2  
  1         3657  
31             #=======================================================================
32             sub new {
33 0     0 1   my ($class, $config, $params) = @_;
34            
35 0           my $self = bless { }, $class;
36            
37             # Server +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38             $self->{ nameserver } = Net::DNS::Nameserver->new(
39             LocalAddr => $params->{ SERVER }->{ address },
40             LocalPort => $params->{ SERVER }->{ port },
41             Verbose => $params->{ SERVER }->{ verbose },
42             Truncate => $params->{ SERVER }->{ truncate },
43             IdleTimeout => $params->{ SERVER }->{ timeout },
44 0     0     ReplyHandler => sub { $self->_handler( @_ ) },
45 0   0       ) || die "Couldn't create nameserver object\n";
46            
47             # Resolver +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
48             $self->{ resolv } = Net::DNS::Resolver->new(
49             tcp_timeout => $params->{ RESOLVER }->{ tcp_timeout },
50             udp_timeout => $params->{ RESOLVER }->{ udp_timeout },
51 0           );
52            
53             # Cache ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
54             $self->{ cache } = Cache::FastMmap->new(
55             cache_size => $params->{ CACHE }->{ size },
56             expire_time => $params->{ CACHE }->{ expire },
57             init_file => $params->{ CACHE }->{ init },
58             unlink_on_exit => $params->{ CACHE }->{ unlink },
59             share_file => $params->{ CACHE }->{ file },
60 0           compress => 1,
61             catch_deadlocks => 1,
62             raw_values => 0,
63             );
64            
65             # Log ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
66 0           my @log_level = qw( FAKE DEBUG INFO WARN ERROR FATAL );
67 0   0       shift @log_level while @log_level and $log_level[ 0 ] ne $params->{ LOG }->{ level };
68              
69 0 0         $self->{ log } = Log::Tiny->new( $params->{ LOG }->{ file } ) or die 'Could not log: ' . Log::Tiny->errstr . "\n";
70 0           $self->{ log }->log_only( @log_level );
71              
72             #select((select(Log::Tiny::LOG), $| = 1)[0]); # turn off buffering of LOG
73             #select((select(Log::Tiny::LOG), $| = 1)[0]); # turn off buffering of LOG
74            
75             # Flags ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
76 0           $self->{ _ra } = $params->{ FLAGS }->{ ra };
77            
78             # Serial +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
79 0   0       $self->{ serial } = $config->{ _ }->{ serial } || $self->_serial;
80            
81             # Slaves +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
82 0           $self->{ SL } = { map { $_ => 1 } split( /\s*,\s*/o, $config->{ _ }->{ slaves } ) };
  0            
83            
84             # Nameservers for domain +++++++++++++++++++++++++++++++++++++++++++
85 0           foreach my $name ( keys %{ $config->{ NS } } ){
  0            
86 0           $self->{ NS }->{ $name } = [ uniq split(/\s*,\s*/, $config->{ NS }->{ $name } ) ];
87             }
88             # $self->{ NS } = {
89             # 'example.com' => [ qw( ns.example.com ) ],
90             # };
91            
92             # A ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
93 0           foreach my $name ( keys %{ $config->{ A } } ){
  0            
94 0           $self->{ A }->{ $name } = [ grep { /^\d+\.\d+\.\d+\.\d+$/o } uniq split( /\s*,\s*/, $config->{ A }->{ $name } ) ];
  0            
95             }
96             # $self->{ A } = {
97             # 'ns1.example.com' => [ qw( 10.3.57.1 ) ],
98             # };
99            
100             # AAAA +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
101 0           foreach my $name (keys %{ $config->{ AAAA } } ){
  0            
102 0           $self->{ AAAA }->{ $name } = [ grep { /^$IPv6_re$/o } uniq split( /\s*,\s*/, $config->{ AAAA }->{ $name } ) ];
  0            
103             }
104             # $self->{ AAAA } = {
105             # 'srv.example.com' => [qw( fe80::20c:29ff:fee2:ed62 )],
106             # 'mail.example.com' => [qw( fe80::21d:7dff:fed5:b3d6 )],
107             # };
108            
109             # CNAME ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
110 0           foreach my $name ( keys %{ $config->{ CNAME } } ){
  0            
111 0           $self->{ CNAME }->{ $_ } = $name for uniq split( /\s*,\s*/, $config->{ CNAME }->{ $name } );
112             }
113             # $self->{ CNAME } = {
114             # 'ns0.example.com' => 'srv.example.com',
115             # };
116            
117             # MX +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
118 0           foreach my $name ( keys %{ $config->{ MX } } ){
  0            
119 0           $self->{ MX }->{ $name } = [ uniq split(/\s*,\s*/, $config->{ MX }->{ $name } ) ];
120             }
121             # $self->{ MX } = {
122             # 'example.com' => [ qw( mail.example.com ) ],
123             # };
124            
125             # SOA ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
126 0           foreach my $name ( keys %{ $config->{ SOA } } ){
  0            
127 0           $self->{ SOA }->{ $name } = $config->{ SOA }->{ $name };
128             }
129             # $self->{ SOA } = {
130             # 'example.com' => [ qw( srv.example.com ) ],
131             # };
132            
133             # PTR ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
134 0           foreach my $name ( keys %{ $self->{ A } } ){
  0            
135 0           foreach my $ip ( @{ $self->{ A }->{ $name } } ){
  0            
136 0           ( my $key = Net::IP::XS->new( $ip )->reverse_ip() ) =~ s/\.$//o;
137 0           $self->{ PTR }->{ $key } = $name;
138             }
139             }
140 0           foreach my $name (keys %{ $self->{ AAAA } } ){
  0            
141 0           foreach my $ip ( @{ $self->{ AAAA }->{ $name } } ){
  0            
142 0           (my $key = Net::IP::XS->new( $ip )->reverse_ip()) =~ s/\.$//o;
143 0           $self->{ PTR }->{ $key } = $name;
144             }
145             }
146             #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
147 0           return $self;
148             }
149             #=======================================================================
150             # RFC1912 2.2
151             sub _serial {
152 0     0     my ($self, $sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime( time );
153              
154 0           $year += 1900;
155 0           $mon += 1;
156              
157 0 0         $sec = q[0] . $sec if $sec =~ /^\d$/o;
158 0 0         $min = q[0] . $min if $min =~ /^\d$/o;
159 0 0         $hour = q[0] . $hour if $hour =~ /^\d$/o;
160 0 0         $mday = q[0] . $mday if $mday =~ /^\d$/o;
161 0 0         $mon = q[0] . $mon if $mon =~ /^\d$/o;
162              
163 0           return $year . $mon . $mday . $hour;
164             }
165             #=======================================================================
166             sub _plain {
167 0     0     my ($self, $str) = @_;
168            
169 0           $str =~ s/[\s\t]+(\d+)\s*(\)?)\s*;[^\n]+\n?/ $1/go;
170 0           $str =~ s/\(\s*//o;
171            
172 0           return $str;
173             }
174             #=======================================================================
175             sub _log_response {
176 0     0     my ($self, $peerhost, $qtype, $qname, $val) = @_;
177            
178 0 0         $self->{ log }->INFO( q[ ] . $peerhost . q[ ] . $qname . ' [' . $qtype . '] ' . ( scalar( @{ $val->[ 1 ] } ) ? q[OK] : q[FAIL] ) );
  0            
179              
180 0           $self->{ log }->DEBUG( "-" x 72 );
181 0           $self->{ log }->DEBUG( 'Code: ' . $val->[0] );
182 0           $self->{ log }->DEBUG( " Ans: " . $self->_plain( $_->string ) ) for @{ $val->[ 1 ] };
  0            
183 0           $self->{ log }->DEBUG( "Auth: " . $self->_plain( $_->string ) ) for @{ $val->[ 2 ] };
  0            
184 0           $self->{ log }->DEBUG( " Add: " . $self->_plain( $_->string ) ) for @{ $val->[ 3 ] };
  0            
185 0           $self->{ log }->DEBUG( "=" x 72 );
186            
187             }
188             #=======================================================================
189             sub _handler {
190 0     0     my ($self, $qname, $qclass, $qtype, $peerhost, $query, $conn) = @_;
191              
192             # sprawdzamy, czy odpowiedz jest w pamieci cache -------------------
193 0           my $key = join( q/$/, $qname, $qclass, $qtype );
194 0           my $val = $self->{ cache }->get( $key );
195            
196 0 0         if( $val ){
197 0           $self->_log_response( $peerhost, $qtype, $qname, $val );
198 0           return @$val;
199             }
200             #-------------------------------------------------------------------
201              
202 0           my ($rcode, @ans, @auth, @add, $local);
203 0 0 0       if($qtype eq A and ( exists $self->{ A }->{ $qname} or exists $self->{ CNAME }->{ $qname} )){
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
      0        
      0        
      0        
      0        
204            
205 0 0         if($self->{ CNAME }->{ $qname } ){
206             push @ans, Net::DNS::RR->new(
207             name => $qname,
208             ttl => TTL,
209             class => $qclass,
210             type => CNAME,
211 0           cname => $self->{ CNAME }->{ $qname },
212             );
213 0           $qname = $self->{ CNAME }->{ $qname };
214             }
215              
216 0           foreach my $ip ( @{ $self->{ A }->{ $qname } } ){
  0            
217 0           push @ans, Net::DNS::RR->new(
218             name => $qname,
219             ttl => TTL,
220             class => $qclass,
221             type => $qtype,
222             address => $ip,
223             );
224             }
225            
226 0           $local = 1;
227 0           $rcode = "NOERROR";
228             }elsif( ( $qtype eq AAAA or $qtype eq A6 ) and ( exists $self->{ AAAA }->{ $qname } or exists $self->{ CNAME }->{ $qname } ) ){
229            
230 0 0         if($self->{ CNAME }->{ $qname } ){
231             push @ans, Net::DNS::RR->new(
232             name => $qname,
233             ttl => TTL,
234             class => $qclass,
235             type => CNAME,
236 0           cname => $self->{ CNAME }->{ $qname },
237             );
238 0           $qname = $self->{ CNAME }->{ $qname };
239             }
240              
241 0           foreach my $ip ( @{ $self->{ AAAA }->{ $qname } } ){
  0            
242 0           push @ans, Net::DNS::RR->new(
243             name => $qname,
244             ttl => TTL,
245             class => $qclass,
246             type => $qtype,
247             address => $ip,
248             );
249             }
250            
251 0           $local = 1;
252 0           $rcode = "NOERROR";
253             }elsif( $qtype eq MX and ( exists $self->{ MX }->{ $qname } or exists $self->{ CNAME }->{ $qname } ) ){
254             MX:
255 0 0         if( $self->{ CNAME }->{ $qname } ){
256             push @ans, Net::DNS::RR->new(
257             name => $qname,
258             ttl => TTL,
259             class => $qclass,
260             type => CNAME,
261 0           cname => $self->{ CNAME }->{ $qname },
262             );
263 0           $qname = $self->{ CNAME }->{ $qname };
264             }
265            
266 0           foreach my $name ( @{$self->{ MX }->{ $qname } } ){
  0            
267 0           push @ans, Net::DNS::RR->new(
268             name => $qname,
269             ttl => TTL,
270             class => $qclass,
271             type => MX,
272             preference => 10,
273             exchange => $name,
274             );
275            
276 0           my @ip;
277 0 0         push @ip, @{ $self->{ A }->{ $name } } if exists $self->{ A }->{ $name };
  0            
278 0 0         push @ip, @{ $self->{ AAAA }->{ $name } } if exists $self->{ AAAA }->{ $name };
  0            
279            
280 0           for my $ip ( @ip ){
281 0 0         push @add, Net::DNS::RR->new(
282             name => $name,
283             ttl => TTL,
284             class => IN,
285             type => $ip =~ /:/o ? AAAA : A,
286             address => $ip,
287             );
288             }
289             }
290            
291 0           $local = 1;
292 0           $rcode = "NOERROR";
293             }elsif( $qtype eq PTR and exists $self->{ PTR }->{ $qname } ){
294             push @ans, Net::DNS::RR->new(
295             name => $qname . q/./,
296             ttl => TTL,
297             class => $qclass,
298             type => $qtype,
299 0           ptrdname => $self->{ PTR }->{ $qname } . q/./,
300             );
301            
302 0           $local = 1;
303 0           $rcode = "NOERROR";
304             }elsif( $qtype eq SOA and exists $self->{ SOA }->{ $qname } ){
305            
306             # SOA ----------------------------------------------------------
307             push @ans, Net::DNS::RR->new(
308             name => $qname . q/./,
309             mname => $self->{ SOA }->{ $qname },
310             rname => q/root./ . $self->{ SOA }->{ $qname } . q/./,
311             ttl => TTL,
312             class => IN,
313             type => SOA,
314             serial => $self->{ serial },
315 0           refresh => 10800, # 3 godziny
316             retry => 3600, # 1 godzina
317             expire => 2592000, # 30 dni
318             minimum => TTL,
319             );
320            
321 0           $local = 1;
322 0           $rcode = "NOERROR";
323             }elsif( $qtype eq NS and exists $self->{ NS }->{ $qname } ){
324             # NS -----------------------------------------------------------
325 0           for my $ns ( @{ $self->{ NS }->{ $qname } } ){
  0            
326 0           push @ans, Net::DNS::RR->new(
327             name => $qname,
328             ttl => TTL,
329             class => IN,
330             type => NS,
331             nsdname => $ns . q/./,
332             );
333             }
334            
335 0           $local = 1;
336 0           $rcode = "NOERROR";
337             }elsif( $qtype eq AXFR and exists $self->{ SOA }->{ $qname } and exists $self->{ SL }->{ $peerhost } ){
338            
339             # SOA ----------------------------------------------------------
340             push @ans, Net::DNS::RR->new(
341             name => $qname . q/./,
342             mname => $self->{ SOA }->{ $qname },
343             rname => q/root./ . $self->{ SOA }->{ $qname } . q/./,
344             ttl => TTL,
345             class => IN,
346             type => SOA,
347             serial => $self->{ serial },
348 0           refresh => 10800, # 3 godziny
349             retry => 3600, # 1 godzina
350             expire => 2592000, # 30 dni
351             minimum => TTL,
352             );
353            
354             # A ------------------------------------------------------------
355 0           for my $name ( keys %{ $self->{ A } } ){
  0            
356 0 0         next if $name !~ /$qname/;
357 0           foreach my $ip ( @{ $self->{ A }->{ $name } } ){
  0            
358 0           push @ans, Net::DNS::RR->new(
359             name => $name,
360             ttl => TTL,
361             class => $qclass,
362             type => A,
363             address => $ip,
364             );
365             }
366             }
367              
368             # CNAME --------------------------------------------------------
369 0           for my $name ( keys %{ $self->{ CNAME } } ){
  0            
370 0 0         next if $name !~ /$qname/;
371             push @ans, Net::DNS::RR->new(
372             name => $name,
373             ttl => TTL,
374             class => $qclass,
375             type => CNAME,
376 0           cname => $self->{ CNAME }->{ $name },
377             );
378             }
379              
380             # NS -----------------------------------------------------------
381 0           for my $ns ( @{ $self->{ NS }->{ $qname } } ){
  0            
382 0           push @ans, Net::DNS::RR->new(
383             name => $qname,
384             ttl => TTL,
385             class => IN,
386             type => NS,
387             nsdname => $ns . q/./,
388             );
389             }
390             # MX -----------------------------------------------------------
391 0           goto MX;
392             #---------------------------------------------------------------
393              
394 0           $local = 1;
395 0           $rcode = "NOERROR";
396             }elsif( $self->{ _ra } ){
397             # poszukujemy informacji o zadanym wezle -----------------------
398 0 0 0       if( $qtype eq A or $qtype eq PTR or $qtype eq MX or $qtype eq SOA or $qtype eq NS ){
      0        
      0        
      0        
399            
400 0           my $q = $self->{ resolv }->send( $query );
401            
402 0 0         if( $q ){
403 0           push @ans, $q->answer;
404 0           push @auth, $q->authority;
405             # adres serwera poczty ---------------------------------
406 0 0         if( $qtype eq MX ){
407 0           my %seen;
408 0           for my $ans ( @ans ){
409 0 0         my $str = $ans->type eq CNAME ? $ans->cname : $ans->exchange;
410 0           my $res = $self->{ resolv }->query( $str );
411 0 0         next unless $res;
412 0           for my $ans ( $res->answer ){
413 0 0         next if $seen{ $ans->name };
414 0           $seen{ $ans->name } = 1;
415 0           push @add, $ans;
416             }
417             }
418             }
419 0 0         $rcode = scalar( @ans ) ? "NOERROR" : "NXDOMAIN";
420             }else{
421 0           $rcode = "NXDOMAIN";
422             }
423             }else{
424 0           $local = 1;
425 0           $rcode = "NOTIMP";
426             }
427             #---------------------------------------------------------------
428             }else{
429 0           $rcode = "NXDOMAIN";
430             }
431              
432 0 0         if( $rcode ne 'NOTIMP' ){
433             # zapis w lokalnej konfiguracji --------------------------------
434 0 0         if( $local ){
435 0           (my $rdom = $qname) =~ s/^[\d\w]+\.//o; # fix it!!!
436 0 0 0       my $dom = ( $qtype eq AXFR || $qtype eq SOA ) ? $qname : $rdom;
437            
438 0 0         if( exists $self->{ NS }->{ $dom } ){
439 0           for my $ns ( @{ $self->{ NS }->{ $dom } } ){
  0            
440              
441 0           push @auth, Net::DNS::RR->new(
442             name => $dom . q/./,
443             ttl => TTL,
444             class => IN,
445             type => NS,
446             nsdname => $ns . q/./,
447             );
448            
449 0 0         my $name = $self->{ CNAME }->{ $ns } ? $self->{ CNAME }->{ $ns } : $ns;
450 0           foreach my $ip ( @{$self->{ A }->{ $name } }, @{ $self->{ AAAA }->{ $name } } ){
  0            
  0            
451 0 0         push @add, Net::DNS::RR->new(
452             name => $ns,
453             ttl => TTL,
454             class => IN,
455             type => $ip =~ /:/o ? AAAA : A,
456             address => $ip,
457             );
458             }
459             }
460             }
461             }
462             # zewnetrzna nazwa DNS ---------------------------------------------
463             else {
464 0 0         if( scalar( @ans ) ){
465 0 0         unless( scalar( @auth ) ){
466 0 0 0       my $str = $qtype eq PTR ? $ans[0]->ptrdname :
    0          
467             $qtype eq MX && $ans[0]->type ne CNAME ? $ans[0]->exchange : $qname;
468            
469 0           while( $str =~ /\./o ){
470 0           my $qry = $self->{ resolv }->query( $str, NS );
471 0 0         if( $qry ){
472 0 0         push @auth, $_ for grep { $_->type eq NS or $_->type eq SOA } $qry->answer;
  0            
473            
474 0           for my $q ( @auth ){
475 0           my $res = $self->{ resolv }->query( $q->nsdname );
476 0 0         push @add, $res->answer if $res;
477             }
478 0           last;
479             }
480 0           $str =~ s/^[^\.]+\.//o;
481             }
482             }
483             }
484             }
485             }
486            
487 0           @ans = sort { ref( $b ) cmp ref( $a ) } @ans;
  0            
488            
489 0 0         my @res = $qtype eq AXFR ? ( $rcode, [ @ans, $ans[0] ], [ ], [ ] ) : ( $rcode, \@ans, \@auth, \@add );
490              
491             # ustawiamy dodatkowe flagi ----------------------------------------
492 0           my %flags;
493 0 0 0       $flags{ aa } = 1 if $local and scalar( @auth );
494 0 0         $flags{ ra } = 1 if $self->{ _ra };
495 0           push @res, \%flags;
496            
497             # zapisujemy odpowiedz w pamieci cache -----------------------------
498 0           $self->{ cache }->set( $key, \@res );
499 0           $self->_log_response( $peerhost, $qtype, $qname, \@res );
500             #-------------------------------------------------------------------
501            
502 0           return @res;
503             }
504             #=======================================================================
505             sub main_loop {
506 0     0 1   my ($self) = @_;
507            
508 0           $self->{ log }->DEBUG( 'Starting...' );
509 0           $self->{ nameserver }->main_loop;
510             }
511             #=======================================================================
512             1;
513              
514             =encoding utf8
515              
516             =head1 NAME
517              
518             Net::DNS::Nameserver::Trivial - Trivial DNS server, that is based on Net::DNS::Nameserver module.
519              
520              
521             =head1 SYNOPSIS
522              
523             use Net::DNS::Nameserver::Trivial;
524            
525             # Configuration of zone(s) -----------------------------------------
526            
527             my $zones = {
528             '_' => {
529             'slaves' => '10.1.0.1'
530             },
531            
532             'A' => {
533             'ns.example.com' => '10.11.12.13',
534             'mail.example.com' => '10.11.12.14',
535             'web.example.com' => '10.11.12.15',
536             'srv.example.com' => '10.11.12.16'
537             },
538            
539             'AAAA' => {
540             'v6.example.com' => 'fe80::20c:29ff:fee2:ed62',
541             },
542            
543             'CNAME' => {
544             'srv.example.com' => 'dns.example.com'
545             },
546            
547             'MX' => {
548             'example.com' => 'mail.example.com'
549             },
550            
551             'NS' => {
552             'example.com' => 'ns.example.com'
553             },
554            
555             'SOA' => {
556             'example.com' => 'ns.example.com'
557             }
558             };
559              
560             # Configuration of server ------------------------------------------
561             my $params = {
562            
563             'FLAGS' => {
564             'ra' => 0, # recursion available
565             },
566              
567             'RESOLVER' => {
568             'tcp_timeout' => 50,
569             'udp_timeout' => 50
570             },
571            
572             'CACHE' => {
573             'size' => 32m, # size of cache
574             'expire' => 3d, # expire time of cache
575             'init' => 1, # clear cache at startup
576             'unlink' => 1, # destroy cache on exit
577             'file' => '../var/lib/cache.db' # cache
578             },
579            
580             'SERVER' => {
581             'address' => '0.0.0.0', # all interfaces
582             'port' => 53,
583             'verbose' => 0,
584             'truncate' => 1, # truncate too big
585             'timeout' => 5 # seconds
586             },
587              
588             'LOG' => {
589             'file' => '/var/log/dns/mainlog.log',
590             'level' => 'INFO'
591             },
592            
593             };
594              
595             # Run server -------------------------------------------------------
596            
597             my $ns = Net::DNS::Nameserver::Trivial->new( $zones, $params );
598             $ns->main_loop;
599            
600             #
601             # ...OR SHORT VERSION with configuration files
602             #
603              
604             use Config::Tiny;
605             use Net::DNS::Nameserver::Trivial;
606            
607             # Read in config of zone -------------------------------------------
608             my $zones = Config::Tiny->read( '../etc/dom.ini' );
609            
610             # Read in config of server -----------------------------------------
611             my $params = Config::Tiny->read( '../etc/dns.ini' );
612              
613             # Run server -------------------------------------------------------
614             my $ns = Net::DNS::Nameserver::Trivial->new( $zones, $params );
615             $ns->main_loop;
616            
617             =head1 DESCRIPTION
618              
619             The C is a very simple nameserver, that is
620             sufficient for local domains. It supports cacheing, slaves, zone
621             transfer and common records such as A, AAAA, SOA, NS, MX, TXT, PTR,
622             CNAME. This module was tested in an environment with over 1000 users and
623             for now is running in a production environment.
624              
625             The main goal was to produce server, that is very easy in configuration
626             and it can be setup in a few seconds. So You should consider BIND if for
627             some reasons You need more powerful and complex nameserver.
628              
629             This module was prepared to cooperete with C, so it is
630             possible to prepare configuration files and run server with them,
631             as it was shown in an example above.
632              
633             =head1 WARNING
634              
635             This version is incompatible with previous versions, because of
636             new format of second configuration file. However modifications are
637             simple.
638              
639             =head1 SUBROUTINES/METHODS
640              
641             =over 4
642              
643             =item new( $zones, $params )
644              
645             This is constructor. You have to pass to it hash with configuration of
646             zones and second hash - with configuration for server.
647              
648             The first hash sould contains sections (as shown in a L):
649              
650             =over 8
651              
652             =item C<_>
653              
654             This section is a hash, that should contains information of slaves of
655             our server. For example:
656              
657             '_' => {
658             'slaves' => '10.1.0.1'
659             }
660              
661              
662             =item C
663              
664             This section is a hash, that is a mapping FDQN to IPv4, for example:
665              
666             'A' => {
667             'ns.example.com' => '10.11.12.13',
668             'mail.example.com' => '10.11.12.14',
669             'web.example.com' => '10.11.12.15',
670             'srv.example.com' => '10.11.12.16'
671             }
672              
673             =item C
674              
675             This section is a hash, that is a mapping FDQN to IPv6, for example:
676              
677             'AAAA' => {
678             'v6.example.com' => 'fe80::20c:29ff:fee2:ed62',
679             }
680              
681             =item C
682              
683             This section is a hash, that contains information about mail servers
684             for domains. For example, if I is a mail server for
685             domain I, a configuration should looks like this:
686              
687             'MX' => {
688             'example.com' => 'mail.example.com'
689             }
690              
691             =item C
692              
693             This section is a hash, that contains aliases for hosts. For example,
694             if alias.example.com and alias1.example.com are aliases for a server
695             srv.example.com, a configuration should looks like this:
696              
697             'CNAME' => {
698             'srv.example.com' => 'alias.example.com, alias1.example.com'
699             }
700              
701             =item C
702              
703             This section is a hash, that contains information about nameservers
704             for a domain. For example:
705              
706             'NS' => {
707             'example.com' => 'ns.example.com'
708             }
709              
710             =item C
711              
712             This section is a hash, that contains information about authoritative
713             nameserver for a domain. For example:
714              
715             'SOA' => {
716             'example.com' => 'ns.example.com'
717             }
718              
719             =back
720              
721             The second hash should contains variables sufficient for configuration of
722             server, cache, logs, etc. The meaning of hash elements was shown below.
723              
724             =over 8
725              
726             =item C
727              
728             This section describes options of server.
729              
730             =over 12
731              
732             =item C
733              
734             Timeout for idle connections.
735              
736             =item C
737              
738             Local IP address to listen on. Server will be listenting on all
739             interfecas if You specify C<0.0.0.0>.
740              
741             =item C
742              
743             Local port to listen on.
744              
745             =item C
746              
747             Truncates UDP packets that are to big for the reply
748              
749             =item C
750              
751             Be verbose. It is useful only for debugging.
752              
753             =back
754              
755             =item C
756              
757             This section describes options of server's cache.
758              
759             =over 12
760              
761             =item C
762              
763             A size of cache, that will be used by server.
764              
765             =item C
766              
767             Expiration time of entries in a cache. It can be diffrent than TTL value.
768             It is effective if makeing of connection to other server is too expensive
769             (i.e. too long).
770              
771             =item C
772              
773             Clear cache at startup.
774              
775             =item C
776              
777             A path to cache file.
778              
779             =item C
780              
781             Unlink a cache file on exit.
782              
783             =back
784              
785             =item C
786              
787             This section describes options of server's log.
788              
789             =over 12
790              
791             =item C
792              
793             A path to log file.
794            
795             =item C
796              
797             Log level.
798              
799             =back
800              
801             =item C
802              
803             This section describes options of resolver.
804              
805             =over 12
806              
807             =item C
808              
809             A timeout for TCP connections.
810            
811             =item C
812              
813             A timeout for UDP connections.
814              
815             =back
816              
817             =back
818              
819             =item C
820              
821             This method starts main loop of a nameserver. See an example in a SINOPSIS.
822              
823             =back
824              
825             =head1 USING CONFIGURATION FILES - examples
826              
827             C was prepared to cooperate with
828             C module. It is possible to prepare configuration files
829             for zones and for server and then make server server run using those
830             files.
831              
832             Config file for zone I could looks like this:
833              
834             slaves = 10.1.0.1
835              
836             [NS]
837             example.com = ns.example.com
838              
839             [SOA]
840             example.com = ns.example.com
841              
842             [MX]
843             example.com = mail.example.com'
844              
845             [AAAA]
846              
847             [CNAME]
848             srv.example.com = alias.example.com, alias1.example.com
849              
850             [A]
851             ns.example.com = 10.11.12.13
852             mail.example.com = 10.11.12.14
853             web.example.com = 10.11.12.15
854             srv.example.com = 10.11.12.16
855              
856             Config file for server could looks like this:
857              
858             [FLAGS]
859             ra = 0
860              
861             [RESOLVER]
862             tcp_timeout = 50
863             udp_timeout = 50
864              
865             [CACHE]
866             size = 32m
867             expire = 3d
868             init = 1
869             unlink = 1
870             file = /var/lib/cache.db
871              
872             [SERVER]
873             address = 0.0.0.0
874             port = 53
875             verbose = 0
876             truncate = 1
877             timeout = 5
878              
879             [LOG]
880             file = /var/log/dns/mainlog.log
881             level = INFO
882              
883             And then a code of server shold looks like this:
884              
885             use Config::Tiny;
886             use Net::DNS::Nameserver::Trivial;
887            
888             # Read in config of zone -------------------------------------------
889             my $zones = Config::Tiny->read( '/path/to/zone/file.ini' );
890            
891             # Read in config of server -----------------------------------------
892             my $params = Config::Tiny->read( '/path/to/server/config.ini' );
893              
894             # Run server -------------------------------------------------------
895             my $ns = Net::DNS::Nameserver::Trivial->new( $zones, $params );
896             $ns->main_loop;
897              
898             A complete example is placed in the example directory.
899              
900             =head1 DEPENDENCIES
901              
902             =over 4
903              
904             =item Net::IP::XS
905              
906             =item Net::DNS
907              
908             =item Log::Tiny
909              
910             =item List::MoreUtils
911              
912             =item Cache::FastMmap
913              
914             =item Regexp::IPv6
915              
916             =back
917              
918             =head1 INCOMPATIBILITIES
919              
920             None known.
921              
922             =head1 BUGS AND LIMITATIONS
923              
924             I'm sure, that they must be there :-) ...but if You found one, give me
925             a feedback.
926              
927             =head1 AUTHOR
928              
929             Strzelecki Ɓukasz
930              
931             =head1 LICENCE AND COPYRIGHT
932              
933             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
934              
935             See http://www.perl.com/perl/misc/Artistic.html