#!/usr/bin/perl -w

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

use Carp;
use Net::DNS;
use Net::Telnet;
use Getopt::Std;
use Sys::Hostname;
use Time::CTime;
($iam = $0) =~ s,.*/,,;

@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)',
    );

$ret = getopts("",\%opt);

if (!$ret) {
  print <<EOF;
Usage: $iam hostname
EOF
  exit(1);
}

$timeout=10;
$FQDN = shift;
print STDERR "Host: $FQDN\n";

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

# 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 "WARNING: 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
$all_good=1;
$incomplete=0;
$unknown=0;

$my_hostname = hostname();
if (!defined($my_hostname) or $my_hostname eq "") {
    print STDERR "Error: cannot determine my own hostname!\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 "Good: all of the hosts passed the checks.\n";
exit(0);

### Support subroutines

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

    $session="While 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\n";
        } else {
            print STDERR " - TIMEOUT\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");

    ### >>> 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);
    }

    ### <<< 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);
    }

    ### >>> 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);
    }

    ### <<< 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);
    }

    $postmaster_failed = 0;

    ### >>> RCPT To: <postmaster@$FQDN> (send)
    $rcpt_retval = $smtp->print("RCPT TO: <postmaster\@$FQDN>");
    $session .= "RCPT To: <postmaster\@$FQDN>\n";
#    $session .= "RCPT To: <abuse\@$FQDN>\n";
    if (!defined($rcpt_retval) or !$rcpt_retval) {
        print STDERR " - FAILED(RCPT)\n";
        $postmaster_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);
    }

    $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";
}

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 " [RBL:ordb.org]";
            last;
        }
    }

}