I am writing a threaded proxy server for windows (see complete code below).. It seems to mostly work as it is. To use this proxy server, you simply have to set your browser connection settings to use Localhost port 8080 as a proxy.

There are a few problems though. For some reason, it will get in a non-responsive state. Would anyone care to help me figure out what I am doing wrong?

Any help would be greatly appreciated.

BTW, I am writing this proxy server mainly as a way for me to learn how to use threads on windows. I do not want to use any other modules if possible.

#!/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 E
+rror : $!";
setsockopt($Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))     || die
+ "Setting Socket Option Error: $!";
bind($Server, sockaddr_in($port, INADDR_ANY)) || die "Cannot bind Sock
+et : $!";
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 w
+indows 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,"So
+cket Error: $!");
    bind($Sock, $local_port) || return (undef,"Socket Bind Error: $!")
+;
    connect($Sock, $remote_port) || return (undef,"Socket Connect Erro
+r: $!");
    $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, a
+nd 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;
    }

[download]

Janitored by holli - added readmore tags

In reply to Windows Threaded Proxy Server by slloyd

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.