#!/usr/contrib/bin/perl 

# UDP_to_TCP, 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. Thanks also go to the
# many gateway users who made suggestions, found bugs, and generally
# annoyed me. :-)
#
# HISTORY:
# 0.9 - Private development version
# 1.0 - Initial release, 23 Apr 1997
# 1.1 - Bug Fix/Prevention release, 24 Apr 1997
#       Also added debugging aids, gateway messages, proxy Authentication.
# 1.2 - Added support for Non-Anonymous participation. Anonymous is the DEFAULT
# 1.3 - Added required email address for gateway owner.
# 1.4 - More install instructions. Added waitpid. Added support to detect
#       if the reply from a web proxy actually came from the other gateway.
#       Added throttling. (9 Jun 1997)

require 5.003;
use strict;
BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
#use lib "/i/put/a/module/someplace/weird";
use Socket;
use Carp;
use Sys::Hostname;
use POSIX; #just to get WNOHANG for waitpid
use MIME::Base64;
use URI::Escape;

#What? Don't have URI::Escape and/or MIME::Base64 installed on your system? 
#Two choices:
#
# 1. Get just the Escape.pm and/or Base64.pm module from:
#    <URL:http://www.cis.ohio-state.edu/~dolske/des97/Escape.pm>
#    <URL:http://www.cis.ohio-state.edu/~dolske/des97/Base64.pm>
#
# 2. Get the full libwww distribution (incluses Escape and Base64) from:
#    <URL:http://www.perl.org/CPAN/modules/by-module/URI/>
#
# You may need to uncomment and adjust the "use lib ..." towards the top
# of the script, if you install libwww, Escape.pm, or Base64.pm in a 
# non-standard place. For example, to install these modules in your
# own directory (/usr/home/johndoe/gateway/) do the following:
#   1) Point the "use lib" to /usr/home/johndoe/gateway
#   2) Put Base64.pm into /usr/home/johndoe/gateway/MIME
#   3) Put Escape.pm into /usr/home/johndoe/gateway/URI
#
# The best solution is to install the full libwww distribution on your
# system, if you (or someone you can contact) are able to do so. Otherwise,
# installing just the two modules as described above will work fine.

###############################################
# some defaults...
#
# You should take a look at these, and make sure
# they're appropriate for your setup.
###############################################

#You MUST enter you email address below. We will only
#use this address if we have a problem with your gateway,
#or to alert you of a new gateway version. Your address
#will never be made public.
#Note that you must surround your address with *single* quotes ('),
#as in the example. Double quotes (") won't work.

my $email = 'joe@nowhere.com';


#By default, your participation will be anonymous.
#(ie, your participation only makes the numbers for 
#the gateways bigger. No one knows your domain is helping)
#If you want to get your own listing in the stats,
#just set $anonymous to 0. Otherwise, leave it set to 1.

my $anonymous = 1;


#The GATEWAY is the other of the UDP/TCP pair.
#  Most users should leave this at the default.

my $gateway= "deschall-gateway.verser.frii.com";
my $gateway_port = 8080;


#The PROXY is your web proxy, if you have one.
#
#Normallty, the DESCHALL clients send their UDP packetstto your U2T gateway 
#  (this script). The U2T gateway then makes a TCP connection to the DESCHALL
#  gateway (T2U), and sends the data from the UDP packet. The DESCHALL
#  gateway then forwards the same data to the keyserver, and gets a reply.
#  The reply is sent back along the whole path just like the client's message.
#For most people, this is sufficient to get around firewalls. However, some
#  firewalls are highly restrictive, and will still block the TCP connection.
#  If this happens to you, you can funnel the TCP connection through your
#  web proxy, if you have one. In this setup, operations is the same, except
#  theat the web proxy acts as an intermediate between this gateway and the 
#  DESCHALL gateway.
#If you find that you need to use a web proxy at your site, do so by
#  giving the hostname and port of the proxy on the command line. You
#  should not change anything here.
#  eg, "deschall-u2t.pl web-proxy.mydomain.com 8080"

my $proxy = shift || $gateway;
my $proxy_port = shift || $gateway_port;


#If your proxy requires authentication, enter your
#  username and password in the ''s below. "Basic"
#  authorization does not use secure cryptography to
#  authenticate, so entering your user/pass here
#  here should not be a problem.

my $username = '';
my $password = '';


#Maximum number of concurrent requests that will be serviced.
#most people won't need to increase this. Large sites may want
#to set this to 8 or 10. Anything larger has the potential to
#cause problems elsewhere. Having large numbers of clients
#connecting at the same time is usually a Bad Thing.
#Note that if a request is dropped, the client will retry later.

my $maxforks = 6;


#set DEBUG to 1 if you want really verbose output for fixing a problem
my $DEBUG = 0;

#you shouldn't ever need to change the following...
my $timeout = 20; #seconds to wait for a TCP reply from gateway
my $port = 8669;  #this is hardcoded into the DESCHALL clients.
my $runfile = "u2trun.$port"; #used to detect I'm already running

######################################################
# DO NOT modify anything below this line! Modified
# gateways that behave badly due to a subtle bug you
# may introduce will not be tollerated -- it's a good
# way to get your domain banned. Contact the author
# before running a modified gateway.
######################################################

my $version = "1.4BETA";
my $forkcount = 0;

#################
#sanity checks...
my $test = uri_unescape(uri_escape("Testing :~/ encode"));
if($test ne 'Testing :~/ encode') {
    die "ERROR: URI::Escape is not installed right, or is the wrong version.
Without this module properly installed, the gateway will not work.
For further info, read the comments in the gateway's source code.\n";
    }
$test = decode_base64(encode_base64('Aladdin:open sesame'));
if($test ne 'Aladdin:open sesame') {
    die "ERROR: MIME::Base64 is not installed right, or is the wrong version.
Without this module properly installed, the gateway will not work.
For further info, read the comments in the gateway's source code.\n";
    }

if($email eq 'joe@nowhere.com') {
   die "Sorry, you must configure this gateway with your email address before
running it. To enter your email address, just edit the gateway code. It's
right at the top of the configuration section.\n";
    }
$email = &uri_escape($email);

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

my $waitedpid = 0;
sub REAPER {
    #$SIG{CHLD} = \&REAPER;  # if you don't have sigaction(2)
    #***only use one of the following two lines***
    #wait; $forkcount=0;     # uncomment this line if waitpid is broken
    while(waitpid(-1,WNOHANG) > 0){$forkcount--; logmsg "WAIT";}  #-1=anypid
    #logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
    }
$SIG{CHLD} = \&REAPER;

############################################
#check to see if gateway is already running
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!
      logmsg "RUNCHECK: U2T gateway is not running, launching." if($DEBUG);
      kill 9, $runpid;
      unlink $runfile;
      }
  else {
      #oops, we're allready running.
      logmsg "RUNCHECK: U2T gateway is running, exiting." if($DEBUG);
      exit;
      }
  }
#we are running, so save the PID
open RUN, "> $runfile";
print RUN "$$\n";
close RUN;

######################################
#set up a UDP socket, and loop forever
my $proto = getprotobyname('udp');
socket(Server, PF_INET, SOCK_DGRAM, $proto) or die "socket: $!";
bind(Server, sockaddr_in($port, INADDR_ANY)) or die "bind: $!";

logmsg "UDP server started on port $port";

my ($paddr, $rin, $rout);

$rin = '';
vec($rin, fileno(Server), 1) = 1;
while(select($rout = $rin, undef, undef, undef)) {
    my($message, $port, $iaddr, $name);
    $message = '';
    undef $paddr;
    #slurp in the message, and get the sender's IP/port too
    $paddr = recv(Server, $message, 65536, 0);
    logmsg "Received  possible connection" if ($DEBUG);
    if(!defined $paddr) {next;} #oops, probably a SIGCHLD
    ($port,$iaddr) = sockaddr_in($paddr) or die "Zoinks! $!";
    $name = gethostbyaddr($iaddr,AF_INET);

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

    #we'll let someone else deal with the message
    if($forkcount < $maxforks) {spawn \&serveit, $paddr, $message;}
    else {logmsg "FLOOD -- forkcount is $forkcount, dropping request";}
    } 


##############################################################
# ripped straight from Perl, 2nd ed, Ch. 6
# ...plus a slight modification to handle 2 arguments
sub spawn {
    my $coderef = shift;
    my @codeargs = (shift, shift);

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

    #if your system does not support fork(), you may comment out the rest
    #of this sub, and instead uncomment the following line of code:
    #
    #return &$coderef(@codeargs);
    #
    #the limitation if this is that the gateway cannot accept new
    #client requests until the current request is completed.

    ##### comment the below out to avoid fork() #####
        my $pid;
        $forkcount++;
        if (!defined($pid = fork)) {
            logmsg "cannot fork: $!";
            $forkcount--;
            return;
        } elsif ($pid) {
            logmsg "fork begat pid $pid" if($DEBUG);
            return; # i'm the parent
        }
        # else i'm the child -- go spawn
        exit &$coderef(@codeargs);
    ##### comment the above out to avoid fork() #####
    confess "Fork weirdness.";
    } 


#############################################################
# Here, we deal with a $message from $paddr
# We open a TCP connection, send the message, wait for a
#   reply, and dump the reply to $paddr via UDP
sub serveit {
    my($paddr, $message) = @_;
    my ( $mypaddr, $myiaddr, $server_rep,
         $host, $iaddr, $port, $proto, $reply,
         $rin, $rout, $rtime, $name);
    my $valid = 0;

    if($message eq "") {
        $reply = "Z Error at U2T: Empty UDP request from the client.";
        }
    else {
        #Forward the request to the exterior gateway (via TCP) and get a reply
        #If a Web proxy was not specified, the proxy and gateway are the same
        $iaddr = gethostbyname($proxy);
        $mypaddr = sockaddr_in($proxy_port, $iaddr) or confess "sockaddr: $!";
        $proto = getprotobyname('tcp');
        socket(SOCKET,PF_INET,SOCK_STREAM,$proto) or confess "TCP socket: $!";
        select((select(SOCKET), $| = 1)[0]); #buffering
        connect(SOCKET, $mypaddr)                 or confess "TCP connect: $!";

        my $foo = uri_escape($message); #teeny workaround for some systems
        my $auth = encode_base64("$username:$password");
        print SOCKET "GET http://$gateway:$gateway_port/$foo HTTP/1.0\n";
        #
        #NOTE! If you're writing your own gateway, DO NOT use the
        #same name for the User-Agent!!! Pick your OWN.
        #
        print SOCKET "Pragma: DESemail=$email\n";
        print SOCKET "User-Agent: UDP2TCPGateway/$version\n";
        print SOCKET "Authorization: Basic $auth\n" if ($password);
        if($anonymous != 1) {
            print SOCKET "Pragma: DESanon=Public\n";
            logmsg "Request is PUBLIC" if ($DEBUG);
            }
        print SOCKET "\n";
        logmsg "GET http://$gateway:$gateway_port/$foo HTTP/1.0" if($DEBUG);
        logmsg "sent TCP request: $message";
        $reply = "";

        #wait no more than $timeout seconds for a reply
        eval {
            local $SIG{ALRM} = sub {die "timeout"};
            alarm $timeout;
            #skip past HTTP headers
            while(<SOCKET>) {
                chomp; 
                logmsg "GOT:$_" if($DEBUG); 
                logmsg "GATEWAY NOTICE: ". join ' ', split '-', $1 if /^Pragma\: DESmessage=(\S+)/;
                $valid = 1 if /^Pragma\: DESCHALL/;
                last if /^\s*$/;
                }
            $reply=<SOCKET>;
            chomp $reply;
            logmsg "Reply: $reply" if($DEBUG);
            alarm 0;
            };
        if($@ and $@ !~ /timeout/) { logmsg "TCP timeout!" if ($DEBUG); return;}
        close SOCKET;
        $reply = uri_unescape($reply);
        logmsg "got TCP reply: $reply";

        if(!$valid) {
            logmsg "Invalid reply detected (web proxy problem?)";
            return;
            }
        if($reply eq "") {
            #This is likely because a packet was dropped or a timeout
            #occurred on the other side. No need to kill client, it will 
            #retry itself.
            logmsg "Empty TCP reply.";
            return;
            #$reply = "Z U2T: Empty TCP reply.";
            }
        }

    ####################################
    # send TCP's reply to client via UDP 
    ($port, $iaddr) = sockaddr_in($paddr) or confess "sockaddr_in: $!";
    $name = gethostbyaddr($iaddr,AF_INET) || inet_ntoa($iaddr);
    $proto = getprotobyname('udp');

    $myiaddr = gethostbyname(hostname());
    $mypaddr = sockaddr_in(0, $myiaddr)        or confess "sockaddr_in: $!";
    socket(SOCKET,PF_INET,SOCK_DGRAM,$proto)   or confess "UDP socket: $!";
    bind(SOCKET, $mypaddr)                     or confess "UDP bind: $!";
    defined(send(SOCKET,$reply,0,$paddr))      or confess "UDP send $host: $!";
    logmsg "sent UDP reply to $name" if ($DEBUG);
};