#!/usr/bin/perl
#
# Copyright (c) 2003,2004,2005 Roy Arends & Jakob Schlyter.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. The name of the authors may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

use strict;
use warnings;

use Net::DNS;
use Net::DNS::Fingerprint;

use Getopt::Std;
use vars qw/ %opt /;
use POSIX ":sys_wait_h";

my $progname = "fpdns";
my $version  = Net::DNS::Fingerprint->version();

my $IPv4RE = qr/\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/;
my $IPv6RE = qr/^(((?=(?>.*?::)(?!.*::)))(::)?([0-9A-F]{1,4}::?){0,5}|([0-9A-F]{1,4}:){6})(\2([0-9A-F]{1,4}(::?|$)){0,2}|((25[0-5]|(2[0-4]|1[0-9]|[1-9])?[0-9])(\.|$)){4}|[0-9A-F]{1,4}:[0-9A-F]{1,4})(?<![^:]:)(?<!\.)\z/i;

sub main {
    $opt{p} = 53;
    $opt{t} = 5;
    $opt{r} = 1;
    $opt{F} = 10;
    $opt{T} = 0;
    $opt{Q} = undef;
    $opt{S} = " ";

    my %children;

    my $concurrent = 0;

    getopts('Q:DF:p:t:r:fsS:dTv', \%opt);

    $opt{v} && die "$progname version $version\n";

    unless ($#ARGV >= 0) {
        usage();
        exit(1);
    }

    my $engine = Net::DNS::Fingerprint->new(
        source    => $opt{Q},
        debug     => $opt{d},
        timeout   => $opt{t},
        retry     => $opt{r},
        forcetcp  => $opt{T},
        qversion  => $opt{v},
        qchaos    => $opt{f},
        separator => $opt{S},
    );

    if ($ARGV[0] eq "-") {
        while (<STDIN>) {
            my $pid = fork;
            if ((not defined $pid)
                and not($! =~ /Resource temporarily unavailable/))
            {
                die "Can't fork: $!\n";
            } elsif ($pid == 0) {
                chomp;
                fingerprint($engine, $_);
                exit(0);
            } else {
                $concurrent++;
                $children{$pid} = 1;
                while ($concurrent >= $opt{F}) {
                    my $child = waitpid -1, 0;
                    $concurrent--;
                    delete($children{$child});
                }
            }
        }
        while ($concurrent) {
            my $child = waitpid -1, 0;
            $concurrent--;
            delete($children{$child});
        }
    } else {
        while ($#ARGV + 1) {
            fingerprint($engine, shift @ARGV);
        }
    }
}

sub fingerprint {
    my ($engine, $server) = @_;
    my @addresses = dnslookup($server);
    if ($#addresses >= 0) {
        for my $a (@addresses) {
            my $fp = $engine->string($a, $opt{p});
            $opt{s} && (printf("%-15s %s\n", $a, $fp))
              || print "fingerprint ($server, $a): $fp\n";
        }
    } else {
        print STDERR "host not found ($server)\n";
    }
}

sub dnslookup {
    my $arg       = shift;
    my @addresses = ();
    return $arg if ($arg =~ $IPv4RE);
    return $arg if ($arg =~ $IPv6RE);

    my $resolver = Net::DNS::Resolver->new(usevc => $opt{T});
    $resolver->srcaddr($opt{Q}) if $opt{Q};
    if ($opt{D}) {
        my $query = $resolver->send($arg, "NS");
        if ($query) {
            for my $rr ($query->answer) {
                next unless $rr->type eq "NS";
                my $query_address = $resolver->send($rr->rdatastr, "A");
                if ($query_address) {
                    for my $address_rr ($query_address->answer) {
                        push @addresses, $address_rr->address
                          if $address_rr->type eq "A";
                    }
                }
                $query_address = $resolver->send($rr->rdatastr, "AAAA");
                if ($query_address) {
                    for my $address_rr ($query_address->answer) {
                        push @addresses, $address_rr->address
                          if $address_rr->type eq "AAAA";
                    }
                }
            }
        }
    } else {
        my $query = $resolver->send($arg, "A");
        if ($query) {
            for my $rr ($query->answer) {
                push @addresses, $rr->address if $rr->type eq "A";
            }
        }
        $query = $resolver->send($arg, "AAAA");
        if ($query) {
            for my $rr ($query->answer) {
                push @addresses, $rr->address if $rr->type eq "AAAA";
            }
        }
    }

    return @addresses;
}

sub usage {
    print STDERR <<EOF;
Usage: $progname [-d] [-D] [-f] [-p port] [-Q srcaddr] [-r retry] [-s] [-t timeout] [-T] [-v] server(s)|Domain
Where: server|Domain is an ip address, a resolvable name, or a domain name.
       or '-' to read list of servers from stdin
       -d         (debug) [off]
       -D         (check all authoritative servers for Domain)
       -f         (force check CH TXT version) [off]
       -F nchild  (maximum forked processes) [10]
       -p port    (nameserver is on this port) [53]
       -Q srcaddr (source IP address) [0.0.0.0]
       -r retry   (set number of attempts) [1]
       -s	  (short form) [off]
       -S	  (separator) [" "]
       -t time    (set query timeout) [5]
       -T         (use TCP) [off]
       -v         (show version)

EOF
    exit 2;

}

&main;

=head1 NAME

fpdns - DNS server fingeprinting tool

=head1 SYNOPSIS

B<fpdns> S<[ B<-d> ]> S<[ B<-f> ]> S<[ B<-F> I<nchild> ]>
   S<[ B<-p> I<port> ]> S<[ B<-Q> I<srcaddr> ]> S<[ B<-r> I<retry> ]>
   S<[ B<-s> ]>  S<[ B<-S> I<separator> ]> S<[ B<-t> I<timeout> ]> S<[ B<-v> ]> [I<server(s)>]

=head1 DESCRIPTION

B<fpdns> is a program that remotely determines DNS server versions.
It does this by sending a series of borderline DNS queries which are
compared against a table of responses and server versions. 

False positives or incorrect versions may be reported when 
trying to identify a set of servers residing behind a 
load-balancing apparatus where the servers are of different 
implementations, when a specific implementation behaves like a 
forwarder, behind a firewall without statefull inspection or without 
I<Application Intelligence>.  

=head1 OPTIONS

=over 5

=item B<-d>

Enable debugging. Off by default. 

=item B<-D>

Check all authoritative servers of the specified domain name.

=item B<-f>

Force checking of CH TXT version. Off by default. 

=item B<-F> I<nchild>

Maximum number of forked child processes. Defaults to 10. 

=item B<-p> I<port>

Port to query remote nameserver on. Default is 53. 

=item B<-Q> I<srcaddr>

Set the source IP address to use. 

=item B<-r> I<retry>

Number of attempt to retry fingerprints. Defaults to 1. 

=item B<-s>

Short display form. Useful for surveys. 

=item B<-S>

Separator. Defaults to " ".

=item B<-t> I<timeout>

Set the query timeout in seconds. Defaults to 5. 

=item B<-T> 
                                                                                                                                      
Use TCP instead of UDP. 

=item B<-v>

Show version of fpdns. 

=item I<server>

IP address or name to query. Alternatively may be '-' to 
read from a list of these from stdin 

=back

=head1 AUTHORS

fpdns was written by Roy Arends and Jakob Schlyter.

=head1 SEE ALSO

L<perl(1)>, L<Net::DNS(1)>

=cut
