#!/usr/bin/perl -wT
#
# GreyDNS - Greylisting DNS-Server
# Copyright (C) 2007  Robert Schulze (rob@rob-schulze.de)
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
###############################################################################

use strict;
use Socket;
use POSIX 'setsid';
use Storable;

###############################################################################

my $PORT=53000;
my $LISTEN='127.0.0.1';
my $LOG='/tmp/greydns.warn';
my $DB='/tmp/greydns.tbl';

# kompletter Pfad zu diesem Skript, fuer exec bei SIGHUP
#
my $GREYDNS='/home/rob/greydns/greydns-004';

# nach $GREY_DELAY Sekunden wird die NXDOMAIN geliefert
#
my $GREY_DELAY=10;

# nach $REMOVE_DELAY Sekunden ohne weitere Abfrage wird der
# Eintrag aus der DB entfernt oder die Domain neu grau gelistet
#
my $REMOVE_DELAY=(60*60); # 1 Stunde

my $ADDR_GREYLISTED=inet_aton('127.0.0.2');
my $TXT_GREYLISTED='450 greylisted';

my $DIALUP_REGEX=qr/t-ipconnect\.de$|tisdip\.tiscali\.de$|ipt\.aol\.com$|vie\.surfer\.at$|chello|bluewin\.ch$|comcast\.net$|ameritech\.net$|pacbell\.net$|attbi\.com$|swbell\.net$|optonline\.net$|charter\.com$|hinet\.net$|\.rr\.com$|bbtec\.net|custom|optin|node|dial|dsl|cable|dyn|ppp|client|dhcp|(([0-9]{1,3}[-\.])+){3}[0-9]{1,3}|\.arpa$|\.it$|\.jp$|\.tw$|\.ru$|\.br$|\.hk$|\.siteprotect\.com$|\.procampaign\.net$|^195\.226\.164|\.domeus\.com$|npgco\.com$/;


###############################################################################
# Hier nix aendern!
# vorkompilierte Teile des DNS-Protokolls
###############################################################################

my $_DNS_BODY_A=pack
	(
	'n n N n a*',1,1,0,
	length($ADDR_GREYLISTED),$ADDR_GREYLISTED
	);
my $_DNS_BODY_TXT=pack
	(
	'n n N n a*',16,1,0,
	length(pack('Ca*',length($TXT_GREYLISTED),$TXT_GREYLISTED)),
	pack('Ca*',length($TXT_GREYLISTED),$TXT_GREYLISTED)
	);

my $_DNS_HDR_LOCALHOST=pack
	(
	'C2 n4',
	128,0,1,2,0,0
	);

my $_DNS_HDR_NXDOMAIN=pack
	(
	'C2 n4',
	128,3,1,0,0,0
	);

###############################################################################

BEGIN
	{
	$ENV{'PATH'}='';
	}

if(!-e $GREYDNS)
	{
	die("$GREYDNS existiert nicht, bitte \$GREYDNS anpassen!");
	}

daemonize();

my $paddr=sockaddr_in($PORT,inet_aton($LISTEN));
socket(SOCKET,PF_INET,SOCK_DGRAM,getprotobyname('udp')) || die "socket: $!";
if(!bind(SOCKET,$paddr))
	{
	die "unable to bind to $LISTEN\:$PORT ($!)\n";
	}

my $TBL={};
if(-e $DB)
	{
	warn "found $DB, loading...\n";
	$TBL=retrieve($DB);
	warn "read ".keys(%{$TBL})." entries\n";
	}

# Signalhandler erst setzen, wenn die DB gelesen wurde
# sonst koennten komische Situationen auftreten
#
my $sigset=POSIX::SigSet->new();
POSIX::sigaction(POSIX::SIGHUP(),POSIX::SigAction->new('restart',$sigset,POSIX::SA_NODEFER()));
POSIX::sigaction(POSIX::SIGTERM(),POSIX::SigAction->new('terminate',$sigset,POSIX::SA_NODEFER()));

my $request='';
while(1)
	{
	my $hispaddr=recv(SOCKET,$request,512,0);
	if(!$hispaddr)
		{
		warn "recv failed: $!\n";
		next;
		}

	my $res='';
	my $now=time();
	my $rq=unpack_request($request);

	#if(get_ptr($rq->{'DOM'})!~m/$DIALUP_REGEX/)
	#	{
	#	$res=pack_response_nxdomain($rq);
	#	}

	if(defined($TBL->{$rq->{'DOM'}}))
		{
		if( ($TBL->{$rq->{'DOM'}}) > $now)		
			{
			# weiterer Request innerhalb GREY_DELAY
			#
			$res=pack_response_localhost($rq);
			}
		elsif( ($TBL->{$rq->{'DOM'}}+$REMOVE_DELAY) < $now)
			{
			# letzte Abfrage ausserhalb des Rahmens		
			# Greylisting neu starten
			#
			$TBL->{$rq->{'DOM'}}=$now+$GREY_DELAY;
			$res=pack_response_localhost($rq);
			}
		else
			{
			# letze Abfrage ist im Rahmen
			# Greylisting nur erneuern
			#
			$TBL->{$rq->{'DOM'}}=$now;
			$res=pack_response_nxdomain($rq);
			}
		}
	else
		{
		# erster Request ueberhaupt
		#
		$TBL->{$rq->{'DOM'}}=$now+$GREY_DELAY;			
		$res=pack_response_localhost($rq);
		}
	

	if(length($res)>512)
		{
		warn "generated udp-msg exceeds 512 bytes\n";
		# TC-Bit setzen?
		}

	if(!send(SOCKET,$res,0,$hispaddr))
		{
		warn "send failed: $!\n";
		}
		
	$request='';
	}

exit(0);

sub daemonize 
{
chdir('/') || die "Can't chdir to /: $!";
open(STDIN,'/dev/null') || die "Can't read /dev/null: $!";
open(STDOUT,'>/dev/null') || die "Can't write to /dev/null: $!";
defined(my $pid = fork) || die "Can't fork: $!";
exit if $pid;
setsid() || die "Can't start a new session: $!";
open(STDERR,">>$LOG") || die "Can't dup stdout: $!";
warn "Started with pid $$\n";
return 1;
}

sub unpack_request
{
my %r=();

# Header
#
@r{'ID','F1','F2','QN','AN','AA','ARR'}=unpack('n C2 n4',$_[0]);


# betreffende Domain
#
my $question=substr($_[0],12);
$r{'QNAME'}=substr($question,0,-length(pack("n2",1,1)));
$r{'QUESTION'}=$question;

my $domain='';
my $finished=0;
while(!$finished)
	{
	my($len,$part)=unpack('Ca*',$question);
	$part=substr($part,0,$len);

	if($part ne '')
		{
		$domain.="$part\.";
		}
	else
		{
		$finished=1;
		}
	$question=substr($question,length(pack('Ca*',$len,$part)));
	}


$r{'DOM'}=substr($domain,0,-1);

# Type und Class
#
@r{'TYPE','CLASS'}=unpack("n2",$question);

return \%r;
}

sub pack_response_nxdomain
{
my $r=shift;
my $res=pack('n',$r->{'ID'});
$res.=$_DNS_HDR_NXDOMAIN;
$res.=$r->{'QUESTION'};
return $res;
}

sub pack_response_localhost
{
my $r=shift;
my $res=pack('n',$r->{'ID'});
$res.=$_DNS_HDR_LOCALHOST;
$res.=$r->{'QUESTION'};

# A
#
$res.=$r->{'QNAME'}.$_DNS_BODY_A;

# TXT
#
$res.=$r->{'QNAME'}.$_DNS_BODY_TXT;

return ($res);
}

###############################################################################
# cleanup
# raeumt auf und sichert die uebrig gebliebenen Datensaetze in einer Datei
###############################################################################

sub cleanup
{
my $limit=time()-$REMOVE_DELAY;
my $exp=0;

while(my($ip,$stamp)=each(%{$TBL}))
	{
	if($stamp < $limit)
		{
		delete($TBL->{$ip});
		$exp++;
		}
	}
store($TBL,$DB);
warn "cleanup: stats (time/expired/db-size) ".join("/",time()-($limit+$REMOVE_DELAY),$exp,(-s $DB))."\n";
}

###############################################################################
# get_ptr
# liefert den PTR Record einer IP-Adresse zurueck
# add-on by Sirko Zidlewitz
###############################################################################

sub get_ptr
{
my $ip=shift;
my @hostnames=gethostbyaddr(pack('C4',split('\.',$ip)), AF_INET);
if(!defined($hostnames[0]))
	{
	$hostnames[0]=$ip;
	}
return $hostnames[0];
}


###############################################################################
# restart
# raeumt auf und startet das Programm via exec() neu, da sonst Unmengen an 
# Speicher angesammelt werden
###############################################################################
 
sub restart
{
local $SIG{'HUP'}='IGNORE';
cleanup();
warn "SIGHUP... restarting\n";
exec($GREYDNS);
}

###############################################################################
# terminate
# raeumt auf und stirbt
###############################################################################

sub terminate
{
local $SIG{'HUP'}='IGNORE';
cleanup();
warn "SIGTERM... exiting\n";
exit(0);
}