#!/usr/bin/perl -w
#!/usr/local/bin/perl -w

my (%opt, @known_rejection_patterns, @known_good_patterns);

use Carp;
use Net::DNS;
use Net::Telnet;
use Sys::Hostname;
use Time::CTime;

# cheat ... clear the screen...
print "\t\t\t\t\t\n\n\n\n\n" x 100;

my $VERSION = 1.0;
my $AUTHOR  = "Unknown; code modified by -Sx- 2/16/2oo4...";

# What is the script name
my $iam;        ($iam = $0) =~ s,.*/,,;

# get the [host.]domain.org passed as cmd line arg
my $FQDN = shift || '';

# How long should we wait for things?
my $timeout = shift || 30;  # Set to taste...


unless ($FQDN) {
  print <<EOF;

        Program: $0\tVersion: $VERSION\nAuthor: $AUTHOR

FATAL:: Usage: $iam [hostname.]domainname.tld [timeout]

        ... where [hostname.] is optional and if given should be a fully 
            qualified host name domain name pair...

            If only domain.tld is given then it is a properly registered 
            domain - as examples:

            chasecreek.insecurity.org or insecurity.org or localhost or
            127.0.0.1 or some other valid IP address...

            [timeout] is optional and should be indicated in seconds.
            (The default timeout is $timeout seconds...)

Notes:  Do not enter the [] brackets...

EOF

  print "\t\t\t\t\t\n\n\n\n\n";
  exit(1);
}


# Let's Rock!!!
print STDERR "OK, we are researching Host/Domain: $FQDN ... timeout set to $timeout\n";

# -Sx- Vars
my (@mx, $name, $res, $query);


@known_rejection_patterns = (
  '^5\d\d .*(?i)((?i:spam)|bogus mail from|invalid (mail|address|user|sender)|access denied|configured to (reject|refuse)|syntax err|empty|<>|buildaddr|fqdn|Malformed|where is .* in that|Anonymous Senders Prohibited|input error|not verified|refused|error parsing|Argument required|Sender Not Authorised|Transaction failed|Illegal Address|envelope sender|sorry|not legal|local error in processing|Internal System Error|non local adresses|Address Rejected|fatal error|command argument|Failed address)',
  '451 (Command parser|Bad sender)',
  '452 Out of memory',
  '421 .*closing transmission channel',
  '451-.*local error in processing',
  '^5\d\d \s*$',
  );


@known_good_patterns = (
    '^[45]\d\d .*(?i)(message size|exceeds maximum|Insufficient disk space)',
    );



my $resolver = new Net::DNS::Resolver;

################################### Start of -Sx- section...
print "\n\n..............................\n\tProgram: $0\tVersion: $VERSION\nAuthor: $AUTHOR\n... Start of -Sx- tests ========\n\n";

#     Look up a host's addresses.

       $res   = Net::DNS::Resolver->new;
       $query = $res->search("$FQDN");

       if ($query) {
           foreach my $rr ($query->answer) {
               next unless $rr->type eq "A"; # Is this an A record?
               print $rr->address, " ... Host record was found!\n";

               &print_if_blackhole($rr->address);
               &print_if_ordb($rr->address);
               &print_if_dsbl($rr->address);
               &print_if_visi($rr->address);
               &print_if_sorbs($rr->address);
           }
       } else {
           warn "query failed: ", $res->errorstring, "\n No Host (A) Records found...\n\n";
       }


#     Find the nameservers for a domain.

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

       if ($query) {
           foreach $rr (grep { $_->type eq 'NS' } $query->answer) {
               print $rr->nsdname, " ... Name Server was found!\n";
           }
       }
       else {
           warn "query failed: ", $res->errorstring, "\n No Name Servers (NS) Records found...\n\n";
       }


#     Find the MX records for a domain.

       $name = "$FQDN";
       $res  = Net::DNS::Resolver->new;
       @mx   = mx($res, $name);

       if (@mx) {
           foreach $rr (@mx) {
               print $rr->preference, " ", $rr->exchange, " ... MX record was found.\n";
           }
       } else {
           warn "Can't find MX records for $name: ", $res->errorstring, "\n No Mail eXchange (MX) Records found...\n\n";
       }


#     Print a domain's SOA record in zone file format.

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

       if ($query) {
           ($query->answer)[0]->print;
       } else {
           print "query failed: ", $res->errorstring, "\n No SOA Record found...\n\n";
       }

print "\n... End of -Sx- tests ========\n..............................\n\n\n";
################################### End of -Sx- section...

# Check RFC-Ignorant lists for known bad behaviour
foreach $rbltype ("dsn", "abuse", "postmaster", "whois") {
  alarm($timeout);
  $query = $resolver->search($FQDN . ".$rbltype.rfc-ignorant.org.");
  alarm(0);
  if ($query) {
    foreach $rr ($query->answer) {
      next unless $rr->type eq "A";
      print STDERR "\n\tWARNING: This host is blocked with <http://www.rfc-ignorant.org/>: $rbltype\n";
    }
  }
}

# Look for MX hosts for the FQDN in question
@mx = mx($resolver,$FQDN);
if (scalar(@mx)>0) {

    # For each host returned on the MX list, get the A record(s)
    foreach $mx (@mx) {
        print STDERR "MX: ",$mx->exchange,"(",$mx->preference,")\n";
        alarm($timeout);
        $query = $resolver->search($mx->exchange);
        alarm(0);
        if ($query) {
            foreach $rr ($query->answer) {
                next unless $rr->type eq "A";
                $check_ips{$rr->address} = "MX:" . $mx->preference . "(" . $mx->exchange . ")";
            }
        }
    }
}

# If there are MX hosts, use those, otherwise, search for an A record
if (!scalar(%check_ips)) {
    $query = $resolver->search($FQDN);
    if ($query) {
        foreach $rr ($query->answer) {
            next unless $rr->type eq "A";
            $check_ips{$rr->address} = "A($FQDN)";
        }
    }
}

# Initialize the state variables that will tell us the results in the end
my $all_good=1;
my $incomplete=0;
my $unknown=0;

$my_hostname = hostname();
if (!defined($my_hostname) or $my_hostname eq "") {
    print STDERR "Error:  Cannot determine my own hostname!  Cannot continue...\n";
    exit(1);
}

foreach $ip (sort(keys(%check_ips))) {
    $result = &check_IP($ip);
    if (!defined($result)) {
        print STDERR "Warning: Unable to check IP: $ip\n";
        $incomplete=1;
    } elsif ($result==0) {
        print STDERR "ERROR: Bad response from IP: $ip\n";
        $all_good=0;
    } elsif ($result == -1) {
        print STDERR "WARNING: Unknown response from IP: $ip\n";
        $unknown=1;
    } else {
        print STDERR "OK: Acceptable response: $ip\n";
    }
}

if (!$all_good) {
  print STDERR "ERROR: At least one host failed the check.\n";
#  exit(1);
}

if ($unknown) {
  print STDERR "WARNING: Unknown response from at least one host, check manually.\n";
#  exit(3);
}

if ($incomplete) {
  print STDERR "WARNING: No bad hosts, but some could not be checked.\n";
#  exit(2);
}

print STDERR "Done checking $FQDN ... completed.\n" if ($all_good);

print "\t\t\t\t\t\n\n\n\n\n";
exit(0);


### Support subroutines

sub check_IP {
    my($ip)=shift;
    print STDERR "Checking IP: $ip [$check_ips{$ip}]";
    &print_if_blackhole($ip);
    &print_if_ordb($ip);
    &print_if_dsbl($ip);
    &print_if_visi($ip);
    &print_if_sorbs($ip);

    $session="\nWhile talking with $ip on " . ctime(time);
    $smtp = new Net::Telnet;
    $smtp->errmode("return");
    $start=time;
    $openretval = $smtp->open(Host => $ip, Port => 25, Timeout => $timeout);
    if (!defined($openretval)) {
        if (time-$start<$timeout) {
            print STDERR " - CONN_REFUSED\nThe remote system refused the request.\n\n";
        } else {
            print STDERR " - TIMEOUT\nIs out-bound Port 25 being blocked from: $my_hostname?\n\n";
        }
        return(undef);
    }
    ($prebanner, $banner) = $smtp->waitfor('/^\d\d\d .*$/');
    $session .= "$prebanner\n" if (defined($prebanner) and $prebanner ne "");
    $session .= "$banner\n"    if (defined($banner)    and $banner    ne "");
#    $smtp->dump_log("/tmp/smtpdump");
    print "\nBanners seen: $prebanner $banner\n\n";

    print "\nTesting >>> HELO (send) ... ";
    $helo_retval = $smtp->print("HELO $my_hostname");
    $session .= "HELO $my_hostname\n";
    if (!defined($helo_retval) or !$helo_retval) {
        print STDERR " - FAILED(HELO)\n";
        return(0);
    }

    print "\nTesting <<< HELO (response) ... ";
    ($prematch, $match) = $smtp->waitfor('/^\d{3}.*$/m');
    $session .= "$prematch\n" if (defined($prematch) and $prematch =~ /\S/m);
    $session .= "$match\n"    if (defined($match)    and $match    ne "");
    if (!defined($match) or $match !~ /^2/) {
        print STDERR " - FAILED(HELO)\n";
        print STDERR ">>> MAIL From: <>\n";
        print STDERR "Failure:\n"; &print_session($session); print STDERR ".\n";
        return(0);
    }

    print "\nTesting >>> MAIL From: <> (send) ... ";
    $mail_retval = $smtp->print("MAIL From: <>");
    $session .= "MAIL From: <>\n";
    if (!defined($mail_retval) or !$mail_retval) {
        print STDERR " - FAILED(MAIL)\n";
        return(0);
    }

    print "\nTesting <<< MAIL (response) ... ";
    ($prematch, $match) = $smtp->waitfor('/^\d{3}.*$/m');
    $session .= "$prematch\n" if (defined($prematch) and $prematch =~ /\S/m);
    $session .= "$match\n"    if (defined($match)    and $match    ne "");
    if (!defined($match) or grep($match=~$_, @known_rejection_patterns)) {
        print STDERR " - FAILED(MAIL)\n";
        print STDERR "Failure:\n"; &print_session($session);
        return(0);
    } elsif (defined($match) and $match !~ /^2/) {
        print STDERR " - UNKNOWN_RESPONSE(MAIL)\n";
        print STDERR "Failure:\n"; &print_session($session);
        return(-1);
    }

#    $anybody_failed	= 0;
#    print "\nTesting >>> RCPT To: <anybody@$FQDN> (send) ... ";
#    $rcpt_retval = $smtp->print("RCPT TO: <anybody\@$FQDN>");
#    $session .= "RCPT To: <anybody\@$FQDN>\n";
#    if (!defined($rcpt_retval) or !$rcpt_retval) {
#        print STDERR " - FAILED(RCPT)\n";
#        $anybody_failed = 1;
#    }
 
    $postmaster_failed	= 0;
    print "\nTesting >>> RCPT To: <postmaster@$FQDN> (send) ... ";
    $rcpt_retval = $smtp->print("RCPT TO: <postmaster\@$FQDN>");
    $session .= "RCPT To: <postmaster\@$FQDN>\n";
    if (!defined($rcpt_retval) or !$rcpt_retval) {
        print STDERR " - FAILED(RCPT)\n";
        $postmaster_failed = 1;
    }
 
    $abuse_failed	= 0;
    print "\nTesting >>> RCPT To: <abuse@$FQDN> (send) ... ";
    $rcpt_retval = $smtp->print("RCPT TO: <abuse\@$FQDN>");
    $session .= "RCPT To: <abuse\@$FQDN>\n";
    if (!defined($rcpt_retval) or !$rcpt_retval) {
        print STDERR " - FAILED(RCPT)\n";
        $abuse_failed = 1;
    }
 
    ### <<< RCPT (response)
    ($prematch, $match) = $smtp->waitfor('/^\d{3}.*$/m');
    $session .= "$prematch\n" if (defined($prematch) and $prematch =~ /\S/m);
    $session .= "$match\n"    if (defined($match)    and $match    ne "");
    if (!defined($match) or $match !~ /^2/) {
        print STDERR " - FAILED(MAIL)\n";
        print STDERR "Failure:\n"; &print_session($session);
        return(0);
    }

    print "\n";
    $rcpt_retval = $smtp->print("RSET");
    $rcpt_retval = $smtp->print("QUIT");
    print STDERR " - OK\n";
}

sub print_session {
    my($session)=shift;
    @session_lines=split(/\n/,$session);
    print STDERR "  ",join("\n  ",@session_lines),"\n";
}

######################## Blackholes
sub print_if_blackhole {
    my($ip)=shift;
    $rev_ip=join(".",reverse(split(/\./,$ip))) . ".backholes.us.";

    my($query,$rr);
    alarm($timeout); $query = $resolver->search($rev_ip);
    alarm(0);
    if ($query) {
        foreach $rr ($query->answer) {
            next unless $rr->type eq "A";
            print STDERR "\n\t\t ... was found listed on [RBL:blackholes.us] ...\n";
        }
    }

    $blackhole = 0;
# Is the IP Address a 'BOGON' Listed IP? in other words, unallocated...
    $blackhole++ if ($ip =~ /^10\./);
    $blackhole++ if ($ip =~ /^223\.0/);
    $blackhole++ if ($ip =~ /^192\.168/);
    $blackhole++ if ($ip =~ /^64\.46\.0/);
    print STDERR "\nWARNING: One or more IP addresses are in the Unallocated IP block ... may be a blackhole.\n" if ($blackhole);
}

################### Open Relays
sub print_if_ordb {
    my($ip)=shift;
    $rev_ip=join(".",reverse(split(/\./,$ip))) . ".relays.ordb.org.";

    my($query,$rr);
    alarm($timeout); $query = $resolver->search($rev_ip);
    alarm(0);
    if ($query) {
        foreach $rr ($query->answer) {
            next unless $rr->type eq "A";
            print STDERR "\n\t\t ... was found listed on [RBL:ordb.org] as a open relay.\n";
        }
    }
}

################### Other tests
sub print_if_dsbl {
    my($ip)=shift;
    $rev_ip=join(".",reverse(split(/\./,$ip))) . ".list.dsbl.org.";

    my($query,$rr);
    alarm($timeout); $query = $resolver->search($rev_ip);
    alarm(0);
    if ($query) {
        foreach $rr ($query->answer) {
            next unless $rr->type eq "A";
            print STDERR "\n\t\t ... was found listed on [RBL:dsbl.org] ...\n";
        }
    }
}

################### Open Relays
sub print_if_visi {
    my($ip)=shift;
    $rev_ip=join(".",reverse(split(/\./,$ip))) . ".relays.visi.com.";

    my($query,$rr);
    alarm($timeout); $query = $resolver->search($rev_ip);
    alarm(0);
    if ($query) {
        foreach $rr ($query->answer) {
            next unless $rr->type eq "A";
            print STDERR "\n\t\t ... was found listed on [RBL:visi.com] as a open relay.\n";
        }
    }
}

#################### Dynamic IPs
sub print_if_sorbs {
    my($ip)=shift;
    $rev_ip=join(".",reverse(split(/\./,$ip))) . ".dnsbl.sorbs.net.";

    my($query,$rr);
    alarm($timeout); $query = $resolver->search($rev_ip);
    alarm(0);
    if ($query) {
        foreach $rr ($query->answer) {
            next unless $rr->type eq "A";
            print STDERR "\n\t\t ... was found listed on [Dynamic IP:dnsbl.sorbs.net]\n\t\t Dynamic IP Space (Cable, DSL & Dial Ups).\n";
        }
    }
}


__END__


... 
Enter any site specific notes here.

WC -Sx- Jones
Feb 16th, 2oo4