#!/usr/bin/perl 
use warnings;
use strict;

use POSIX ":sys_wait_h";
use IO::Socket::INET;
use Net::DNS;
use Sys::Hostname;
use Sys::Syslog;
use DBI;

my $hostname = hostname();

my $configfile = $ARGV[0] || "/etc/smtp_callback/smtpcbd.conf";
open (my $cfh, '<', $configfile) or die "cannot open $configfile: $!";
my %cfg = (
    listen_port => 4571,
    facility => 'LOG_DAEMON',
    query_address => "<postmaster\@$hostname>",
);
while (<$cfh>) {
    chomp;
    my ($k, $v) = split(/\s*:\s*/, $_, 2);
    $cfg{$k} = $v;
}
close($cfh);

detach();

my $ident = $0;
$ident =~ s{.*/}{};
openlog $ident, 'pid', $cfg{facility};

my $lsck = IO::Socket::INET->new(Proto => 'tcp',
				 Listen => 20,
				 ReuseAddr => 1,
				 $cfg{listen_addr} ? ( LocalAddr => $cfg{listen_addr} ) : (),
				 LocalPort => $cfg{listen_port},
				);
unless ($lsck) {
	syslog('err', "cannot bind to socket %s:%d: %m", $cfg{listen_addr} || 'ANY', $cfg{listen_port});
	exit(1);
}
syslog('info', "listening on %s:%d", $cfg{listen_addr} || 'ANY', $cfg{listen_port});

my $terminate;
$SIG{TERM} = sub { $terminate = 1};

for (;;) {
    if ($terminate) {
	syslog('notice', "going down");
	exit(0);
    }
    my $rsck = $lsck->accept();
    my $pid = fork();
    unless (defined($pid)) {
	syslog('err', "fork failed: %m");
	sleep(1);
	next;
    }
    if ($pid) {
	while ((my $pid = waitpid(-1, WNOHANG)) > 0) {
	    syslog('debug', "kid $pid terminated");
	}
	next;
    }
    my $request = $rsck->getline();
    syslog('info', "get request [$request]");
    my ($address, @args) = split(' ', $request);
    syslog('info', "address = %s, args = " . join(", ", ("%s") x @args), $address, @args);

    $address = "<$address>" unless $address =~ /^<.*>$/;

    syslog('info', __LINE__);
    my $dbh = DBI->connect($cfg{cache_datasource}, $cfg{cache_user}, $cfg{cache_password}, 
    			   { } );
    syslog('info', __LINE__);
    unless ($dbh) {
	syslog('err', "cannot connect to cache $cfg{cache_datasource}: %s", $DBI::errstr);
	exit(1);
    }
    syslog('info', __LINE__);
    my ($email, $cstatus, $first_seen, $expire, $count, $msg, $server) = 
	$dbh->selectrow_array("select email, status, first_seen, expire, count, msg, server from smtpcb where email=?", {}, $address);
    syslog('info', __LINE__);
    if ($email && $expire > time()) {
	syslog('info', "found in cache: %s %s %s %s %s %s %s", $email, $cstatus, $first_seen, $expire, $count, $msg, $server);
	$rsck->print("${cstatus}:${msg}:${address}:$server:$first_seen:$expire\n");
	exit(0);
    }
    syslog('info', __LINE__);

    my $domain;
    if ($address =~ /\@([-.a-zA-Z0-9]+)>?$/) {
	$domain = $1;
	syslog('info', "domain is $domain");
    } else {
	syslog('info', "FAIL: no domain: $address");
	$rsck->print("FAIL:no domain:$address\n");
	exit 0;
    }
    my @mx = get_mx($domain);
    unless (@mx) {
	syslog('info', "FAIL: no MX or A for domain: $address");
	$rsck->print("FAIL:no MX or A for domain:$address\n");
	exit 0;
    }

    my $status;
    MX: for my $mx (@mx) {
	for my $ip ((@$mx)[2..$#$mx]) {
	    syslog('info', "trying ip $ip");
	    eval {
		local $SIG{ALRM} = sub { die "timeout" };
		alarm(120);
		my $s = IO::Socket::INET->new(PeerAddr => $ip, PeerPort => 25, Timeout => 60);
		unless ($s) {
		    syslog('info', "cannot connect to %s: %m", $ip);
		    next;
		}

		while (my $r = $s->getline) {
		    syslog('info', "connect: %s", $r);
		    last if ($r =~ /^\d\d\d /);
		}
		$s->print("EHLO $hostname\r\n");
		my $ln = 0;
		my $size = 0;
		my $vrfy_supported;
		my $esmtp;
		while (my $r = $s->getline) {
		    syslog('info', "ehlo: %s", $r);
		    if ($r =~ /^250[- ]([-\w]+)/ && ++$ln > 1 && uc($1) eq 'VRFY') {
			$vrfy_supported = 1;
		    }
		    $esmtp = 1 if ($r =~ /^250 /);
		    last if ($r =~ /^\d\d\d /);
		}
		unless ($esmtp) {
		    $s->print("HELO $hostname\r\n");
		    while (my $r = $s->getline) {
			syslog('info', "helo: %s", $r);
			last if ($r =~ /^\d\d\d /);
		    }
		}
		if ($vrfy_supported && $cfg{use_vrfy}) {
		    alarm(120);
		    $s->print("VRFY $address\r\n");
		    $msg = "";
		    while (my $r = $s->getline) {
			syslog('info', "vrfy: %s", $r);
			$msg .= $r;
			if ($r =~ /^250 /) {
			    $status = 'OK';
			    $server = $ip;
			    syslog('info', "status=$status");
			}
			if ($r =~ /^251 /) {
			    $status = 'OK';
			    $server = $ip;
			    syslog('info', "status=$status");
			}
			if ($r =~ /^550 /) {
			    $status = 'FAIL';
			    $server = $ip;
			    syslog('info', "status=$status");
			}
			if ($r =~ /^551 /) {
			    $status = 'FAIL';
			    $server = $ip;
			    syslog('info', "status=$status");
			}
			last if ($r =~ /^\d\d\d /);
		    }
		}
		unless (defined $status && $status ne 'TEMPFAIL') {
		    alarm(120);
		    $s->print("MAIL FROM:<>\r\n");
		    while (my $r = $s->getline) {
			syslog('info', "mail from: %s", $r);
			$msg .= $r;
			if ($r =~ /^2/) {
			    $status = 'OK';
			    $server = $ip;
			    syslog('info', "status=$status");
			}
			if ($r =~ /^4/) {
			    $status = 'TEMPFAIL';
			    $server = $ip;
			    syslog('info', "status=$status");
			}
			if ($r =~ /^5/) {
			    $status = 'FAIL';
			    $server = $ip;
			    syslog('info', "status=$status");
			}
			last if ($r =~ /^\d\d\d /);
		    }
		    if ($status eq 'OK') {
			$status = undef;
			$s->print("RCPT TO:$address\r\n");
			$msg = "";
			while (my $r = $s->getline) {
			    syslog('info', "rcpt to: %s", $r);
			    $msg .= $r;
			    if ($r =~ /^2/) {
				$status = 'OK';
				$server = $ip;
				syslog('info', "status=$status");
			    }
			    if ($r =~ /^4/) {
				$status = 'TEMPFAIL';
				$server = $ip;
				syslog('info', "status=$status");
			    }
			    if ($r =~ /^5/) {
				$status = 'FAIL';
				$server = $ip;
				syslog('info', "status=$status");
			    }
			    last if ($r =~ /^\d\d\d /);
			}
		    }
		    if ($status eq 'FAIL') {
			# maybe the recipient doesn't like bounces. 
			# try a real address
			alarm(120);
                        $s->print("RSET\r\n");
                        while (my $r = $s->getline) {
                            syslog('info', "rset: %s", $r);
                            $msg .= $r;
                            if ($r =~ /^2/) {
                                $status = 'OK';
                                $server = $ip;
                                syslog('info', "status=$status");
                            }
                            if ($r =~ /^4/) {
                                $status = 'TEMPFAIL';
                                $server = $ip;
                                syslog('info', "status=$status");
                            }
                            if ($r =~ /^5/) {
                                $status = 'FAIL';
                                $server = $ip;
                                syslog('info', "status=$status");
                            }
                            last if ($r =~ /^\d\d\d /);
                        }

			syslog('info', "trying mail from:%s", $cfg{query_address});
			$s->print("MAIL FROM:$cfg{query_address}\r\n");
			while (my $r = $s->getline) {
			    syslog('info', "mail from: %s", $r);
			    $msg .= $r;
			    if ($r =~ /^2/) {
				$status = 'OK';
				$server = $ip;
				syslog('info', "status=$status");
			    }
			    if ($r =~ /^4/) {
				$status = 'TEMPFAIL';
				$server = $ip;
				syslog('info', "status=$status");
			    }
			    if ($r =~ /^5/) {
				$status = 'FAIL';
				$server = $ip;
				syslog('info', "status=$status");
			    }
			    last if ($r =~ /^\d\d\d /);
			}
			if ($status eq 'OK') {
			    $status = undef;
			    $s->print("RCPT TO:$address\r\n");
			    $msg = "";
			    while (my $r = $s->getline) {
				syslog('info', "rcpt to: %s", $r);
				$msg .= $r;
				if ($r =~ /^2/) {
				    $status = 'OK';
				    $server = $ip;
				    syslog('info', "status=$status");
				}
				if ($r =~ /^4/) {
				    $status = 'TEMPFAIL';
				    $server = $ip;
				    syslog('info', "status=$status");
				}
				if ($r =~ /^5/) {
				    $status = 'FAIL';
				    $server = $ip;
				    syslog('info', "status=$status");
				}
				last if ($r =~ /^\d\d\d /);
			    }
			}
		    }
		}


		$s->print("QUIT\r\n");
		while (my $r = $s->getline) {
		    syslog('info', "quit: %s", $r);
		    last if ($r =~ /^\d\d\d /);
		}
		alarm(0);
	    };
	    last MX if (defined($status) && $status ne 'TEMPFAIL');
	}
    }
    syslog('info', __LINE__);
    exit(0) unless defined($status);
    $msg =~ s/(\r?\n)+$//;
    $msg =~ s/%/%25/g;
    $msg =~ s/:/%3A/g;
    $msg =~ s/\r?\n/%0A/g;
    if ($first_seen && $cstatus eq $status) {
	my $now = time();
	$expire = int($now + ($now - $first_seen) * 0.2);
	if ($status eq 'TEMPFAIL') {
	    $expire = $now + 3600 if $expire > $now + 3600;
	} else {
	    $expire = $now + 86400*7 if $expire > $now + 86400*7;
	}

    } else {
	$first_seen = time();
	$expire = $first_seen + 3600;
    }
    $rsck->print("${status}:${msg}:$address:$server:$first_seen:$expire\n");
    if ($email) {
	if ($cstatus eq $status) {
	    $dbh->do("update smtpcb set expire=?, count=count+1, msg=?, server=? where email=?", {},
		     $expire,
		     $msg,
		     $server,
		     $address);
	} else {
	    $dbh->do("delete from smtpcb where email=?", {},
		     $address);
	    $dbh->do("insert into smtpcb(email, status, first_seen, expire, count, msg, server) values (?, ?, ?, ?, ?, ?, ?)", {},
					 $address, $status, $first_seen, $expire, 1, $msg, $server);
	}
    } else {
	$dbh->do("insert into smtpcb(email, status, first_seen, expire, count, msg, server) values (?, ?, ?, ?, ?, ?, ?)", {},
				     $address, $status, $first_seen, $expire, 1, $msg, $server);
    }
    syslog('info', __LINE__);
    exit(0);
}

sub get_mx {
    my ($domain) = @_;

    my $res = Net::DNS::Resolver->new;
    my $answer = $res->query($domain, 'MX');
    my @mx = ();
    if ($answer) {
	syslog('info', "DNS query $domain MX: ", $answer->header->rcode, "");
	for my $rr ($answer->answer) {
	    if ($rr->type eq 'MX') {
		push @mx, [ $rr->preference, $rr->exchange ]
	    }
	}
    }
    push @mx, [ 0, $domain ] unless @mx;

    @mx = sort { $a->[0] <=> $b->[0] } @mx;
    for my $mx (@mx) {
	my $answer = $res->query($mx->[1], 'A');
	if ($answer) {
	    syslog('info', "DNS query $mx->[1] A: ", $answer->header->rcode, "");
	    for my $rr ($answer->answer) {
		if ($rr->type eq 'A') {
		    push @$mx, $rr->address;
		}
	    }
	}
    }

    # now each entry of @mx contains a priority, a domain name and zero or more IP addresses
    # we are only interested in entries with at least one ip address
    @mx = grep { scalar @$_ > 2 } @mx;
    return @mx;
}

sub detach {
    open STDIN, '/dev/null' or die "/dev/null: $!";
    open STDOUT, '>/dev/null' or die "/dev/null: $!";
    open STDERR, '>&STDOUT' or die "open(stderr): $!";
    defined (my $pid = fork) or die "fork: $!";
    exit 0 if $pid;
    POSIX::setsid or die "setsid: $!";
}