#!/usr/bin/perl
# check_dns v1.0  (c) 5.6.2013 by Andreas Ley  (u) 27.5.2025
# Check DNS for correct resolving

# FIXME: replace $host by Net::DNS

$root = '/var/www';
$mailaddr = 'apache@scc.kit.edu';

use locale;
use Getopt::Std;
use File::Spec::Functions;
use Net::Domain ('hostfqdn','hostdomain');
use Net::DNS;
use NetAddr::IP ':lower';

# FIXME: Find a perl module for DNS queries
#my $host = '/usr/bin/host';
my @sendmail = ('/usr/sbin/sendmail','-i','-f',$mailaddr,'-t');

sub usage
{
	my $image = $0;
	$image =~ s!.*/!!;
	print STDERR "Usage: $image [-v] fqdn [file]\n";
	exit(1);
}

getopts('DL:hxv') or &usage;

&usage if (defined($opt_h) || $#ARGV < 0);

$opt_D = $opt_L if (defined($opt_L));
if (defined($opt_v) || defined($opt_D)) {
	$|=1;
	select((select(STDERR),$|=1)[0]);
}

my $res = Net::DNS::Resolver->new;

for my $vhost (@ARGV) {
	print STDERR "VHost: \"$vhost\"\n" if ($opt_D>0);
	## IAI needs mod_proxy, so it has a proxy in front of our server. Skip them until buster with mod_proxy is available
	#next if ($vhost =~ /\.iai\.kit\.edu$/);

	# Check configuration file
	my $httpd = catfile($root,$vhost,'conf','httpd.conf');
	# We could check for failure here, but will fail later on anyway...
	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($httpd);
	# Ignore VHosts whose configuration has been changed in the last
	# 24 hours - a DNS inconsistency is more than probable
	next unless ($mtime < time-86400);
	print STDERR "Config: \"$httpd\" ",time-$mtime,"\n" if ($opt_D>2);

	# Create pattern of possible legal canonical names
	# This allows every pattern for every host - in the future, one may
	# check the domain's SOA and use only the correct patterns
	my $atis;
	if ($vhost =~ /\.kit\.edu$/) {
		$atis = ($` =~ s/\./-atis-/gr).'.scc.kit.edu';
		print STDERR "ATIS: \"$atis\"\n" if ($opt_D>2);
	}
	elsif ($vhost =~ /\.uni-karlsruhe\.de$/) {
		$atis = ($` =~ s/\./-atis-/gr).'.rz.uni-karlsruhe.de';
		print STDERR "ATIS: \"$atis\"\n" if ($opt_D>2);
	}
	else {
		$atis = $vhost;
		$atis =~ s/\./-/g;
		$atis .= '-atis.scc.kit.edu';
	}
	$extern = ($vhost =~ s/\./-/gr).'.scc.kit.edu';
	my $pattern = qr/^(?:test-)?(?:\Q$vhost\E|\Q$atis\E|\Q$extern\E)$/;
	print STDERR "Pattern: \"$pattern\"\n" if ($opt_D>1);

	# Check forward resolving
	my (%alias,%ip,$log);
	for my $fqdn ($vhost,'test-'.$vhost) {
		print STDERR "FQDN: \"$fqdn\"\n" if ($opt_D>1);

#		$log .= "\n+ $host $fqdn\n";
#		open(HOST,'-|',$host,$fqdn) or die "Can't run $host $fqdn: $!\n";
#		while (<HOST>) {
#			$log .= $_;
#			chomp;
#			print STDERR "# \"$_\"\n" if ($opt_D>2);
#			if (/^$fqdn\s+is\s+an\s+alias\s+for\s+(\S+)\.$/) {
#				$alias{$fqdn} = $1;
#				print STDERR "# \$alias{$fqdn} = $1\n" if ($opt_D>1);
#				# FIXME: And now?! What happens with %alias?!
#			}
#			elsif (/\shas\s+(?:IPv6\s+)?address\s+/) {
#				my $ip = NetAddr::IP->new($')->addr;
#				$ip{$ip} = $`;
#				print STDERR "# \$ip{$ip} = $`\n" if ($opt_D>1);
#			}
#		}
#		close(HOST);

		for my $type ('A','AAAA') {
			my $reply = $res->query($fqdn,$type);
			if ($reply) {
				if ($opt_D>2) {
					for my $rr ($reply->answer) {
						print STDERR $rr->string,"\n";
						if ($rr->type eq "A" || $rr->type eq "AAAA") {
							print STDERR $rr->owner," ",$rr->type," ",$rr->address,"\n";
						}
					}
				}
				for my $rr ($reply->answer) {
					if ($rr->type eq $type) {
						my $ip = NetAddr::IP->new($rr->address)->addr;
						$ip{$ip} = $rr->owner;
						print STDERR "\$ip{$ip} = $ip{$ip}\n" if ($opt_D>1);
						# FIXME: Check for range from vhost.ini, set $bad{$fqdn} if outside
					}
					elsif ($rr->type eq "CNAME") {
						$alias{$rr->owner} = $rr->cname;
						print STDERR "\$alias{".$rr->owner."} = $alias{$rr->owner}\n" if ($opt_D>1);
					}
				}
			}
			else {
				$bad{$fqdn} = "No $type RR for this VHost: ".$res->errorstring;
				print STDERR "\$bad{$fqdn} = $bad{$fqdn}\n" if ($opt_D>1);
			}
		}
	}

	# Read configured IPs, check their reverse resolving
	open(HTTPD,'<',$httpd) or die "Can't read $httpd: $!\n";
	my (%seen,%bad);
	while (<HTTPD>) {
		chomp;
		print STDERR "\"$_\"\n" if ($opt_D>2);
		if (/^\s*Listen\s+(?:([0-9.]+)|\[([0-9a-f:]+)\])(?::\d+)?$/i) {
			my $ip = NetAddr::IP->new($1.$2)->addr;
			if (!defined($seen{$ip})) {
				print STDERR "IP: \"$ip\"\n" if ($opt_D>1);
				$bad{$ip} .= "Forward:\n\tNo A/AAAA RR points to this address\n" unless (defined($ip{$ip}));

#				$log .= "\n+ $host $ip\n";
#				open(HOST,'-|',$host,$ip) or die "Can't run $host $ip: $!\n";
#				while (<HOST>) {
#					$log .= $_;
#					chomp;
#					print STDERR "# \"$_\"\n" if ($opt_D>1);
#					if (/\sdomain\s+name\s+pointer\s+(\S+)\.$/) {
#						$ptr = $1;
#						print STDERR "# ",(($ptr =~ /$pattern/) ? "Match" : "Bad"),": $ptr\n" if ($opt_D>0);
#						$bad{$ip} .= "Bad PTR:\t$_\n" unless ($ptr =~ /$pattern/);
#					}
#					else {
#						$bad{$ip} .= "No PTR:\t$_\n";
#					}
#				}
#				close(HOST);

				my $reply = $res->query($ip);
				if ($reply) {
					if ($opt_D>2) {
						for my $rr ($reply->answer) {
							print STDERR $rr->string,"\n";
							if ($rr->type eq "PTR") {
								print STDERR $rr->owner," ",$rr->type," ",$rr->ptrdname,"\n";
							}
						}
					}
					for my $rr ($reply->answer) {
						if ($rr->type eq 'PTR') {
							my $ptr = $rr->ptrdname;
							print STDERR (($ptr =~ /$pattern/) ? "Match" : "Bad"),": $ptr\n" if ($opt_D>0);
							$bad{$ip} .= "Reverse:\n\tPTR does not match DNS name pattern for this VHost\n\t".$rr->string."\n" unless ($ptr =~ /$pattern/);
						}
					}
				}
				else {
					$bad{$ip} .= "PTR not found: ".$res->errorstring."\n";
					print STDERR "\$bad{$ip} = $bad{$ip}\n" if ($opt_D>1);
				}

				$seen{$ip} = 1;
			}
		}
	}
	close(HTTPD);

	# If there were discrepancies, send mail
	if (%bad) {
		my $image = $0;
		$image =~ s!.*/!!;
		@sendmail = 'cat' if ($opt_D>3);
		open(SENDMAIL,'|-',@sendmail) or die "Can't run ".join(' ',@sendmail).": $!\n";
		print SENDMAIL "From: $image\@".hostdomain()."\n";
		print SENDMAIL "To: $mailaddr\n";
		print SENDMAIL "Subject: Bad PTR for $vhost\n";
		print SENDMAIL "\nHost:\t".hostfqdn()."\n";
		print SENDMAIL "\nVHost:\t$vhost\n";
		for my $fqdn ($vhost,'test-'.$vhost) {
			print SENDMAIL $bad{$fqdn};
		}
		for my $ip (sort keys %bad) {
			print SENDMAIL "\nIP:\t$ip\n";
			print SENDMAIL $bad{$ip};
			#print STDERR $bad{$ip} if ($opt_D>0);
		}
		print SENDMAIL $log;
		close(SENDMAIL);
	}
}
