#!/usr/bin/perl
#################################################################
###  Use and Requires
use strict;
use threads qw[ yield ];
use threads::shared;
use Thread::Queue;
use Thread::Queue::Any;
use Socket;
#################################################################
###  Initialize
$|=1;
my $worker_cnt=6;	#Number of worker threads to start
my $hostname = `hostname`;
$hostname=strip($hostname);
my $hostip = (gethostbyname($hostname))[4];
my %SocketInfo=(
	hostname	=> $hostname,
	hostip		=> $hostip,
	);
#################################################################
###  Create thread Queues
print "creating thread queues ...";
my $Qwork       = new Thread::Queue::Any;
my $Qprint    = new Thread::Queue::Any;
my %ThreadStatus : shared = ();
my %ClientAddr : shared = ();
print "Done\n";
#################################################################
###  Start up worker threads
my @threads=();
print "starting 1 writer thread ... \n";
my $cthread = threads->new(\&writer);
push(@threads,$cthread);
print "starting $worker_cnt worker threads ... ";
for(my $x=0;$x<$worker_cnt;$x++){
	$cthread = threads->new(\&worker);
	push(@threads,$cthread);
	}
print "Done\n";
my $threadcnt=@threads;
#################################################################
### Connect to Socket
my $port = 8080;
my $address='';
my $Server;
my ($name, $aliases, $protocol) = getprotobyname('tcp');
if ($port !~ /^\d+$/) {($name, $aliases, $port) = getservbyport($port, 'tcp');}
my $proto = getprotobyname('tcp');
socket($Server,PF_INET,SOCK_STREAM,$proto) || die "Socket Connection Error : $!";
setsockopt($Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) 	|| die "Setting Socket Option Error: $!";
bind($Server, sockaddr_in($port, INADDR_ANY)) || die "Cannot bind Socket : $!";
listen($Server,SOMAXCONN) || die "Error listening on Socket: $!";
binmode $Server;
select($Server);$| = 1;
select(STDOUT);$|= 1;
#################################################################
###  Listener on Socket for Client Requests
# Use fileno to pass Globs between threads
#     http://www.perlmonks.org/index.pl?node_id=395373
print "Listening on port $port\n";
my $Client;
while (my $addr = accept($Client, $Server)){
	$Qwork->enqueue(fileno $Client,$addr,"");
	#sleep for 1 millisecond to avoid pegging the CPU
	select(undef,undef,undef,.01);
	}
#################################################################
###  send a Die message to each thread by putting a die message in the queue for each thread to get.
$Qwork->enqueue(["",'DIE_NOW']) for 1 .. @threads;
#################################################################
###  Join threads - cleanup and exit
#$_->join for @threads;  - this should work but causes a crash.. Let windows clean up the threads.
use POSIX qw[_exit];
_exit 0;
#################################################################
###  Subs
sub writer {
	#Grab items from the Qprint queue and print them to STDOUT
	my $tid = threads->tid();
	$ThreadStatus{$tid}='idle';
	while(1){
		select(undef,undef,undef,.01) until $Qprint->pending();
		$ThreadStatus{$tid}='working';
		my ($thrid,$msg)=$Qprint->dequeue;
		last if length($msg) && $msg=~/^DIE NOW$/is;
		print "[$thrid] $msg\n";
		#Show the state of each thread
		foreach my $tid (sort(keys(%ThreadStatus))){
			print STDOUT "\t$tid is $ThreadStatus{$tid}\n";
			}
		$ThreadStatus{$tid}='idle';
		#sleep for 1 millisecond to avoid pegging the CPU
		select(undef,undef,undef,.01);
		}
    return 1;
	}
sub worker {
	my $tid = threads->tid();
	$ThreadStatus{$tid}='idle';
	while(1){
		select(undef,undef,undef,.01) until $Qwork->pending();
		$ThreadStatus{$tid}='working';
		my ($fno,$addr,$action)=$Qwork->dequeue;
		last if length($action) && $action=~/^DIE NOW$/is;
		open($Client, "+<&=$fno") || last;
		#Process Request;
		processRequest($Client,$addr,$tid);
		close($Client);
		$ThreadStatus{$tid}='idle';
		}
    return 1;
	}
sub processRequest{
	my $Client=shift || return;
	my $addr=shift || return;
	my $tid=shift;
	$Qprint->enqueue($tid,"Processing");
	$ThreadStatus{$tid}='processing';
	my $socket_format = 'S n a4 x8';
	my @tmp=unpack($socket_format,$addr);
	my $port=$tmp[1];
	my $inetaddr = $tmp[2];
	my @inetaddr = unpack('C4',$inetaddr);
	my $client_ip=join(".", @inetaddr);
	my $client_host = gethostbyaddr($inetaddr, AF_INET);
	my %Request=();
	my @request=readSocket(\%Request,$Client);
	my ($UrlSock,$err)=connectToHost($Request{host},80);
	#Send Request to the internet
	$request[0] =~ s/http:\/\/[^\/]+//;
	$request[0] =~ s/HTTP\/1.1/HTTP\/1.0/;
	foreach my $line (@request){
		print $UrlSock $line;
		}
	if(length($Request{postdata})){
		print $UrlSock $Request{postdata};
		}
	#Get Reply Header
	my %Reply=();
	my @reply=&readSocket(\%Reply,$UrlSock);
	if($Reply{'content-type'}=~/^(image|application)/is){
		binmode $UrlSock;
		binmode $Client;
		}
	#Print the Reply Header to the browser client
	print $Client @reply;
	$Qprint->enqueue($tid,"Listening for $Reply{'content-type'} from $Request{host}");
	$ThreadStatus{$tid}='waiting for reply [0]';
	my $clen=0;
	my $linecnt=0;
	while (<$UrlSock>) {
		my $line=$_;
		$linecnt++;
		$ThreadStatus{$tid}="reading reply line $linecnt";
		print $Client $line;
		if($Reply{'content-length'} && $Reply{'content-length'} > 0){
			$clen += length($line);
			last if $clen >= $Reply{'content-length'};
			}
		last if $line=~/\<\/html\>/is;
		last if $line=~/^0$/s;
		if($line=~/\<\/body\>$/is){
			print $Client qq|</html>|;
			last;
			}
		}
	}
########################
sub readSocket{
	my $hash=shift || return "No Hash Reference";
	my $Socket=shift || return "No Socket";
	binmode $Socket;
	my @lines=();
	%{$hash}=();
	#Read in First line and process it
	my $firstline=<$Socket>;
	$hash->{request}=strip($firstline);
	push(@lines,$firstline);
	$hash->{url} = ($firstline =~ m|(http://\S+)|)[0];
	if($hash->{url}=~/\?(.+)/s){
		$hash->{getdata}=$1;
		}
	#Method,host,port
	my ($method,$host,$port);
	#POST http://www.basgetti.com/cgi-bin/wasql.pl HTTP/1.1
	#CONNECT www.netteller.com:443 HTTP/1.1
	if($firstline =~ m!(GET|POST|HEAD) http://([^/:]+):?(\d*)!){
		$method=$1;
		$host=$2;
		$port=$3
		}
	elsif($firstline=~m!(CONNECT) ([^/:]+):?(\d*)!){
		$method=$1;
		$host=$2;
		$port=$3
		}
	$hash->{method}=$method;
	$hash->{host}=$host;
	$hash->{port}=$port;
	#Read in rest of Header
	while (<$Socket> ) {
		next if (/(Proxy-Connection:|Keep-Alive:|Accept-Encoding:)/);
		if(/^([a-z\-]+)\:(.+)/is){
			my $attr=lc(strip($1));
			my $val=lc(strip($2));
			$hash->{$attr}=$val;
			}
		push(@lines,$_);
		last if ($_ =~ /^[\s\x00]*$/);
		}
	my $len=$hash->{'content-length'}?$hash->{'content-length'}:0;
	if ($method=~/^POST$/is && $len) {
		my $data='';
		my $dlen=0;
		my $bytes=$len>2048?2048:$hash->{'content-length'};
		while($dlen<$len){
			my $cdata;
			my $n=read($Socket,$cdata,$bytes);
			$data .= $cdata;
			$dlen=length($data);
			last if $n==0;
			last if !defined $n;
			select(undef,undef,undef,.01);
			}
		$hash->{'postdata'}=$data;
		}
	$hash->{url}=~s/\?.*//s;
	return @lines;
	}
##################
sub connectToHost {
	# Create a socket that connects to a certain host
	# connectToHost($MainSock, $remote_hostname, $port)
	my ($remote_hostname, $port) = @_;
	my $Sock;
	my ($socket_format, $proto, $packed_port, $cur);
	my ($remote_addr, @remote_ip, $remote_ip);
	my ($local_port, $remote_port);
	if ($port !~ /^\d+$/) {
		$port = (getservbyname($port, "tcp"))[2];
		$port = 80 unless ($port);
		}
	$proto = (getprotobyname('tcp'))[2];
	$remote_addr = (gethostbyname($remote_hostname))[4];
	if (!$remote_addr) {
		return (undef,"Unknown host: $remote_hostname");
		}
	@remote_ip = unpack("C4", $remote_addr);
	$remote_ip = join(".", @remote_ip);
	$socket_format = 'S n a4 x8';
	$local_port = pack($socket_format, &AF_INET, 0, $SocketInfo{hostip});
	$remote_port = pack($socket_format, &AF_INET, $port, $remote_addr);
	socket($Sock, &AF_INET, &SOCK_STREAM, $proto) || return (undef,"Socket Error: $!");
	bind($Sock, $local_port) || return (undef,"Socket Bind Error: $!");
	connect($Sock, $remote_port) || return (undef,"Socket Connect Error: $!");
	$cur = select($Sock);
	$| = 1; # Disable buffering on socket.
	select($cur);
	return $Sock;
	}
###############
sub strip{
	#usage: $str=strip($str);
	#info: strips off beginning and endings returns, newlines, tabs, and spaces
	my $str=shift;
	if(length($str)==0){return;}
	$str=~s/^[\r\n\s\t]+//s;
	$str=~s/[\r\n\s\t]+$//s;
	return $str;
	}