#!/usr/bin/perl
#
# dnswalk    Walk through a DNS tree, pulling out zone data and
# dumping it in a directory tree
#
# $Id: dnswalk,v 1.3 2010-03-25 01:36:37-10 tony Exp $
#
# check data collected for legality using standard resolver
#
# invoke as dnswalk domain > logfile
# Options:
#    -r    Recursively descend subdomains of domain
#    -i    Suppress check for invalid characters in a domain name.
#    -a    turn on warning of duplicate A records.
#    -d    Debugging
#    -m    Check only if the domain has been modified.  (Useful only if
#          dnswalk has been run previously.)
#    -F    Enable "facist" checking.  (See man page)
#    -l    Check lame delegations
#    -p    Check PTR existence for A and AAAA

use Getopt::Std;
use IO::Socket;
use Net::DNS;
use Net::IP;
use Socket6;
use Net::IPv6Addr;

getopts("D:rfiadmFl");

$num_error{'FAIL'}=0;		# failures to access data
$num_error{'WARN'}=0;		# questionable data
$num_error{'BAD'}=0;		# bad data

# Where all zone transfer information is saved.  You can change this to
# something like /tmp/dnswalk if you don't want to clutter up the current
# directory
if ($opt_D) {
    $basedir = $opt_D;
} else {
    $basedir = ".";
}
($domain = $ARGV[0]) =~ tr/A-Z/a-z/;
if ($domain !~ /\.$/) {
    die "Usage: dnswalk domain\ndomain MUST end with a '.'\n";
}
if (! -d $basedir) {
	mkdir($basedir,0777) || die "FAIL: Cannot create $basedir: $!\n";
}

&dowalk($domain);
print STDERR "$num_error{'FAIL'} failures, $num_error{'WARN'} warnings, $num_error{'BAD'} errors.\n";
exit $num_error{'BAD'};

sub dowalk {
    my (@subdoms);
    my (@sortdoms);
    my ($domain)=$_[0];
    $modified=0;
    return unless $domain;
    print "Checking $domain\n";
    @subdoms=&doaxfr($domain);
    &check_zone($domain) if (@zone);
    undef @zone;
    return if (!@subdoms);
    @sortdoms = sort byhostname @subdoms;
    local ($subdom);
    if ($opt_r) {
        foreach $subdom (@sortdoms) {
            &dowalk($subdom);
        }
    }
}
# try to get a zone transfer, trying each listed authoritative server if
# if fails.
sub doaxfr {
    local ($domain)=@_[0];
    local (%subdoms)=();
    local ($subdom);
    local(@servers) = &getauthservers($domain);
    &printerr("BAD", "$domain has only one authoritative nameserver\n") 
	if (scalar(@servers) == 1);
    &printerr("BAD", "$domain has NO authoritative nameservers!\n")
	if (scalar(@servers) == 0);
    SERVER:
    foreach $server (@servers) {
        print STDERR "Getting zone transfer of $domain from $server...";
	my $res = new Net::DNS::Resolver( tcp_timeout=>2, udp_timeout=>1, retry=>1 );
	$res->nameservers($server);
	@zone=$res->axfr($domain);
	unless (@zone) {
	    print STDERR "failed\n";
	    &printerr("FAIL",
		      "Zone transfer of $domain from $server failed: "
		      . $res->errorstring . "\n");
	    next SERVER;
	}
	@subdoms=undef;
        foreach $rr (@zone) {
            if ($rr->type eq "NS") {
		$subdom = $rr->name;
                $subdom =~ tr/A-Z/a-z/;
                if ((!&equal($subdom,$domain)) && ( !$subdoms{$subdom})) {
                    $subdoms{$subdom}=1;
                }
            }
        }
        print STDERR "done.\n";
        last SERVER;
    } # foreach #
    unless (@zone) {
	    &printerr("BAD","All zone transfer attempts of $domain failed!\n");
	    return undef;
    }
    return (keys %subdoms);
}

sub getauthservers {
    my ($domain)=$_[0];
    my ($master)=&getmaster($domain);
    my ($foundmaster)=0;
    my ($ns);
    my ($ns_tmp);
    my ($res);
    my ($ns_req);
    my (@servers);
    my (%servhash);
    return if (!$master);  # this is null if there is no SOA or not found
    return if (!$domain);
    $res = new Net::DNS::Resolver( tcp_timeout=>2, udp_timeout=>1, retry=>1 );
    $ns_req = $res->query($domain, "NS");
    &printerr("FAIL", "No nameservers found for $domain: " . 
	      $res->errorstring . "\n") 
	    unless (defined($ns_req) and ($ns_req->header->ancount > 0));
    foreach $ns ($ns_req->answer) {
	$ns_tmp = $ns->nsdname;
	$ns_tmp =~ tr/A-Z/a-z/;
	if (&equal($ns_tmp,$master)) {
	    $foundmaster=1;   # make sure the master is at the top
	} else {
	    push(@servers,$ns_tmp) if ($servhash{$ns_tmp}++<1);
	}
    }
    if ($foundmaster) {
	unshift(@servers,$master);
    }
    return @servers;
}

# return 'master' server for zone
sub getmaster {
    my ($zone)=$_[0];
    my ($res) = new Net::DNS::Resolver( tcp_timeout=>2, udp_timeout=>1, retry=>1 );
    my ($packet) = new Net::DNS::Packet($zone, "SOA", "IN");
    my ($soa_req) = $res->send($packet);
    unless (defined($soa_req)) {
	&printerr("FAIL", "Cannot get SOA record for $zone:" . 
		  $res->errorstring . "\n");
	return "";
    }
    unless (($soa_req->header->ancount >= 1) && 
	   (($soa_req->answer)[0]->type eq "SOA")) {
	&printerr("BAD", "SOA record not found for $zone\n");
	return "";
    }
    return ($soa_req->answer)[0]->mname;
}

# open result of zone tranfer and check lots of nasty things
# here's where the fun begins
sub check_zone {
    my ($domain)=$_[0];
    local (%glues)=();	# look for duplicate glue (A) records
    local ($name, $aliases, $addrtype, $length, @addrs);
    local ($prio,$mx);
    local ($soa,$contact);
    local ($lastns);	# last NS record we saw
    local (@keys);	# temp variable
    foreach $rr (@zone) {
	# complain about invalid chars only for mail names
        if ((($rr->type eq "A") || ($rr->type eq "AAAA") ||
             ($rr->type eq "MX")) && 
	    (!$opt_i) && 
	    ($rr->name =~ /[^\*][^-A-Za-z0-9.]/)) {
            &printerr("WARN", $rr->name . ": invalid character(s) in name\n");
        }
        if ($rr->type eq "SOA") {
	    print STDERR 's' if $opt_d;
	    my @soa = split(/\s+/,$rr->rdstring);
	    my $rname = $soa[1];
	    print "SOA=" . $rr->mname . " contact=" . $rname . "\n";
	    # basic address check.  No "@", and user.dom.ain (two or more dots)
	    if (($rname =~ /@/)||!($rname =~ /[^.]+(\.[^.]+){2,}/)) {
		&printerr("WARN", "SOA contact name (" . $rname . ") is invalid\n");
	    }
        } elsif ($rr->type eq "PTR") {
            print STDERR 'p' if $opt_d;
            @keys = split(/\./, $rr->name);
            if (scalar(@keys) == 6 || scalar(@keys) == 34) {
                $af = (scalar(@keys) == 6) ? AF_INET : AF_INET6;
		$t = ($af == AF_INET) ? "A" : "AAAA";
                # check if forward name exists, but only if reverse is
                # a full IP addr
                ($name, $aliases, $addrtype, $length, @addrs) =
                    mygethostbyname($rr->ptrdname, $t);
                if (!$name) {
                    &printerr("WARN", $rr->name . " PTR " . $rr->ptrdname .
			      ": unknown host\n");
                }
#               elsif (!&equal($name,$rr->ptrdname)) {
#                   &printerr("WARN", $rr->name . " PTR " . $rr->ptrdname .
#		      ": CNAME (to $name)\n");
#               }    
                elsif (!&matchaddrlist($rr->name)) {
                    &printerr("WARN", $rr->name . " PTR " . $rr->ptrdname .
			      ": $t record not found\n");
                }
            }
        } elsif ($opt_p && ($rr->type eq "A" || $rr->type eq "AAAA")) {
            print STDERR 'a' if $opt_d;
	    $af = ($rr->type eq "A") ? AF_INET : AF_INET6;
	    # check to see that a reverse PTR record exists
	    ($name, $aliases, $addrtype, $length, @addrs) =
                gethostbyaddr(inet_pton($af, $rr->address), $af);
	    if (!$name) {
		# hack - allow RFC 1101 netmasks encoding
		if ($rr->address !=~ /^255/) {
		    &printerr("WARN", $rr->name . " " . $rr->type . " " .
                              $rr->address . ": no PTR record\n");
		}
	    }
	    elsif ($opt_F && !&equal($name,$rr->name)) {
		# Filter out "hostname-something" (like "neptune-le0")
		if (index(split (/\./, $rr->name, 2) . "-", 
			    split (/\./, $name, 2)) == -1 ) {
			&printerr("WARN", $rr->name . " " . $rr->type . " " . 
                                  $rr->address . ": points to $name\n") 
			    if ((split(/\./,$name))[0] ne "localhost");
		}
	    }
	    if ($main'opt_a) {
		# keep list in %glues, report any duplicates
		if ($glues{$rr->address} eq "") {
		    $glues{$rr->address}=$rr->name;
		}
		elsif (($glues{$rr->address} eq $rr->name) &&
			(!&equal($lastns,$domain))) {
		    &printerr("WARN", $rr->name .
			      ": possible duplicate " . $rr->type .
			      " record (glue of $lastns?)\n");
		}
	    }
        } elsif ($rr->type eq "NS") {
            $lastns=$rr->name;
            print STDERR 'n' if $opt_d;
            # check to see if object of NS is real
            &checklamer($rr->name,$rr->nsdname) if ($main'opt_l);
	    # check for bogusnesses like NS->IP addr
	    if (&isipaddr($rr->nsdname)) {
		&printerr("BAD", $rr->name . " NS " . $rr->nsdname .
			  ": Nameserver must be a hostname\n");
	    }
            ($name, $aliases, $addrtype, $length,
		    @addrs)=mygethostbyname($rr->nsdname,"A");
            if (!$name) {
                &printerr("BAD", $rr->name . " NS " . $rr->nsdname .
			  ": unknown host\n");
#           } elsif (!&equal($name,$rr->nsdname)) {
#               &printerr("BAD", $rr->name . " NS " . $rr->nsdname .
#		  ": CNAME (to $name)\n");
            }
        } elsif ($rr->type eq "MX") {
            print STDERR 'm' if $opt_d;
            # check to see if object of mx is real
	    if (&isipaddr($rr->exchange)) {
		&printerr("BAD", $rr->name . " MX " . $rr->exchange .
			  ": Mail exchange must be a hostname\n");
	    }
            ($name, $aliases, $addrtype, $length,
		    @addrs)=mygethostbyname($rr->exchange, "A");
            if (!$name) {
                &printerr("WARN", $rr->name . " MX " . $rr->exchange .
			  ": unknown host\n");
            }
#           elsif (!&equal($name,$rr->exchange)) {
#               &printerr("WARN", $rr->name . " MX " . $rr->exchange .
#		  ": CNAME (to $name)\n");
#           }
        } elsif ($rr->type eq "CNAME") {
            print STDERR 'c' if $opt_d;
#           ($name, $aliases, $addrtype, $length,
#	    @addrs)=mygethostbyname($rr->cname, "ANY");
            ($name, $aliases, $addrtype, $length,
		    @addrs)=mygethostbyname($rr->cname, "A");
	    if (&isipaddr($rr->cname)) {
		&printerr("BAD", $rr->name . " CNAME " . $rr->cname .
			  ": alias must be a hostname\n");
	    }
            if (!$name) {
               ($name, $aliases, $addrtype, $length, @addrs)=mygethostbyname($rr->cname, "NAPTR");
               if (!$name) {
                  ($name, $aliases, $addrtype, $length, @addrs)=mygethostbyname($rr->cname, "SRV");
                  if (!$name) {
                     &printerr("WARN", $rr->name . " CNAME " . $rr->cname .  ": unknown host\n");
                  }
               }
#           } elsif (!&equal($name,$rr->cname)) {
#               &printerr("WARN", $rr->name . " CNAME " . $rr->cname .
#		  ": CNAME (to $name)\n");
            }
        }
    }
    print STDERR "\n" if $opt_d;
    close(FILE);
}

# prints an error message, suppressing duplicates
sub printerr {
    my ($type, $err)=@_;
    if ($errlist{$err}==undef) {
	print "$type: $err";
	$num_error{$type}++;
	print STDERR "!" if $opt_d;
	$errlist{$err}=1;
    } else {
	print STDERR "." if $opt_d;
    }
}

sub equal {
    # Do case-insensitive string comparisons
    local ($one)= $_[0];
    local ($two)= $_[1];
    $stripone=$one;
    if (chop($stripone) eq '.') {
	$one=$stripone;
    }
    $striptwo=$two;
    if (chop($striptwo) eq '.') {
	$two=$striptwo;
    }
    $one =~ tr/A-Z/a-z/;
    $two =~ tr/A-Z/a-z/;
    return ($one eq $two);
}

# check if argument looks like an IP address
sub isipaddr {
    my $ip = new Net::IP($_[0]) || return 0;
    return $ip->version;
}
sub matchaddrlist {
    my $name = shift;
   #print "DEBUG: name=$name", $/;
    local(@x) = reverse( split(/\./, $name) );
    shift @x;
    local($arpatype) = shift @x;
    local($found)=0;
    if ($arpatype =~ /in-addr/i) {
       $match = join(".", @x );
       foreach $i (@addrs) {
          $found=1 if ($i->address eq $match);
       }
    } elsif ( $arpatype =~ /ip6/i) {
      #print "DEBUG: arpatype=ip6", $/;
       foreach $i (@addrs) {
          $name .= '.';
          my $x = new Net::IPv6Addr($i->address);
          my $arpa = $x->to_string_ip6_int();
          $arpa =~ s/INT/arpa/;
          $arpa = lc( $arpa );
         #print "DEBUG: arpa=$arpa", $/;
          $found=1 if ($name eq $arpa);
       }

    }
    return $found;
}

# there's a better way to do this, it just hasn't evolved from
# my brain to this program yet.
sub byhostname {
    @c = reverse(split(/\./,$a));
    @d = reverse(split(/\./,$b));
    for ($i=0;$i<=(($#c > $#d) ? $#c : $#d) ;$i++) {
        next if $c[$i] eq $d[$i];
        return -1 if $c[$i] eq "";
        return  1 if $d[$i] eq "";
        if ($c[$i] eq int($c[$i])) {
            # numeric
            return $c[$i] <=> $d[$i];
        }
        else {
            # string
            return $c[$i] cmp $d[$i];
        }
    }
    return 0;
}

sub checklamer {
    my ($zone,$nameserver)=@_;
    my ($packet) = new Net::DNS::Packet($zone, "SOA", "IN");
    my ($soa_req);
    my ($res) = new Net::DNS::Resolver( tcp_timeout=>2, udp_timeout=>1, retry=>1 );
    unless ($res->nameservers($nameserver)) {
	&printerr("FAIL", "Cannot find address for nameserver: " .
		  $res->errorstring . "\n");
    }
    $soa_req = $res->send($packet);
    unless (defined($soa_req)) {
	&printerr("FAIL",
		  "Cannot get SOA record for $zone from $nameserver (lame?): "
		  . $res->errorstring . "\n");
	return;
    }
    &printerr("BAD", "$zone NS $nameserver: lame NS delegation\n") 
	unless ($soa_req->header->aa);
    return;
}

sub mygethostbyname {
   my $qname = shift;
   my $type = shift;

  #print "DEBUG: trying to resolve $qname|$type", $/;
   my $res = Net::DNS::Resolver->new;
   if ( my $dns_packet = $res->query($qname, $type) ) {
      foreach my $question ( $dns_packet->question ) {
         $name = $question->qname;
      }
      $length = $dns_packet->answersize;
      @addrs = $dns_packet->answer;

      return ($name, "", $type, $length, @addrs);
   } else {
  #   print "ERROR: unable to resolve $qname|$type", $/;
   }
   return ();
}
