#!/usr/bin/perl
#
# dnswalk    Walk through a DNS tree, pulling out zone data and
# dumping it in a directory tree
#
# $Id: dnswalk,v 1.18 1997/10/06 13:23:58 barr Exp barr $
#
# 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

#
# modern perl needs this explicitly globalized:
#
# File-scope "globals"
my %errlist;
my %num_error;


use Getopt::Std;
use IO::Socket;
use Net::DNS;

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 \tOptions:\n \t\t-r\tRecursively descend subdomains of domain\n \t\t-i\tSuppress check for invalid characters in a domain name.\n \t\t-a\tturn on warning of duplicate A records.\n \t\t-d\tDebugging\n \t\t-m\tCheck only if the domain has been modified.  (Useful only if\n \t\t\tdnswalk has been run previously.)\n \t\t-F\tEnable 'facist' checking.  (See man page)\n \t\t-l\tCheck lame delegations\n\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 {
    my ($domain) = @_;
    my %subdoms;
    my @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;

    my @zone;

    SERVER:
    foreach my $server (@servers) {
        print STDERR "Getting zone transfer of $domain from $server...";

        my $res = Net::DNS::Resolver->new;
        $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;
        }

        foreach my $rr (@zone) {
            if ($rr->type eq "NS") {
                my $subdom = lc($rr->name);  # lowercase for comparison
                if (!equal($subdom, $domain) && !$subdoms{$subdom}) {
                    $subdoms{$subdom} = 1;
                }
            }
        }

        print STDERR "done.\n";
        last SERVER;  # Exit loop after successful transfer
    }

    unless (@zone) {
        printerr("BAD", "All zone transfer attempts of $domain failed!\n");
        return ();
    }

    return keys %subdoms;
}


sub getauthservers {
    my ($domain) = @_;
    return unless $domain;

    my $master = getmaster($domain);
    return unless $master;  # No SOA/master found, abort.

    my $res = Net::DNS::Resolver->new;
    my $ns_req = $res->query($domain, "NS");

    unless (defined $ns_req && $ns_req->header->ancount > 0) {
        printerr("FAIL", "No nameservers found for $domain: " . $res->errorstring . "\n");
        return;
    }

    my @servers;
    my %servhash;
    my $foundmaster = 0;

    foreach my $ns_rr ($ns_req->answer) {
        my $ns_name = lc($ns_rr->nsdname);

        if (equal($ns_name, $master)) {
            $foundmaster = 1;  # Put master at top
        } else {
            unless ($servhash{$ns_name}) {
                push @servers, $ns_name;
                $servhash{$ns_name} = 1;
            }
        }
    }

    # Put master at the top if found
    unshift @servers, $master if $foundmaster;

    return @servers;
}



# return 'master' server for zone
sub getmaster {
    my ($zone) = @_;

    return "" unless $zone;

    my $res = Net::DNS::Resolver->new;
    my $soa_req = $res->query($zone, "SOA");

    unless (defined $soa_req) {
        printerr("FAIL", "Cannot get SOA record for $zone: " . $res->errorstring . "\n");
        return "";
    }

    foreach my $rr ($soa_req->answer) {
        if ($rr->type eq "SOA") {
            return $rr->mname;
        }
    }

    printerr("BAD", "SOA record not found for $zone\n");
    return "";
}



# open result of zone tranfer and check lots of nasty things
# here's where the fun begins
use Net::DNS;
use Socket;

sub check_zone {
    my ($domain) = @_;
    my %glues;
    my ($name, $aliases, $addrtype, $length, @addrs);
    my $lastns;

    foreach my $rr (@zone) {
        # Warn about invalid characters in A or MX names
        if (($rr->type eq "A" || $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 contact format check
            if ($rname =~ /@/ || $rname !~ /[^.]+(\.[^.]+){2,}/) {
                printerr("WARN", "SOA contact name (" . $rname . ") is invalid\n");
            }

        } elsif ($rr->type eq "PTR") {
            print STDERR 'p' if $opt_d;
            my @keys = split(/\./, $rr->name);
            if (scalar(@keys) == 6 && $keys[0] ne "0") {
                ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($rr->ptrdname);

                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 . ": A record not found\n");
                }
            }

        } elsif ($rr->type eq "A") {
            print STDERR 'a' if $opt_d;
            my $packed_ip = pack('C4', split(/\./, $rr->address));
            ($name, $aliases, $addrtype, $length, @addrs) = gethostbyaddr($packed_ip, AF_INET);

            if (!$name && $rr->address !~ /^255/) {
                printerr("WARN", $rr->name . " A " . $rr->address . ": no PTR record\n");
            } elsif ($opt_F && $name && !equal($name, $rr->name)) {
                # Ignore localhost and similar special cases
                if (index((split(/\./, $rr->name, 2))[0] . "-", (split(/\./, $name, 2))[0]) == -1) {
                    printerr("WARN", $rr->name . " A " . $rr->address . ": points to $name\n")
                        if (split(/\./, $name))[0] ne "localhost";
                }
            }

            if ($main::opt_a) {
                # Duplicate glue record detection
                if (!$glues{$rr->address}) {
                    $glues{$rr->address} = $rr->name;
                } elsif ($glues{$rr->address} eq $rr->name && !equal($lastns, $domain)) {
                    printerr("WARN", $rr->name . ": possible duplicate A record (glue of $lastns?)\n");
                }
            }

        } elsif ($rr->type eq "NS") {
            $lastns = $rr->name;
            print STDERR 'n' if $opt_d;

            checklamer($rr->name, $rr->nsdname) if $main::opt_l;

            if (isipv4addr($rr->nsdname)) {
                printerr("BAD", $rr->name . " NS " . $rr->nsdname . ": Nameserver must be a hostname\n");
            }

            ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($rr->nsdname);

            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;

            if (isipv4addr($rr->exchange)) {
                printerr("BAD", $rr->name . " MX " . $rr->exchange . ": Mail exchange must be a hostname\n");
            }

            ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($rr->exchange);

            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) = gethostbyname($rr->cname);

            if (isipv4addr($rr->cname)) {
                printerr("BAD", $rr->name . " CNAME " . $rr->cname . ": alias must be a hostname\n");
            }

            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) = @_;

    unless (exists $errlist{$err}) {
        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 IPv4 address
sub isipv4addr {
    my ($host)=$_[0];
    my ($one,$two,$three,$four);
    ($one,$two,$three,$four)=split(/\./,$host);
    my $whole="$one$two$three$four";
    # strings evaluated as numbers are zero
    return (($whole+0) eq $whole);
}
sub matchaddrlist {
    local($match)=pack('C4', reverse(split(/\./,$_[0],4)));
    local($found)=0;
    foreach $i (@addrs) {
        $found=1 if ($i eq $match);
    }
    return $found;
}

# there's a better way to do this, it just hasn't evolved from
# my brain to this program yet.
sub byhostname {
    my @c = reverse split(/\./, $a);
    my @d = reverse split(/\./, $b);

    my $max = @c > @d ? $#c : $#d;
    for my $i (0 .. $max) {
        next if $c[$i] eq $d[$i];
        return -1 if !defined($c[$i]) || $c[$i] eq "";
        return  1 if !defined($d[$i]) || $d[$i] eq "";
        if ($c[$i] =~ /^\d+$/ && $d[$i] =~ /^\d+$/) {
            return $c[$i] <=> $d[$i];
        } else {
            return $c[$i] cmp $d[$i];
        }
    }
    return 0;
}

sub checklamer {
    my ($zone, $nameserver) = @_;

    my $res = Net::DNS::Resolver->new;
    unless ($res->nameservers($nameserver)) {
        printerr("FAIL", "Cannot find address for nameserver: " . $res->errorstring . "\n");
        return;
    }

    my $packet = Net::DNS::Packet->new($zone, "SOA", "IN");
    my $soa_req = $res->send($packet);

    unless (defined $soa_req) {
        printerr("FAIL", "Cannot get SOA record for $zone from $nameserver (lame?): " . $res->errorstring . "\n");
        return;
    }

    unless ($soa_req->header->aa) {
        printerr("BAD", "$zone NS $nameserver: lame NS delegation\n");
    }
}