qmail vrfy.pl

#!/usr/local/bin/perl
# vrfy.pl v.92b
# copyright 2004 Jeremy Kister.  
# released under Perl's Artistic License 20040812
#
# verify envelope sender can take mail
# (similar to rather decommissioned VRFY SMTP verb)
#
# I dont recommend using this; it's just concept code to show
# what Verizon and friends are doing.
#
# If you do use this, it's *very* important to cache your results
# as you dont want to DoS some poor little server.  The implemented
# sql commands are natively compatible with MySQL and MSSQL w/FreeTDS.
#
#CREATE TABLE `email_cache` (
#  `email` varchar(255) NOT NULL,
#  `time` int(4) unsigned NOT NULL,
#  `code` tinyint(1) unsigned NOT NULL,
#  PRIMARY KEY  (`email`)
#) TYPE=MyISAM;

use strict;
use IO::Socket::INET;
use Net::DNS;
use DBI;

my $VERBOSE=0;

my $email = shift;
die "invalid looking email: $email\n"
 unless($email =~ /^([a-z0-9_\.\+\-\=\?\^\#])+\@(([a-z0-9\-])+\.)+([a-z0-9]{2,4})+$/i);

my $dsn = 'DBI:mysql:host=mysql.example.net;database=isp';
my $dbun = 'dbun';
my $dbpw = 'dbpw';
my $dbh = DBI->connect($dsn, $dbun, $dbpw, {RaiseError => 1});

my $sql = 'SELECT code FROM email_cache WHERE email = ' . $dbh->quote($email);
$sql .= ' AND time > ' . $dbh->quote($^T-43200); # 12 hours ago
my $sth = $dbh->prepare($sql);
$sth->execute;
my $row = $sth->fetchrow_hashref;
my $code = $row->{code};
if($code eq '1' || $code eq '0'){
	print $code;
	exit;
}

my $me;
if(open(F, "/var/qmail/control/helohost") || open(F, "/var/qmail/control/me") || open(F, "/etc/hostname")){
	chop($me = );
	close F;
}else{
	die "cannot determine helohost\n";
}

my ($user,$domain) = split /\@/, $email;
my $res = Net::DNS::Resolver->new;
my @mx = mx($res, $domain);

my $code = 0;
foreach my $rr (@mx){ # sorted by pref
	my $exchanger = $rr->exchange;
	if(($exchanger =~ /^(127|0|10|255|224)\./) ||
	   ($exchanger =~ /^192\.168\./) ||
	   ($exchanger =~ /^172\.(1(6|7|8|9)|2\d|3(0|1))\./) ||
	   ($exchanger =~ /^192\.0\.2\./)){
		sqllog($dbh,$email,0);
		last;
	}else{
		my $sock = IO::Socket::INET->new(PeerAddr => $exchanger,
		                                 PeerPort => 25,
		                                 Proto    => 'tcp',
		                                 Timeout  => 12);
		if($sock){
			my @banner = getlines($sock);
			print "banner: @banner\n" if($VERBOSE);
			unless($banner[-1] =~ /^220\s/){
				print $sock "QUIT\r\n"; # be nice
				next;
			}

			print $sock "HELO $me\r\n";
			my @helo = getlines($sock);
			print "helo: @helo\n" if($VERBOSE);
			unless($helo[-1] =~ /^250\s/){
				print $sock "QUIT\r\n"; # be nice
				next;
			}

			print $sock "MAIL FROM:<>\r\n";
			my @mf = getlines($sock);
			print "mf: @mf\n" if($VERBOSE);
			unless($mf[-1] =~ /^250\s/){
				print $sock "QUIT\r\n"; # be nice
				next;
			}

			print $sock "RCPT TO:<${email}>\r\n";
			my @rt = getlines($sock);
			print "rt: @rt\n" if($VERBOSE);
			if($rt[-1] =~ /^250\s/){
				# host accepted
				$code = 1;
				print $sock "QUIT\r\n"; # be nice
				last;
			}elsif($rt[-1] =~ /^5\d{2}/){
				# host rejected
				$code = 0;
				print $sock "QUIT\r\n"; # be nice
				last;
			}	# else tmp fail or dunno wtf, try next exchanger
		} # else try next exchanger.
	}
}


sqllog($dbh,$email,$code);

$dbh->disconnect;
print $code;
#exit $code;

sub getlines {
	my $sock = shift;
	my @lines;
	while(<$sock>){
		if(/^\d+\s/){
			chomp;
			push @lines, $_;
			last;
		}else{
			push @lines, $_;
		}
	}
	return(@lines);
}

sub sqllog {
	my ($dbh,$email,$code) = @_;

	my $sql = 'SELECT COUNT(*) FROM email_cache WHERE email = ' . $dbh->quote($email);
	my $sth = $dbh->prepare($sql);
	$sth->execute;
	my $row = $sth->fetchrow_hashref;
	my ($count) = values %$row;
	my $sql;
	if($count > 0){
		$sql = 'UPDATE email_cache SET time = ' . $dbh->quote($^T);
		$sql .= ', code = ' . $dbh->quote($code) . ' WHERE email = ' . $dbh->quote($email);
	}else{
		$sql = 'INSERT INTO email_cache VALUES (' . $dbh->quote($email);
		$sql .= ',' . $dbh->quote($^T) . ',' . $dbh->quote($code) . ')';
	}
	my $sth = $dbh->prepare($sql);
	$sth->execute;
}