#!/usr/bin/perl -w
$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;						# script
my %option;
my $options = 'dtv';					# options
getopts("$options", \%option);				# also  --help  --version
my ($domain, @server) = @ARGV;				# arguments

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),		# -d	enable diagnostics
		igntc	=> ($option{t} || 0),		# -t	ignore truncation
		recurse	=> 0	);

my $verbose = $option{v};				# -v	verbose

my $neg_ttl	= 86400;				# NCACHE TTL reporting threshold
my $udp_timeout	= 5;					# timeout for parallel operations
my $udp_wait	= 0.010;				# minimum polling interval


my $name = Net::DNS::Question->new($domain)->qname;	# invert IP address/prefix
die "\tFeature not supported by Net::DNS ",&Net::DNS::version,"\n"
					if $name =~ m#:[A-Fa-f0-9:]+[0-9.]*$|\s\.ip6|/\d+$#;

my $resolver = Net::DNS::Resolver->new(@conf, recurse => 1 );	# create resolver object
$resolver->nameservers(@server) || die $resolver->string;

my @ns = NS($name);					# find NS serving name
unless ( @ns ) {
	print $resolver->string;			# show resolver state
	displayRR($name, 'NS');				# show response code
	displayRR($name, 'ANY');			# show any RR for name
	exit;						# game over
}

my @nsdname = map{lc $_->nsdname} @ns unless @server;	# extract server names from NS records
my @nameserver = (@server, sort @nsdname);

my $zone = $ns[0]->name;				# find zone name

for ( displayRR($zone, 'SOA') ) {			# simple sanity check
	my $mname = lc $_->mname;			# primary server
	my $rname = lc $_->rname;			# mailbox of person responsible for zone
	my $n = int $_->expire/($_->retry || 1);	# number of transfer attempts
	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;			# flag large NCACHE TTL
		report('negative cache TTL', clock($ttl)) if $ttl > $neg_ttl;
	}

	next if $mname eq lc $zone;			# local zone

	if ( "$rname." =~ /[^\\]\.(.+)$/i ) {		# check mail domain for RNAME
		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');	# skip if address record exists
	next if $resolver->query("$mname.", 'AAAA');
	report("unresolved MNAME field:\t$mname.");		# RFC2181, 7.3

	next unless $mname =~ /((.+\.){2})$zone$/i;	# missing final dot?
	report("absolute name expected:\t$1  <----- '.' absent") if $resolver->query($1, 'ANY');
}

displayRR($zone, 'NS') if @server;			# show NS if testing specified server
displayRR($name, 'ANY');				# show RR for user-specified name

print "----\n";

my ($bad) = checkNS($zone, @nameserver);		# report status
print "\n";
exit if @server;
my $s = $bad != 1 ? 's' : '';
print "Unsatisfactory response from $bad nameserver$s\n\n" if $bad;

exit;


sub catnap {				# short duration sleep
	my $duration = shift;				# seconds
	sleep(1+$duration) unless eval { defined select(undef, undef, undef, $duration) };
}


sub checkNS {				# check nameservers (in parallel) and report status
	my $zone = shift;
	my $index = @_;					# index last element
	my $element = pop @_ || return (0,0,{});	# pop element, terminate if undef
	my ($ns, $if) = split / /, $element;		# name + optional interface IP

	my $res = Net::DNS::Resolver->new(@conf);	# use clean resolver for each test
	my @xip = sort $res->nameservers($if || $ns);	# point at nameserver
	@xip = $res->nameservers("$ns.") unless @xip;	# retry as absolute name (eg. localhost.)
	my $ip = pop @xip;				# last (or only) interface
	$res->nameservers($ip) if @xip;
							# send query packet to nameserver
	my ($socket, $sent) = ($res->bgsend($zone,'SOA'), time) if $ip;

	my ($fail, $latest, $uniq) = checkNS($zone,@_);	# recurse to query others in parallel
							# pick up response as recursion unwinds

	my @pass = ($fail, $latest, $uniq);		# use prebuilt return values
	my @fail = ($fail+1, $latest, $uniq);

	my %nsaddr;
	if ( @xip and $socket ) {			# special handling for multihomed server
		$nsaddr{lc $ip}++;			# silently ignore duplicate address record
		until ($res->bgisready($socket)) {	# wait for outstanding query to complete
			last if time > ($sent + $udp_timeout);
			catnap($udp_wait);
		}
	}
	foreach my $xip (@xip) {			# iterate over remaining interfaces
		my ($f) = checkNS($zone, (undef)x@_, "$ns $xip") unless $nsaddr{lc $xip}++;
		@pass = @fail if $f;			# propagate failure to caller
	}

	my %nsname;					# identify nameserver
	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 ) {	# show address records
			listRR($ns, 'A');
			listRR($ns, 'AAAA');
		}
	}

	my $packet;
	if ( $socket ) {
		until ( $res->bgisready($socket) ) {	# timed wait on socket
			last if time > ($sent + $udp_timeout);
			catnap($udp_wait);		# snatch a few milliseconds sleep
		}
		$packet = $res->bgread($socket) if $res->bgisready($socket);	# get response
	} else {
		$packet = $res->send($zone, 'SOA');	# use sequential query model
	}

	unless ( $packet ) {				# ... is no more! It has ceased to be!
		report('no response');
		return @fail;
	}

	unless ( $packet->header->rcode eq 'NOERROR' ) {
		report($packet->header->rcode);		# NXDOMAIN or fault at nameserver
		return @fail;					# RFC2308, 2.1
	}

	my $aa = $packet->header->aa;			# authoritative answer
	my $tc = $packet->header->tc ? 'tc' : '';	# truncated  response
	my @answer = $packet->answer;			# answer section
	my @soa = grep{$_->type eq 'SOA'} @answer;	# SOA records (plural!)

	my @result = @fail;				# analyse response
	if ( @soa ) {
		@result = @pass if $aa and @soa == 1;		# RFC2181, 6.1
		report(scalar @soa, 'SOA records') unless @soa == 1;
		my $ttl = $soa[0]->ttl;				# RFC1034, 6.2.1 (2)
		report("non-authoritative answer\tTTL", clock($ttl)) unless $aa;
	} elsif ( @soa = grep{$_->type eq 'SOA'} $packet->authority ) {
		my $ttl = $soa[0]->ttl;				# RFC2308, 2.2 (1)(2)
		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');	# RFC2308, 2.2 (4)
		my @n = grep{$_->nsdname =~ /$ns/i} @ns; # self referral?
		my @a = grep{$_->rdatastr =~ /$ip/i} $packet->additional;
		report('authoritative data expired') if @n or @a;
		return @fail;					# RFC2181, 6.1
	} else {
		report('NODATA response from nameserver');	# RFC2308, 2.2 (3)
		return @fail;					# RFC2181, 6.1
	}

	my $serial;					# zone serial number
	for ( @soa ) {
		print "$tc\t\t\tzone serial\t", ($serial = $_->serial), "\n";
		$_->serial(0);				# key on static fields only
		next if $uniq->{lc $_->rdatastr}++;	# skip repeated occurrences
		next unless keys %$uniq > 1;		# zone should have unique SOA
		report('SOA record not unique');		# RFC2181, 6.1
		@result = @fail;
	}

	return @result if $serial == $latest;		# server has latest data

	unless ( $aa and ($serial > $latest) ) {	# unexpected serial number
		report('serial number not current') if $latest;
		return @fail;
	}

	my $unrep = $latest ? (@_ - $fail) : 0;		# all previous out of date
	my $s = $unrep > 1 ? 's' : '';			# pedants really are revolting!
	report("at least $unrep previously unreported stale serial number$s") if $unrep;
	return ($result[0]+$unrep, $serial, $uniq);	# restate partial result
}


sub clock {				# human-friendly TTL
	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 {				# print specified RRs with flags or error code
	my $packet = $resolver->send(@_) || return ();	# get specified RRs
	my $header = $packet->header;
	my $rcode = $header->rcode;			# response code
	my $na = $header->tc ? 'tc' : '';		# non-auth  response
	my $aa = $header->aa ? "aa $na" : $na;		# authoritative answer
	my ($question) = $packet->question;
	my $qname = $question->qname;
	my $qtype = $question->qtype;
	my @answer = $packet->answer;
	my @rr = grep{$_->type !~ /^(NS|SOA)$/o} @answer;	# almost ANY
	foreach ( ($qtype eq 'ANY') ? @rr : @answer) {	# print RR with status flags
		my $string = $_->string;		# display IPv6 compact form
		$string =~ s/(:[:0]*:)(?!.*::|.+\1)/::/o if $_->type eq 'AAAA';
		my $l = 95;				# abbreviate long RR
		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') ) {	# NODATA pseudo-RCODE per RFC2308, 2.2
		my @authority = $packet->authority;
		my @additional = $packet->additional;
		$rcode = 'NODATA' unless @authority + @additional;		# type 3
		$rcode = 'NODATA' if grep{$_->type eq 'SOA'} @authority;	# type 1 or 2
	}
	report("$rcode:\t", $question->string) unless $rcode eq 'NOERROR';
	return @answer;
}


sub listRR {				# print specified RRs without flags or error code
	my $packet = $resolver->send(@_) || return ();	# get specified RRs
	my @answer = $packet->answer;
	foreach ( @answer ) {				# print RR
		my $string = $_->string;		# display IPv6 compact form
		$string =~ s/(:[:0]*:)(?!.*::|.+\1)/::/o if $_->type eq 'AAAA';
		print "\t$string\n";
	}
	return @answer;
}


sub NCACHE {				# get NCACHE SOA for domain
	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 {				# find nameservers for domain
	my $domain = shift || '.';
	my @ns = ();
	while (	$domain ) {
		my $packet = $resolver->send($domain, 'NS');
		die $resolver->string unless $packet;	# local resolver problem
		last if @ns = grep{$_->type eq 'NS'} $packet->answer;
		my ($ncache) = grep{$_->type eq 'SOA'} $packet->authority;
		my $apex = $ncache->name if $ncache;	# zone cut
		return NS($apex) if $apex;		# NODATA from zone server
		return () if defined $apex;		# NXDOMAIN from root server
							# accept referral if any
		my @referral = grep{$_->type eq 'NS'} $packet->authority;
		last if @ns = grep{$_->name =~ /^$domain$/i} @referral;
		$resolver->recurse(0);			# retry as non-recursive query
		$packet = $resolver->send($domain, 'NS');
		$resolver->recurse(1);
		@referral = grep{$_->type eq 'NS'} $packet->authority;
		last if @ns = grep{$_->name =~ /^$domain$/i} @referral;
							# IP (pre 0.59 compatibility)
		my ($x) = grep{$_->qtype eq 'PTR'} $packet->question;
		return NS($x->qname) if $x;
		($x, $domain) = split /\./, $domain, 2;	# strip leftmost label
	}
	return @ns;
}


sub report {				# concatenate strings into fault report
	print join(' ', '*'x4, @_, "\n");
}

__END__