$VERSION = (qw$LastChangedRevision: 688 $)[1];
$VERSION ||= 0.23;
=head1 NAME
check_soa - Check nameservers for a domain
=head1 SYNOPSIS
B<check_soa> [B<-d>] [B<-t>] [B<-v>] I<domain> [I<server> ...]
=head1 DESCRIPTION
B<check_soa> builds a list of nameservers for the zone
which contains the specified domain name.
The program queries each nameserver for the relevant SOA record
and reports the zone serial number.
=over 8
=item I<domain>
Fully qualified domain name to be tested.
Domains within ip6.arpa or in-addr.arpa namespaces
may be specified using the appropriate IP address or prefix.
=item I<server>
Optional name or list of IP addresses of specific nameserver to be tested.
Addresses are used in the sequence they appear in the argument list.
=back
Error reports are generated for nameservers which reply with non-authoritative,
outdated or incorrect information.
SOA query packets are sent to the nameservers as rapidly as the underlying
hardware will allow. The program waits for a response only when it is needed
for analysis. Execution time is determined by the slowest nameserver.
The perldoc(1) documentation page is displayed if the I<domain> argument is omitted.
This program is based on the B<check_soa> idea described by Albitz and Liu.
=head1 OPTIONS
=over 8
=item B<-d>
Turn on resolver diagnostics.
=item B<-t>
Ignore UDP datagram truncation.
=item B<-v>
Verbose output including address records for each server.
=back
=head1 EXAMPLES
=over 8
=item check_soa example.com
Query all nameservers for the specified domain.
=item check_soa example.com ns.icann.org
Query specific nameserver as above.
=item check_soa 192.168.99.0
Query nameservers for specified in-addr.arpa subdomain.
=item check_soa 2001:DB8::8:800:200C:417A
Query nameservers for specified ip6.arpa subdomain.
=item check_soa 2001:DB8:0:CD30::/60
As above, for IPv6 address prefix of specified length.
=back
=head1 BUGS
The timeout code exploits the 4 argument form of select() function.
This is not guaranteed to work in non-Unix environments.
=head1 COPYRIGHT
(c) 2003-2007 Dick Franks E<lt>rwfranks[...]acm.orgE<gt>
This program is free software;
you may use or redistribute it under the same terms as Perl itself.
=head1 SEE ALSO
Paul Albitz, Cricket Liu.
DNS and BIND, 5th Edition.
O'Reilly & Associates, 2006.
M. Andrews.
Negative Caching of DNS Queries.
RFC2308, IETF Network Working Group, 1998.
Tom Christiansen, Jon Orwant, Larry Wall.
Programming Perl, 3rd Edition.
O'Reilly & Associates, 2000.
R. Elz, R. Bush.
Clarifications to the DNS Specification.
RFC2181, IETF Network Working Group, 1997.
P. Mockapetris.
Domain Names - Concepts and Facilities.
RFC1034, IETF Network Working Group, 1987.
=cut
use strict;
use Getopt::Std;
my $self = $0; my %option;
my $options = 'dtv'; getopts("$options", \%option); my ($domain, @server) = @ARGV;
my $synopsis = "Synopsis:\t$self [-$options] domain [server]";
die eval{ system("perldoc -F $self"); "" }, "\n$synopsis\n\n" unless @ARGV;
require Net::DNS;
my @conf = ( debug => ($option{d} || 0), igntc => ($option{t} || 0), recurse => 0 );
my $verbose = $option{v};
my $neg_ttl = 86400; my $udp_timeout = 5; my $udp_wait = 0.010;
my $name = Net::DNS::Question->new($domain)->qname; die "\tFeature not supported by Net::DNS ",&Net::DNS::version,"\n"
if $name =~ m
my $resolver = Net::DNS::Resolver->new(@conf, recurse => 1 ); $resolver->nameservers(@server) || die $resolver->string;
my @ns = NS($name); unless ( @ns ) {
print $resolver->string; displayRR($name, 'NS'); displayRR($name, 'ANY'); exit; }
my @nsdname = map{lc $_->nsdname} @ns unless @server; my @nameserver = (@server, sort @nsdname);
my $zone = $ns[0]->name;
for ( displayRR($zone, 'SOA') ) { my $mname = lc $_->mname; my $rname = lc $_->rname; my $n = int $_->expire/($_->retry || 1); my $s = $n != 1 ? 's' : '';
report("data expires after $n zone transfer failure$s") unless $n > 3;
report('zone data expires before scheduled refresh') unless $_->expire > $_->refresh;
my @ncache = NCACHE($zone) if $_->minimum > $neg_ttl;
for ( @ncache ) {
my $ttl = $_->ttl; report('negative cache TTL', clock($ttl)) if $ttl > $neg_ttl;
}
next if $mname eq lc $zone;
if ( "$rname." =~ /[^\\]\.(.+)$/i ) { my $rnameok;
foreach my $type (qw(MX A AAAA)) {
my $packet = $resolver->send($1, $type);
next unless $packet;
$rnameok++ unless $packet->header->ra;
$rnameok++ if $packet->answer;
}
report("unresolved RNAME field:\t$1") unless $rnameok;
}
next if $resolver->query("$mname.", 'A'); next if $resolver->query("$mname.", 'AAAA');
report("unresolved MNAME field:\t$mname.");
next unless $mname =~ /((.+\.){2})$zone$/i; report("absolute name expected:\t$1 <----- '.' absent") if $resolver->query($1, 'ANY');
}
displayRR($zone, 'NS') if @server; displayRR($name, 'ANY');
print "----\n";
my ($bad) = checkNS($zone, @nameserver); print "\n";
exit if @server;
my $s = $bad != 1 ? 's' : '';
print "Unsatisfactory response from $bad nameserver$s\n\n" if $bad;
exit;
sub catnap { my $duration = shift; sleep(1+$duration) unless eval { defined select(undef, undef, undef, $duration) };
}
sub checkNS { my $zone = shift;
my $index = @_; my $element = pop @_ || return (0,0,{}); my ($ns, $if) = split / /, $element;
my $res = Net::DNS::Resolver->new(@conf); my @xip = sort $res->nameservers($if || $ns); @xip = $res->nameservers("$ns.") unless @xip; my $ip = pop @xip; $res->nameservers($ip) if @xip;
my ($socket, $sent) = ($res->bgsend($zone,'SOA'), time) if $ip;
my ($fail, $latest, $uniq) = checkNS($zone,@_);
my @pass = ($fail, $latest, $uniq); my @fail = ($fail+1, $latest, $uniq);
my %nsaddr;
if ( @xip and $socket ) { $nsaddr{lc $ip}++; until ($res->bgisready($socket)) { last if time > ($sent + $udp_timeout);
catnap($udp_wait);
}
}
foreach my $xip (@xip) { my ($f) = checkNS($zone, (undef)x@_, "$ns $xip") unless $nsaddr{lc $xip}++;
@pass = @fail if $f; }
my %nsname; unless ( $ip ) {
return @pass if lc $ns eq lc $zone;
print "\n[$index]\t$ns\n";
report('unresolved server name');
return @fail;
} elsif ( $ns =~ /:|^[0-9\.]+$/o ) {
print "\n[$index]\t$ip\n";
} else {
print "\n[$index]\t$ns ($ip)\n";
$nsname{lc $1}++ if $ns =~ /(.*[^\.])\.*$/o;
}
if ( $verbose ) {
foreach ( grep{$_->type eq 'PTR'} listRR($ip) ) {
$nsname{lc $_->ptrdname}++;
}
foreach my $ns ( sort keys %nsname ) { listRR($ns, 'A');
listRR($ns, 'AAAA');
}
}
my $packet;
if ( $socket ) {
until ( $res->bgisready($socket) ) { last if time > ($sent + $udp_timeout);
catnap($udp_wait); }
$packet = $res->bgread($socket) if $res->bgisready($socket); } else {
$packet = $res->send($zone, 'SOA'); }
unless ( $packet ) { report('no response');
return @fail;
}
unless ( $packet->header->rcode eq 'NOERROR' ) {
report($packet->header->rcode); return @fail; }
my $aa = $packet->header->aa; my $tc = $packet->header->tc ? 'tc' : ''; my @answer = $packet->answer; my @soa = grep{$_->type eq 'SOA'} @answer;
my @result = @fail; if ( @soa ) {
@result = @pass if $aa and @soa == 1; report(scalar @soa, 'SOA records') unless @soa == 1;
my $ttl = $soa[0]->ttl; report("non-authoritative answer\tTTL", clock($ttl)) unless $aa;
} elsif ( @soa = grep{$_->type eq 'SOA'} $packet->authority ) {
my $ttl = $soa[0]->ttl; report("NODATA response\tTTL", clock($ttl));
return @fail unless grep{$_->name =~ /^$zone$/i} @soa;
report('requested SOA in authority section; violates RFC2308');
} elsif ( my @ns = grep{$_->type eq 'NS'} $packet->authority ) {
report('referral received from nameserver'); my @n = grep{$_->nsdname =~ /$ns/i} @ns; my @a = grep{$_->rdatastr =~ /$ip/i} $packet->additional;
report('authoritative data expired') if @n or @a;
return @fail; } else {
report('NODATA response from nameserver'); return @fail; }
my $serial; for ( @soa ) {
print "$tc\t\t\tzone serial\t", ($serial = $_->serial), "\n";
$_->serial(0); next if $uniq->{lc $_->rdatastr}++; next unless keys %$uniq > 1; report('SOA record not unique'); @result = @fail;
}
return @result if $serial == $latest;
unless ( $aa and ($serial > $latest) ) { report('serial number not current') if $latest;
return @fail;
}
my $unrep = $latest ? (@_ - $fail) : 0; my $s = $unrep > 1 ? 's' : ''; report("at least $unrep previously unreported stale serial number$s") if $unrep;
return ($result[0]+$unrep, $serial, $uniq); }
sub clock { if ( (my $s = shift) < 180000 ) {
my $h = int( ($s+180)/360 )/10;
return "$s (${h}h)";
} else {
my $d = int( ($s+43200)/86400 );
return "$s (${d}d)";
}
}
sub displayRR { my $packet = $resolver->send(@_) || return (); my $header = $packet->header;
my $rcode = $header->rcode; my $na = $header->tc ? 'tc' : ''; my $aa = $header->aa ? "aa $na" : $na; my ($question) = $packet->question;
my $qname = $question->qname;
my $qtype = $question->qtype;
my @answer = $packet->answer;
my @rr = grep{$_->type !~ /^(NS|SOA)$/o} @answer; foreach ( ($qtype eq 'ANY') ? @rr : @answer) { my $string = $_->string; $string =~ s/(:[:0]*:)(?!.*::|.+\1)/::/o if $_->type eq 'AAAA';
my $l = 95; substr($string,$l) = ' ...' if length $string > $l and $_->type !~ /SOA|PTR/o;
print $_->name =~ /^$qname$/i ? $aa : $na, "\t$string\n";
}
unless ( @answer or ($rcode ne 'NOERROR') ) { my @authority = $packet->authority;
my @additional = $packet->additional;
$rcode = 'NODATA' unless @authority + @additional; $rcode = 'NODATA' if grep{$_->type eq 'SOA'} @authority; }
report("$rcode:\t", $question->string) unless $rcode eq 'NOERROR';
return @answer;
}
sub listRR { my $packet = $resolver->send(@_) || return (); my @answer = $packet->answer;
foreach ( @answer ) { my $string = $_->string; $string =~ s/(:[:0]*:)(?!.*::|.+\1)/::/o if $_->type eq 'AAAA';
print "\t$string\n";
}
return @answer;
}
sub NCACHE { my $domain = shift || '';
my $seq = time;
my $nxdomain = "_nxdn_$seq.$domain";
my $reply = $resolver->send($nxdomain) || return ();
return grep{$_->type eq 'SOA'} $reply->authority;
}
sub NS { my $domain = shift || '.';
my @ns = ();
while ( $domain ) {
my $packet = $resolver->send($domain, 'NS');
die $resolver->string unless $packet; last if @ns = grep{$_->type eq 'NS'} $packet->answer;
my ($ncache) = grep{$_->type eq 'SOA'} $packet->authority;
my $apex = $ncache->name if $ncache; return NS($apex) if $apex; return () if defined $apex; my @referral = grep{$_->type eq 'NS'} $packet->authority;
last if @ns = grep{$_->name =~ /^$domain$/i} @referral;
$resolver->recurse(0); $packet = $resolver->send($domain, 'NS');
$resolver->recurse(1);
@referral = grep{$_->type eq 'NS'} $packet->authority;
last if @ns = grep{$_->name =~ /^$domain$/i} @referral;
my ($x) = grep{$_->qtype eq 'PTR'} $packet->question;
return NS($x->qname) if $x;
($x, $domain) = split /\./, $domain, 2; }
return @ns;
}
sub report { print join(' ', '*'x4, @_, "\n");
}
__END__