1#!/usr/bin/perl -w 2$VERSION = (qw$LastChangedRevision: 688 $)[1]; 3$VERSION ||= 0.23; 4 5=head1 NAME 6 7check_soa - Check nameservers for a domain 8 9=head1 SYNOPSIS 10 11B<check_soa> [B<-d>] [B<-t>] [B<-v>] I<domain> [I<server> ...] 12 13=head1 DESCRIPTION 14 15B<check_soa> builds a list of nameservers for the zone 16which contains the specified domain name. 17The program queries each nameserver for the relevant SOA record 18and reports the zone serial number. 19 20=over 8 21 22=item I<domain> 23 24Fully qualified domain name to be tested. 25Domains within ip6.arpa or in-addr.arpa namespaces 26may be specified using the appropriate IP address or prefix. 27 28=item I<server> 29 30Optional name or list of IP addresses of specific nameserver to be tested. 31Addresses are used in the sequence they appear in the argument list. 32 33=back 34 35Error reports are generated for nameservers which reply with non-authoritative, 36outdated or incorrect information. 37 38SOA query packets are sent to the nameservers as rapidly as the underlying 39hardware will allow. The program waits for a response only when it is needed 40for analysis. Execution time is determined by the slowest nameserver. 41 42The perldoc(1) documentation page is displayed if the I<domain> argument is omitted. 43 44This program is based on the B<check_soa> idea described by Albitz and Liu. 45 46=head1 OPTIONS 47 48=over 8 49 50=item B<-d> 51 52Turn on resolver diagnostics. 53 54=item B<-t> 55 56Ignore UDP datagram truncation. 57 58=item B<-v> 59 60Verbose output including address records for each server. 61 62=back 63 64=head1 EXAMPLES 65 66=over 8 67 68=item check_soa example.com 69 70Query all nameservers for the specified domain. 71 72=item check_soa example.com ns.icann.org 73 74Query specific nameserver as above. 75 76=item check_soa 192.168.99.0 77 78Query nameservers for specified in-addr.arpa subdomain. 79 80=item check_soa 2001:DB8::8:800:200C:417A 81 82Query nameservers for specified ip6.arpa subdomain. 83 84=item check_soa 2001:DB8:0:CD30::/60 85 86As above, for IPv6 address prefix of specified length. 87 88=back 89 90=head1 BUGS 91 92The timeout code exploits the 4 argument form of select() function. 93This is not guaranteed to work in non-Unix environments. 94 95=head1 COPYRIGHT 96 97(c) 2003-2007 Dick Franks E<lt>rwfranks[...]acm.orgE<gt> 98 99This program is free software; 100you may use or redistribute it under the same terms as Perl itself. 101 102=head1 SEE ALSO 103 104Paul Albitz, Cricket Liu. 105DNS and BIND, 5th Edition. 106O'Reilly & Associates, 2006. 107 108M. Andrews. 109Negative Caching of DNS Queries. 110RFC2308, IETF Network Working Group, 1998. 111 112Tom Christiansen, Jon Orwant, Larry Wall. 113Programming Perl, 3rd Edition. 114O'Reilly & Associates, 2000. 115 116R. Elz, R. Bush. 117Clarifications to the DNS Specification. 118RFC2181, IETF Network Working Group, 1997. 119 120P. Mockapetris. 121Domain Names - Concepts and Facilities. 122RFC1034, IETF Network Working Group, 1987. 123 124=cut 125 126use strict; 127use Getopt::Std; 128 129my $self = $0; # script 130my %option; 131my $options = 'dtv'; # options 132getopts("$options", \%option); # also --help --version 133my ($domain, @server) = @ARGV; # arguments 134 135my $synopsis = "Synopsis:\t$self [-$options] domain [server]"; 136die eval{ system("perldoc -F $self"); "" }, "\n$synopsis\n\n" unless @ARGV; 137 138 139require Net::DNS; 140 141my @conf = ( debug => ($option{d} || 0), # -d enable diagnostics 142 igntc => ($option{t} || 0), # -t ignore truncation 143 recurse => 0 ); 144 145my $verbose = $option{v}; # -v verbose 146 147my $neg_ttl = 86400; # NCACHE TTL reporting threshold 148my $udp_timeout = 5; # timeout for parallel operations 149my $udp_wait = 0.010; # minimum polling interval 150 151 152my $name = Net::DNS::Question->new($domain)->qname; # invert IP address/prefix 153die "\tFeature not supported by Net::DNS ",&Net::DNS::version,"\n" 154 if $name =~ m#:[A-Fa-f0-9:]+[0-9.]*$|\s\.ip6|/\d+$#; 155 156my $resolver = Net::DNS::Resolver->new(@conf, recurse => 1 ); # create resolver object 157$resolver->nameservers(@server) || die $resolver->string; 158 159my @ns = NS($name); # find NS serving name 160unless ( @ns ) { 161 print $resolver->string; # show resolver state 162 displayRR($name, 'NS'); # show response code 163 displayRR($name, 'ANY'); # show any RR for name 164 exit; # game over 165} 166 167my @nsdname = map{lc $_->nsdname} @ns unless @server; # extract server names from NS records 168my @nameserver = (@server, sort @nsdname); 169 170my $zone = $ns[0]->name; # find zone name 171 172for ( displayRR($zone, 'SOA') ) { # simple sanity check 173 my $mname = lc $_->mname; # primary server 174 my $rname = lc $_->rname; # mailbox of person responsible for zone 175 my $n = int $_->expire/($_->retry || 1); # number of transfer attempts 176 my $s = $n != 1 ? 's' : ''; 177 report("data expires after $n zone transfer failure$s") unless $n > 3; 178 report('zone data expires before scheduled refresh') unless $_->expire > $_->refresh; 179 180 my @ncache = NCACHE($zone) if $_->minimum > $neg_ttl; 181 for ( @ncache ) { 182 my $ttl = $_->ttl; # flag large NCACHE TTL 183 report('negative cache TTL', clock($ttl)) if $ttl > $neg_ttl; 184 } 185 186 next if $mname eq lc $zone; # local zone 187 188 if ( "$rname." =~ /[^\\]\.(.+)$/i ) { # check mail domain for RNAME 189 my $rnameok; 190 foreach my $type (qw(MX A AAAA)) { 191 my $packet = $resolver->send($1, $type); 192 next unless $packet; 193 $rnameok++ unless $packet->header->ra; 194 $rnameok++ if $packet->answer; 195 } 196 report("unresolved RNAME field:\t$1") unless $rnameok; 197 } 198 199 next if $resolver->query("$mname.", 'A'); # skip if address record exists 200 next if $resolver->query("$mname.", 'AAAA'); 201 report("unresolved MNAME field:\t$mname."); # RFC2181, 7.3 202 203 next unless $mname =~ /((.+\.){2})$zone$/i; # missing final dot? 204 report("absolute name expected:\t$1 <----- '.' absent") if $resolver->query($1, 'ANY'); 205} 206 207displayRR($zone, 'NS') if @server; # show NS if testing specified server 208displayRR($name, 'ANY'); # show RR for user-specified name 209 210print "----\n"; 211 212my ($bad) = checkNS($zone, @nameserver); # report status 213print "\n"; 214exit if @server; 215my $s = $bad != 1 ? 's' : ''; 216print "Unsatisfactory response from $bad nameserver$s\n\n" if $bad; 217 218exit; 219 220 221sub catnap { # short duration sleep 222 my $duration = shift; # seconds 223 sleep(1+$duration) unless eval { defined select(undef, undef, undef, $duration) }; 224} 225 226 227sub checkNS { # check nameservers (in parallel) and report status 228 my $zone = shift; 229 my $index = @_; # index last element 230 my $element = pop @_ || return (0,0,{}); # pop element, terminate if undef 231 my ($ns, $if) = split / /, $element; # name + optional interface IP 232 233 my $res = Net::DNS::Resolver->new(@conf); # use clean resolver for each test 234 my @xip = sort $res->nameservers($if || $ns); # point at nameserver 235 @xip = $res->nameservers("$ns.") unless @xip; # retry as absolute name (eg. localhost.) 236 my $ip = pop @xip; # last (or only) interface 237 $res->nameservers($ip) if @xip; 238 # send query packet to nameserver 239 my ($socket, $sent) = ($res->bgsend($zone,'SOA'), time) if $ip; 240 241 my ($fail, $latest, $uniq) = checkNS($zone,@_); # recurse to query others in parallel 242 # pick up response as recursion unwinds 243 244 my @pass = ($fail, $latest, $uniq); # use prebuilt return values 245 my @fail = ($fail+1, $latest, $uniq); 246 247 my %nsaddr; 248 if ( @xip and $socket ) { # special handling for multihomed server 249 $nsaddr{lc $ip}++; # silently ignore duplicate address record 250 until ($res->bgisready($socket)) { # wait for outstanding query to complete 251 last if time > ($sent + $udp_timeout); 252 catnap($udp_wait); 253 } 254 } 255 foreach my $xip (@xip) { # iterate over remaining interfaces 256 my ($f) = checkNS($zone, (undef)x@_, "$ns $xip") unless $nsaddr{lc $xip}++; 257 @pass = @fail if $f; # propagate failure to caller 258 } 259 260 my %nsname; # identify nameserver 261 unless ( $ip ) { 262 return @pass if lc $ns eq lc $zone; 263 print "\n[$index]\t$ns\n"; 264 report('unresolved server name'); 265 return @fail; 266 } elsif ( $ns =~ /:|^[0-9\.]+$/o ) { 267 print "\n[$index]\t$ip\n"; 268 } else { 269 print "\n[$index]\t$ns ($ip)\n"; 270 $nsname{lc $1}++ if $ns =~ /(.*[^\.])\.*$/o; 271 } 272 273 if ( $verbose ) { 274 foreach ( grep{$_->type eq 'PTR'} listRR($ip) ) { 275 $nsname{lc $_->ptrdname}++; 276 } 277 foreach my $ns ( sort keys %nsname ) { # show address records 278 listRR($ns, 'A'); 279 listRR($ns, 'AAAA'); 280 } 281 } 282 283 my $packet; 284 if ( $socket ) { 285 until ( $res->bgisready($socket) ) { # timed wait on socket 286 last if time > ($sent + $udp_timeout); 287 catnap($udp_wait); # snatch a few milliseconds sleep 288 } 289 $packet = $res->bgread($socket) if $res->bgisready($socket); # get response 290 } else { 291 $packet = $res->send($zone, 'SOA'); # use sequential query model 292 } 293 294 unless ( $packet ) { # ... is no more! It has ceased to be! 295 report('no response'); 296 return @fail; 297 } 298 299 unless ( $packet->header->rcode eq 'NOERROR' ) { 300 report($packet->header->rcode); # NXDOMAIN or fault at nameserver 301 return @fail; # RFC2308, 2.1 302 } 303 304 my $aa = $packet->header->aa; # authoritative answer 305 my $tc = $packet->header->tc ? 'tc' : ''; # truncated response 306 my @answer = $packet->answer; # answer section 307 my @soa = grep{$_->type eq 'SOA'} @answer; # SOA records (plural!) 308 309 my @result = @fail; # analyse response 310 if ( @soa ) { 311 @result = @pass if $aa and @soa == 1; # RFC2181, 6.1 312 report(scalar @soa, 'SOA records') unless @soa == 1; 313 my $ttl = $soa[0]->ttl; # RFC1034, 6.2.1 (2) 314 report("non-authoritative answer\tTTL", clock($ttl)) unless $aa; 315 } elsif ( @soa = grep{$_->type eq 'SOA'} $packet->authority ) { 316 my $ttl = $soa[0]->ttl; # RFC2308, 2.2 (1)(2) 317 report("NODATA response\tTTL", clock($ttl)); 318 return @fail unless grep{$_->name =~ /^$zone$/i} @soa; 319 report('requested SOA in authority section; violates RFC2308'); 320 } elsif ( my @ns = grep{$_->type eq 'NS'} $packet->authority ) { 321 report('referral received from nameserver'); # RFC2308, 2.2 (4) 322 my @n = grep{$_->nsdname =~ /$ns/i} @ns; # self referral? 323 my @a = grep{$_->rdatastr =~ /$ip/i} $packet->additional; 324 report('authoritative data expired') if @n or @a; 325 return @fail; # RFC2181, 6.1 326 } else { 327 report('NODATA response from nameserver'); # RFC2308, 2.2 (3) 328 return @fail; # RFC2181, 6.1 329 } 330 331 my $serial; # zone serial number 332 for ( @soa ) { 333 print "$tc\t\t\tzone serial\t", ($serial = $_->serial), "\n"; 334 $_->serial(0); # key on static fields only 335 next if $uniq->{lc $_->rdatastr}++; # skip repeated occurrences 336 next unless keys %$uniq > 1; # zone should have unique SOA 337 report('SOA record not unique'); # RFC2181, 6.1 338 @result = @fail; 339 } 340 341 return @result if $serial == $latest; # server has latest data 342 343 unless ( $aa and ($serial > $latest) ) { # unexpected serial number 344 report('serial number not current') if $latest; 345 return @fail; 346 } 347 348 my $unrep = $latest ? (@_ - $fail) : 0; # all previous out of date 349 my $s = $unrep > 1 ? 's' : ''; # pedants really are revolting! 350 report("at least $unrep previously unreported stale serial number$s") if $unrep; 351 return ($result[0]+$unrep, $serial, $uniq); # restate partial result 352} 353 354 355sub clock { # human-friendly TTL 356 if ( (my $s = shift) < 180000 ) { 357 my $h = int( ($s+180)/360 )/10; 358 return "$s (${h}h)"; 359 } else { 360 my $d = int( ($s+43200)/86400 ); 361 return "$s (${d}d)"; 362 } 363} 364 365 366sub displayRR { # print specified RRs with flags or error code 367 my $packet = $resolver->send(@_) || return (); # get specified RRs 368 my $header = $packet->header; 369 my $rcode = $header->rcode; # response code 370 my $na = $header->tc ? 'tc' : ''; # non-auth response 371 my $aa = $header->aa ? "aa $na" : $na; # authoritative answer 372 my ($question) = $packet->question; 373 my $qname = $question->qname; 374 my $qtype = $question->qtype; 375 my @answer = $packet->answer; 376 my @rr = grep{$_->type !~ /^(NS|SOA)$/o} @answer; # almost ANY 377 foreach ( ($qtype eq 'ANY') ? @rr : @answer) { # print RR with status flags 378 my $string = $_->string; # display IPv6 compact form 379 $string =~ s/(:[:0]*:)(?!.*::|.+\1)/::/o if $_->type eq 'AAAA'; 380 my $l = 95; # abbreviate long RR 381 substr($string,$l) = ' ...' if length $string > $l and $_->type !~ /SOA|PTR/o; 382 print $_->name =~ /^$qname$/i ? $aa : $na, "\t$string\n"; 383 } 384 unless ( @answer or ($rcode ne 'NOERROR') ) { # NODATA pseudo-RCODE per RFC2308, 2.2 385 my @authority = $packet->authority; 386 my @additional = $packet->additional; 387 $rcode = 'NODATA' unless @authority + @additional; # type 3 388 $rcode = 'NODATA' if grep{$_->type eq 'SOA'} @authority; # type 1 or 2 389 } 390 report("$rcode:\t", $question->string) unless $rcode eq 'NOERROR'; 391 return @answer; 392} 393 394 395sub listRR { # print specified RRs without flags or error code 396 my $packet = $resolver->send(@_) || return (); # get specified RRs 397 my @answer = $packet->answer; 398 foreach ( @answer ) { # print RR 399 my $string = $_->string; # display IPv6 compact form 400 $string =~ s/(:[:0]*:)(?!.*::|.+\1)/::/o if $_->type eq 'AAAA'; 401 print "\t$string\n"; 402 } 403 return @answer; 404} 405 406 407sub NCACHE { # get NCACHE SOA for domain 408 my $domain = shift || ''; 409 my $seq = time; 410 my $nxdomain = "_nxdn_$seq.$domain"; 411 my $reply = $resolver->send($nxdomain) || return (); 412 return grep{$_->type eq 'SOA'} $reply->authority; 413} 414 415 416sub NS { # find nameservers for domain 417 my $domain = shift || '.'; 418 my @ns = (); 419 while ( $domain ) { 420 my $packet = $resolver->send($domain, 'NS'); 421 die $resolver->string unless $packet; # local resolver problem 422 last if @ns = grep{$_->type eq 'NS'} $packet->answer; 423 my ($ncache) = grep{$_->type eq 'SOA'} $packet->authority; 424 my $apex = $ncache->name if $ncache; # zone cut 425 return NS($apex) if $apex; # NODATA from zone server 426 return () if defined $apex; # NXDOMAIN from root server 427 # accept referral if any 428 my @referral = grep{$_->type eq 'NS'} $packet->authority; 429 last if @ns = grep{$_->name =~ /^$domain$/i} @referral; 430 $resolver->recurse(0); # retry as non-recursive query 431 $packet = $resolver->send($domain, 'NS'); 432 $resolver->recurse(1); 433 @referral = grep{$_->type eq 'NS'} $packet->authority; 434 last if @ns = grep{$_->name =~ /^$domain$/i} @referral; 435 # IP (pre 0.59 compatibility) 436 my ($x) = grep{$_->qtype eq 'PTR'} $packet->question; 437 return NS($x->qname) if $x; 438 ($x, $domain) = split /\./, $domain, 2; # strip leftmost label 439 } 440 return @ns; 441} 442 443 444sub report { # concatenate strings into fault report 445 print join(' ', '*'x4, @_, "\n"); 446} 447 448__END__ 449