#!/usr/bin/perl
#
# $Id: snowderby,v 1.5 2002/02/17 14:18:00 magnus Exp $
#

use strict;
use IO::Socket;

####
#
# Just change this: 

# FULL PATH to script.
my $ME = 'http://example.com/cgi-bin/snowderby';

# THE DOMAIN NAME OF THE script. (used for mangled cookies)
my $MYDOMAIN = 'example.com';

#############################

# intri settings
my $CHUNKSIZE = 4096;
my $SUBMITBUTTON = 'GO THERE';

my ($serverpseudohost, $serverhost, $serverport, $serverdoc);
my (@hdrs, $result);

# DO NOT PUT 'Host' in here, as it will *break* snow derby.
# DO NOT PUT 'Connection' in here, as it will *break* snow derby.
# DO NOT PUT 'Referer' in here, as it may break things, and it also
#                      reveals the indirect URL to the host.
my @PASS_THESE = qw(
	Accept
	Accept-Encoding
	Accept-Language
	Cookie
	User-Agent
);

my $MY_PATH = $ME;
$MY_PATH =~ s#^http://[^/]+##;
$MY_PATH =~ s#/+$##;

my $QUERY_STRING = $ENV{QUERY_STRING};
$QUERY_STRING =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;

sub prox_URI
{
	my ($host, $port, $doc) = @_;

	$port ||= 80; 
	$doc =~ s#^/+##;
	s#^/+#/#;
	my $pseudohost = join '/', reverse split(/\./,$host);
	my $URI = 
	return "$ME/i/$pseudohost/_$port/$doc";
}

sub do_302
{
	my ($host, $port, $doc) = @_;
	my $URI = prox_URI($host, $port, $doc);
	print "Location: $URI\r\n\r\n";
}

#
# PLEASE DO NOT EDIT THIS CODE. 
# AT LEAST: PLEASE DO NOT REMOVE THE LINK TO THE SOFTWARE SITE;
#
sub do_blurb ($)
{
	my ($t) = @_;
	print "Content-type: text/html\r\n\r\n";
	print <<"--EOD";
<?xml version="1.0" encoding="iso-8859-1"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head><title>snow derby</title></head><body bgcolor="#ffffff">
<form action="$ME" method="get"><div><tt>URL:&nbsp;<input type="text" name="uri" size="50" />&nbsp;<input type="submit" value=" $SUBMITBUTTON " /></tt></div></form><hr />
<div><tt>$t</tt></div>
<p></p>
<div>
  <a href="http://validator.w3.org/check/referer"><img
  src="http://validator.w3.org/images/vxhtml10" height="31" width="88"
  align="right" border="0" alt="Valid XHTML 1.0!" /></a>
  <tt><i>powered by</i> <b>x42 <a href="http://x42.com/software/snowderby/?1.5">snow derby</a> 1.5</b></tt>
  <br />&nbsp;
</div>
</body>
</html>
--EOD
	exit 0;
}


sub do_proxy
{
	my $method = $ENV{REQUEST_METHOD};
	my ($content_type, $content_length, $buff, $data);
	if ($method eq 'POST')
	{
    	1 while $CHUNKSIZE == read STDIN, $data, $CHUNKSIZE, length $data;
		$content_type = $ENV{CONTENT_TYPE};
		$content_length = length $data;
	}

    my $server = new IO::Socket::INET(
		Proto => 'tcp',
		PeerAddr => "$serverhost.",
		PeerPort => $serverport
	) or do_blurb "Couldn't connect to host '$serverhost:$serverport'<br />($!)";

    binmode $server;
    binmode STDOUT;
    $server->autoflush(1);
    autoflush STDOUT;

    print $server "$method $serverdoc HTTP/1.0\r\n";
	for (@PASS_THESE)
	{
		my $http_header = $_;
		my $envvar = uc "http-$http_header";
		$envvar =~ y/-/_/;
		if (length($ENV{$envvar}) > 0)
		{
			print $server "$http_header: $ENV{$envvar}\r\n";
		}
	}

	print $server "Host: $serverhost\r\n";
	if ($method eq 'POST')
	{
		print $server "Content-type: $content_type\r\n";		
		print $server "Content-length: $content_length\r\n";		
		print $server "\r\n";
		print $server $data;
	}
	else
	{
		print $server "\r\n";
	}

    $result = <$server>;
	$result =~ s/[\s\r\n]+$//;

    my $MIME;
	@hdrs = ();
    while (<$server>)
	{
		s/[\s\r\n]+$//;
		last if /^$/;

		unless (/^(connection|accept-ranges):\s+/i)
		{
			if (m#^location:\s+http://([^:/]+)(:\d+)?(/.*)?#i)
			{
				my $URI = prox_URI($1, $2, $3);
				push @hdrs, "Location: $URI";
			}
			elsif (m#^set-cookie:\s+(.+)$#i)
			{
				my $cookie_hdr = $_;
				$cookie_hdr =~ s#\bpath=/#path=$MY_PATH/i/$serverpseudohost/_$serverport/#i;
				$cookie_hdr =~ s#\bdomain=[a-z0-9\.\-]+#domain=$MYDOMAIN#i;
				push @hdrs, $cookie_hdr;

			}
			else
			{
				push @hdrs, $_;
			}
		}
        if (/^Content-type: (.*)$/i)
		{
			$MIME = $1;
		} 
    }

    my $body = "";
    1 while $CHUNKSIZE == read $server, $body, $CHUNKSIZE, length $body;
	
	if (($MIME eq 'text/html')
		||($MIME eq 'application/x-javascript')
		||($MIME eq 'text/css')
	)
	{
	    $body =~ s{(ACTION|BACKGROUND|HREF|SRC|VALUE)\s*\=\s*"([^"]+)}
			{"$1=\"".&reloc($1, $2).'"'}ige;
		$body =~ s{(ACTION|BACKGROUND|HREF|SRC|VALUE)\s*\=\s*'([^']+)'}
			{"$1=\"".&reloc($1, $2).'"'}ige;
		$body =~ s{content\s*=\s*\"\s*(\d+)\s*;\s*URL\s*\=\s*([^"]+)"}
			{"content=\"$1;URL=".&reloc('URL', $2).'"'}ige;
		$body =~ s#(<body[^>]+>)#$1<!-- tjohej -->#i;
	}

	for (@hdrs)
	{
		print STDOUT "$_\r\n";
	}

    print STDOUT	"Connection: close\r\n",
					"Content-Type: $MIME\r\n",
					"\r\n",
					$body;
}

sub reloc {
	my ($tag, $link)=@_;
	my ($res,$doc2,$link2);

	if (($tag =~ /value/i) && ($link !~ m!^http://(.*)!i))
	{
		$res = $link;
	}
	elsif ($link =~ m#^(http:)?//([^:/]+)(:\d+)?(/.*)?#i)
	{
		$res = prox_URI($2, $3, $4);
	}
	elsif ($link =~ m!^mailto:!i)
	{
		$res = $link;
	}
	elsif ($link =~ m!^news:!i)
	{
		$res = $link;
	}
	elsif ($link =~ m!^telnet:!i)
	{
		$res = $link;
	}
	elsif ($link =~ m!^gopher:!i)
	{
		$res = $link;
	}
	elsif ($link =~ m!^ftp:!i)
	{
		$res = $link;
	}
	else
	{
		if ($link =~ m#^\./(.*)#)
		{
			$res = "$ME/i/$serverpseudohost/_$serverport/$1";
		}
		elsif ($link =~ m#^/(.*)#)
		{
			$res = "$ME/i/$serverpseudohost/_$serverport/$1";
		}
		elsif ($link =~ m!^\.\.!)
		{
			$doc2 = $serverdoc; $link2 = $link;
			$doc2 = $1 if $doc2 =~ m!(.*/)[^/]+$!;
			while (($link2 =~ m!^\.\./(.*)!) || ($link2 =~ m!^\.\.$!))
			{
				$link2 = $1;
				$doc2 = $1 if $doc2 =~ m!(.*/)[^/]+/$!;
			}
			$res = "$ME/i/$serverpseudohost/_$serverport/$doc2$link2";
		}
		else
		{
			if ($serverdoc =~ m#/$#)
			{
				$res = "$ME/i/$serverpseudohost/_$serverport/$serverdoc$link";
			}
			else
			{
			    $doc2 ='';
				$doc2 = $1 if $serverdoc =~ m!(.*/)[^/]+$!;
				$doc2 =~ s#^/+##; 
				$res = "$ME/i/$serverpseudohost/_$serverport/$doc2$link";
			}	
		}		
	}
	return $res;
}

my ($pair,$name,$value);

# only one URL-format we like.
if ($ENV{PATH_INFO} =~ m#^/i/(.+)/_(\d+)/(.*)$#i)
{
	$serverpseudohost = $1;
	$serverport = $2;
	$serverdoc = '/'.$3;
	$serverhost = join '.', reverse split('/', $serverpseudohost);
	$QUERY_STRING = "?$QUERY_STRING" if $QUERY_STRING;
	do_proxy();
}
elsif ($QUERY_STRING =~ m#^uri=$#i)
{
	do_blurb('Please enter hostname or URL and submit again');
}
elsif ($QUERY_STRING =~ m#^(uri=)?htt?p://?([^:/]+)(:(\d+))?(/.*)?#i)
{
	do_302($2, $4, $5);
}
elsif ($QUERY_STRING =~ m#^(uri=)?([^:/]+)(:(\d+))?(/.*)?#i)
{
	do_302($2, $4, $5);
}
else
{
	my $BLURB = '';
	$BLURB = "MALFORMED QUERY_STRING:<br />$QUERY_STRING" if length($QUERY_STRING);
	do_blurb($BLURB);
}
