#!/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	= '0.0.0.0';			# where to listen for incomming TCP connections
my $bind_port	= 9990;				# port to listen on
my $remote_host = '127.0.0.1';			# where to connect to on the remote/server site
my $remote_port = '22';				# port to connect to

my $base_name	= 'tunnel.example.com';		# the base DNS name
my $chunk_size	= 32;				# max number of bytes to send in a query (bevor encoding)

my $mininterval = 0.0005;			# min wait time between polling queries
my $maxinterval = 0.75;				# max wait time between polling queries
my $seq_cycle   = 1000;				# sequence cycle, MUST be the same as on clients
my $query_tries = 5;				# retry count if query fails
my $verbose     = 1;				# enable verbosity
my %resconf;					# Net::DNS::Resolver config:
$resconf{'debug'} = 0;				#  debug flag
$resconf{'persistent_tcp'} = 1;			#  keep a TCP socket open
$resconf{'persistent_udp'} = 1;			#  keep a single UDP socket open
$resconf{'usevc'} = 1;				#  use virtual circuits (TCP) instead of datagrams (UDP)
#== END CONFIG ==

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

sub encode() {
    my $enc = shift;

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

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

    while(length($dec) % 4) { $dec .= '='; }

    return decode_base64($dec);
}

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

my $sock = IO::Socket::INET->new(   Listen => 5,
				    LocalAddr => $bind_ip,
				    LocalPort => $bind_port,
				    ReuseAddr => 1,
				    Proto => 'tcp');
				    
unless ($sock) {
    die "Could not listen on socket: $!";
}

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

$SIG{CHLD} = 'IGNORE';

my $client;
while($client = $sock->accept()) {
    $client->autoflush(1);

    my $pid;
    if (!defined($pid = fork)) {
	die("cannot fork: $!");
	return;
    } elsif (!$pid) {
	close($sock);

	my $remote = $client->peerhost().':'.$client->peerport();

	print "\nnew connection from $remote\n";
	my $ret = &client_handler($client);
	print "\nconnection from $remote closed";
	print ": $ret" if (defined($ret));
	print "\n";

        close($client);
	exit 0;
    }
    close($client);
}

sub client_handler() {
    my $sock = shift;
    my $res = Net::DNS::Resolver->new(%resconf);

    my $packet;
    my $qname = "$remote_host-$remote_port.0.0$base_name";
    unless ($packet = $res->query($qname, 'TXT')) {
	print "No answer for query '$qname'\n";
	return;
    }
    
    my @answer = $packet->answer;
    
    unless (($#answer == 0) && (${$answer[0]}{'type'} eq 'TXT') && (${$answer[0]}{'name'} eq $qname)) {
	return 'could not negotiate with tunnel DNS server';
    }
    my $port = substr(${$answer[0]}{'rdata'},1);
    my $seq = 0;
    my $interval = 0;
    my $rin = '';
    vec($rin, fileno($sock), 1) = 1;
    my $ret;

    for(;; $seq = ($seq + 1) % $seq_cycle) {
	if ($interval > $mininterval) {
	    select($rin, undef, undef, $interval);
	}

	my $data;
	my $transfer;

	$sock->blocking(0);
	my $nread = sysread($sock, $data, $chunk_size);
	if (defined($nread) && ($nread == 0)) {
	    $ret = 'closed by local';
	    last;
	}
	
	if (length($data)) {
	    $data = &encode($data);
	    $transfer = 1;

	    print 'i' if ($verbose);
	}
	else {
	    $data = '';
	}

	# Wait forever for the answer
	my $packet;
	for(my $i = 0; (!defined($packet = $res->query($data."$seq.$port$base_name", 'TXT'))) && ($i < $query_tries); $i++) { };
	if (!defined($packet)) {
	    $ret = "no answer for '$data$seq.$port$base_name'";
	    last;
	}

	foreach my $answer ($packet->answer) {
	    next unless (${$answer}{'type'} eq 'TXT');

	    my $data = substr(${$answer}{'rdata'},1);
	    if ($data eq '__CLOSED__') {
		$seq++;
		for(my $i = 0; (!defined($packet = $res->query("$seq.$port$base_name", 'A'))) && ($i < $query_tries); $i++) { };

		return 'closed by remote';
	    }

	    $data =~ s@#@\n@;
	    if (length($data)) {
		$data = &decode($data);

		$sock->blocking(1);
		syswrite($sock, $data, length($data));
		print 'o' if ($verbose);

		$transfer = 1;
	    }
	}
	
	if ($transfer) {
	    $interval = 0;
	}
	else {
	    if ($interval < $mininterval) {
		$interval = $mininterval;
	    }
	    elsif ($interval < $maxinterval) {
		$interval *= 2;
	    }
	}
    }

    for(my $i = 0; (!defined($packet = $res->query("$seq.$port$base_name", 'A'))) && ($i < $query_tries); $i++) { };
    
    return $ret;
}