SPF Test
Check what MX servers reject on spf fail
[Intro] [Description] [Results] [Conclusions] [Perl script]

#! /usr/bin/perl
# use: shuf < domain-list | runtest.pl
# check whether MX servers reject on fail

use strict;
use warnings;
use Net::DNS;
use Net::DNS::RR;
use NetAddr::IP;
use Mail::SPF;
use Error qw(:try);
use IO::Socket::INET;
use Net::Cmd;
use DBI;

@main::ISA = qw(Net::Cmd IO::Socket::INET);

# test options:
my $spf_server = Mail::SPF::Server->new(
	query_rr_types => Mail::SPF::Server->query_rr_type_txt);
my $spf_test_ip = new NetAddr::IP::Lite('203.0.113.99'); # TEST-NET-3 from RFC 5737

my $table_name = 'survey';
my $local_ip = '62.94.243.229';          # IP (or name) to use for SMTP client
my $helo_cmd = 'HELO spftest.tana.it';   # all cmd except trailing CRLF
my $mail_cmd = 'MAIL FROM:<dummy@spf-all.com>';
my $mail_chk = 'MAIL FROM:<dummy@spftest.tana.it>';
my $resolver = Net::DNS::Resolver->new;  # set any DNS options here

# DB options:
my $dbh = DBI->connect("DBI:mysql:database=mix;", "web") or
	die $DBI::err.": ".$DBI::errstr;
$dbh->do(' CREATE TABLE IF NOT EXISTS '. $table_name .' ('.
	' domain VARCHAR(64) NOT NULL PRIMARY KEY,'.
	' test_date TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,'.
	# the following column names are used in SET <column-name>=<value>
	' up_date TIMESTAMP,'.
	' ranges INT,'.            # number of different IP ranges with domain
	' score VARCHAR(16),'.     # from dnswl scores
	' category VARCHAR(16),'.  # categories
	' spf_type VARCHAR(4),'.   # NONE, TXT, SPF, BOTH, VARY, BAD
	' spf_queries TINYINT,'.   # additional queries to establish default result
	' spf_default VARCHAR(10),'.  # spf result for spf_test_ip (fail/softfail...)
	' result VARCHAR(10) NOT NULL,'. # R-ON_FAIL for reject-on-fail
	' host VARCHAR(64),'.    # mx server
	' mx_order TINYINT,'.    # 0 if using fallback-to-a, 1.. otherwise
	' banner TINYTEXT,'.
	' reply_mail TINYTEXT,'. # what did it say for mail_cmd
	' mail_code SMALLINT,'.
	' mail_chk TINYTEXT,'.   # what did it say for mail_chk command
	' mail_chk_code SMALLINT)') or
	die $DBI::err.": ".$DBI::errstr;
my $insert_stmt = 'REPLACE INTO '. $table_name .' SET';


# utility
sub trim
{
	my $s = shift;
	return '' unless defined $s;
	$s =~ s/^\s+|\s+$//g;
	return $s
}

my %results = ();
print 'Started ', $$, $/;

# main loop
while (<STDIN>)
{
	chomp;
	#              domain                 ranges              category  score
	next unless m/^([-._a-zA-Z0-9]+)(?:\s+([1-9][0-9]*)(?:\s+(\S+)(?:\s+(\S+))?)?)?\s*$/;
	my $domain = $1;
	my $result = 'UNEXPECTED';
	my $mx_order = 0;

	# Initialize db variables
	my $db_values = ' domain='. $dbh->quote($domain) .',up_date=NOW(),';
	$db_values .= 'ranges='. $2 .',' if defined($2);
	$db_values .= 'category='. $dbh->quote(trim($3)) .',' if defined($3);
	$db_values .= 'score='. $dbh->quote(trim($4)) .',' if defined($4);


	# Lookup MXes.  If none try domain name
	my @mx = mx($resolver, $domain);
	if (@mx <= 0)
	{
		if ($resolver->errorstring eq 'NOERROR')
		{
			$mx_order = -1;
			@mx = Net::DNS::RR->new("$domain. MX 0 $domain.");
		}
		else # SERVFAIL, NXDOMAIN
		{
			$result = $resolver->errorstring;
		}
	}

	# Try each MX until can connect to one
	foreach my $rr (@mx)
	{
		my $host = lc($rr->exchange);
		chomp($host);
		++$mx_order;
		$result = 'SMTPNOCONN';
		my $s = IO::Socket::INET->new(
			LocalAddr => $local_ip,
			PeerAddr => $host,
			PeerPort => 'smtp(25)',
			Timeout => 60)
				or next;
		
		# connected?
		my $sock = bless($s);
		$sock->response();
		next unless defined($sock->code) && defined($sock->message);
		
		$db_values .= 'host='. $dbh->quote(trim($host)) .','.
			"mx_order=$mx_order,".
			'banner='. $dbh->quote(trim($sock->message)) .',';

		# test if they define an SPF record, and its result on a dummy IP
		try
		{
			my $spf_SPF = $resolver->bgsend($domain, 'SPF');
			my $spf_request = Mail::SPF::Request->new(
				scope => 'helo', identity => $domain, ip_address  => $spf_test_ip);
			my $spf_result = $spf_server->process($spf_request);
			my $spf_SPF_packet = $resolver->bgisready($spf_SPF)?
				$resolver->bgread($spf_SPF) : undef;
			$spf_SPF = undef;
			if (defined($spf_SPF_packet) &&
				$spf_SPF_packet->header->rcode eq 'NOERROR')
			{
				my @versions = $spf_request->versions;
				my @recs =
					$spf_server->get_acceptable_records_from_packet(
						$spf_SPF_packet,
						'SPF',
						\@versions,
						$spf_request->scope,
						$spf_request->authority_domain);
				$spf_SPF = $recs[0] if (@recs == 1);
			}
			$db_values .= sprintf('spf_queries=%d,',
				$spf_request->state('dns_interactive_terms_count'));

			my $spf_type;
			my $record = $spf_request->record;
			if (defined($record) and defined($spf_SPF))
			{
				$spf_type = ($spf_SPF eq $record)? 'BOTH': 'VARY';
			}
			elsif (defined($record))
			{
				$spf_type = 'TXT';
			}
			elsif (defined($spf_SPF))
			{
				$spf_type = 'SPF';
			}
			else
			{
				$spf_type = 'NONE';
			}
			$db_values .= 'spf_type='. $dbh->quote(trim($spf_type)) .',';

			if (defined($spf_result))
			{
				$db_values .= 'spf_default='. $dbh->quote(trim($spf_result->code)) .',';
				#	'spf record: ', $record->text, "\n";
			}
		}
		otherwise
		{
			$db_values .= 'spf_type='. $dbh->quote('BAD') .',';
		};

		# Try sending helo + mailfrom(bad).
		# If rejected, RSET and try mailfrom(chk).
		# Then quit.
		if ($sock->code != 220)
		{
			$result = 'SMTPERROR';
		}
		else
		{
			$sock->command($helo_cmd)->response();
			if ($sock->code != 250)
			{
				$result = 'REJECTHELO';
				$db_values .= 'reply_mail='.
					$dbh->quote(trim($sock->message)) .',';
			}
			else
			{
				$sock->command($mail_cmd)->response();
				$db_values .= 'mail_code='. $sock->code .',';
				if ($sock->code == 250)
				{
					$result = 'ACCEPT';
				}
				elsif ($sock->code >= 500)
				{
					$db_values .= 'reply_mail='.
						$dbh->quote(trim($sock->message)) .',';
					$sock->command('RSET')->response();
					if ($sock->code == 250)
					{
						$result = 'REJECT';
						$sock->command($mail_chk)->response();
						$result = 'R-ON-FAIL' if ($sock->code == 250);
						$db_values .= 'mail_chk_code='. $sock->code .','.
							'mail_chk='. $dbh->quote(trim($sock->message)) .',';
					}
					else # doesn't take RSET
					{
						$result = 'NONE';
					}
				}
				else # invalid code (4xx?)
				{
					$result = 'OTHER';
				}
			}
		}
		$sock->command("QUIT");
		$sock->close();
		last;
	}
	
	# report result
	$results{$result} += 1;
	$db_values .= 'result='. $dbh->quote(trim($result));
	$dbh->do($insert_stmt . $db_values) or
		warn $DBI::err.": ".$DBI::errstr;
}

print $$, ' ', $_, ' ', $results{$_}, $/ foreach (sort (keys %results));
print 'End ', $$, $/;