#!/usr/bin/perl -wT

#
#     Copyright (c) 2005, 2006 Thomas Liske <thomas@fiasko.dyndns.org>
#
#     You may distribute under the terms of the GNU General Public License.
#

use strict;

#== BEGIN CONFIG ==
my $bind_ip	= '127.0.0.1'; 			# where to listen for DNS requests
my $bind_port	= 8888;				# port to listen on

my $base_name	= 'tunnel.example.com';		# the base DNS name
my $dns_server  = 'ns.example.com';		# the official nameserver for $base_name (just used in NS and SOA RR replies)
my $chunk_size	= 64;				# max number of bytes to return in a query (bevor encoding)

my $seq_cycle   = 1000;				# sequence cycle, MUST be the same as on clients
my $max_ports   = 32;				# max number of simultan connections
my $verbose     = 1;				# enable Net::DNS::Nameserver verbosity
#== END CONFIG ==

use Net::DNS;
use Net::DNS::Nameserver;
use MIME::Base64;

sub encode() {
    my $enc = shift;

    $enc = encode_base64($enc, '');
#    $enc =~ s@/@-@;
    $enc =~ s@=*$@@;

    return $enc;
}
sub decode() {
    my $dec = shift;

    $dec =~ s@-@/@;
    while(length($dec) % 4) { $dec .= '='; }

    return decode_base64($dec);
}

$|=1;
$base_name = ".$base_name" unless ($base_name =~ /^\./);

print "Listening on $bind_ip:$bind_port for $base_name\n\n";

my $ns = Net::DNS::Nameserver->new(
    LocalAddr		=> $bind_ip,
    LocalPort		=> $bind_port,
    ReplyHandler	=> \&reply_handler,
    Verbose		=> ($verbose > 1)
);
die unless ($ns);

my $count = 0;
my %counts;
my %lasts;
my %socks;

# Enter loop and wait for incomming DNS requests
$ns->main_loop;

# Handle incomming DNS request
sub reply_handler {
    my ($qname, $qclass, $qtype) = @_;
    my ($rcode, @ans, @auth, @add);
    my $ttl = 1;

    # Handle TXT RR request in the $base_name domain
    if ((substr($qname,-length($base_name)) eq $base_name) && ($qtype eq 'TXT')) {
	# Cut off $base_name.
	my $query = substr($qname, 0, -length($base_name));
    
	$rcode = "FORMERR";

	# We expect something like [data].<seq>.<port>
	if ($query =~ /^(.+\.)?([a-z0-9]+)\.([a-z0-9]+)$/) {
	    my ($data, $seq, $port) = ($1, $2, $3);
	    
	    # Zero port means new connection
	    if ($port == 0) {
		# Extract destination host and port from [data]
		if ($data =~ /^([^-]+)-(\d+)\.$/) {
		    my ($host, $port) = ($1, $2);
    		    my $id = $count;
		    
		    while (exists($socks{++$id}) && ($id<=$max_ports)) {};
		    if (exists($socks{$id})) {
			$id = 0;
		        while (exists($socks{++$id}) && ($id<=$max_ports)) {};
		    }
		    
		    if (exists($socks{$id})) {
			    print "\nno free slot for connection to ",substr($data, 0, length($data)-1), "\n";
			
			    $rcode = "REFUSED";
		    }
		    else {
			$count = ($count + 1) % $max_ports;
		    
			# Open connection to target
			$socks{$id} = IO::Socket::INET->new(
							    PeerAddr => $host,
							    PeerPort => $port,
							    Proto => 'tcp');
			unless ($socks{$id}) {
			    delete($socks{$id});
			    $count--;

			    print "\nfailed connection to $host:$port\n";
			
			    $rcode = "REFUSED";
		        }
			else {
			    $socks{$id}->autoflush(1);
		    	    $counts{$id} = 0;
			    $lasts{$id} = '';
			
			    print "\nnew connection to $host:$port\n";

    			    push @ans, Net::DNS::RR->new("$qname $ttl $qclass $qtype '$id'");
			    $rcode = "NOERROR";
			}
		    }
		}
	    }
	    # Request for an established connection
	    elsif (exists($socks{$port})) {
		my $rdata;

		# Only send/recv on new packets
		if ($seq == $counts{$port}) {
		    # Write [data] if available
		    if (($data) && (length($data) > 1)) {
			# Cut off the trailing dot
			chop($data);

			# Decode data.
			$data = &decode($data);
			
			# Write data to socket (blocking)
			$socks{$port}->blocking(1);
		        syswrite($socks{$port}, $data, length($data));
			
			print 'o' if ($verbose);
		    }

		    # Reply data if available (non-blocking)
		    $socks{$port}->blocking(0);
		    my $nread = sysread($socks{$port}, $rdata, $chunk_size);
		    if (length($rdata)) {
		        $rdata = &encode($rdata);

			print 'i' if ($verbose);
		    }
		    # Check if socket is closed and if so, tell the client
		    elsif (defined($nread) && ($nread == 0)) {
			$rdata = '__CLOSED__';
		    
			print 'connection closed from '.$socks{$port}->peerhost().':'.$socks{$port}->peerport()."\n";
			close($socks{$port});
		    
			delete($socks{$port});
		        delete($counts{$port});
			delete($lasts{$port});

			$rcode = 'NOERROR';
			return ($rcode, \@ans, \@auth, \@add, { aa => 1 });
		    }
		    $rcode = 'NOERROR';

		    # Save etherything for retransmissions
		    $lasts{$port} = $rdata;
		    $counts{$port} = ($counts{$port} + 1) % $seq_cycle;
		}
		# Retransmit lost packets
		elsif ($seq == ($counts{$port} - 1) % $seq_cycle) {
		    $rdata = $lasts{$port};
		    $rcode = 'NOERROR';
		}

		# Transmit data
    		push @ans, Net::DNS::RR->new("$qname $ttl $qclass $qtype '$rdata'");
	    }
	}
	
    }
    # Handle A RR requests in the $base_name domain
    elsif ((substr($qname,-length($base_name)) eq $base_name) && ($qtype eq 'A')) {
	# Cut off $base_name.
	my $query = substr($qname, 0, -length($base_name));
    
	$rcode = "FORMERR";

	# We expect <seq>.<port>
	if ($query =~ /^([a-z0-9]+)\.([a-z0-9]+)$/) {
	    my ($seq, $port) = ($1, $2);

	    # Check if socket still exists
	    if (exists($socks{$port})) {
		my $rdata;

		# Only terminate if it is the right sequence number
		if ($seq == $counts{$port}) {
		    print "\nconnection closed to ".$socks{$port}->peerhost().':'.$socks{$port}->peerport()."\n";
		    close($socks{$port});
		    
		    delete($socks{$port});
		    delete($counts{$port});
		    delete($lasts{$port});

		    # Transmit data
    		    push @ans, Net::DNS::RR->new("$qname $ttl $qclass $qtype 0.0.0.0");
		    $rcode = 'NOERROR';
		}
	    }
	}
    }
    # Reply on NS RR requests
    elsif ((substr(".$qname",-length($base_name)) eq $base_name) && ($qtype eq 'NS')) {
    	push @ans, Net::DNS::RR->new("$qname 86400 $qclass $qtype $dns_server");
	$rcode = 'NOERROR';
    }
    # Reply on SOA RR requests
    elsif ((substr(".$qname",-length($base_name)) eq $base_name) && ($qtype eq 'SOA')) {
    	push @ans, Net::DNS::RR->new("$qname 86400 $qclass $qtype $dns_server nobody.example.com 2004042500 86400 21600 1209600 3600");
	$rcode = 'NOERROR';
    }
    # Everything else is just denied
    else {
	$rcode = 'REFUSED';
    }
    
    return ($rcode, \@ans, \@auth, \@add, { aa => 1 });
}