package check_mail_address;

use strict;

use Sys::Syslog qw(:DEFAULT setlogsock);
use IO::Socket;
use Net::DNS;
use Net::Domain qw(hostname hostfqdn hostdomain);

use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);

use Exporter;

$VERSION = 0.01;

@ISA = qw(Exporter);

# Автоматически экспортируемые имена (набор :DEFAULT)
@EXPORT      = qw(verify_address);

# Имена, экспортируемые по запросу
@EXPORT_OK   = qw(verify_address);

my(@excluded) = (
#"550 ukr.net . R u jokin' .",
#"550 .* Relaying denied",
#"Administrative prohibition"
);

my(%alternative_mx) = (
#    'ukr.net' => 'freemail.ukr.net',
    'localhost' => 'localhost'
);

sub verify_address {
    my($address, $use_vrfy, $max_attempts, $syslog_param, $verbose) = @_;
    $address =~ s/^\s*\<//;
    $address =~ s/\>\s*$//;
    my($mailbox, $domain) = ($address =~ /\s*(.+)\@(.+)\s*$/);
    my($socket, $command, $answer);

    my($use_syslog) = 1 if ($syslog_param);

    if (($mailbox) and ($domain)) {
	my(@tmp);
	($command, $answer) = get_mx_records($mailbox, $domain, \@tmp, $verbose);

	my(@hosts);
	$max_attempts = 1 if ($max_attempts < 1);
	my($i);
	for ($i = 0; $i < $max_attempts; $i++) {
	    @hosts = (@hosts, @tmp);
        }

	while (@hosts) {
	    my($host) = pop(@hosts);
	    print_msg("connect to $host:25...", $verbose);
	    $socket = IO::Socket::INET->new(
		PeerAddr => $host, PeerPort => 25, Proto => 'tcp', Type => SOCK_STREAM);
	    unless ($socket) {
		$command = "connect to $host:25\r\n";
		$answer = "431 couldn't connect to $host:25\r\n";
		print_msg(" failed:".$@."...\n", $verbose);
		print_syslog($mailbox, $domain, $host, "couldn't connect to $host:25", $@, "check passed", $use_syslog, $syslog_param);
	    } else {
		print_msg(" success...\n", $verbose);
		$socket->autoflush(1);

		$command = "getting MTA prompt\r\n";
		$answer = print_socket($socket, "", $verbose);

		if ($answer !~ /^220\s/) {
		    $answer = "431 couldn't get MTA prompt\r\n";
		    print_syslog($mailbox, $domain, $host, "getting MTA prompt failed", $answer, "check passed", $use_syslog, $syslog_param);
		} else {
		    my($hostname) = hostfqdn();
		    unless ($hostname) {
			if (open(HOSTNAME, "|/bin/hostname")) {
			    $hostname = <HOSTNAME>;
			    close(HOSTNAME);
			}
		    }
		    $hostname = 'sorry-test.'.$domain unless ($hostname);
		    $command = "HELO $hostname\r\n";
		    $answer = print_socket($socket, $command, $verbose);

		    if ($answer !~ /^25\d\s/) {
			print_syslog($mailbox, $domain, $host, "helo $hostname", $answer, "check passed", $use_syslog, $syslog_param);
		    } else {
			$answer = '';
			if ($use_vrfy) {
			    $command = "vrfy $mailbox\@$domain\r\n";
			    $answer = print_socket($socket, $command, $verbose);
			    if ($answer =~ /^55\d\s/) {
				print_syslog($mailbox, $domain, $host, "vrfy $mailbox\@$domain", $answer, "user unknown", $use_syslog, $syslog_param);
			    } elsif ($answer !~ /^250\s/) {
				$answer = '';
			    }
			}
			unless ($answer) {
			    $command = "MAIL From:<>\r\n";
			    $answer = print_socket($socket, $command, $verbose);
			    if ($answer !~ /^25\d\s/) {
				print_syslog($mailbox, $domain, $host, "mail from:<>", $answer, "check passed", $use_syslog, $syslog_param);
			    } else {
				$command = "RCPT To:<$mailbox\@$domain>\r\n";
				$answer = print_socket($socket, $command, $verbose);

				if ($answer =~ /^55\d\s/) {
				    foreach (@excluded) {
					$answer = '250 answer in excluded list: '.$answer if ($answer =~ /^$_$/i);
				    }
				    if ($answer =~ /^55\d\s/) {
					print_syslog($mailbox, $domain, $host, "rcpt to:<$mailbox\@$domain>", $answer, "user unknown", $use_syslog, $syslog_param);
				    } else {
					print_syslog($mailbox, $domain, $host, "rcpt to:<$mailbox\@$domain>", $answer, "excluded", $use_syslog, $syslog_param);
				    }
				} else {
				    print_syslog($mailbox, $domain, $host, "rcpt to:<$mailbox\@$domain>", $answer, "user ok", $use_syslog, $syslog_param);
				}
			    }
			    last;
			}
		    }
		}
		print_socket($socket, "quit\r\n", $verbose);
	    }
	}
    }
    return(($command, $answer));
}

sub get_mx_records() {
    my($mailbox, $domain, $hosts, $verbose) = @_;
    my($command, $answer);

    if ($alternative_mx{$domain}) {
	$command = "use alternative MX record(s) for domain '$domain'\r\n";
	$answer = "250 Ok\r\n";
	@$hosts = ($alternative_mx{$domain});
	if (scalar(@$hosts) == 1) {
	    print_msg("use alternative host '".$$hosts[0]."' for checking address $mailbox\@$domain\n", $verbose);
	} elsif (scalar(@$hosts) > 1) {
	    print_msg("use folowing alternative hosts for checking address $mailbox\@$domain:\n", $verbose);
	    foreach (@$hosts) {
		print_msg("$_\n", $verbose);
	    }
	}
    } else {
	print_msg("connect to resolver...", $verbose);
	my($res) = Net::DNS::Resolver->new();
	if (!$res) {
	    print_msg(" failed...\n", $verbose);
	    $command = "connect to resolver\r\n";
	    $answer = "451 couldn't connect to resolver\r\n";
	} else {
	    print_msg(" success...\n", $verbose);
	    print_msg("check MX records for domain '$domain'...", $verbose);
	    my(@mx) = mx($res, $domain);
	    if (!@mx) {
		print_msg(" no MX records found\n", $verbose);
		$command = "check MX records for domain '$domain'\r\n";
		$answer = "451 Domain '$domain' does not resolve\r\n";

		print_msg("check A record(s) for domain '$domain'...", $verbose);
		my($query) = $res->search($domain);
		if ($query) {
		    foreach my $rr ($query->answer) {
			next unless ($rr->type eq "A");
			push(@$hosts, $rr->address);
		    }
		    if (!@$hosts) {
			print_msg(" no A record(s) found\n", $verbose);
			$command = "check MX or A records for domain '$domain'\r\n";
			$answer = "451 Domain '$domain' does not resolve\r\n";
		    } else {
			if (scalar(@$hosts) == 1) {
			    print_msg(" 1 A record found - ".$$hosts[0]."\n", $verbose);
			} elsif (scalar(@$hosts) > 1) {
			    print_msg(" ".scalar(@$hosts)." records found:\n", $verbose);
				foreach (@$hosts) {
				print_msg("$_\n", $verbose);
			    }
			}
		    }
		} else {
		    print_msg(" Domain '$domain' does not exist\n", $verbose);
		    $command = "check any records for domain '$domain'\r\n";
		    $answer = "553 Domain '$domain' does not exist\r\n";
		}
	    } else {
		print_msg(" ".scalar(@mx)." record(s) found\n", $verbose);
		my($record);
		my($preference) = -1;
		foreach $record (@mx) {
		    print_msg("MX record found: ".$record->exchange.", pri=".$record->preference."\n", $verbose);
		    if (($preference == -1) or ($preference > $record->preference)) {
			@$hosts = ($record->exchange);
			$preference = $record->preference;
		    } elsif ($preference == $record->preference) {
			push(@$hosts, $record->exchange);
		    }
		}
		if (scalar(@$hosts) == 1) {
		    print_msg("primary MX record is ".$$hosts[0]."\n", $verbose);
		} elsif (scalar(@$hosts) > 1) {
		    print_msg("primary MX records are:\n", $verbose);
		    foreach (@$hosts) {
			print_msg("$_\n", $verbose);
		    }
		}
	    }
	}
    }
    return(($command, $answer));
}

sub print_socket() {
    my($socket, $msg, $verbose) = @_;

    my($answer);
    if ($msg) {
	print($socket $msg);
#	$socket->send($msg) ;
	print_msg($msg, $verbose);
    }

    $answer = <$socket>;
#    $socket->recv($answer, 2048);
    print_msg($answer, $verbose);
    while (($answer) and ($answer !~ /^\d\d\d /)) {
	$answer = <$socket>;
#	$socket->recv($answer, 2048);
	print_msg($answer, $verbose);
    }
    return($answer);
}

sub print_msg() {
    my($msg, $verbose) = @_;
    print(STDERR $msg) if ($verbose);
}

sub print_syslog() {
    my($mailbox, $domain, $host, $SMTP_command, $SMTP_answer, $check_result, $use_syslog, $syslog_param) = @_;
    if ($use_syslog) {
	$SMTP_answer =~ s/[\r\n]$//g;
	my($msg) = $$syslog_param{'logformat'};
	$msg =~ s/\%mailbox/$mailbox/;
	$msg =~ s/\%domain/$domain/;
	$msg =~ s/\%SMTP_host/$host/;
	$msg =~ s/\%SMTP_command/$SMTP_command/;
	$msg =~ s/\%SMTP_answer/$SMTP_answer/;
	$msg =~ s/\%check_result/$check_result/;
	syslog($$syslog_param{'priority'}, $msg);
    }
}

1;
