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

package RegexResolver;
use Net::DNS;
use Net::DNSServer::Base;
use Net::DNS::Packet;
use Exporter;
use vars qw(@ISA);
@ISA = qw(Net::DNSServer::Base);

# I should really make these "const" instead...
my ($DNS_NAME_OK,$DNS_NAME_MISSING,$DNS_NAME_FAILED,$DNS_NAME_SPOOFED);

sub init {
	my $self = shift;

	#grep(warn("ARG: $_ => ".$self->{$_}."\n"),keys %{ $self });
	
	if (!defined($self->{resolver}
			=Net::DNS::Resolver->new(
				$self->{regex_resolver}
			))) {
		die "Cannot create my own resolver";
	}
}

sub cleanup {
	my $self = shift;

	# Toss the old resolver
	undef $self->{resolver};
}

# resolve subroutine must be defined
sub resolve {
	my $self = shift;
	my $dns_packet = $self->{question};
	my ($question) = $dns_packet->question();
	my $possible = $question->qname;

	# FIXME: preprocess this regex for speedup?
	if ($possible =~ /^(\d+\.\d+\.\d+\.\d+)\.$self->{dom}$/)
	{
          my $ip=join(".",reverse(split(/\./,$1)));

	  my $response = bless \%{$dns_packet}, "Net::DNS::Packet";
	  if (!$response) {
		warn "Could not initialize response packet";
		return undef;
	  }

	  # Make response authoritative: this is our domain!
	  my $response_header = $response->header;
	  $response_header->aa(1);
	  $response_header->ra(0); # We can't recurse
	  $response_header->qr(1); # We're responding

	  $response->push("authority",
                             Net::DNS::RR->new
                              ("$self->{dom} 86400 NS ns.$self->{dom}"));
	  $response->push("additional",
                             Net::DNS::RR->new
                              ("ns.$self->{dom} 86400 A 127.0.0.1"));

	  # Handle IP address lookups
	  if ($question->qtype eq "A") {
		if ($self->found_spammer($ip)) {
			$response->push("answer",
                             Net::DNS::RR->new
                              ("$possible 300 A 127.0.0.2"));
		}
		else {
			# No such domain
			$response_header->rcode("NXDOMAIN");
		}
	  }

	  return $response;
	}
	return undef;
} 

sub found_spammer_name
{
	my ($self,$name)=@_;

	# Perform regex's against the name

	# Looks like a dial-up or enumerated IP
	if ($name=~/[A-Za-z0-9-]*\d+-\d+-\d+-\d+[A-Za-z0-9-]*/ ||
	    $name=~/[a-fA-F0-9-]{8}[^\.]*\.[^\.]\.[^\.]/) {
		return 1;
	}

	return 0;
}

# This returns 4 possible states, along with the DNS name as an array
$DNS_NAME_OK=0;
#	0	Authoritative DNS name found
$DNS_NAME_MISSING=1;
#	1	Authoritatively no DNS name
$DNS_NAME_FAILED=2;
#	2	DNS name lookup failure ("temporary")
$DNS_NAME_SPOOFED=3;
#	3	Authoritative DNS name found, but IP does not match 'A'
#		 record lookup for that name
sub dns_name
{
	my ($self,$ip)=@_;
	my ($result,$name)=($DNS_NAME_FAILED,"");

	warn "Looking up '$ip'\n" if ($self->{debug_lookup});

	if (defined($self->{resolver})) {
		my $query = $self->{resolver}->query($ip,'PTR');

		# Did we get an answer?
		if (defined($query)) {
			my @name = grep { $_->type eq 'PTR' } $query->answer;
			$name=$name[0] ? $name[0]->ptrdname : undef;

			# Is there a name for this host?
			if (defined($name)) {
				warn "Got '$name'\n" if ($self->{debug_lookup});

				# FIXME: Do Spoofing check here
				$result=$DNS_NAME_OK;
			}
			else {
				warn "DNS Missing (no name)\n"
					if ($self->{debug_lookup});

				# NO DNS FOR THIS IP: REJECT
				$result=$DNS_NAME_MISSING;
			}
		}
		else {
			my $reason = $self->{resolver}->errorstring;

			if ($reason eq "NXDOMAIN") {
				warn "DNS Missing ($reason)\n"
					if ($self->{debug_lookup});
				# NO DNS FOR THIS IP: REJECT
				$result=$DNS_NAME_MISSING;
			}
			else {
				warn "DNS error: $reason\n"
					if ($self->{debug_lookup});
				# Other dns failure: continue
			}
		}
	}

	$name=lc($name);
	return ($result,$name);
}

sub found_spammer
{
	my ($self,$ip)=@_;

	# Override: 127.0.0.2 always fails
	if ($ip eq "127.0.0.2") {
		# Always return 127.0.0.2 as being an rbl
		warn "Auto Matched '127.0.0.2'\n"
			if ($self->{debug});
		return 1;
	}

	# Regex against the IPs
	foreach my $match (@{$self->{ip_white_list}}) {
		if ($ip =~ /$match/) {
			warn "IP ($ip) Matched Whitelist '$match'\n"
				if ($self->{debug});
			return 0;
		}
	}
	foreach my $match (@{$self->{ip_black_list}}) {
		if ($ip =~ /$match/) {
			warn "IP ($ip) Matched Blacklist '$match'\n"
				if ($self->{debug});
			return 1;
		}
	}

	# Attempt DNS *name* checks
	my ($result,$name,$realip) = $self->dns_name($ip);
	#warn "OK: $DNS_NAME_OK\n" if ($self->{debug});
	#warn "MISSING: $DNS_NAME_MISSING\n" if ($self->{debug});
	#warn "SPOOFED: $DNS_NAME_SPOOFED\n" if ($self->{debug});
	#warn "FAILED: $DNS_NAME_FAILED\n" if ($self->{debug});
	#warn "result: $result name: $name\n" if ($self->{debug});

	if ($result == $DNS_NAME_OK ||
            ($result == $DNS_NAME_SPOOFED && !$self->{spoofed_dns_reject})) {
		# Handle spammer names

		# Regex against the names
		foreach my $match (@{$self->{name_white_list}}) {
			if ($name =~ /$match/) {
				warn "Name ($ip,$name) Matched Whitelist '$match'\n"
					if ($self->{debug});
				return 0;
			}
		}
		foreach my $match (@{$self->{name_black_list}}) {
			if ($name =~ /$match/) {
				warn "Name ($ip,$name) Matched Blacklist '$match'\n"
					if ($self->{debug});
				return 1;
			}
		}
	}
	elsif ($result == $DNS_NAME_MISSING) {
		if ($self->{no_dns_reject}) {
			warn "IP ($ip) Missing DNS Matched\n"
				if ($self->{debug});
			return 1;
		}
	}
	elsif ($result == $DNS_NAME_SPOOFED) {
		if ($self->{spoofed_dns_reject}) {
			warn "IP ($ip,$name) Spoofing '$realip' Matched\n"
				if ($self->{debug});
			return 1;
		}
	}
	else {
		# no action...
	}
		
	# Nothing matched
	warn "IP ($ip,$name) Fell Through\n"
		if ($self->{debug});
	return 0;
}

package main;
use Net::DNSServer;
use Net::DNSServer::Cache;

our $VERSION="0.001000";
our $ID='$Id: reresolv,v 1.1 2003/08/10 10:14:00 nemesis Exp $';

my $use_cache=0;
my @resolvers;

if ($use_cache) {
	my $resolver_cache = new Net::DNSServer::Cache;
	die "Could not allocate resolver cache"
		unless (defined($resolver_cache));
	push(@resolvers,$resolver_cache);
}

my $regex_resolver = new RegexResolver {
	# Domain we're "serving" our RBL from
	dom => "rbl.outflux.net",

	# Details on how to manage our real DNS resolver
	regex_resolver => {
				retry => 1,
#				tcp_timeout => 30,
#				udp_timeout => 30,
		},

	# List of IP address regexs to pass
	ip_white_list => [
		],
	# List of IP address regexs to reject
	ip_black_list => [
			'^127.0.0.2$',
		],
	# List of DNS name regexs to pass
	name_white_list => [
		],
	# List of DNS name regexs to reject
	name_black_list => [
			#'[a-z0-9-]*\d+-\d+-\d+[A-Za-z0-9-]*',

			# 3 sets of numbers, 3rd level high
			'\d+[^\d]+\d+[^\d]+\d+[^\.]*\.[^\.]+\.',

			# 2 sets of digits, separated by dashes, with
			#  extra letters mixed in on the 3rd level domain
			#  or higher
			'[^\.]*\d+[^\.]*[\.-][^\.]*\d+[^\.]*\.[^\.]+\.',

			# digits with possible non-digits in the middle,
			# on the 3rd level domain or higher
			'\d{2,}[^\d]*\d{2,}[^\.]*\.[^\.]+\.',

			# contained above
			## 4 numbers in a row, 3rd level high
			#'\d{4,}[^\.]*\.[^\.]\.',

			# 8 hex digits in a row, on the 3rd level domain
			#  or higher
			# C8B0C595
			'[a-f0-9-]{8,}[^\.]*\.[^\.]+\.',

			# Misc sites
			'cool-dealz\.com$',
			'solutionspromos\.com$',
			'optinbargains4u\.com$',
			'summertimespecials\.com$',
			'expappcc\d+\.dvd\.com$',
			'mycoolbargains\.com$',
			'\d+\.postnote.com$',
			'4pitasake\.com$',
			'users\.co\.josephine\.or\.us$',
			'a\.ew01\.com$',
			'adshas6\.com$',
			'e\.rb\d+\.beeshoney\.net$',
			'uclickusave\.com$',
			'4jo2ely\.com$',
			'dsl-.*dial\.inet\.fi$',
			'btfusion\.com$',
			'bstmail\.com$',
			'fireballmail\.com$',
			'chesapeakemail\.com$',
			'mybeyondoffers\.net$',
			'femmail\.com$',
			'tomts\d+\.bellnexxia\.net$',
			'lessthanyouthink\.com$',
			'sender4\.com$',
			'tgr\d+\.thegasrag\.com$',
			'ustroistvo\.com$',
			'infostrea\.us$',
			'nnsuserc\d+\.nns\.ne\.jp$',
			'tpcper\.com$',
			'mail\.odvs\.de$',
			'\d+\.dsl\.easynet\.co\.uk$',
			'intaspharma\.com$',
			'postalbureau\.com$',
			'quickinspirations\.com$',
			'econpc\.com$',
			'amazingoffersdirect\.com$',
			'hm02\.com$',
			'kidspark\.com\.tw$',
			'list\d+\.thundercut\.com$',
			'client\d+\.attbi\.com$',
			'homelink\.vk\.com\.br$',
			'americanhotties\.net$',
			'emailselections\.com$',
			'dc03\.com$',
		],

	# If there is no reverse DNS, reject
	no_dns_reject => 1,
	# If ip->name->ip doesn't resolve, reject
	spoofed_dns_reject => 1,

	# Turn on matching debugging?
	debug => 1,
	# Turn on normal resolver debugging?
	debug_lookup => 0,
};
die "Could not allocate regex resolver"
	unless (defined($regex_resolver));
push(@resolvers,$regex_resolver);


# FIXME: need to do *FULL* ip -> name -> ip verification
# FIXME: do something to generate a report a-la trustic's daily
# FIXME: handle alias lookups

run Net::DNSServer {
	# Net::Server options go here
	server => {
			user  => 'nobody',
			group => 'nobody',

			syslog_ident => 'reresolv',
			#log_file => 'Sys::Syslog',
			log_file => '/tmp/reresolv.log',

			pid_file => '/tmp/reresolv.pid',

			#server_type => 'Fork',
			server_type => 'PreFork',

			host => '127.0.0.1',
		},

	debug => 0,

	priority => [@resolvers]
};