#!/usr/bin/perl
#
# Mini web server for Windows, works under perlsock too.
#
# Original Author: Jay Thorne jayt@activestate.com
# Since Modified by: Murray Nesbitt <murrayn@activestate.com>
#		and: Michael Smith <mikesm@activestate.com>
#
# Copyright © 1998-1999 ActiveState Tool Corp. All rights reservered.
#
###############################################################################
#
# Version 2.0 changes by Murray Nesbitt <murray@activestate.com>
#   - Tracing
#   - Configurable document root directory, etc. via the registry
#   - POD docs
#   - various performance enhancements
#
# Version 2.01
#   - save and restore values of any proxy-related env vars
#
# Version 2.02
#   - Simple authentication code, called if the connection
#     is not being made from localhost.
#
# Version 2.03
#   - If running under PerlSock, let it deal with sockets and
#     don't run
#
# Version 2.04
#   - eval() the use Win32::Service incase we are running on
#     Win9x
#   - don't use Win32::NetAdmin
#
# Version 2.05
#   - remove PerlSock support
#   - disallow any non-localhost connection
#
###############################################################################

require 5.006;
use FileHandle;
use Win32::Registry;
use MIME::Base64;
use File::Basename;
use Socket;

my $VERSION = "2.05";

# Default values for options; may be overridden in the registry
our $RegHome = "SOFTWARE\\ActiveState\\MiniSrv";
our ($Port,$Trace,$TraceFile,$DefaultMIMEType,$DocRoot,$Script);

$SIG{__DIE__} = sub { return if $_[0] =~ /^The \w+ function is unimplemented/; Trace($_[0]) if $Trace };

GetOptions();
OpenTrace() if $Trace;
Trace(join($/, @INC));
# Set up the mime types
my %EXT =   ('txt'=>	'text/plain',
	    'html'=>	'text/html',
	    'htm'=>	'text/html',
	    'aspl'=>	'text/plain',
	    'pl'=>	'text/plain',
	    'log'=>	'text/plain',
	    'gif'=>	'image/gif',
	    'jpeg'=>	'image/jpeg',
	    'au'=>	'audio/basic',
	    'snd'=>	'audio/basic',
	    'mpeg'=>	'image/mpeg',
	    'tiff'=>	'image/tiff',
	    'xbm'=>	'image/xbm');

# this is the perl script that we are running under miniserver
unless ($Script) { $Script = shift; }
if ($Script eq "-n") {
    $Script = shift;
}
elsif ($Script eq "-r") {
    CreateRegEntries();
    exit 0;
}

if (! -e $Script) { die "Script Not found"; }

Trace("Evaluating script '$Script'") if $Trace > 1;
if (my $ret = EvalScript ($Script)) {die "Eval error $ret";}


# need to keep %SYSTEMROOT%, otherwise gethostbyname() fails.
my $systemroot = $ENV{SYSTEMROOT};
# need to keep %PATH%, otherwise, e.g., perl.exe can't be
# executed by install scripts
my $path = $ENV{PATH};
# need to keep any proxy-related environment vars
my $proxy = $ENV{'HTTP_proxy'} if defined $ENV{'HTTP_proxy'};
my $proxy_user = $ENV{'HTTP_proxy_user'} if defined $ENV{'HTTP_proxy_user'};
my $proxy_pass = $ENV{'HTTP_proxy_pass'} if defined $ENV{'HTTP_proxy_pass'};

close STDIN; close STDOUT; # so we can use the socket for everything
# Initialize port, standard perl server boilerplate
*STDOUT = *STDIN;
my($sockaddr) = 'S n a4 x8';
my ($name, $aliases, $proto) = getprotobyname('tcp');
my ($thisport) = pack($sockaddr, AF_INET, $Port, "\0\0\0\0"); # wildcard addr
socket(SERVER, PF_INET, SOCK_STREAM, $proto) or die "socket: $!\n";
setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, pack('l', 1)) or die "setsockopt: $!\n";
bind(SERVER, $thisport) or die "bind: $!\n";
listen(SERVER, 5) or die "listen: $!\n";


# by select()in the socket, all print output goes to the socket.
# to patch bug in Win95 (no dup() available);

while (accept(STDIN, SERVER)) {
    binmode (STDOUT);
    $| = 1;
    # We are accepting on a SOCKET named STDIN
    HandleRequest();
    close(STDIN);
    last if (defined $ENV{EXITSRV});
}

Trace("VPM.pl stopping") if $Trace;
close(TRACE);
exit 0 if (defined $ENV{EXITSRV});

sub HandleRequest {
    %ENV=();  # Kill environment every time, to prevent erroneous setup

    # Restore any necessary environment vars
    $ENV{SYSTEMROOT}      = $systemroot;
    $ENV{PATH}            = $path;
    $ENV{HTTP_proxy}      = $proxy      if defined $proxy;
    $ENV{HTTP_proxy_user} = $proxy_user if defined $proxy_user;
    $ENV{HTTP_proxy_pass} = $proxy_pass if defined $proxy_pass;

    my($method, $command) = SetupCommand();
    return unless $method;
    if ($method eq 'GET') {
	ProcessGet($command);
    }
    elsif ($method eq 'POST') {
	ProcessPost($command);
    }
    else {
	ErrorMessage(400, "Bad Request.");
    }
}

sub OpenTrace {
    my $ret = open(TRACE, ">>$TraceFile");
    if (!$ret) {
        print STDERR "MiniSrv: Can't open $TraceFile: $!\n";
        $Trace = 0;
    }
    else {
	my $oldfh = select(TRACE);
	$| = 1;
	select($oldfh);
    }
}

sub Trace {
    print TRACE "$0: @_ at ",  scalar localtime(), "\n";
}

sub CreateRegEntries {
    my $RegObj;
    $main::HKEY_LOCAL_MACHINE->Create($RegHome, $RegObj) or die "Can't create reg entries: $!";
    $RegObj->SetValueEx('Port',            0, REG_DWORD, $Port);
    $RegObj->SetValueEx('Trace',           0, REG_DWORD, $Trace);
    $RegObj->SetValueEx('TraceFile',       0, REG_SZ,    $TraceFile);
    $RegObj->SetValueEx('DefaultMIMEType', 0, REG_SZ,    $DefaultMIMEType);
    $RegObj->SetValueEx('DocRoot',         0, REG_SZ,    $DocRoot);
    $RegObj->SetValueEx('Script',          0, REG_SZ,    $Script);
    $RegObj->Close();
}

sub GetOptions {
    my $RegObj;
    $main::HKEY_LOCAL_MACHINE->Open($RegHome, $RegObj) or return;
    $RegObj->QueryValueEx('Port',            REG_DWORD, $Port);
    $RegObj->QueryValueEx('Trace',           REG_DWORD, $Trace);
    $RegObj->QueryValueEx('TraceFile',       REG_SZ,    $TraceFile);
    $RegObj->QueryValueEx('DefaultMIMEType', REG_SZ,    $DefaultMIMEType);
    $RegObj->QueryValueEx('DocRoot',         REG_SZ,    $DocRoot);
    $RegObj->QueryValueEx('Script',          REG_SZ,    $Script);
    $RegObj->Close();
    print STDERR ("Initializing VPM: Script: $Script, Port: $Port, Trace: $Trace, TraceFile: $TraceFile, DefaultMIMEType: $DefaultMIMEType, DocRoot: $DocRoot") if $Trace;
}

#.........................................................................
# SetupCommand: reads in from socket and figures out what we are doing
#.........................................................................
sub SetupCommand {
    my @accept =();
    my $args ;
    my $inp ;
    my $userpass;
    my ($method, $command);
    chomp($inp = getline());
    $inp =~ /^([A-Z]*) \/(.*) (\w*)\/(\d*\.\d*)/;
    # We should check if the match failed!
    $method = $1;
    my $commandline = $2;
    my $protocol = $3;
    my $protocol_version = $4;
    if ($commandline =~ /(.*?)\?(.*)/) { # it's a query/form request
	$command = $1;
	$args = $2;
    }
    else {
	$command = $commandline;
	$args = '';
    }
    # to be safe, quote shell metacharacters
    $command =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"])/\\$1/g;
    Parse($command);
    $ENV{SERVER_SOFTWARE}   = "MiniSrv/$VERSION";
    $ENV{GATEWAY_INTERFACE} = "CGI/1.0";
    $ENV{SERVER_PROTOCOL}   = "$protocol/$protocol_version";
    $ENV{SERVER_PORT}       = $Port;
    $ENV{REQUEST_METHOD}    = $method;
    $ENV{QUERY_STRING}      = $args;

    $rem_ip_addr = (unpack_sockaddr_in(getpeername(STDIN)))[1];
    $ENV{REMOTE_HOST} = (gethostbyaddr($rem_ip_addr, AF_INET))[0];
    $ENV{REMOTE_ADDR} = inet_ntoa($rem_ip_addr);

    Trace("$inp From: $ENV{REMOTE_ADDR}") if $Trace > 1;
    my $string="";
    for (;;) {
	chomp($string = getline());
	last if length($string) == 0;
	Trace("$ENV{REMOTE_ADDR} id:$$  PROLOG: $string LENGTH: " . (length($string)) . "CHR: " . ord($string)) if $Trace > 3;

        $ENV{'CONTENT_LENGTH'}          = (split(':', $string))[1] if $string =~ /Content-Length:/i;
        (undef,$ENV{'HTTP_USER_AGENT'}) = split(" ", $string, 2)   if $string =~ /User-Agent:/i;
        (undef,$ENV{'CONTENT_TYPE'})    = split(" ", $string, 2)   if $string =~ /Content-type:/i;
        (undef,undef,$userpass)         = split(" ", $string, 3)   if $string =~ /Authorization: Basic/i;
	push(@accept,(split(':', $string))[1])                     if $string =~ /Accept:/i;
    }
    $ENV{'HTTP_ACCEPT'} = join(",", @accept) if @accept;

    # Only allow local connections!
    unless ($ENV{REMOTE_ADDR} eq '127.0.0.1') {
	ErrorMessage(403, "Only localhost is allowed to access this port.");
	return;
    }

    return ($method, $command);
}

sub getline {
    my $ch ='';
    my $string = '';
    my $count = 0;
    for(;;) {
	if ($count = sysread(STDIN, $ch, 1)) { # returns undef or 1
	    last if $ch eq "\n" || $ch eq chr(255);
	    $string .= $ch unless $ch eq "\r"; # skip <cr>
	}
	last if $count == 0;
    }
    Trace("getline() = $string");
    return $string;
}

sub ProcessGet {
    my ($command) = @_;
#XXX This checks for the master Script name in the request, and handles it differently
    if ($Script =~ /$command/i) {
	ProcessPost($command);
    }
    else {
	sendfile("$DocRoot/$command");
    }
}

sub sendfile {
   # to send HTML and Graphic files
   my ($file) = @_;
   chomp $file;
   local *DF;  # can't use my on type globs
   $file =~ s/((\.\.\/)|(\/\.\.$)|(\/\.$))//g;
   $file =~ s/\/\.$//g;
   my $size = (stat($file))[7];
   if (open(DF, "<$file")) {
	my ($n, $e) = split(/\./, $file);
	$e = lc $e;
        print "HTTP/1.0 200 OK\r\n";
	print "Content-length: $size\r\n";
	Trace("Content-length: $size") if $Trace > 3;
        if(defined $EXT{$e}){
            print "Content-type: $EXT{$e}\r\n\r\n";
        }
	else {
	    print "Content-type: $DefaultMIMEType\r\n\r\n";
        }
	binmode (DF); # to read/send gif files on NT
	binmode (STDOUT);
        while(<DF>) {
	    Trace($_) if $Trace > 3;
            print $_;
        }
    	close DF;
    }
    else {
	ErrorMessage(404, "The requested file, $file, was not found : $!");
    }
}

sub ProcessPost {
    my($command) = @_;
    # socket is unneccessary since all post method CGIs
    # read from STDIN
#    if (Execute($command) != 0 ) { ErrorMessage($fd, 500, "Error In Script");}
    Execute($command);
}

sub Parse {
    # set cgi environmental variables
    my $command=$_[0];
    if ($command =~ /^cgi-bin/) {
	my ($a, $b, $c ) = split('/', $command, 3);
	if (defined $b) {
	    # There was a slash after cgi-bin, if thats all there is
	    # then it does not matter cuz they want a dir listing
	    return if length($b) == 0;
	    $ENV{SCRIPT_NAME} = "/cgi-bin/$b";
	}
        if (defined $c) { # there was a slash after the scriptname
            $ENV{PATH_INFO} = "/$c";
            $ENV{PATH_TRANSLATED} = "$DocRoot/$c";
    	}
    }
}

sub ErrorMessage {
    my($error, $message) = @_;
    Trace("ErrorMessage $error, $message") if $Trace;
    my $errstr = "HTTP/1.0 200 OK\r\n";
    $errstr .= "Content-type: text/html\r\n\r\n";
    $errstr .= "<HTML><TITLE>Error Message</TITLE><BODY>";
    $errstr .= "<H1>Error $error</H1>";
    $errstr .= "<HR>\r\n";
    $errstr .= $message;
    $errstr .= "<HR></BODY></HTML>\r\n";
    print $errstr;
}

sub EvalScript {
    unless( defined $TheScript ) {
	my ($file_name) = shift;
	my ($fh) = FileHandle->new($file_name);
	local $/;
	my ($sub)= <$fh>;
	my $eval = join(' ', "\nsub {", "\n#line 1 $file_name\n$sub","\n}" );
	$TheScript = eval $eval;
	if ($@) {
	    Trace("File:[$file_name], Eval Error: $@") if $Trace;
	    Trace("Returning $@ at ",__LINE__) if $Trace;
	    return $@;
	}
	return 0;
    }
    return 0;
}

#..........................................................
#
# This routine is the entry point for executing scripts
#
#.........................................................
sub Execute {
    Trace("Executing script '$Script'") if $Trace > 1;
	my $ret = $TheScript->(@_);
	return $ret;
}

=item -n script

Specifies the Perl script for the server to evaluate.

=item -r

Creates registry entries for MiniSrv options with default values.
See the 'CONFIGURATION' section for more information.

=back

=head1 CONFIGURATION

MiniSrv behaviour can be modified using the following
registry entries under HKLM\SOFTWARE\ActiveState\MiniSrv\$VERSION :

=over 4

=item DocRoot

Server document root.

=item Port

Port the server will listen to (default: 4444)

=item Trace

Trace level for debug messages.

    0: no debug output
    1: Server errors, fatal errors
    2: Level 1 info + request logging
    4: Level 2 info + verbose logging of C/S interaction

    The default tracing level is 1.

=item TraceFile

File to contain Trace output (default: "MiniSrv.log")

=item DefaultMIMEType

Default MIME type of served documents (default: "text/plain")

=item AuthFile

Access to this file (if specified) will be the determining
factor for user authentication for any non-localhost connections.

=back

=cut
