#!/usr/perl/bin/perl -w

# Syllable version

# ABOUT
#
# This is Mephistoles DNSd, a little insecure domain name service server,
# written entirely in perl (a write-only programming language)!
# Actually, it is a DNS cacher rather than a real server.
# Version 0.2 supports tunneling longer queries via TCP.
# In order to server your own domain, you would need to craft your
# own query/response packets and to add them to the cache.
# This program is placed under the GNU General Public License (GPL).
# Enjoy and send bugfixes to: kwench79@yahoo.de !

# Mephistoles DNSd 0.2.0beta1 (2001-12-15)

use IO::Socket;
use Fcntl;
use Socket;
use POSIX;

### server configuration ##################################################

$dnsn="130.235.132.90";			# valid DNS server
$dnss=sockaddr_in(53,inet_aton($dnsn));	# valid DNS UDP port
$hosts="/var/dnsd/";			# dir where to save cache
$logfile="/usr/mephistoles/var/log/dns";			# file where to log (perl-param.)

$maxq=50;				# query cache (how many clients?)
$maxh=500;				# host cache (how many entries?)
$recycle=250;				# start recycling entries here
$maxreqlen=1200;			# max. udp length
$tcptunnel=1;				# tunnel 53/tcp requests?

### end of config #########################################################

sub logmsg {                                                                    
        print LOG scalar localtime,": @_\n";                                    
}

### subroutines for tcp ###################################################

sub tcptunnel {
	my $bp=shift || 53;
	socket(Server, PF_INET, SOCK_STREAM, getprotobyname('tcp')) || die "socket: $!";
	setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) || die "setsockopt: $!";
	bind(Server, sockaddr_in($bp, INADDR_ANY)) || die "bind: $!";
	select(Server); $| = 1; select(STDOUT);
	listen(Server,SOMAXCONN) || die "listen: $!";
	while (1) {
		$0="dnsd tcp-tunnel [accepting connections]";
		$paddr = accept(Client,Server);
		$0="dnsd tcp-tunnel [tunneling]";
		select(Client); $| = 1; select(STDOUT);
		my($port,$iaddr) = sockaddr_in($paddr);
		$cip=inet_ntoa($iaddr);
		socket(P, AF_INET, SOCK_STREAM, getprotobyname('tcp')) || warn ("socket");
		bind(P, sockaddr_in(0, INADDR_ANY)) || warn ("bind");
		connect(P, $dnss); # || warn ("connect");
		select(P); $| = 1; select(STDOUT);
		fcntl(P, F_SETFL, O_NONBLOCK) || warn "fcntl: $!";
		fcntl(Client, F_SETFL, O_NONBLOCK) || die "fcntl: $!";
		logmsg("$cip - tunneling");
		my $rin = '';
		vec($rin, fileno(Client), 1) = 1;
		while (select($rin, undef, undef, 1)>0) {
			print P <Client>;
		}
		$rin = '';
		vec($rin, fileno(P), 1) = 1;
		while (select($rin, undef, undef, 1)>0) {
			print Client <P>;
		}
		close(P);
		close(Client);
	}
}

### subroutines for udp ###################################################

sub qlplace {
	my $j;
	for($j=0;$j<$maxq;$j++) {
		last if (!defined $qs[$j]);
	}
	return $j;			# cache is full? overwrite last... :)
					# this not nice... set $maxq higher!
}

sub hlplace {
	my $j;
	for($j=0;$j<$maxh;$j++) {
		last if (!defined $lq[$j]);
	}
	if ($j==$maxh) {		# cache full, recycle
		$j=$cycle;
		$cycle++;
	}
	if ($j==$maxh) {		# cycle complete
		$j=$recycle;
		$cycle=$recycle;
	}
	return $j;
}

sub findquery {				# do we know this query? can we respond?
	my $d=shift;
	my $j;
	for($j=0;$j<$maxh;$j++) {
		next if (!defined $lq[$j]);
		last if ($lq[$j] eq $d);
	}
	return $j;			# not found? return $maxh
}

sub findquest {				# remeber, who asked us something...
	my $d=shift;
	my $j;
	my $buf;
	$buf=substr($d,0,2);
	for($j=0;$j<$maxq;$j++) {
		next if (!defined $qi[$j]);
		last if ($qi[$j] eq $buf);
	}
	return $j;			# not found? return $maxh
}

sub isquery {
	my $s=shift;
	my $b;
	$b=substr($s,2,1);
	$b=ord($b);
	if ($b < 128) {			# quick 'n' dirty...
		return 1;
	} else {
		return 0;
	}
}

sub readdb {
	my $j;
	my $buf;
	$buf=$hosts."recycling";
	if (open(F,$buf)) {
		$cycle=<F>;
		close(F);
	} else {
		$cycle=$recycle;
	}
	for($j=0;$j<$maxh;$j++) {
		$buf=$hosts.$j."-q";
		if (open(F,$buf)) {
			# logmsg "loading entry $j-q...";
			while(<F>) {
				$lq[$j]=$lq[$j].$_;	# pure beauty...
			}
			close(F);
		}
		$buf=$hosts.$j."-r";
		if (open(F,$buf)) {
			# logmsg "loading entry $j-r...";
			while(<F>) {
				$lr[$j]=$lr[$j].$_;	# pure beauty...
			}
			close(F);
		}
	}
}

sub writedb {
	my $j=shift;
	$buf=">".$hosts."recycling";
	if (open(F,$buf)) {
		print F $cycle;
		close(F);
	}
	$buf=">".$hosts.$j."-q";
	if (open(F,$buf)) {
		print F $lq[$j];
		close(F);
	}
	$buf=">".$hosts.$j."-r";
	if (open(F,$buf)) {
		print F $lr[$j];
		close(F);
	}
}

### main ##################################################################

$0="dnsd starting";

my $port = shift || 53;
my $proto = getprotobyname('udp');
my $mpid;

my $sender;
my $data;
my $rhost;
my $rport;

@qs=();		# query sender
@qi=();		# query ID
@qq=();		# query text

@lq=();		# list of queries
@lr=();		# list of responses

my $i;
my $k;
my $buf;

if (!defined($mpid=fork)) {                                                  
	print "*** startup error: cannot fork to background!\n";
	print "*** this might cause some problems later...\n";
	print "*** whatever! continuing...\n";
} elsif ($mpid) {
	print "dns daemon forked to background\n";
	exit; # I'm the parent
}  

open(LOG,$logfile) || print "WARNING! No logging possible because of file error!\n";

logmsg "reading old data...";
readdb;

$port = $1 if $port =~ /(\d+)/; 		# untaint port number

if (!defined($mpid=fork)) {                                                  
	print "*** cannot fork tcp-tunnel!\n";
} elsif ($mpid) {
	# parent, do nothing
} else {
	# child
	tcptunnel($port) if ($tcptunnel==1);
	exit;
}

my $S = IO::Socket::INET->new(Proto=>'udp',Type=>SOCK_DGRAM,LocalPort=>$port) || die "can't make socket: $!";

logmsg "server started on port $port";

#chroot($hosts) && ($hosts="/") || warn "warning: couldn't chroot() to $hosts";
#POSIX::setsid() || warn "warning: can't start a new session: $!";

while (1) {
	$0="dnsd udp [accepting queries]";
	$sender = $S->recv($data,$maxreqlen,0) || logmsg "recv(): $!";
	($rport,$rhost) = sockaddr_in($sender);
	$rhost = inet_ntoa($rhost);
	$0="dnsd udp [serving $rhost]";
	logmsg "rec ".length($data)." from $rhost : $rport";

        if (isquery($data)) {
		# logmsg "processing query...";
		$buf=substr($data,2);			# sub ID
		$i=findquery($buf);
		if ($i==$maxh) {
			logmsg "query: unknown host, saving and forwarding...";
			$i=qlplace();
			$qi[$i]=substr($data,0,2);
			$qq[$i]=substr($data,2);
			$qs[$i]=$sender;
			$S->send($data,0,$dnss) || logmsg "ext. query: send(): $!";
		} else {
			logmsg "query: known data (entry $i), responding...";
			$buf=substr($data,0,2).$lr[$i];		# add ID
			$S->send($buf,0,$sender);
		}
	} else {
		# logmsg "processing response...";
		$i=findquest($data);
		if ($i==$maxq) {
			logmsg "response: got unwanted response !?!";
		} else {
			logmsg "response: notifying client no $i...";
			$S->send($data,0,$qs[$i]) || logmsg "ext. resp.: send(): $!";
			undef $qs[$i];			# rem client
			undef $qi[$i];
			$k=hlplace();			# and save...
			# logmsg "saving as query/response pair no $k...";
			$lq[$k]=$qq[$i];
			$lr[$k]=substr($data,2);
			undef $qq[$i];
			writedb($k);			# write to disk
		}
	}
	# logmsg $data;
	# $S->send($data,0,$sender) || logmsg "send(): $!";
}
