#!/usr/bin/perl
use strict;
use warnings;
my $VERSION = (qw$LastChangedRevision: 1811 $)[1];
=head1 NAME
check_soa - Check nameservers for a domain
=head1 SYNOPSIS
check_soa [-d] [-n] [-s] [-t] [-v] domain [nameserver]
=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.
Error reports are generated for nameservers which reply with incorrect,
non-authoritative or outdated information.
=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 notation.
=item I<nameserver>
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
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.
This perldoc(1) documentation page is displayed if the I<domain> argument is omitted.
The 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<-n>
Report negative cache TTL.
=item B<-s>
Request DNSSEC resource records.
=item B<-t>
Ignore UDP datagram truncation.
=item B<-v>
Verbose output including address records for each nameserver.
=back
=head1 EXAMPLES
=over 8
=item check_soa example.com
Query all nameservers for the specified domain.
=item check_soa 192.0.2.1
Query nameservers for the corresponding in-addr.arpa subdomain.
=item check_soa 2001:DB8::8:800:200C:417A
Query nameservers for the corresponding ip6.arpa subdomain.
=item check_soa 2001:DB8:0:CD30::/60
As above, for IPv6 address prefix of specified length.
=item check_soa 192.0.2.1 z.arin.net
Query specific nameserver as above.
=back
=head1 BUGS
The program can become confused by zones which originate,
or appear to originate, from more than one primary server.
The timeout code uses the perl 4-argument select() function.
This is not guaranteed to work in non-Unix environments.
=head1 COPYRIGHT
(c) 2003-2011 Dick Franks E<lt>rwfranks[...]acm.orgE<gt>
All rights reserved.
FOR DEMONSTRATION PURPOSES ONLY, NO WARRANTY, NO SUPPORT
=head1 SEE ALSO
Paul Albitz, Cricket Liu.
DNS and BIND, 5th Edition.
O'Reilly, 2006.
Andrews, M.,
Locally Served DNS Zones,
RFC6303, IETF, 2011.
Andrews, M.,
Negative Caching of DNS Queries,
RFC2308, IETF Network Working Group, 1998.
Elz, R., Bush, R.,
Clarifications to the DNS Specification,
RFC2181, IETF Network Working Group, 1997.
Mockapetris, P.,
Domain Names - Implementation and Specification,
RFC 1035, USC/ISI, 1987.
Larry Wall, Tom Christiansen, Jon Orwant.
Programming Perl, 3rd Edition.
O'Reilly, 2000.
=cut
use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see UTR#16 3.6]
require Encode;
Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' );
};
my $self = $0; # script
my $options = 'dnstv'; # options
my %option;
eval { require Getopt::Std; Getopt::Std::getopts( $options, \%option ) };
warn "Can't locate Getopt::Std\n" if $@;
my @arg = qw( domain [nameserver] ); # arguments
my @flag = map { "[-$_]" } split( //, $options ); # documentation
die eval { system("perldoc -F $self"); "" }, <<END unless scalar @ARGV;
Synopsis: $self @flag @arg
END
my ( $target, @nameserver ) = @ARGV;
my $domain = UTF8 && $target =~ /[^\000-\177]/ ? Encode::decode_utf8($target) : $target;
require Net::DNS;
my @conf = (
debug => ( $option{d} || 0 ), # -d enable diagnostics
igntc => ( $option{t} || 0 ), # -t ignore truncation
udppacketsize => 1024
);
my $negtest = $option{n}; # -n report NCACHE TTL
my $dnssec = $option{s}; # -s request DNSSEC RRs
my $verbose = $option{v}; # -v verbose
my $neg_min = 300; # NCACHE TTL reporting threshold
my $neg_max = 86400; # NCACHE TTL reporting threshold
my $udp_timeout = 5; # timeout for concurrent queries
my $udp_wait = 0.100; # minimum polling interval
local $SIG{__WARN__} = sub { }; # suppress all warnings
my $resolver = Net::DNS::Resolver->new(@conf); # create resolver object
$resolver->nameservers(@nameserver) or die $resolver->string;
my $question = Net::DNS::Question->new($domain); # invert IP address/prefix
my $name = lc $question->qname;
my $NetDNSrev = &Net::DNS::version;
die "\tFeature not supported by Net::DNS $NetDNSrev\n" if $name =~ m#[:/\s]|\.\d+$#;
my $packet = $resolver->send( "_nx_.$name", 'CNAME' ) or die $resolver->errorstring;
my ($zone) = map { lc( $_->name ) } $packet->authority;
my @ns = ( $zone or $name eq '.' ) ? NS($zone) : (); # find NS serving name
die "\nno such zone: $name\n\n", $resolver->string unless @ns; # game over
my @nsname = grep { $_ ne $zone } map { $_->nsdname } @ns; # extract server names from NS records
my @server = @nameserver ? (@nameserver) : ( sort @nsname );
$resolver->dnssec(1) if $dnssec;
my @soa = grep { $_->type eq 'SOA' } displayRR( $zone, 'SOA' );
foreach my $soa (@soa) { # simple sanity check
my $owner = lc $soa->name; # zone name
my $mname = lc $soa->mname; # primary server
my $rname = lc $soa->rname; # responsible person
my $resolved; # check MNAME resolvable
foreach my $rrtype (qw( A AAAA CNAME )) {
my $probe = $resolver->send( $mname, $rrtype ) || next;
last if ( $resolved = scalar $probe->answer );
}
for ($mname) {
last unless $_ eq $owner; # RFC6303 local zone
displayRR( $zone, 'NS' ) unless @nameserver; # ensure NS always listed
last unless /(in-addr|ip6)\.arpa/i;
report('unexpected address record in locally served zone [RFC6303]') if $resolved;
}
last unless @nsname; # suppress remaining tests
report( 'unresolved MNAME', $mname ) unless $resolved;
unless ( $rname =~ /(@|[^\\]\.)([^@]+)$/ ) { # parse RNAME
report( 'incomplete RNAME', $rname ) unless $rname eq '<>';
} elsif ( $2 ne $mname ) {
my $resolved; # check RNAME resolvable
foreach my $rrtype (qw( MX A AAAA CNAME )) {
my $probe = $resolver->send( $2, $rrtype );
last if ( $resolved = scalar $probe->answer );
}
report( 'unresolved RNAME', $rname ) unless $resolved;
}
unless ( $soa->expire > $soa->refresh ) { # check refresh/retry timing
report('zone data expires with no refresh');
} else {
my $window = $soa->expire - $soa->refresh - 1; # zone transfer window
my $retry = $soa->retry || 1; # retry interval
my $n = 1 + int( $window / $retry ); # number of transfer attempts
my $s = $n > 1 ? 's' : '';
report("zone data expires after $n transfer failure$s") unless $n > 3;
}
my ($min) = sort { $a <=> $b } ( $soa->minimum, $soa->ttl ); # force NCACHE test for extreme TTLs
$negtest++ if $min < $neg_min or $soa->minimum > $neg_max;
}
my @ncache = $negtest ? NCACHE($zone) : (); # report observed NCACHE TTL
displayRR( $zone, 'NS' ) if @nameserver; # show NS if testing specific nameserver
$resolver->usevc(1); # no longer ok to query ANY over UDP
$resolver->nameservers(@server);
displayRR( $name, 'ANY' );
print "----\n";
my ( $bad, $seq, $iphash ) = checkNS( $zone, @server ); # report status
$iphash->{$seq} ||= '<unidentified>';
print "\n";
my $s = $bad != 1 ? 's' : '';
print "Unsatisfactory response from $bad nameserver$s\n\n" if $bad and @server > 1;
my %mname = reverse %$iphash; # invert address hash
my $mcount = keys %mname; # number of distinct MNAMEs
if ( $mcount > 1 ) {
report('SOAs do not identify unique primary server'); # RFC1034, 4.3.5
foreach my $mname ( sort keys %mname ) {
foreach ( $mname, $resolver->nameservers($mname) ) { delete $iphash->{$_} }
}
my %serial = map { ( $iphash->{$_} => $_ ) } sort { $a <=> $b } keys %$iphash;
foreach ( sort keys %mname ) { report( sprintf '%10s %s', $serial{$_}, $_ ) }
}
exit;
sub checkNS0 { ## initial status vector for checkNS
my $serial = undef;
my $hash = {};
my $res = Net::DNS::Resolver->new(@conf);
foreach my $soa ( grep { $_->type eq 'SOA' } @ncache, @soa ) {
my $mname = lc $soa->mname; # populate hash with name/IP of primary
next if $mname eq lc $soa->name; # RFC6303 local zone
foreach ( $mname, $res->nameservers($mname) ) { $hash->{$_} = $mname }
my $s = $soa->serial;
$hash->{$s} = $mname;
$serial = $s if ordered( $serial, $s );
}
return ( 0, $serial, $hash );
}
sub checkNS { ## query nameservers (concurrently) and report status
my $zone = shift;
my $index = scalar @_; # index last element
my $element = pop(@_) || return checkNS0; # pop element, terminate if undef
my ( $ns, $if ) = split / /, lc $element; # name + optional interface IP
my $res = Net::DNS::Resolver->new(@conf); # use clean resolver for each test
my @xip = $res->nameservers( $if || $ns ); # point at nameserver
my $ip = pop @xip; # last (or only) interface
$res->nameservers($ip) if @xip;
$res->recurse(0); # send non-recursive query to nameserver
my ( $socket, $sent );
( $socket, $sent ) = ( $res->bgsend( $zone, 'SOA' ), time ) if $ip;
my ( $fail, $latest, $hash ) = checkNS( $zone, @_ ); # recurse to query others concurrently
# pick up response as recursion unwinds
my $packet;
if ($socket) {
until ( $res->bgisready($socket) ) { # timed wait on socket
last if time > ( $sent + $udp_timeout );
delay($udp_wait); # snatch a few milliseconds sleep
}
$packet = $res->bgread($socket) if $res->bgisready($socket); # get response
} elsif ($ip) {
$packet = $res->send( $zone, 'SOA' ); # use sequential query model
}
my @pass = ( $fail, $latest, $hash ); # use prebuilt return values
my @fail = ( $fail + 1, $latest, $hash );
my %nsaddr = $ip ? ( $ip => 1 ) : (); # special handling for multihomed server
foreach my $xip (@xip) { # iterate over remaining interfaces
next if $nsaddr{$xip}++; # silently ignore duplicate address record
my ( $f, $x, $h ) = checkNS( $zone, (undef) x scalar(@_), "$ns $xip" );
%$hash = ( %$hash, %$h ); # merge address hashes
@pass = @fail if $f; # propagate failure to caller
}
my $rcode;
my @soa;
unless ($packet) { # ... is no more! It has ceased to be!
$rcode = 'no response';
} elsif ( $packet->header->rcode ne 'NOERROR' ) {
$rcode = $packet->header->rcode; # NXDOMAIN or fault at nameserver
} else {
@soa = grep { $_->type eq 'SOA' } $packet->answer;
foreach my $soa (@soa) {
my $mname = lc $soa->mname; # hash MNAME by IP
my @ip = $hash->{$mname} ? () : $res->nameservers($mname);
foreach ( $mname, @ip ) { $hash->{$_} = $mname }
}
}
my $primary = $hash->{$ip || $ns} ? '*' : ''; # flag zone primary
unless ($ip) { # identify nameserver
print "\n[$index]$primary\t$ns\n"; # name only
$rcode = 'unresolved server name';
} elsif ( $ns eq $ip ) {
print "\n[$index]$primary\t$ip\n"; # ip only
} else {
print "\n[$index]$primary\t$ns [$ip]\n"; # name and ip
}
if ($verbose) { # show PTR record
my @ptr = grep { $_->type eq 'PTR' } $ip ? displayRR($ip) : ();
my @fwd = sort map { lc $_->ptrdname } @ptr;
foreach my $name ( @fwd ? @fwd : ($ns) ) { # show address records
displayRR( $name, 'A' );
displayRR( $name, 'AAAA' );
}
}
if ($rcode) {
return @pass if $ns eq lc $zone; # RFC6303 local zone
report($rcode); # abject failure
return @fail;
}
my @result = @fail; # analyse response
my @auth = @soa ? () : $packet->authority;
my @ncache = grep { $_->type eq 'SOA' } @auth;
my @refer = grep { $_->type eq 'NS' } @auth;
if (@soa) {
if ( @soa > 1 ) {
report('multiple SOA records'); # RFC2181, 6.1
} elsif ( $packet->header->aa ) {
@result = @pass; # RFC1034, 6.2.1(1)
} else {
my $ttl = $soa[0]->ttl; # RFC1034, 6.2.1(2)
report( 'non-authoritative answer', ttl($ttl) );
}
} elsif (@ncache) {
my ($ttl) = map { $_->ttl } @soa = @ncache; # RFC2308, 2.2(1)(2)
report( 'negative cache', ttl($ttl) );
return @fail unless grep { $_->name =~ /^$zone$/i } @ncache;
report('requested SOA in authority section; violates RFC2308');
} elsif (@refer) {
my @n = grep { $_->nsdname =~ /$ns/i } @refer; # RFC2308, 2.2(4)
report('authoritative data expired') if @n; # self referral
report('not configured for zone') unless @n;
return @fail;
} else {
report('NOERROR (no data)'); # RFC2308, 2.2(3)
return @fail;
}
report('truncated response from nameserver') if $packet->header->tc;
my ($serial) = map { $_->serial } @soa; # check serial number
if ( $primary && ordered( $serial, $latest ) ) { # primary should have latest data
my $response = $res->send( $zone, 'SOA' ); # repeat test before pointing finger
my ($retest) = grep { $_->type eq 'SOA' } $response ? $response->answer : ();
$serial = $retest->serial if ordered( $serial, $retest->serial );
}
print "\t\t\tzone serial\t", $serial, "\n";
$hash->{$serial} = $hash->{$ip} if $primary;
if ( ordered( $serial, $latest ) ) {
report('serial number not current');
return @fail unless $primary;
report('discredited as unique primary nameserver');
return @fail;
}
return @result if $serial == $latest;
my $x = $if ? 0 : ( $index - 1 ) - $fail; # all previous out of date
my $s = $x > 1 ? 's' : ''; # pedants really are revolting!
report("at least $x previously unreported stale serial number$s") if $x;
return ( $result[0] + $x, $serial, $hash ); # restate partial result
}
sub delay { ## short duration sleep
my $duration = shift; # seconds
sleep( 1 + $duration ) unless eval { defined select( undef, undef, undef, $duration ) }; ## no critic
return;
}
sub displayRR { ## print specified RRs or error code
my $packet = $resolver->send(@_) or return (); # get specified RRs
my $header = $packet->header;
my $rcode = $header->rcode; # response code
my ($question) = $packet->question;
my $qtype = $question->qtype;
my $qname = $question->qname;
my $name = $qname =~ /^xn--/ ? eval { $question->name } : '';
my @annotation = $name ? ("; $name\n") : ();
my @answer = $packet->answer;
my @authority = $packet->authority;
my @ncache = grep { $_->type eq 'SOA' } @authority; # per RFC2308
my @workaround = $qtype eq 'SOA' ? @ncache : (); # SOA misplaced/withheld?
my @remark = @workaround ? qw(unexpected) : ();
foreach my $rr ( @answer, @workaround ) { # print RRs unless shown elsewhere
next if $qtype eq 'ANY' && $rr->type =~ /^(SOA|NS|RRSIG)$/;
print @annotation if $rr->name eq $qname; # annotate IDN
for ( $rr->string ) {
my $l = $verbose ? length($_) : 108; # abbreviate long RR
substr( $_, $l ) = ' ...' if length($_) > $l && $rr->type ne 'SOA';
print "$_\n";
}
}
report( @remark, "$rcode:", $question->string, @annotation ) if $rcode ne 'NOERROR';
return @answer;
}
sub NCACHE { ## report observed NCACHE TTL for domain
my $domain = shift || '';
my $seq = time;
my $nxdomain = "_nx_$seq.$domain"; # intentionally perverse query
my $reply = $resolver->send( $nxdomain, 'PTR' ) or return ();
for ( $reply->answer ) {
report( 'wildcard invalidates NCACHE test:', $_->string );
return ();
}
my @ncache = grep { $_->type eq 'SOA' } $reply->authority;
for (@ncache) {
my $serial = $_->serial;
my ($seen) = ( @soa, @ncache );
my @source = $serial > $seen->serial ? ("\t(SOA: $serial)") : ();
report( 'negative cache data', ttl( $_->ttl ), @source );
}
return @ncache;
}
sub NS { ## find NS records for domain
my $name = shift;
my $packet = $resolver->send( $name, 'NS' ) or die $resolver->string;
# Bear in mind the possibility of malformed zones!
return ( grep { $_->type eq 'NS' } $packet->answer, $packet->authority );
}
sub ordered { ## irreflexive 32-bit partial ordering
use integer;
my ( $l, $r ) = @_;
return defined $r unless defined $l; # ( undef, any )
return 0 unless defined $r; # ( any, undef )
# unwise to assume 32-bit arithmetic, or that integer overflow goes unpunished
if ( $l < 0 ) { # translate $a<0 region
$l = ( $l ^ 0x80000000 ) & 0xFFFFFFFF; # 0 <= $l < 2**31
$r = ( $r ^ 0x80000000 ) & 0xFFFFFFFF; # -2**31 <= $r < 2**32
}
return $l < $r ? ( $l > ( $r - 0x80000000 ) ) : ( $b < ( $l - 0x80000000 ) );
}
sub report { ## concatenate strings into fault report
return print '### ', join( "\t", @_ ), "\n";
}
sub ttl { ## human-friendly TTL
my $t = shift;
my ( $s, $m, $h, $y, $d ) = ( gmtime($t) )[0 .. 2, 5, 7];
unless ( $y == 70 ) {
return sprintf 'TTL %u (%uy%ud)', $t, $y - 70, $d;
} elsif ($h) {
return sprintf 'TTL %u (%ud%0.2uh)', $t, $d, $h if $d;
return sprintf 'TTL %u (%uh%0.2um)', $t, $h, $m if $m;
return sprintf 'TTL %u (%uh)', $t, $h;
} else {
return sprintf 'TTL %u (%ud)', $t, $d if $d;
return sprintf 'TTL %u (%um%0.2us)', $t, $m, $s if $s;
return sprintf 'TTL %u (%um)', $t, $m;
}
}
__END__
Generated by dwww version 1.14 on Sat Sep 6 10:39:22 CEST 2025.