#!/usr/local/bin/perl -T


# TCP_to_UDP, part of a pair of gateways for tunneling DESCHALL
# UDP requests through a TCP link simulating an HTTP exchange.
#
# See <URL:http://www.frii.com/~rcv/deschall.htm> for the project 
# home page; <URL:http://www.interhack.net/projects/deschall> for 
# the mailing list archives, other code samples, etc. 
#
# (C) 1997 Justin Dolske <dolske.1@osu.edu>
# Based on example code from "Programming Perl", 2nd edition.
# Unlimited free distribution is allowed.
#
# Thanks to Matt Curtin and Rocke Verser for assistance in testing
# the gateways in a production environment.
#
# HISTORY:
#  0.9 - Private development release
#  1.0 - Private production release
#  1.1 - Private Bug Fix/Prevention release
#  1.1b - Private Bug Fix for proxies that alter the GET request
#  1.2 - Private update, passes U2T IP with client request
#        Also squished obscure bug with the GET pattern match being greedy
#  1.3 - Private update, added support for email address, and SIGUSR1
#  1.3b - Private update. %A/%P added to all outgoing msgs, not just I2
#  1.3c - Prv: REAPER now uses waitpid -- WNOHANG hardcoded to 1! [fixed 1.4]
#  1.3d - Prv: AutoThrottle, all responses delayed 0-3 seconds
#         delay set to zero if server is loaded too much
#         Connection immediately dropped if > N t2u processing running
#         Prints gateway email every 100 connects
#  1.3e - Automatic warning/panic if server unreachable
#  1.4  - Prv: WNOHANG now via POSIX module. Sends Pragma: DESCHALL for
#         use by U2T 1.4.

require 5.003;
use strict;
BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
use Socket;
use Carp;
use POSIX;
use lib "/home/dolske/proj/proxy";
use Sys::Hostname;
use URI::Escape;

######################################################
# some defaults...
######################################################
my $port = shift || 2345;
$port =~ /(\d+)/; $port = $1;
my $timeout = 15;    #seconds to wait for reading TCP requests
my $udptimeout = 20; #seconds to wait for server's UDP reply
my $keyhost = "keymaster.verser.frii.com";
my $keyport = 8669;
my $hostname = hostname();
my $runfile = "t2urun.$hostname.$port";
my $statfile = "t2u.$hostname.$port.status";
my $DEBUG = 0;
my $logpath = "/home/dolske/proj/proxy";
my $touch = "/usr/bin/touch";
my @warning = ('/home/dolske/proj/proxy/warning', $hostname, $port);
my @panic = ('/home/dolske/proj/proxy/panic', $hostname, $port);
my @panic2 = ('/home/dolske/proj/proxy/panic2', $hostname, $port);
open STDOUT, ">> $logpath/gatelog.$hostname.$port" or die "can't dup STDIN\n";
open STDERR, ">> $logpath/gatelog.$hostname.$port" or die "can't dup STDERR\n";
select((select(STDERR), $|=1)[0]);

######################################################
# you shouldn't need to modify anything below here...

my $version = "1.3e";
my $forks=0;
my %seen_hosts;
my $new_host;

if(-e $runfile) {
  #are we really running? Get the PID.
  open RUN, $runfile;
  my $runpid = <RUN>;
  if($runpid =~ /^(\d+$)/) { #stupid taint checking
    $runpid = $1;
    }
  close RUN;
  #if we can send signals, we're probably alive.
  if(!(kill 0, $runpid)) { 
      #no server running!
      kill 9, $runpid;
      unlink $runfile;
      }
  else {
      #oops, we're allready running.
      exit;
      }
  }
#we are running, so save the PID
open RUN, "> $runfile";
print RUN "$$\n";
close RUN;

#some foreward declarations, and a couple quicky subs
sub spawn;
sub serveit;
sub logmsg { 
    my $report;
    $report = join '', ("T2U $$: @_ at ", scalar localtime, "\n");
    print STDERR $report;
    } 

my $waitedpid = 0;
sub REAPER {
    #$SIG{CHLD} = \&REAPER;  # if you don't have sigaction(2)
    #$waitedpid = wait;
    #logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
    while(waitpid(-1,WNOHANG) > 0){$forks--;}; #-1=anypid
    }
$SIG{CHLD} = \&REAPER;
$SIG{USR1} = sub {$DEBUG = $DEBUG ? 0 : 1;};

#get a TCP socket to listen on
my $proto = getprotobyname('tcp');
socket(Server, PF_INET, SOCK_STREAM, $proto) or die "socket: $!";
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
                                             or die "setsockopt: $!";
bind(Server, sockaddr_in($port, INADDR_ANY)) or die "bind: $!";
listen(Server,SOMAXCONN)                     or die "listen: $!";

logmsg "server started on port $port";

my $paddr;
my $looper=0;
my $lastwarn = 0;
srand time;
#start accepting client connections
while(1) {
    undef $paddr;
    $paddr = accept(Client,Server);
    next if(!defined $paddr); #accept failed, probably a SIGCHLD
    $looper = ($looper+1) % 10;
    my($port,$iaddr) = sockaddr_in($paddr);
    my $name = gethostbyaddr($iaddr,AF_INET);
    my $ipa = inet_ntoa($iaddr);
    if($name eq "") {$name = $ipa;}

    logmsg "con $name [" .
            inet_ntoa($iaddr) . "] at port $port";

    #if forking is not available, change to just &serveit
    my $delay = rand 3;
    if($forks > 16) {
        $delay = 0;
        logmsg "FLOOD: forks is $forks";
        }
    else {
        if(!defined $seen_hosts{$ipa} || $seen_hosts{$ipa} == 0) {
            $new_host = 1;
            }
        $seen_hosts{$ipa} = ($seen_hosts{$ipa} + 1) % 100;
        spawn \&serveit, $ipa, $delay; 
        }
    close Client;
    $new_host = 0;
    if($looper==0 && $hostname eq "lion" && $port == 2345) {
	#see if things are working well
	my @stat = stat $statfile;
	my $delta = time - $stat[9];
	if($delta > 2090) { #2100 = 35 minutes
            #panic! where's the server?!
            if(time - $lastwarn > 590) {system (@panic2,int $delta/60); $lastwarn=time;}
            }
        if($delta > 1500) { #1500 = 25 minutes
	    #panic! where's the server?!
	    if(time - $lastwarn > 590) {system (@panic,int $delta/60); $lastwarn=time;}
	    }
        elsif($delta > 900) { #900 = 15 minutes
	    #warn that things are turning sour
	    if(time - $lastwarn > 960) {system @warning; $lastwarn=time;}
	    }
	}
    } 

logmsg "Huh? All done?";

##############################################################
# Forks off a sub in a child process
sub spawn {
    my $coderef = shift;
    my @codeargs = (shift, shift);

    unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') { 
        confess "usage: spawn CODEREF";
    }

    my $pid;
    if (!defined($pid = fork)) {
        logmsg "cannot fork: $!";
        return;
    } elsif ($pid) {
        $forks++;
        logmsg "begat $pid, forks is $forks" if($DEBUG);
        return; # i'm the parent
    }
    # else i'm the child -- go spawn

    open(STDIN,  "<&Client")    or die "can't dup client to stdin";
    open(STDOUT, ">&Client")    or die "can't dup client to stdout";
    #open(STDERR, ">&STDOUT") or die "can't dup stdout to stderr";
    exit &$coderef(@codeargs);
} 


##############################################################
sub serveit {
    my ( $remote, $delay ) = (shift, shift, shift);
    my ( $hisiaddr, $hispaddr, $hisiaddr2, $server_rep,
         $iaddr, $paddr, $port, $proto, $client_req,
         $rin, $rout, $rechost, $dummy, $anon, $email);

    ###################################
    #First, read client's request (TCP)
    #note that the TCP socket is now the default filehandle
    $| = 1;
    $client_req = "";
    $anon = 1;
    #timeout after a few seconds
    eval {
        local $SIG{ALRM} = sub {die "timeout"};
        alarm $timeout;
        while(<>) {
            chomp;
            logmsg "DEBUG: Got $_" if($DEBUG);
            if(/^Pragma: DESanon=Public/){$anon = 0; logmsg "DEBUG: Public" if ($DEBUG);}
            elsif(/^Pragma: DESemail=(\S+)/) {
                $email = &uri_unescape($1);
                }
            elsif(/^User-Agent: (\S*)/){
                if($1 ne "UDP2TCPGateway/1.1" &&
                   $1 ne "UDP2TCPGateway/1.2" &&
                   $1 ne "UDP2TCPGateway/1.3"    ){logmsg "Via Gateway: $1";}
                }
            elsif(/^GET/) {
                ($dummy, $client_req) = 
                  /^GET (http\:\/\/\S+?\:\d+)?\/?(\S+?) HTTP\/\d\.\d/;
                }
            last if /^\s*$/;
            }
        alarm 0;
        };
    logmsg "inf[$remote] Email=$email" if ($new_host || $DEBUG);
    logmsg "DEBUG: Request: $dummy $client_req" if ($DEBUG);
    if($@ and $@ !~ /timeout/) {confess "TCP timeout";}
    $client_req = uri_unescape($client_req);
    chomp $client_req;
    if($client_req eq "") {
        #Kill the client, this should not happen
        logmsg "bad TCP request: $client_req";
        print "Z T2U: Empty or Bad TCP request.\n";
        return;
        }
    #add client's IP to request
    if($anon) {
        $client_req = join '', $client_req, " %A$remote";
        }
    else {
        $client_req = join '', $client_req, " %P$remote";
        }
    logmsg "req[$remote]: $client_req";

    #########################################################################
    #Next, forward the request to the server and get server's reply (all UDP)
    $iaddr = gethostbyname(hostname());
    $proto = getprotobyname('udp');
    $paddr = sockaddr_in(0, $iaddr); # 0 means let kernel pick

    socket(SOCKET, PF_INET, SOCK_DGRAM, $proto)   or confess "UDP socket: $!";
    bind(SOCKET, $paddr)                          or confess "UDP bind: $!";

    $hisiaddr = inet_aton($keyhost)               or confess "UDP unknown host";
    $hispaddr = sockaddr_in($keyport, $hisiaddr);
    defined(send(SOCKET, $client_req, 0, $hispaddr))    
      or confess "UDP send $keyhost: $!";
    #logmsg "sent UDP request";

    $rin = '';
    vec($rin, fileno(SOCKET), 1) = 1;
    $server_rep = "";

    #wait for a UDP reply from the keyserver, with a timeout
    if(select($rout = $rin, undef, undef, $udptimeout)) {
        ($hispaddr = recv(SOCKET, $server_rep, 65536, 0))  
          or confess "UDP recv: $!";
        ($port, $hisiaddr2) = sockaddr_in($hispaddr);
        $rechost = gethostbyaddr($hisiaddr2, AF_INET);
        if($hisiaddr2 ne $hisiaddr) {
            $server_rep = "Z T2U: UDP from unexpected source: $rechost";
            logmsg "UDP from unexpected source: $rechost";
            }
        }

    if($server_rep eq "") {
        logmsg "timeout or error for UDP reply";
        #This is most likely a timeout, which the client can deal with.
        #Killing the client here is only useful for debugging.
        #$server_rep = 
        #  "Z T2U: Timeout or error waiting for UDP reply from keyserver.";
        }
    else {
        #logmsg "got UDP reply";
        }

    ###############################################
    # send UDP reply back over TCP to other gateway
    select undef,undef,undef,$delay;
    print "HTTP/1.0 200 OK\n";
    print "Server: UDP2TCPGateway/$version\n";
    print "Pragma: no-cache\n";
    print "Pragma: DESCHALL\n";
    #print "Pragma: DESmessage=This-is-a-test\n";
    print "Expires: Thu, 01 Dec 1994 16:00:00 GMT\n";
    print "Content-type: text/html\n";
    print "\n";
    print uri_escape($server_rep), "\n";
    logmsg "snt[$remote]: $server_rep";

    if($server_rep ne "") {exec $touch, $statfile;}
};