use warnings;
use IO::Socket;

$ARGV[0]||='';

# Web Proxy by Tyler Bletsch
if ($ARGV[0] =~ /-h(.*)/) {
    shift;
    $localHost = $1;
} else {
    $localHost = &getLocalHost;
}

unless ($listenPort = $ARGV[0]) {
	print "Syntax: $0 [-h<host>] <port>\n\n";
	exit;
}

my $sockListen = new IO::Socket::INET (LocalPort => $listenPort, Proto => 'tcp', Listen => 20, Reuse => 1);
die "Could not create socket: $!\n" unless $sockListen;

$localURL = "http://$localHost:$listenPort/";

print "Server up at $localURL.\n";

#print "Waiting to accept on port $listenPort...\n";

while (1) {
	$sockClient = $sockListen->accept(); # Get next client

	our $thread++;
	
	$clientSockAddr = $sockClient->peername();
	($clientPort, $clientAddr) = sockaddr_in($clientSockAddr);
	$clientHost = gethostbyaddr($clientAddr, AF_INET);
	$clientIP = inet_ntoa($clientAddr);
	if ($clientHost eq $clientIP) {
		print "<$thread> Connected to $clientHost, local port $clientPort!\n";
	} else {
		print "<$thread> Connected to $clientHost ($clientIP), local port $clientPort!\n";
	}
	
	my $pid = fork();
	die "Cannot fork '$!'" unless defined $pid;
	if ($pid) { # Parent
		close $sockClient;
		next;
	}

	# Child
	&doClient($sockClient);
	
	### DO STUFF WITH $sockClient
	#print $sockClient scalar localtime; # Uncomment to make this a simple time server
	
	close $sockClient;
	exit;
}

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

sub doClient {
	my ($sockClient) = @_;
	
	print "<$thread>   Getting request...";
	
	my $request = <$sockClient>;
	$request =~ /GET (.*?) HTTP\/\d\.\d/;
	$doc = $1;
	$doc =~ s#^/##;
	#$localDoc = ".$doc";
	#$localDoc =~ s/\/$//; # Remove trailing slash
	
	print "for '$doc'...\n";
	
	($remHost,$remPort,$remDoc) = urlToList($doc);
	#print "($remHost\n $remPort\n  $remDoc\n)\n";
	if ($remHost) {
		($retCode,$retMsg,$headHash,$content) = getPage($remHost,$remPort,$remDoc);
    	if ($retCode) {
    		
    		#print "($retCode,$retMsg,$headHash,$content)\n";
    		
            print $sockClient "HTTP/1.0 $retCode $retMsg\n";
            if ($$headHash{'Content-Type'}) {
            	print $sockClient "Content-Type: ".$$headHash{'Content-Type'}."\n";
            }
            print $sockClient "\n";
            
            if ($$headHash{'Content-Type'} =~ '^text/html') {
                #print "    Translocating...\n";
                translocatePage($remHost,$remPort,$remDoc,@$content);
            } else {
                #print "    Will not translocate, since type is '".$$headHash{'Content-Type'}."'\n";
            }
            print $sockClient @$content;
            #print @$content;
        } else {
            print $sockClient "HTTP/1.0 401 Can't connect\n\n401 Can't connect\n";
        }
	} else {
	    print $sockClient "HTTP/1.0 400 Bad request\n\n400 bad request\n";
    }	
	
	print "<$thread>   Done.\n";
	close($sockClient); # We're done with this client
	

	
}


sub getLocalHost () {
    use Sys::Hostname;
    use Socket;
    my($addr)=inet_ntoa((gethostbyname(hostname))[4]);
    return $addr;
}

sub urlToList ($) {
    $_ = shift;
    if (m#^http://(.+):(\d+)(/?.*)$#) {
        return ($1,$2,$3 eq ''?'/':$3);
    } elsif  (m#^http://([^/]+)(/?.*)$#) {
        return ($1,80,$2 eq ''?'/':$2);
    } else {
        return 0;
    }
}

sub getPage ($$$) {
    my ($host,$port,$doc) = @_;
    my $sock = new IO::Socket::INET (PeerHost => $host, PeerPort => $port, Proto => 'tcp');
    return 0 if (!$sock);
    binmode $sock,":raw";
    print $sock "GET $doc HTTP/1.0\nHost: $host:$port\n\n";
    my $topHeader = <$sock>;
    my ($retCode,$retMsg) = $topHeader=~m#HTTP/\S* (\d*) (.*)#;
    #print ">>>>$retCode>>>>\n";
    while (<$sock>) { #while (0) { 
        s/\r\n/\n/g; # conv crlf to lf
        chomp;
        last if ($_ eq "");
        my ($key,$val) = /([^:]*): (.*)/;
        #print "~~~>$key~~>$val\n";
        $headHash{$key} = $val;
    }
        
    my @content = <$sock>;
    return $retCode,$retMsg,\%headHash,\@content;
}

sub translocatePage {
    my ($host,$port,$doc) = (shift,shift,shift);
    $doc =~ s#/[^/]*$#/#;
    #s/GNU/Bananaphone/g for (@_);
    @attribs = qw/SRC HREF ACTION/;
    #getloc
    for $attrib (@attribs) {
        for (@_) {
            #http://www.dls.net/doc.htm
            #http://ME/THIS
            #/doc.htm
            #http://ME/RS:RP.THIS
            #doc.htm
            
            s#$attrib="(http://[^"]*)"#$attrib="$localURL$1"#ig;
            s#$attrib="/([^"]*)"#$attrib="${localURL}http://$host:$port/$1"#ig;
            s#$attrib="([^:"]*)"#$attrib="${localURL}http://$host:$port$doc$1"#ig;

            s#$attrib=(http://[^ >]*)[ >]#$attrib="$localURL$1"#ig;
            s#$attrib=/([^ >]*)[ >]#$attrib="${localURL}http://$host:$port/$1"#ig;
            s#$attrib=([^: >]*)[ >]#$attrib="${localURL}http://$host:$port$doc$1"#ig;
        }
    }
}