#!/usr/bin/perl

use Tk;
use Tk::NoteBook;
use Tk::Frame;
use Tk::Text;
use Tk::Label;
use Tk::Button;
use Tk::Entry;
use Tk::Scrollbar;
use Tk::Checkbutton;
use IO::Socket;
use Socket;
use English;
use Tk::DialogBox;
use Tk::Listbox;
use strict;
use IO::Socket;
use strict;
use IO::Socket;
use Tk::MenuButton;


sub process_request;
sub printHeader;
sub error;
sub gotMetaChars;
sub isACLscriptOK;
sub isItHTML;
sub SSI;
sub HTTPtime;
sub LOCALtime;


my $mw = MainWindow->new();
$mw->title("Pyxus Web Server Response Window");
$mw->resizable(1,1);

 my $menubar = $mw->Frame(-relief=>"raised",-borderwidth=>2);
 $menubar->pack(-side=>"top", -fill=>"x");
 my  $filebutton = $menubar->Menubutton(-text=>"Exit Server",-underlin
+e => 0);  
 my  $filemenu = $filebutton->Menu();
     $filebutton->configure(-menu=>$filemenu);
     $filemenu->command(-label => "Stop Server And Return To Pyxus Mai
+n Screen",-command => \&exit_all,-underline => 1);  


$filebutton->pack(-side=>"left");
$menubar->pack(-side=>"top", -fill=>"x");
my $status = $mw->Label(-text=>"Pyxus Web Server Running...",-borderwi
+dth=>2,-anchor=>"w");
$status->pack(-side=>"bottom", -fill=>"x");


my $lookup_frame = $mw->Frame()->pack(-expand => '1', -fill => 'both',
+ -side => 'top');
my $scroll = $mw->Scrollbar();
$scroll->pack(-side => 'right', -fill => 'y');
my $display = $mw->Text(-height => '25', -width => '85', -yscrollcomma
+nd => ['set', $scroll]) ->pack(-side => 'top', -expand => '1', -fill 
+=> 'both');
$scroll->configure(-command => ['yview', $display]);



system('cls');
binmode(STDOUT); #win32 platforms must use this!!

######################################################################
+##
# Set up error messages in hash.
######################################################################
+##

my %errors = (
    "403", "Forbidden - access denied!",
    "404", "File Not Found.",
    "500", "Internal error.",
    "501", "Not implemented.",
    "900", "Excessive GET length",
    "901", "Excessive POST size.",
    "902", "Excessive ENV length.",
    "903", "Too many variables."
    );

my %verrors = (
    "403", "Your client is not permitted to request this item.",
    "404", "The requested item was not found on this server.",
    "500", "An error occurred while trying to retrieve item.",
    "501", "This server does not support the given request type.",
    "900", "The GET length is excessive.",
    "901", "The POST size is excessive.",
    "902", "Environment variable length is excessive.",
    "903", "Too many variables in client header."
    );

######################################################################
+##
# Get Server Variables
######################################################################
+##

my %PROC;
open(PROC, "pyxus.conf") or die "Where is the PYXUS Configuration FILE
+?\n";
while(<PROC>) {
    chomp;
    my @allconf = split(/\n/);
    foreach my $line (@allconf) {
            unless($line =~ /^#/) {
                # Remove white space
                $line =~ s/\s+|\t+//g;
                $line =~ /(.*)=(.*)/;
                $PROC{$1} = $2;
            }
        }
    }
close(PROC);

my $port = $PROC{'port'};
my $maxconn = $PROC{'maxconn'};
my $root = $PROC{'docroot'};
my $cgibin = $PROC{'cgibin'};
my $BINSECkey = $PROC{'binseckey'};
my $enablelogs = $PROC{'enablelogs'};
my $maxGETlength = $PROC{'maxGETlength'};
my $maxPOSTlength = $PROC{'maxPOSTlength'};
my $timezone = $PROC{'timezone'};

my @ACLscript = split(',', $PROC{'securedscripts'});

my @ACLfiletypes = split(',', $PROC{'securedfiletypes'});
my %mimetype;
my $index;
for ($index = 0; $index <= $#ACLfiletypes; $index += 2) {
    $mimetype{$ACLfiletypes[$index]} = $ACLfiletypes[$index + 1];
}

my $maxHdrVars = 10;
my $files_served = 1;
my $client;
my $method;
my $url;
my $versionid;

my $qryfile = "Queryfile.txt";

my $msg1;
my $msg2;
my $querystring;
my $querylength;

$ENV{'SERVER_NAME'} = "Pyxus";
$ENV{'SERVER_PORT'} = $port;
$ENV{'SERVER_PROTOCOL'} = "HTTP/1.1";
$ENV{'SERVER_SOFTWARE'} = "Pyxus 2.0";

######################################################################
+##
# Start Server Logfile
######################################################################
+##

my $Date = localtime();
open(LOGS, ">>serverlog.txt");
print LOGS "\n*** Server started $Date \n";
print LOGS "*** Server port:$port, maximum connnections: $maxconn \n";
print LOGS "*** Server document root is $root \n\n";
close(LOGS);

######################################################################
+##
# Start Network Server
######################################################################
+##



my @promote;
$promote[2]= "Mollensoft Labs & Monashee Information Systems - Http Se
+rver ver 2.2g\n\n";
$promote[3]="PYXUS = \"Fast Stream\"\n\n";
$promote[7]="Server operating under username: $ENV{'USERNAME'}\n";
$promote[8]="Starting Server Log....\n";
$promote[9]="PYXUS Server Started, $Date \n";
$promote[10]="Listening on Port: $port\n";
$promote[11]="Maxconnections: $maxconn\n";
$promote[12]= "Server File Root: $root\n";
$promote[13]= "CGI directory is: $cgibin \n";
$promote[14]="The server is running ...\n\n"; 
           $display-> yview('end');
          $mw->update;
              $display -> insert('end',"@promote");





my $server = IO::Socket::INET->new
    (
    Type=>SOCK_STREAM,
    LocalPort=>$port, 
        Listen=>$maxconn, 
        Reuse=>1
    ) or die "Sorry, cannot open server socket!\n";

my $sss = '#' x 65;
print "$sss\n";
print "Mollensoft Labs & Monashee Information Systems - Http Server ve
+r 2.0\n\n";
print "PYXUS = \"Fast Stream\"\n\n";
print "$sss\n";
print "Use Control-C to exit Server (until GUI control is complete)\n"
+;
print "$sss\n";
print "Server operating under username: $ENV{'USERNAME'}\n";
print "Starting Server Log....\n";
print "PYXUS Server Started, $Date \n";
print "Listening on Port: $port\n";
print "Maxconnections: $maxconn\n";
print "Server File Root: $root\n";
print "CGI directory is: $cgibin \n";
print "The server is running ...\n\n"; 

######## Main Loop of Web Server ########

my $pid = fork;
if ($pid) {


}else{




while ($client = $server->accept) {
    $client->autoflush(1);

    my @hdr = split(' ', <$client>);
    $hdr[0] =~ /(.*)/;    $method =$1;
    $hdr[1] =~ /(.*)/;    $url = $1;
    $hdr[2] =~ /(.*)/;    $versionid = $1;

    $msg1 = join(" ","Client:", $files_served, $client->peerhost(), $D
+ate, " "); 
    $msg2 = join(" ","Header: ", $method, $url, $versionid, "\n");
    print $msg1, $msg2;

    if ($enablelogs eq "Y") {
        open(LOGS, ">>serverlog.txt") or die "Error: Cannot open SERVE
+RLOG.TXT!\n";
        print LOGS $msg1, $msg2;
        close(LOGS);
    }


########################################
           $display-> yview('end');
          $mw->update;
              $display -> insert('end',"$msg1\n"."$msg2\n");
########################################




    if ($method eq "GET" or "POST" && ($versionid eq "HTTP/1.0" || $ve
+rsionid eq "HTTP/1.1")) {
        &process_request;
        $root = $PROC{'docroot'};
    } else {
        # If not GET or POST then what is it? It could be one of
        # the other legitimate HTTP headers that are legal but,
        # not recognized by our server.
        if ($method eq "HEAD" || "PUT" || "DELETE" || "LINK" || "UNLIN
+K") {
            &error(501);
        } else {
            # Unrecognized header, abandon request!    
        }
    }
    close($client);
}
close($server);

#exit;

exit 0;

######################################################################
+##
# Processing of requests are done after here.
######################################################################
+##

sub process_request {




    # Prevent directory go-back and directory tree traversals.
    # This type of request is so dangerous, don't even respond.
    if ($url =~ /\.\./) {return}

    if (rindex($url, "/") == length($url)-length("\n")) {$url .= "inde
+x.htm"}

    # If this is a Perl GET form request, then extract query string.
    $url =~ /(.*?)\.pl\?(.*$)/;
    $querystring = $2;
    $querylength = length($querystring);

    $ENV{'QUERY_STRING'} = $querystring;
    $ENV{'CONTENT_LENGTH'} = $querylength;
    $ENV{'DATE_GMT'} = HTTPtime;
    $ENV{'DATE_LOCAL'} = LOCALtime;
    $ENV{'REQUEST_METHOD'} = $method;
    $ENV{'REMOTE_HOST'} = $client->peerhost();
    $ENV{'REMOTE_ADDR'} = inet_ntoa($client->peeraddr());

    # Now, strip away all query characters after the url filename.
    $url =~ s/\?.*$//;

    # Reject any filenames with Meta characters! Likely a hacker if tr
+ue.
    if (gotMetaChars($url)) {return}

    if ($method eq "GET" && isACLscriptOK($url)) {
        unless($querylength < $maxGETlength) {&error(900); return;}
        my $rs = `perl.exe -T $cgibin.$url`;
        if ($?) {
            &error(500, $?); return;
        } else {
            printHeader;
            print $client $rs;
            $BINSECkey += 100;
            return;
        }
    }

    if ($method eq "POST") {
        unless(isACLscriptOK($url)) {&error(403); return;}
        my $line;
        my $flag=0;
        # Collect header variables and create environment variables
        # with them. By prefixing all header variables with HTTP_ to
        # incoming variables we ensure that no one can overwrite
        # sensitive system variables. Limit the number of them as well
+.
        while ($flag <= $maxHdrVars - 1) {
            $line = <$client>;
            if(length($line) >= $maxGETlength) {
                &error(902,$querylength);
                return;
            }
            $flag++;
            my ($var, $val) = split(": ", $line);    
            $var =~ tr/-/_/;
            $var = join("", "HTTP_", $var);
            $ENV{$var} = $val;
            if ($line =~ /(Content-Length: )(\d+)/) {
                $querylength = $2;
                $flag = $maxHdrVars;
            }
        }
        if ($flag > $maxHdrVars + 1) {&error(903,$flag); return;}
        if ($querylength > $maxPOSTlength) {&error(901,$querylength); 
+return;}
        read($client, $querystring, $querylength);
        my @array = split("\n", $querystring);
        for (my $index = 0; $index < $#array; $index++) {
            if(length($array[$index]) >= $maxGETlength) {
                &error(902,length($array[$index]));
                return;
            }
            my ($var, $val) = split(": ", $array[$index]);
            $var =~ tr/-/_/;
            $var = join("", "HTTP_", $var);
            $ENV{$var} = $val;
        }
        $ENV{'CONTENT_LENGTH'} = length($array[$#array]);
        open(QSTR, ">$qryfile");
        print QSTR "$array[$#array]\n";
        close(QSTR);
        my $rs = `perl.exe -T $cgibin.$url <$qryfile`;
        if ($?) {
            &error(500, $?); return;
        } else {
            printHeader;
            print $client $rs;
            $BINSECkey += 101;
            return;
        }
    }

    # Here we get a normal HTML file to send back to the client. If ei
+ther
    # the GET or POST above fail, we fall through to here for an HTML 
+file
    # specified in the URL. 

    if ((my $ct = isItHTML($url)) && (my $buffer = gulpFile($root.$url
+))) {
        $buffer =~ s/<!--#(.*?)-->/&SSI($1)/ge;
        printHeader($ct);
        print $client $buffer;
        $files_served++;
    } else {
        &error(404); return;
    }
}

sub printHeader {
    my $ct = @_[0];
    my $xxx = HTTPtime;
    if (!defined($ct)) {$ct = "text/html";}
    print $client "$versionid 200 OK\n";
    print $client "$xxx\n";
    print $client "Content-type: $ct\n\n";
}

sub SSI {
    # Here we process some common server-side include statements.  
    my ($cmd, $arg) = split('=', @_[0]);
    my $root = $PROC{'docroot'};
    $arg =~ s/"|'//g;

    if (gotMetaChars($arg)) {
        return "SSI Error: Meta characters present! = $arg"
    }

    if ($cmd eq "include file") {
        return gulpFile($root.$arg);
    }

    if ($cmd eq "fsize file") {
        if (-e $root.$arg) {
            return -s $root.$arg;
        } else {
            return "SSI Error: $cmd = $arg";
        }
    }

    if ($cmd eq "flastmod file") {
        if (-e $root.$arg) {
            return -A $root.$arg;
        } else {
            return "SSI Error: $cmd = $arg";
        }
    }

    # Be careful! In principle, clients would never know what's going
    # on here but there are risks.
    #if ($cmd eq "exec cgi") {
    #    return;
    #}
    #if ($cmd eq "exec cmd") {
    #    `$arg >Outfile.txt`;
    #    return getFile("Outfile.txt");
    #}

    if ($cmd eq "echo var") {
        return $ENV{"$arg"};
    }

    return "SSI Error: $cmd = $arg - not found!";
}

sub gulpFile {
    my $file = @_[0];
    if (open(FH, $file)) {
        binmode(FH);
        my $size = -s FH;
        my $buff;
        read(FH, $buff, $size);
        close(FH);
        return "$buff";
    }
    return 0;
}

sub error {
    my ($errno, $rv) = @_;
    my $ermsg = "$errno $errors{$errno}";
    my $message = join(' ',"Server error:", $errno, $client->peerhost,
+ $Date, $root.$url, "\n");
    my $xxx = HTTPtime;
    my $Hi;
    my $Lo;
    if (defined($rv)) {
        $Hi = $rv / 256;
        $Lo = $rv & 127;
    }

    ### Echo error to Client ###
    print $client "$versionid $errno OK\n";
    print $client "$xxx\n\n";
    print $client "<HTML><HEAD><TITLE>$ermsg</TITLE></HEAD>\n";
    print $client "<BODY><H1>$ermsg</H1>\n";
    print $client "$verrors{$errno}: <PRE> @_[1]</PRE><HR>\n";
    print $client "</BODY></HTML>\n";

    ### Echo error to Console ###
    print $message;
    if (defined($rv)) {print "System return value $Hi $Lo \n"}

    ### Echo error to Server log(file) ###
    open(LOGS, ">>serverlog.txt");
    print LOGS $message;
    if (defined($rv)) {print LOGS "System return value $Hi $Lo \n"}
    close(LOGS);
}


sub gotMetaChars {
    my $arg = $_[0];
    return ($arg =~ /[^A-Za-z0-9\.\-\_\/]+/g);
}

sub isACLscriptOK {
    # This routine is a test to see if the script is on our list
    # of explcitly approved scripts. See 'Pyxus.conf'.
    my $u = @_[0];
    foreach my $script (@ACLscript) {
        ($u =~ /\/${script}\Z/) && {return 1};
    }
    return 0;
}

sub isItHTML {
    # This routine checks requested files for its presence on our
    # secured file list. If it is then the 'Content-type' is returned.
    # See 'Pyxus.conf'.
    my $u = @_[0];
    foreach my $filetype (%mimetype) {
        if ($u =~ /\.${filetype}\Z/i) {
            return $mimetype{$filetype};
        }
    }
    return 0;
}

sub HTTPtime {
    my ($dd, $mm, $DD, $tt, $yy) = split(' ',localtime(time()+3600*$ti
+mezone));
    return "Date: $dd, $DD $mm $yy $tt GMT";
}

sub LOCALtime {
    my ($dd, $mm, $DD, $tt, $yy) = split(' ',localtime(time()));
    return "Date: $dd, $DD $mm $yy $tt PST";
}
sub bind_message {
  my ($widget, $msg) = @_;
}


sub exit_all {
    exec 'pyxus-start.pl';
}

}


MainLoop;
[download]