#!/usr/local/bin/perl -w
my $VERSION = 'Version 0.10';
#
=head1 NAME

B<check_soa> - Check nameservers for a domain

=head1 SYNOPSIS

B<check_soa> [B<-d>] [B<-t>] [B<-v>] domain [server]

=head1 DESCRIPTION

Each nameserver for the specified domain name
is queried for the relevant SOA record and
the zone serial number printed.

Error reports are generated for servers tendering
non-authoritative, outdated or incorrect information.

This program is a parallel implementation of
the check_soa idea described by Albitz and Liu.

=head1 OPTIONS AND ARGUMENTS

=over 8

=item -d

Turn on resolver diagnostics.

=item -t

Ignore UDP datagram truncation.

=item -v

Verbose output including address records for each server.

=item domain

Fully qualified name of domain to be tested.

=item server

Name or list of IP addresses of DNS nameserver to be tested.

=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

Copyright (c) 2003-2005, 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 and Cricket Liu.
DNS and BIND, 4th Edition.
O'Reilly & Associates, 2001.

M. Andrews.
Negative Caching of DNS Queries.
RFC2308, IETF Network Working Group, 1998.

R. Elz and 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.

Larry Wall, Tom Christiansen and Jon Orwant.
Programming Perl, 3rd Edition.
O'Reilly & Associates, 2000.

=cut

use strict;
use Getopt::Std;

my $self = $0;						# script
my %option;
my $options = 'dtv';					# options
getopts("$options", \%option);
my ($domain, @server) = @ARGV;				# arguments

my $synopsis = "Usage:\t$self [-$options] domain [server]\t\t# $VERSION";
die eval{ system("perldoc $self"); "" }, "\n$synopsis\n\n" unless @ARGV;


require Net::DNS;

my @conf = (	debug	=> ($option{'d'} ? 1 : 0),	# -d	enable diagnostics
		igntc	=> ($option{'t'} ? 1 : 0),	# -t	ignore truncation
		recurse	=> 0,
		retry	=> 2	);

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

my $udp_timeout	= 5;					# timeout for parallel operations
my $udp_wait	= 0.010;				# minimum polling interval


my $resolver = Net::DNS::Resolver->new(@conf, recurse => 1 );	# set up resolver for preamble
my @ip = $resolver->nameservers(@server);
my @ns = NS($resolver, $domain);			# find NS serving domain
die join(' ', $resolver->string, "\n", uc $domain, "not known by nameserver", @ip) unless @ns;


my $zone = $ns[0]->name;				# find zone cut
for ( "$zone." ) {					# show RR for domain name
	listRR($resolver, $domain, 'ANY') unless /$domain[.]?/;
}
my @soa = listRR($resolver, $zone, 'SOA');		# show SOA
report('SOA query fails for', uc "$zone.") unless @soa;

foreach ( @soa ) {					# simple sanity check
	report('no retry when zone transfer fails') if ($_->refresh + $_->retry) > $_->expire;
	report('minimum TTL exceeds zone expiry time') if $_->minimum > $_->expire;
	next if query($resolver, $_->mname, 'A')->answer;
	next if query($resolver, $_->mname, 'AAAA')->answer;
	report('unresolvable name:', uc $_->mname);		# RFC2181, 7.3
}

print "----\n";

if ( @server ) {
	checkNS($zone, @ip > 1 ? sort @ip : @server);	# check nominated server
} else {
	my @dns = sort map { $_->nsdname } @ns;		# server names from NS records
	my ($errors, @etc) = checkNS($zone, @dns);	# report status
	my $n = @dns;
	print "\nUnexpected response from $errors of $n nameservers\n\n" if $errors;
}

exit;


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

sub checkNS {				# check servers (in parallel) and report status
	my $zone = shift;
	my $index = @_ || return (0,0);			# server list empty
	my $ns = pop @_;				# remove last element of list

	my $res = Net::DNS::Resolver->new(@conf);	# use clean resolver for each test
	my @ip = $res->nameservers($ns);		# point at nameserver

	my $parallel = (@ip == 1) unless @server;	# parallel query if exactly one IP
	my ($socket, $sent) = ($res->bgsend($zone,'SOA'), time) if $parallel;

	my @pass = checkNS($zone, @_);			# recurse to do others in parallel
							# pick up response as recursion unwinds

	print "\n[$index]\t$ns (",join(', ',@ip),")\n";	# identify server

	my ($fail, $latest, %soa) = @pass;		# use prebuilt return values
	my @fail = @pass;	$fail[0]++;

	unless ( @ip ) {				# no address
		report('unresolved server name');
		return @fail;
	}

	if ( $verbose ) {
		my %dname;
		foreach ( @ip ) {			# collect names from PTR records
			$dname{lc $ns}++ unless /$ns/;	# and from NS if available
			foreach ( grep{$_->type eq 'PTR'} listRR($resolver, $_) ) {
				$dname{lc $_->ptrdname}++;
			}
		}
		foreach ( sort keys %dname ) {		# show address info
			listRR($resolver, $_, 'A');
			listRR($resolver, $_, '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 $_;
	} else {
		$packet = query($res, $zone, 'SOA');	# using sequential query model
	}

	unless ( $packet ) {				# ... is no more, 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;
	}

	my @aa = $packet->header->aa ? qw(aa) : ();	# authoritative answer
	my @tc = $packet->header->tc ? qw(tc) : ();	# truncated response
	my @answer = $packet->answer;			# answer section

	my @result = @fail;				# analyse response
	if ( @answer ) {
		@result = @pass if @aa;				# RFC1034, 6.2.1 (1)
		report('non-authoritative answer') unless @aa;	# RFC1034, 6.2.1 (2)
	} elsif ( grep{$_->type eq 'SOA'} $packet->authority ) {
		report('NCACHE response from nameserver');	# RFC2308, 2.2 (1)(2)
	} elsif ( grep{$_->type eq 'NS'} $packet->authority ) {
		report('referral received from nameserver');	# RFC1034, 6.2.6
	} else {
		report('NODATA response from nameserver');	# RFC2308, 2.2 (3)
	}

	my @soa = grep{$_->type eq 'SOA'} @answer;	# extract SOA records (plural!)

	unless ( @soa ) {				# no answer for SOA query
		@result = @fail;				# RFC2181, 6.1
		report('SOA query failed');
		return @result unless @aa;			# RFC1034, 3.7
		@soa = grep{$_->type eq 'SOA'} $packet->authority;
		return @result unless @soa;
	}

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

	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, %soa);
	}

	my $unrep = $index-1 - $fail;			# 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, %soa);	# restate partial result
}


sub listRR {				# print all RR for specified name
	my $packet = query(@_) || return ();		# get specified RRs
	my $na = $packet->header->tc ? 'tc' : '';	# non-auth  response
	my $aa = $packet->header->aa ? "aa $na" : $na;	# authoritative answer
	my $qname = ($packet->question)[0]->qname;
	my @answer = $packet->answer;
	foreach ( @answer ) {				# print RR with status flags
		print $_->name eq $qname ? $aa : $na, "\t";
		$_->print;
	}
	return @answer;
}


sub NS {				# find nameservers for domain
	my @resolver = ref $_[0] ? (shift) : ();	# optional resolver arg
	my $domain = shift;				# name or IP address
	my @ns = ();
	while (	$domain ) {
		my $packet = query(@resolver, $domain, 'NS') || return ();
		last if @ns = grep {$_->type eq 'NS'} $packet->answer;
		($_, $domain) = split /\./, ($packet->question)[0]->qname, 2;
	}
	return @ns;
}


sub query {				# query nameservers
	my $resolver = ref $_[0] ? shift : Net::DNS::Resolver->new;
	return $resolver->send(@_) || return undef;
}


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

__END__