#!/usr/bin/perl
#
#

#
# Run an off-the-shelf HTML client against a dedicated HTML server.  The
# server executes PERL files that are specified in HTML requests.
#
# Authentication is magic-cookie style via the file system.  This should
# be good enough: the client-server conversation never goes over the
# network so the magic cookie cannot be stolen by a network sniffer.
# 
# Values in POST attribute-value lists are assigned to the corresponding
# global PERL variables.  See &process_html_request() for details.
#

sub html {
	local($helper, $wd, $host);

	#
	# Start the HTML server and generate the initial cookie for
	# client-server authentication.
	#
	%authenticated = ();
	$running_from_html = 1;
	chmod 0700, <~/.mosaic*>;	# Yuck!
	chmod 0700, <~/.netsca*>;	# Yuck!
	chmod 0700, <~/.MCOM*>;		# Yuck!
	&start_html_server();
	&make_password_seed();

	#
	# These strings are used in, among others, PERL-to-HTML scripts.
	#
	$wd = `pwd`;
	chop $wd;
	$html_root = "$wd/html";
	$start_page = "saint.html";
	$auth_page = "auth/saint_auth_form.pl";
	$THIS_HOST = $my_address;
	$THIS_HOST = &getfqdn(&hostname()) unless $THIS_HOST;
	die "Can't find my own hostname: set \$dont_use_nslookup or \$my_address in $SAINT_CF\n"
	    unless $THIS_HOST;
	if ($remote_mode) {
	    $HTML_SERVER = "http://$THIS_HOST:$server_port/$html_root";
	    $HTML_ROOT = $HTML_SERVER;
	    $HTML_STARTPAGE = "$HTML_ROOT/$start_page";
	    $HTML_AUTHPAGE = "$HTML_ROOT/$auth_page";
	} else {
	    $HTML_ROOT = "file://localhost$html_root";
	    $HTML_SERVER = "http://$THIS_HOST:$html_port/$html_password/$html_root";
	    $HTML_STARTPAGE = "$HTML_ROOT/$start_page";
	}

	#
	# Some obscurity. The real security comes from magic cookies.
	#
	if ($remote_mode) {
		$html_client_addresses = $allow_hosts;
	} else {
		$html_client_addresses = find_all_addresses($THIS_HOST) ||
			die "Unable to find all my network addresses\n";
	}

	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 $@;
	}

	#
	# Fork off the HTML client, and fork off a server process that
	# handles requests from that client. The parent process waits
	# until the client exits and terminates the server.
	#

	if (! $remote_mode) {
	    print "Starting $MOSAIC...\n" if $debug;
	    if (($client = fork()) == 0) {
		foreach (keys %ENV) {
			delete $ENV{$_} if (/proxy/i && !/no_proxy/i);
		}
		exec($MOSAIC, "$HTML_STARTPAGE") 
		    || die "cannot exec $MOSAIC: $!";
	    } 
	}
	if (($server = fork()) == 0) {
		if (($helper = fork()) == 0) {
			alarm 3600;
			&patience();
		}
		&init_saint_data();
		&read_saint_data() unless defined($opt_i);
		kill 'TERM',$helper;
		$SIG{'PIPE'} = 'IGNORE';
		unless ($web_server) {
		    for (;;) {
			accept(CLIENT, SOCK) || die "accept: $!";
			select((select(CLIENT), $| = 1)[0]);
			&process_html_request();
			close(CLIENT);
		    }
		} else {
		    for (;;) {
			# wait for a query from the pipe
			open(QUERY, "< $query_pipe")
			    || die "cannot open query pipe";
			chomp($pipe_ext = <QUERY>);
			open(CLIENT, "> /tmp/$response_pipe.$pipe_ext")
			    || die "Cannot open response pipe /tmp/$response_pipe.$pipe_ext";
			&process_html_request();
			close QUERY;
			close CLIENT;
		    }
		}
	}

	#
	# In remote mode, log PID and port in saint.pid and
	# exit. Otherwise, wait until the client terminates,
        # then terminate the server.
	#
	close(SOCK);
	if ($remote_mode) {
	  if ($web_server) {
	    # Check whether SAINT is already running
	    open(PID, "< config/saint.pid");
	    while(<PID>) {
	      if (/\d+:$/) {
		warn "There seem to be multiple SAINT processes running;\n";
		warn "This could cause unpredictable behavior\n";
		break;
	      }
	    }
	    close PID;
	  }
	  if (!open(PID, ">> config/saint.pid")) {
	    warn "Could not open config/saint.pid; -k option won't work\n";
	  } else {
	    ($web_server && print PID "$server:\n")
		|| print PID "$server:$server_port\n";
	    close PID;
	  }
	}
	else {
	  waitpid($client, 0);
	  kill('TERM', $server);
	}
	exit;
}

#
# Compute a hard to predict number for client-server authentication. Exploit
# UNIX parallelism to improve unpredictability. We use MD5 only to compress
# the result.
#
sub make_password_seed {
	local($command);

	die "Cannot find $MD5. Did you run \"configure\" and \"make\"?\n"
		unless -x "$MD5";
	$command = "ps axl&ps -el&netstat -na&netstat -s&ls -lRt /dev*&w";
	open(SEED, "($command) 2>/dev/null | $MD5 |")
		|| die "cannot run password command: $!";
	($html_password = <SEED>) || die "password computation failed: $!";
	close(SEED);
	chop($html_password);
}

#
# Set up a listener on an arbitrary port. There is no good reason to
# listen on a well-known port number.
#
sub start_html_server {
	local($sockaddr, $proto, $junk);

    if (!$web_server) {
	$sockaddr = 'S n a4 x8';
	($junk, $junk, $proto) = getprotobyname('tcp');
	socket(SOCK, &_AF_INET, &_SOCK_STREAM, $proto) || die "socket: $!";
	if ($remote_mode) {
		$binder = pack($sockaddr, &_AF_INET, $server_port, "\0\0\0\0");
		bind(SOCK, $binder) || die "bind: $!";
		print "Starting SAINT server on port $server_port\n";
	}
	listen(SOCK, 1) || die "listen: $!";
	($junk, $html_port) = unpack($sockaddr, getsockname(SOCK));
    } else {
	# Instead of listening on a port, create named pipe
	# for receiving queries
	unless (-p "$query_pipe") {
	    unlink "$query_pipe";
	    if (-x "$MKFIFO") {
		system($MKFIFO, $query_pipe)
		&& die "Cannot create named pipe $query_pipe";
	    } elsif (-x "$MKNOD") {
		system($MKNOD, $query_pipe, "p")
		&& die "Cannot create named pipe $query_pipe";
	    } else {
		die "Cannot execute $MKNOD or $MKFIFO";
	    }
	}
    }
}

#
# Kill the HTML server on specified port as
# defined in saint.pid (All ports if none specified)
#
sub stop_html_server {
	my($port) = @_;
	my($pid, $p);

	if (!open(PID, "< config/saint.pid")) {
	    warn "Could not open config/saint.pid\n";
	    return;
	}
	if (!open(NEWPID, "> config/saint.pid.new")) {
	    warn "Could not create new config/saint.pid\n";
	    return;
	}
	while(<PID>) {
	    ($pid, $p) = split /:/;
	    if (!$port || !$p || $p==$port) {
		if (kill 'TERM', $pid) {
		    ($p =~ /\d/ && print "Stopped SAINT server on port $p\n")
		    || print "Stopped SAINT process ID $pid\n";
		} else {
		    warn "Could not kill process $pid\n";
		}
	    } else {
		print NEWPID;
	    }
	}
	close PID;
	close NEWPID;
	system("mv config/saint.pid.new config/saint.pid");
}

#
# Process one client request.  We expect the client to send stuff that
# begins with:
#
#	command /password/perl_script junk
#
# Where perl_script is the name of a perl file that is executed via
# do "perl_script";
#
# In case of a POST command the values in the client's attribute-value
# list are assigned to the corresponding global PERL variables.
#
sub process_html_request {
	local($request, $command, $script, $magic, $url, $peer);
	local(%args);

	#
	# Parse the command and URL. Update the default file prefix.
	#
	unless ($web_server) {
	    $peer = &get_peer_addr(CLIENT);
	    $request = <CLIENT>;
	} else {
	    chomp($peer = <QUERY>);
	    $request = <QUERY>;
	}
	print $request if $debug;
	($command, $url) = split(/\s+/, $request);
	if ($command eq "" || $command eq "QUIT") {
		return;
	}

	#
	# Make sure they gave us the right magic number.
	#
	if (!$remote_mode) {
	    ($junk, $magic, $script) = split(/\//, $url, 3);
	    if ($magic ne $html_password) {
		&bad_html_magic($request);
		return;
	    }
	} else {
	    ($junk, $script) = split(/\//, $url, 2);
	    $script = "$html_root/$auth_page,$peer" if ($script !~ /^$html_root/);
	}

	($script, $html_script_args) = split(',', $script, 2);
	($HTML_CWD = "file:$script") =~ s/\/[^\/]*$//;

	#
	# Assume the password has leaked out when the following happens.
	#
	if (!$remote_mode) {
	    die "SAINT password from unauthorized client: $peer\n"
		unless is_member_of($peer, $html_client_addresses);
	    die "Illegal URL: $url received from: $peer\n" 
		if index($script, "..") >= $[
		|| index($script, "$html_root/") != $[;
	#	|| ($script !~ /\.pl$/);
	} else {
	    if (!is_member_of($peer, $html_client_addresses)) {
		&host_denied();
	    	return;
	    }
	    if (index($script, "..") >= $[
		|| index($script, "$html_root/") != $[) {
		&illegal_url();
	    }
	}

	#
	# Process HTTP headers
	# Warn them when the browser leaks parent URLs to web servers.
	#
	unless ($web_server) {
	    while (<CLIENT>) {
		if (!$cookie_leak_warning && /$html_password/) {
			&flush_http_input();
                        send_http_header("200 OK");
			&cookie_leak_warning();
			return;
		}
		$length = $1 if (/Content-length:\s*([0-9]+)/i);
		last if (/^\s+$/);
	    }
	} else {
	    while (<QUERY>) {
		$length = $1 if (/Content-length:\s*([0-9]+)/i);
		last if (/^\s+$/);
	    }
	}

	# if using remote mode, check that we are authenticated
	if ($remote_mode) {
	    if (!defined($authenticated{$peer})) {
		if ($script !~ /^$html_root\/auth/ &&
	            $script !~ /^$html_root\/images\//) {
		  &auth_required();
		  return;
		}
	    } elsif ($authenticated{$peer} > 0) {
		if ($script =~ /\/running\// ||
		    $script =~ /\/data\// ||
		    $script =~ /\/admin\//) {
		  &admin_required();
		  return;
		}
	    }
	}

	if ($command eq "GET") {
		if ($script =~ /\.jpg$/i) {
			&send_file("image/jpeg", $script);
		} elsif ($script =~ /\.gif$/i) {
			&send_file("image/gif", $script);
		} elsif ($script =~ /\.png$/i) {
			&send_file("image/png", $script);
		} elsif ($script =~ /\.html$/i) {
			&send_file("text/html", $script);
		} elsif ($script =~ /\.pl$/i) {
			perl_html_script($script);
		} else {
			die "Request for unknown file type $script received from $peer\n";
		}
	} elsif ($command eq "POST") {

		#
		# Process the attribute-value list.
		#
		unless ($web_server) {
		    read CLIENT, $_, $length;
		} else {
		    read QUERY, $_, $length;
		}
		if ($_) {
			s/%0[ad]//ig;
			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 "\$$_ = $args{$_}\n" if $debug;
				${$_} = $args{$_};
			}
			if ($script =~ /$html_root\/running\/saint_run_action.pl/ ||
			    $script =~ /$html_root\/data\/saint_open_action.pl/ ||
			    $script =~ /$html_root\/data\/saint_merge_action.pl/) {
			    if (($helper = fork()) == 0) {
				alarm 3600;
				&patience();
			    }
			    perl_html_script($script);
			    kill 'TERM', $helper;
			} else {
			    perl_html_script($script);
			}
		} else {
			&bad_html_form($script);
		}
	} else {
		&bad_html_command($request);
	}
	close CLIENT if $web_server;
}


#
# Map IP to string.
#
sub inet_ntoa {
	local($ip) = @_;
	local($a, $b, $c, $d);

	($a, $b, $c, $d) = unpack('C4', $ip);
	return "$a.$b.$c.$d";
}

#
# Look up peer address and translate to string form.
#
sub get_peer_addr {
	local($peer) = @_;
	local($junk, $inet);

	($junk, $junk, $inet) = unpack('S n a4', getpeername($peer));
	return &inet_ntoa($inet);
}

#
# Send HTTP headers
#
sub send_http_header {
    my($error)=@_;
    my($message);

    print CLIENT "HTTP-server: $HTML_SERVER\n" if $web_server;
    print CLIENT <<EOF;
HTTP/1.0 $error
Content-type: text/html
Server: SAINT/3.5.x

EOF
}

#
# Send a file
#
sub send_file {

    my($type, $sourcepath)=@_;

    if (! -e $sourcepath) {
	send_http_header("404 Not Found");
	print CLIENT <<EOF;
<HTML>
<HEAD>
<TITLE>File not found</TITLE>
</HEAD>
<BODY>
<H2>File not found</H2>
The requested file does not exist on the server.
</BODY>
</HTML>
EOF
	return;
    }
    $sourcelen = (-s "$sourcepath");

    print CLIENT "HTTP-server: $HTML_SERVER\n" if $web_server;
    print CLIENT <<EOF;
HTTP/1.0 200 OK
Content-type: $type
Server: SAINT/3.5.x
Content-length: $sourcelen

EOF
    open(SRC, "< $sourcepath");
    if ($type =~ /text/) {
	while(<SRC>) {
	    print CLIENT;
	}
    } else {
	read(SRC, $data, $sourcelen);
	print CLIENT $data;
    }
    close(SRC);
}

#
# Wrong magic number.
#
sub bad_html_magic {
	local($request) = @_;
	local($peer);

	$peer = &get_peer_addr(CLIENT);
	print STDERR "bad request from $peer: $request\n";

	send_http_header("401 Unauthorized");
        print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>Bad client authentication code</TITLE>
<LINK REV="made" HREF="mailto:saint\@wwdsi.com">
</HEAD>
<BODY>
<H1>Bad client authentication code</H1>
The command: <TT>$request</TT> was not properly authenticated.
</BODY>
</HTML>
EOF
}

#
# Unexpected HTML command.
#
sub bad_html_command {
	local($request) = @_;

	send_http_header("501 Not Implemented");
	print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>Unknown command</TITLE>
<LINK REV="made" HREF="mailto:saint\@wwdsi.com">
</HEAD>
<BODY>
<H1>Unknown command</H1>
The command <TT>$request<TT> was not recognized.
</BODY>
</HTML>
EOF
}

#
# Execute PERL script with extreme prejudice.
#
sub perl_html_script {
	local($script) = @_;

	if (! -e $script) {
                send_http_header("404 Not Found");
		print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>File not found</TITLE>
<LINK REV="made" HREF="mailto:saint\@wwdsi.com">
</HEAD>
<BODY>
<H1>File not found</H1>
The file <TT>$script</TT> does not exist or is not accessible.
</BODY>
</HTML>
EOF
;		return;
	}
        send_http_header("200 OK")
	    unless $script =~ /saintwriter_action/;
	    # saintwriter_action sends its own headers
	do $script;
	if ($@ && ($@ ne "\n")) {
		print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>Command failed</TITLE>
<LINK REV="made" HREF="mailto:saint\@wwdsi.com">
</HEAD>
<BODY>
<H1>Command failed</H1>
$@
</BODY>
</HTML>
EOF
	}
}

#
# Missing attribute list
#
sub bad_html_form {
	local($script) = @_;

	send_http_header("400 Bad Request");
	print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>No attribute list</TITLE>
<LINK REV="made" HREF="mailto:saint\@wwdsi.com">
</HEAD>
<BODY>
<H1>No attribute list</H1>

No attribute list was found.
</BODY>
</HTML>
EOF
}

#
# Scaffolding for stand-alone testing.
#
if ($running_under_saint == 1) {

	require 'perl/socket.pl';
	require 'config/paths.pl';
	require 'perl/hostname.pl';
	require 'perl/getfqdn.pl';
	require 'config/saint.cf';

} else {
	$running_under_saint = 1;

	require 'perl/socket.pl';
	require 'config/paths.pl';
	require 'perl/hostname.pl';
	require 'perl/getfqdn.pl';
	require 'config/saint.cf';

	&html();
}

#
# Give them something to read while the server is initializing.
#
sub patience {
	for (;;) {
	    unless ($web_server) {
		accept(CLIENT, SOCK) || die "accept: $!";
		<CLIENT>;
	    } else {
		open(QUERY, "< $query_pipe") ||
		    die "Cannot open query pipe";
		<QUERY>;
	    }
	    send_http_header("200 OK");
	    print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>Server is busy</TITLE>
<LINK REV="made" HREF="mailto:saint\@wwdsi.com">
</HEAD>
<BODY>
<H1>Server is busy</H1>
The server is busy right now.  SAINT is either initializing
or processing another request.  Please try again later.
</BODY>
</HTML>
EOF
;
		close(CLIENT);
		close QUERY if $web_server;
	}
}

# Look up all IP addresses listed for this host name, so that we can
# filter out requests from non-local clients. Doing so offers no real
# security, because network address information can be subverted.
# 
# All client-server communication security comes from the magic cookies
# that are generated at program startup time. Client address filtering
# adds an additional barrier in case the cookie somehow leaks out.

sub find_all_addresses {
	local($host) = @_;
	local($junk, $result);

	($junk, $junk, $junk, $junk, @all_addresses) = gethostbyname($host);
	for (@all_addresses) { $result .= &inet_ntoa($_) . " "; }
	return $result;
}

sub is_member_of {
	local($elem, $list) = @_;
	local($pre, $junk);

	for (split(/\s+/, $list)) {
	    return 1 if ($elem eq $_);
	    if (/\*$/) {
		($pre, $junk) = split /\*/;
		return 1 if ($elem =~ /^$pre/);
	    }
	}
	return 0;
}

sub flush_http_input {
	while (<CLIENT>) {
		$length = $1 if (/Content-length:\s*([0-9]+)/i);
		last if (/^\s+$/);
	}
	read CLIENT, $_, $length;
}

sub auth_required {
	send_http_header("401 Unauthorized");
	print CLIENT <<EOF;
<HTML>
<HEAD>
<TITLE>Authentication is required</TITLE>
</HEAD>
<BODY>
<H2>Authentication is required</H2>
You have not supplied the required authentication to view
this page.  Please
EOF
	print CLIENT "<A HREF=\"$HTML_AUTHPAGE,$peer\">click here</A>\n";
	print CLIENT <<EOF;
and log in.
</BODY>
</HTML>
EOF
}

sub admin_required {
	send_http_header("403 Forbidden");
	print CLIENT <<EOF;
<HTML>
<HEAD>
<TITLE>Permission Denied</TITLE>
</HEAD>
<BODY>
<H2>Permission Denied</H2>
Access to the requested page requires SAINT administrator privileges.
Please
EOF
	print CLIENT "<A HREF=\"$HTML_AUTHPAGE,$peer\">click here</A>\n";
	print CLIENT <<EOF;
and log in as <tt><b>admin</b></tt>.
</BODY>
</HTML>
EOF
}

sub host_denied {
	send_http_header("403 Forbidden");
	print CLIENT <<EOF;
<HTML>
<HEAD>
<TITLE>Access Denied</TITLE>
</HEAD>
<BODY>
<H2>Access Denied</H2>
Access from your workstation is not permitted.
</BODY>
</HTML>
EOF
}

sub illegal_url {
	send_http_header("400 Bad Request");
	print CLIENT <<EOF;
<HTML>
<HEAD>
<TITLE>Invalid URL</TITLE>
</HEAD>
<BODY>
<H2>Invalid URL</H2>
An invalid URL has been entered.
</BODY>
</HTML>
EOF
}

sub cookie_leak_warning {
	print CLIENT <<EOF;
<HTML>
<HEAD>
<TITLE>Warning - SAINT Password Disclosure</TITLE>
<LINK REV="made" HREF="mailto:saint\@wwdsi.com">
</HEAD>
<BODY BGCOLOR="#FFFFFF">
<H1>Warning - SAINT Password Disclosure</H1>

<HR>

<H3> 

Your Hypertext viewer may reveal confidential information when you
contact remote WWW servers from within SAINT.

<p>

For this reason, SAINT advises you to not contact other WWW servers
from within SAINT.

<p>

For more information, see <a
href="$HTML_ROOT/tutorials/vulnerability/SAINT_password_disclosure.html">the
SAINT vulnerability tutorial</a>.

<p>

This message will appear only once per SAINT session. 

<p>

In order to proceed, send a <i>reload</i> command (Ctrl-R with Lynx),
or go back to the previous screen and select the same link or button
again.

</H3>

</BODY>
</HTML>
EOF
	$cookie_leak_warning = 1;
}

1;
