#!/usr/bin/perl -w
#
# blackberries - A multiplexer for DNS-based blacklists
#
# Copyright 1998,1999 by River of Stars, LLC
# All rights reserved.
#
# Automatic licensing for this software is available.  This software
# can be copied and used under the terms of the GNU Public License,
# version 1 or (at your option) any later version, or under the
# terms of the Artistic license.  Both of these can be found with
# the Perl distribution, which this software is intended to augment.
#
# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# ----------------------------------------------------------------------
# blackberries is:
#  A very simple (brain-dead) DNS server
#	Listens to UDP only
#	Handles one connection at a time only
#	Deals with 'A' RRs only
#	Authoritative for any lookups it's asked for
#  A very simple DNS resolver
#	Queries a list of DNS-based blacklist (RBL-like)
#	Queries a list of pattern blacklist services (EDUL-like)
#	Returns 'A' RR of 127.0.0.2 if any blacklist says it contains the
#	 offending IP
#  Apparently runnable on Mac OS (Mac Perl 5.20r4 tested), OpenBSD
#	(Perl 5.004 tested) and Solaris (Perl 5.004 tested)
#
# How it works:
#  blackberries listens for DNS queries for the addresses of
#	RBL-like reverse IP names, e.g., for lookups of
#	names like "12.230.250.208.rbl.domain.tld"
#	(You must set up NS delegation to your blackberries server
#	for the domain 'rbl.domain.tld'.  If you don't understand this,
#	visit http://maps.vix.com/rbl/ and read until you do.)
#  If any of the blacklists to which blackberries passes the lookup
#	return an address of 127.0.0.2, blackberries returns an address
#	of 127.0.0.2 to whoever asked it about the name.
#
# To Do (in relative order of interest or ease of implementation):
#	Add EDUL support
#	Taint checks and cleanup - code is probably too insecure to run as
#	 root on UNIX boxes
#	Allow requests only from specific IP ranges (private service) -
#	 return "you smell bad" error (REFUSED) for others who query it
#	Add optional syslog submission, rather than spewing everything to
#	 STDOUT
#	Port Net::UDP (from Net-ext) to Mac Perl, and use it for our UDP
#	 socket stuff
#	Use a multi-threaded DNS server on Mac OS and a forking DNS server
#	 on UNIX systems
#	Check returned IP address, and do different things depending on
#	 whether it's 127.0.0.2, 127.0.0.3, etc. or an unrecognized IP
#
# Thanks to: (in somewhat random order)
#	Paul Vixie and RBL volunteers - for the RBL
#	Alan Hodgson - for the Dorkslayers ORBS
#	Gordon Fecyck - for the Orca DUL
#	Ronald Guilmette - for the EDUL and IMRSS
#	Michael Fuhr - for DNS.pm
#	Paul Phillips - for showing the way on EDUL support
#	Shawn Colvin - for tunes
#
# ----------------------------------------------------------------------

# version history
# 0.00 - 1998-11-10 intial prototype
# 0.01 - 1998-11-11 working socket code with dummy lookups and responses
# 0.02 - 1998-11-13 rewrote name extraction and added real responses
# 0.03 - 1998-11-15 added exceptions
# 0.04 - 1998-11-20 built Mac Perl runtime, first public disclosure
# 0.05 - 1998-12-28 implemented config file
# 0.06 - 1998-12-29 switched to using Net::DNS instead of nasty looking home-grown routines
$version = 0.06;


use Socket;
#use Net::UDP;
use Net::DNS;
#use Sys::Hostname;


# constants
# our config file name
$CONFNAME = "blackberries.conf";
# we're talking UDP DNS (protocol 17 port 53)
$PROTO = getprotobyname ('udp');
$PORT = getservbyname ('domain', 'udp');
# query types allowed
$TYPEA = "A";         # query type for A RR
$TYPEANY = "ANY";       # query type for 'Anything'
# query classes allowed
$CLASSIN = "IN";     # query class for Internet
$CLASSANY = "ANY";    # query class for 'Anything'
# dns packet size is 512
$PACKETSZ = 1024;


sub log_message {
#	print scalar localtime, " $0 $$: @_\n";
	print scalar localtime, " @_\n";
}

sub lookup_name {
# look up the host name in all our configured blacklists and patternlists
#
	my ($revname, $forwardname) = @_;
	
	# check for whether we want to make an exception for this IP address
	if ( $EXCEPTIONS =~ m/$forwardname/ ) {
		log_message "EXCEPTION: $forwardname" if $VERBOSE;
		return undef;
	}
	
	# check each of the patternlists
	foreach $list (@PATTERNLISTDOMAINS) {
		
	}
	
	# check each of the blacklists
	foreach $list (@BLACKLISTDOMAINS) {
		$rql = join ('.', $revname, $list);	# build the reverse query name for this blacklist
		$addr = gethostbyname ($rql);	# look up address only - scalar context
		if ( $addr ) {
			# we got ourselves a live one, so further lookups in remaining lists are pointless
			$blackIP = join ('.', unpack ("C4", $addr));
			log_message "BLACKLISTED: $forwardname => $blackIP at $list" if $VERBOSE;
			return ($blackIP);
			# NOTE - we just assumed any A return is a blacklisting.  this could
			# be considered a bug, but we just pass the IP straight through and let
			# whoever queried us decide what to do with anything not 127.0.0.2.
		} else {
			log_message "debug: lookup_name - $list: IP clean (or lookup failed)" if $DEBUG;
		}
	}
	return undef;
}

sub parse_name {
# nuke our mux domain from the query request, ensure four octets are present, and reverse it
#
	my $revname = shift;
	
	# we only serve our own domain, not those created by resolvers glomming domain search path extensions onto them
	if ( ! ($revname =~ m/$OURRBLMUXDOM$/) ) {
		log_message "error: reverse_name - BAILING with lookup on $revname not ending in our domain $OURRBLMUXDOM" if $ERRORS;
		return (undef, undef);
	}

	$revname =~ s/\.$OURRBLMUXDOM.*$//i;
	@ddoctets = split /\./, $revname;
	$forwardname = join ('.', reverse (@ddoctets));
	log_message "debug: reverse_name - generated name: $forwardname from $revname" if $DEBUG;
	if ( ($numoctets = @ddoctets) != 4) {
		log_message "error: reverse_name - BAILING with address $forwardname containing $numoctets octets, not 4 octets" if $ERRORS;
		return ($revname, undef);
	}
	return ($revname, $forwardname);
}

sub answer_request {
	
	# rip apart the packet
	my $response = 0;
	my $err;
	($packet, $err) = new Net::DNS::Packet(\$buffer, $DEBUG);
	log_message ("error: answer_request - packet decode problem: ", $err) if ( $ERRORS and $err );
	
	# inflate the query
	@question = $packet->question;
	$query = shift @question;	# only the first (we have yet to see more than one in a packet)
	
	# answer the query
	if ( $query ) {
#		log_message ("debug: answer_request - query dump:\n", $query->string) if $DEBUG;
		$qname =  $query->qname; # name to look up (with our rbl mux domain attached)
		my $qtype = $query->qtype;	# query type
		my $qclass = $query->qclass;	# query class
		log_message "debug: answer_request - parsed query - qname: $qname, qtype: $qtype, qclass: $qclass" if $DEBUG;
		
		# we only answer queries of type A or any, and class IN or any
		if ( ( ($qtype eq $TYPEA) or ($qtype eq $TYPEANY) ) and ( ($qclass eq $CLASSIN) or ($qclass eq $CLASSANY) ) ) {
			# strip, check and reverse the name
			my ($revname, $forwardname) = &parse_name ($qname);
			
			# look up any valid name found
			if ( $forwardname ) {
				my $blacklistaddr = &lookup_name ($revname, $forwardname);
				if ( $blacklistaddr ) {
					log_message "debug: answer_request blacklist IP: $blacklistaddr" if $DEBUG;
					# pass whatever address we got from the blacklist back to our client
#					$packet->push("answer", rr_add("$revname\.$OURRBLMUXDOM $TTL A $blacklistaddr"));
					$packet->push("answer", rr_add("$qname $TTL A $blacklistaddr"));
					$packet->header->qr(1);
					$packet->header->rcode("NOERROR");
					$response = 1;
				} else {
					$packet->header->rcode("NXDOMAIN");	# give our client the good news
					$response = 1;
					log_message "clean IP: $forwardname" if $VERBOSE;
				}
			} else { # ! $forwardname
				# we are confused, so we'd best just deny everything
				$packet->header->rcode("NXDOMAIN");
				$response = 1;
				log_message "clean failure - No lookup done for: $revname" if $VERBOSE;
			}
		} else { # unsupported $qtype or $qclass
			$packet->header->rcode("NOTIMPL");
			$response = 1;
			log_message "error: answer_request - unsupported qtype of $qtype or qclass of $qclass" if $ERRORS;
		}
	} else { # ! $query
		# darn, we don't know what the heck we were asked to do, but it wasn't answer a question
		$packet->header->rcode("NOTIMPL");
		$response = 1;
		log_message "error: answer_request - bogus DNS request without query" if $ERRORS;
	}
	$packet->header->aa(1);	# we are always authoritative, even when we're dead wrong
	
	return $response;
}


# set some defaults
$OURRBLMUXDOM = "rbl.ourdomain.tld";
@BLACKLISTDOMAINS = ("rbl.maps.vix.com", "dul.orca.bc.ca");
@PATTERNLISTDOMAINS = ("fix", "later");
$EXCEPTIONS = "";
$TTL = 3600;
$ERRORS = 1;
$VERBOSE = 1;
$DEBUG = 0;

# read the config file
open (CONFIG, "<$CONFNAME") or die "conf file open failure: $!";
while (<CONFIG>) {
	next if /^#/;
	next if /^$/;
	chop;
	eval;	
}
close CONFIG;

# fire up our network listener
socket (Server, AF_INET, SOCK_DGRAM, $PROTO) or die "receiving socket failure: $!";
setsockopt (Server, SOL_SOCKET, SO_REUSEADDR, 1);
bind (Server, pack_sockaddr_in ($PORT, INADDR_ANY)) or die "receiving bind failure: $!";

log_message "$0\n\tserver version $version started on port $PORT";

my $paddr;
my $rout;
#my $myiaddr = gethostbyname (hostname());
my $myiaddr = gethostbyname ('localhost');
my $mypaddr;

# listen forever
until ( 0 ) {
	$rin=''; 
	vec($rin,fileno(Server),1) = 1;
	$nfound = select ($rout=$rin, undef, undef, undef);
	if ( $nfound > 0 ) {
		$paddr = recv (Server, $buffer, $PACKETSZ, 0) or warn "Cannot receive: $!";
		
		# who is calling?
		my ($rport, $iaddr) = unpack_sockaddr_in ($paddr);
		my $name = gethostbyaddr ($iaddr, AF_INET);
		my $hname = inet_ntoa ($iaddr);
		log_message "connection from $name [$hname:$rport]" if $VERBOSE;
		
		# parse DNS packet, do lookups, and answer the call
		my $response = &answer_request ();
		if ( $response ) {
			log_message ("debug: main - response packet:\n", $packet->string) if $DEBUG;
			# pick a sending address/port
			$mypaddr = pack_sockaddr_in ($PORT, $myiaddr);
			if ( $DEBUG ) {
				my ($myport, $myiaddr) = unpack_sockaddr_in ($mypaddr);
			}
			# spit the response packet
			defined (send (Server, $packet->data, 0, $paddr)) or warn "Cannot send: $!";
		} else { # no $response
			# note the failure
			log_message "error: main - NO RESPONSE MADE to request from $name, port $PORT" if $ERRORS;
		}
		undef $packet;
		undef $buffer;
	}
}

exit 0;