File Coverage

blib/lib/Net/DNS/Nameserver/Trivial.pm
Criterion Covered Total %
statement 60 258 23.2
branch 0 94 0.0
condition 0 64 0.0
subroutine 20 27 74.0
pod 2 2 100.0
total 82 445 18.4


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