#
# Spammer-Friendly Registrar URIBL service.
#
# Copyright (c) 2006 John Hardin <jhardin@impsec.org>
# 
# This code is licensed under the GNU GPL, version 2
#
# $Id: surbl_registrar_uribl_server.pl,v 1.12 2006-08-14 20:25:24-07 jhardin Exp jhardin $
#
# Set this up on some machine somewhere, then in a domain you own
# add a forward-only zone:
# 
#   zone "sr.surbl.org" IN {
#     type forward;
#     forwarders { 127.0.0.1 port 5353; };
#     forward only;
#   };
#

# TODO: Proper logging via syslog

package main;

use Net::DNS;
use Net::DNS::Method;
use Net::DNS::Server;

use GDBM_File;

my $TTL_SEC = 3600 * 24 * 7;	# TODO: Take from config file
my %domains = {};
my %timeouts = {};
my %blacklist = {};
my $domroot = "sr.surbl.org";	# TODO: Take from config file
my $listenIP = "127.0.0.1";	# TODO: Take from config file
my $listenport = 5353;		# TODO: Take from config file

# TODO: Get filenames from config file
tie(%domains, 'GDBM_File', 'domains.db', &GDBM_WRCREAT, 0644) || die "Can't tie to domains database: $!";
tie(%timeouts, 'GDBM_File', 'timeouts.db', &GDBM_WRCREAT, 0644) || die "Can't tie to timeouts database: $!";

# Format of registrars file is:
#   REGISTRAR NAME AS REPORTED BY WHOIS[|SCORE]
# for example:
#
#   MONIKER ONLINE SERVICES, INC.
#   ENOM, INC.|80
#   NAMEKING.COM, INC.
#   COMPUTER SERVICES LANGENBACH GMBH DBA JOKER.COM|100
open (RL, "< registrars") || die "Can't read registrars file: $!";
while (<RL>) {
	chomp;
	s/#.*$//;
	($score) = /\|\s*([0-9][0-9]+)\s*$/;
	if ($score) {
		s/\s*\|\s*[0-9]+\s*$//;
		$score = 100 if $score > 100;
	}
	else
	{
		$score = 75;	# default spam-friendliness score
	}
	s/^\s+//;
	s/\s+$//;
	if ($_) {
		$registrar = "\U$_";
		print "Adding \"$registrar\" with score $score.\n";
		$blacklist{$registrar} = $score;
	}
}
close(RL);

# purge hashes of expired entries
$purged = 0;
$cached = 0;
while (($key,$val) = each %timeouts) {
	if ($val < time()) {
		# expired, forget it
		# next query will verify still with spammy registrar
		delete $domains{$key};
		delete $timeouts{$key};
		$purged++;
	}
	else
	{
		$cached++;
	}
}
print "$cached cached domains. $purged expired entries purged.\n";

my $method = Net::DNS::Method::SURBL_Registrar->new;

my $server = new Net::DNS::Server("${listenIP}:${listenport}", [ $method ])
    || die "Cannot create server object: $!";

while ($server->get_question()) {
    print " get_question succesful\n";

    $server->process;

    if ($server->send_response()) {
	print "send_response ok\n";
    }
    else {
	print "send_response failed: $!\n";
    }
}

#############################################################################
package Net::DNS::Method::SURBL_Registrar;
use Net::DNS::Method;
use Net::DNS;

our @ISA = qw(Net::DNS::Method);

sub new { bless [], $_[0]; }

sub A { 
	my $self = shift;
	my $q = shift;
	my $a = shift;
    
	$_ = $q->qname;

	unless (/\.${domroot}$/) {
		$a->header->rcode('REFUSED');
		return;
	}

	s/\.${domroot}$//;

	if (/^[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+$/) {
		$a->header->rcode('NXDOMAIN');
		return;
	}

	$percentile = 1;
	if (/\.[0-9]+pct$/)
	{
		($pct) = /\.([0-9]+)pct$/;
		s/\.[0-9]+pct$//;
		$pct *= 1;	# convert to number
		if ($pct > 0)
		{
			$percentile = $pct;
		}
	}

	s/^.+\.([^.]+\.[^.]+)$/$1/;

	print "Checking $_\n";
	print "Restricting to ${percentile}% or higher registrars.\n" if $percentile > 0;
	$domain = $_;

	if (defined($blacklisted = $domains{$domain})) {
		print "Cache hit.\n";
		# check expiry
		if (defined($timeouts{$domain})) {
			print "Time now ", time(), ", timeout at ", $timeouts{$domain}, "\n";
			if ($timeouts{$domain} < time()) {
				# expired, forget it
				# next query will verify still with spammy registrar
				delete $domains{$domain};
				delete $timeouts{$domain};
			}
		}
	}
	else
	{
		print "Doing whois lookup\n";
		$blacklisted = 0;
		$registrar = "";
		open(WHOIS, "/usr/bin/whois -in -- '$domain' |") || die;
		while (<WHOIS>) {
			next unless /Registrar:/;
			chomp;
			s/^.*Registrar:\s*//;
			s/\s+[(]R[0-9]+-[A-Z]+[)]\s*$//;
			s/\s+$//;
			$registrar = "\U$_";
			if ($registrar){
				print "Registrar is \"$registrar\"\n";
				if (defined($blacklist{$registrar})) {
					$blacklisted = $blacklist{$registrar};	# registrar's score
				}
				$domains{$domain} = $blacklisted;
				$timeouts{$domain} = time() + $TTL_SEC;
				print "Time now ", time(), ", timeout at ", $timeouts{$domain}, "\n";
				last;
			}
		}
		close(WHOIS);
		unless ($registrar) {
			# no data, cache for a short time.
			# TLD may not support whois, or we may have hit query limits
			print "No registrar data from whois.\n";
			$domains{$domain} = 0;
			$timeouts{$domain} = time() + 3600;
			print "Time now ", time(), ", timeout at ", $timeouts{$domain}, "\n";
		}
	}


	print "* $domain score is $blacklisted, reporting at $percentile or higher.\n";
	if ($blacklisted >= $percentile) {
		$a->header->rcode('NOERROR');
		$a->push('answer', Net::DNS::RR->new(
					name    => $q->qname,
					ttl     => $TTL_SEC,
					class   => "IN",
					type    => "A",
					address => "127.0.0.$blacklisted",
					)
			);
	}
	else
	{
		$a->header->rcode('NXDOMAIN');
	}

	return NS_OK;
}