eval 'exec perl -S $0 ${1+"$@"}'
    if "";
#########################################################################
# 
# MERLIN : A program to manage security tools.
#
# John Fisher, CIAC
# fisher23@llnl.gov
#
# Copyright (c) 1995
#   The Regents of the University of California.  All rights reserved.
#
# This work was produced at the University of California, Lawrence
# Livermore National Laboratory (UC LLNL) under contract number
# W-7405-ENG-48 (Contract 48) between the U.S. Department of Energy
# (DOE) and the Regents of the University of California (University) for
# the operation of UC LLNL.  Copyright is reserved to the University for
# purposes of controlled dissemination, commercialization through formal
# licensing, or other disposition under Contract 48; DOE policies,
# regulations and orders; and U.S. statutes.  The rights of the Federal
# Government are reserved under Contract 48 subject to the restrictions
# agreed upon by the DOE and University as allowed under DOE Acquisition
# Letter 88-1.
#
#########################################################################
#
# pHTTPd 1.0
# is a simple HTTP server.
#
# Use of this script is without warranty and may be freely distributed
# provided this copyright message is left intact.
# 
# (C) Pratap Pereira
# pereira@ee.eng.ohio-state.edu
# 12/10/94
# Send bug reports, comments and enhancements to be incorporated for later
# releases. 
#
# John Fisher:
#   - Numerous additions/modifications have been made, including several
#     security mechanisms, support for POST requests,
#     and Merlin-specific additions.
#
########################################################################

print "Merlin is starting up....\n";

do 'config.ph';
defined $http_data || die "Can't find config.ph - did you run merlin-config?\n";
-f "$http_data/merlin" || die "Can't find $http_data - did you run merlin-config?\n";
eval `$http_data/bin/headers` || die "You must run make before running Merlin\n";
require "$http_data/perl/tools.pl";
#require "$http_data/perl/html.pl";
eval `cat $http_data/perl/html.pl`;

# Make sure we exit gracefully
$SIG{'QUIT'}='quit_handler';
$SIG{'HUP'}='quit_handler';
$SIG{'INT'}='quit_handler';
$SIG{'TERM'}='quit_handler';


# This section has been modified somewhat. No bind is done, and the port
# select is remember for when the client is forked.
$sockaddr = 'S n a4 x8';
($junk, $junk, $proto) = getprotobyname('tcp');
$thisport = pack($sockaddr, &AF_INET, $html_port, "\0\0\0\0"); # wildcard addr
socket(S, &AF_INET, &SOCK_STREAM, $proto) || die "cannot create socket: $!";
listen(S,5) || die "cannot listen socket: $!";
($junk, $html_port) = unpack($sockaddr, getsockname(S));

# Keep track of the requests made to this server
open(LOG,">> $http_data/phttpd.log");
select(LOG); $|=1;
print LOG &timestamp." : Started Server\n";

# Now that we have our port number, we can build our
# path-related strings.
require 'setup.pl';

REFRESH_PACKAGE_REQUEST();
REFRESH_PACKAGE_INFORMATION();

# Time to start the client
if (($client = fork()) == 0)
{
    exec("$NETSCAPE -install $HTML_STARTPAGE")
	|| die "cannot exec $NETSCAPE: $!";
    exit(0);
} 

# Time to start the server!
# By forking the server again each time we get a request, we prevent
# the server from accidently crashing due to a bad .pl program,
# other such ugly incident.
# This stylized forking code which leaves at most one zombie
# process is credited to khera@cs.duke.edu (Vivek Khera)
# from a posting of his in comp.lang.perl
$WNOHANG=1;
$KeyClean = 0;
if (($server = fork()) == 0)
{
    while (1)
    {
	accept(CLIENT_SOCKET,S) || die "cannot accept socket: $!";

	REFRESH_PACKAGE_INFORMATION();


	if ($pid=fork())
	{
	    close(CLIENT_SOCKET);
	    while (1)
	    {
		last if (waitpid(-1, &WNOHANG) < 1);
	    };
	} elsif (defined $pid)
	{
	    &process_connection;  # for every incoming connection fork and process
	    exit(0);
	} elsif ($! =~ /No more process/)
	{
	    sleep 2;
	} else
	{
	    die "Could not fork child process to hand connection - $!\n";
	}
    }
}

# Kill the server when the client has finished running.
waitpid($client, 0);
kill('TERM', $server);
exit(0);


# The heart of the connection handler begin here.
sub process_connection
{

    local($cmd, $doc, $httpd, $request, $path);

    # Report to the log file that we have a new connection
    print LOG &timestamp." : connection from "
	."($myaddr[0].$myaddr[1].$myaddr[2].$myaddr[3]) "
	    .&full_host(@myaddr)."\n";	# Log the connection

    # Ok, let's see what's been sent to us!
    while (<CLIENT_SOCKET>)
    {
	# Break the message down into components
	($cmd, $doc, $http)=split;
	print STDOUT "$cmd:$doc:$http\n" if defined($debug);
	print LOG "$cmd:$doc:$http\n";
	($url, $html_script_args) = split(',',$doc, 2);
	($junk, $pass, $request) = split(/\//, $url, 3);
	print STDOUT "TT $request:$html_script_args\n" if defined($debug);
	$script = "$http_data/$request";
	# Is this request to a valid directory?
	$found = 0;
	foreach $path (@html_paths)
	{
	    local($lpath) = $path;
	    $lpath =~ s/(\W)/\\$1/g;
	    if ($script =~ $lpath)
	    {
		$found = 1;
		last;
	    }
	}


	# Was this an invalid request?
	($junk, $junk, $inet) = unpack('S n a4', getpeername(CLIENT_SOCKET));
	($a, $b, $c, $d) = unpack('C4', $inet);
	if (! $found || ($doc =~ /\.\./) || ($inet ne gethostbyname($THIS_HOST)) ||
	    ($pass ne $password)) {
	    print CLIENT_SOCKET "HTTP/1.0 403 Forbidden\n";
	    print CLIENT_SOCKET "\n";
	    close CLIENT_SOCKET;
	}

	# Was this a GET request?
	elsif (/^GET/)
	{
	    if ($doc =~ /.pl/)
	    {
		if (-e $script)
		{		
		    print STDOUT "Executing: $script\n" if defined($debug);
		    open (CLIENT, "> ".$tmp_data_file);
		    do $script;
		    close CLIENT;
		    &send_out($tmp_data_file);
		    close CLIENT_SOCKET;
		}
		else		# Not found
		{	    
		    print STDOUT "Script Not found ($script)\n" if defined($debug); 
		    print CLIENT_SOCKET "HTTP/1.0 404 Not Found\n";
		    print CLIENT_SOCKET "\n";
		    close CLIENT_SOCKET;
		}
	    }
	    else		# Must be just a regular file
	    {
		&send_out($request);
	    }

	} elsif (/^POST/)
	{
	    
	    # Process the attribute-value list.
	    # This code was taken from SATAN, written by Dan Farmer and
            # Wietse Venema
	    while (<CLIENT_SOCKET>)
	    {
		last if (/^\s+$/);
	    }
	    if ($_ = <CLIENT_SOCKET>)
	    {
		s/\s+$//;
		s/^/\n/;
		s/&/\n/g;
		$html_post_attributes = '';
		$* = 1;
		for (split(/(%[0-9][0-9A-Z])/, $_))
		{
		    $html_post_attributes .= (/%([0-9][0-9A-Z])/) ? 
			pack('c',hex($1)) : $_;
		}
		%args = ('_junk_', split(/\n([^=]+)=/, $html_post_attributes));
		delete $args{'_junk_'};
		for (keys %args)
		{
		    print STDOUT "\$$_ = $args{$_}\n" if $debug;
		    eval "\$$_ = \"$args{$_}\";";    # I do it this way, in order to
                                                        # allow variables to be array elements
	        }
	        if ($doc =~ /.pl/)
		{
		    if (-e $script)
		    {		
			print STDOUT "Post Executing: $script\n" if defined($debug);
			open (CLIENT, "> ".$tmp_data_file);
			do $script;
			close CLIENT;
			&send_out($tmp_data_file);
			close CLIENT_SOCKET;
		    }
		    else
		    {	    
			print STDOUT "Script Not found ($script)\n" 
			    if defined($debug);
			print CLIENT_SOCKET "HTTP/1.0 404 Not Found\n";
			print CLIENT_SOCKET "\n";
			close CLIENT_SOCKET;
		    }
		}
	        close CLIENT_SOCKET;
	     }
	}
    }
    close CLIENT_SOCKET;
}



sub send_out
{
    if ($_[0])
    {
	    print STDOUT "Sending Cleartext: $_[0]\n" if defined($debug);
	    print CLIENT_SOCKET "HTTP/1.0 200 OK\n";
	    print CLIENT_SOCKET "\n";
	    open (CLIENT, $_[0]);

	# Ok, NOW we can spit it out!
	while (<CLIENT>)
	{
	    print CLIENT_SOCKET $_;
	}
	close CLIENT;
    }
    else			
    {
	print STDOUT "Not Found\n" if defined($debug);
	print CLIENT_SOCKET "HTTP/1.0 404 Not Found\n";
	print CLIENT_SOCKET "\n";
    }
    unlink($tmp_file);
    unlink($tmp_data_file);
    close CLIENT_SOCKET;
}
    
# Handle all ways of shutting down.
sub quit_handler
{
    print &timestamp." : Shutting Down\n";
    close CLIENT_SOCKET;
    close S;
    close LOG;
    exit(0);
}

# Generate a time stamp for the log files...
sub timestamp
{
    ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
    sprintf("%02u:%02u:%02u on %02u/%02u/%02u", $hour, $min,
	      $sec, $mon+1, $mday, $year);
}


# Get host name from address of incoming connection. Used for logging.
# For this version, however, only the local host is supported.
sub full_host
{
      $addr=pack("C4",@_);
      local($in_host,@aliases,$adrtyp,$adrlen,@adrlist)=gethostbyaddr($addr,
 							 &AF_INET);
      $in_host;
}


# Function : REFRESH_PACKAGE_INFORMATION()
# This function of code goes through each package in the
# pkg directory, and loads the corresponding configuration
# information.
sub REFRESH_PACKAGE_INFORMATION {

    if (-r "$http_data/.merlin_update") {
	undef @Packages;
	undef %PkgNames;
	undef %PkgDirs;
	undef %ToolNames;
	undef %ToolDirs;
	undef %ToolPkg;
	@Packages = `ls $pkg_root/*/merlin_config`;
	foreach $app (@Packages)
	{
	    open(CONFIG, $app);
	    ($rpt, $dir, $name) = split(':', <CONFIG>);
	    if (-d $dir) {
		$PkgNames{$rpt} = $name;	# The user-friendly name
		$PkgDirs{$rpt} = $dir;	# The directory where the actual pkg is found.
		chop $name;
		while (<CONFIG>)		# Load all the tools in the package
		{
		    ($tool, $name) = split(':', $_); # $tool should be 3 characters long
		    chop $name;
		    $ToolNames{$tool} = $name; # The user-friendly name of the tool
		    $ToolDirs{$tool} = $dir; # Assume all tools are in same place
		    $ToolPkg{$tool} = $rpt;	# Assume all tools have the same 3 character
		    # Character prefix.
		}
	    }
	    close(CONFIG);
	}
	for (<$html_root/*.pl>)
	{
	    s/\.pl$//;
	    unlink "$_.html";
	    open(HTML, ">$_.html")
		|| die "cannot write $_.html: $!\n";
	    select HTML;
	    do "$_.pl";
	    close HTML;
	    select STDOUT;
	    die $@ if $@;
	}
	unlink "$http_data/.merlin_update";
    }
}

# Function : REFRESH_PACKAGE_REQUEST()
# Since the Merlin server forks every time it gets a request
# (to prevent potential crashes caused by poorly written packages),
# I need to use this hack to tell it that the package information
# has changed.
sub REFRESH_PACKAGE_REQUEST {
    open(UPDATE, "> $http_data/.merlin_update");
    print UPDATE "temp";
    close UPDATE;
}
