#
# Filename: perl/html.pl
#   Author: Adam H. Pendleton
#   Modifier:  Bob Todd
#

# grab the socket module
#use Socket;
require 'perl/socket.pl';
require 'perl/hostname.pl';
require 'perl/getfqdn.pl';
require 'perl/get_host.pl';

require 'perl/sara-data.pl';
require 'perl/passwd.pl';

# HTTP Error Messages
%errors =
(
    "403", "Forbidden",
    "404", "Not Found",
    "499", "Server Busy",
    "500", "Internal Error",
    "501", "Not Implemented"
);

%verrors =
(
    "403", "Your client is not allowed to request this item",
    "404", "The requested item was not found on this server",
    "499", "The server is busy supporting another user",
    "500", "An error occurrred while trying to retrieve item",
    "501", "This server does not support the given request type"
);

# This function is called when running in HTML User Interface (HUI)
# or daemon mode.  We start a server for both, but with different
# behavior for both.

sub html {
    local($wd);

    # Clear out the auth_table hash for later
    %auth_table = ();

    # Start the HTML server
    start_html_server();

    # Grab the working directory
    $wd = `pwd`;
    chomp $wd;

    # Variables for scripts
    $html_root = "$wd/html/";
    $start_page = "sara.html";

    # Grab host variables
    $THIS_HOST = getfqdn(hostname());
    if (!$THIS_HOST) {
	$dont_use_nslookup=1;
	$hostname = undef;
	$THIS_HOST = getfqdn(hostname());
	if (!$THIS_HOST) {
	    print "   Can't find my hostname; Be sure hostname has IP defined\n";
            exit;
	}
    }
    # More script variables
    $html_server = "http://$THIS_HOST:$html_port";
    $HTML_SERVER = "$html_server";
    $HTML_ROOT = "";

    # Collect our allowed hosts
    if ($daemon) {
	# The sara.cf file can contain hosts, as well as this machine
	if ($allowable_hosts ne "") {
	    $allowable_hosts .= " ";
	}
	$allowable_hosts .= find_all_addresses($THIS_HOST) or
	    die "Unable to find all my network addresses";
	$html_client_addresses = $allowable_hosts;
    }
    else {

	$html_client_addresses = find_all_addresses($THIS_HOST) or
	    die "Unable to find all my network addresses";
    }

    # Some of the html pages are generated .pl scripts
    for (<$html_root/*.pl>) {
	# Remove the .pl extension for the page name
	s/\.pl$//;
	unlink "$_.html";
	open(HTML, ">$_.html") or die "Can't write $_.html: $!";
	select HTML;
	do "$_.pl";
	close HTML;
	select STDOUT;
	die $@ if $@;
    }

    # If we're not a daemon, then we should act normal
    if (!$daemon) {
	# Start the browser client and get going
	print "Starting $MOSAIC...\n" if $debug;
	if (($client = fork()) == 0) {
	    exec($MOSAIC, "$html_server") or die "Can't exec $MOSAIC: $!";
	}
    }

    # Start the server process
    # Daemon mode gets a fixed port, regular mode doesn't
    if (($server = fork()) == 0) {
	# We fork a helper to wait for sara_data() functions
	if (($helper = fork()) == 0) {
	    alarm 3600;
	    patience();
	}
	# Initialize the SARA data
	init_sara_data();
	read_sara_data() unless defined ($opt_i);
	kill 'TERM', $helper;
	$SIG{'PIPE'} = 'IGNORE';
	for (;;) {
	  if(accept(CLIENT, SOCK)) {
	    select((select(CLIENT), $| = 1)[0]);
	    process_html_request();
	    close(CLIENT);
          }
	}
    }

    close(SOCK);
    if ($daemon) {
	waitpid($server, 0);
	exit;
    }
    else {
	waitpid($client, 0);
	kill('TERM', $server);
	exit;
    }
}

sub start_html_server {
    local($protocol);

    # Plant a random seed
    srand(time|$$);

    # We only want a specified port if we are in daemon mode
    if (!$daemon) {
	# Generate random port between 10000 and 55000
	$html_port = int (rand(45000)) + 10000;
    }
    else {
	$html_port = $daemon_port;
    }

    print "Starting server on port $html_port\n" if $debug && $daemon;

    # Fancy network stuff
    $sockaddr = 'S n a4 x8';
    $protocol = getprotobyname('tcp');
    socket(SOCK, &_AF_INET, &_SOCK_STREAM, $protocol) or die "socket: $!";
    $bindsocket = pack($sockaddr, &_AF_INET, $html_port, "\0\0\0\0");
    bind(SOCK, $bindsocket);

    listen(SOCK, 1) or die "listen: $!";
   }

# This handles each and every html request including non-script ones
sub process_html_request {
    local($request, $url, $method, $proto);
    local(%args);

    $request = <CLIENT>;
#    print $request if $debug;
    $peer = get_peer_addr(CLIENT);
    if (!is_member_of($peer, $html_client_addresses)) {
      $time = gettime();
      print "    $peer unauthorized to connect to SARA at $time\n";
      close(CLIENT);
      return;
    }
    if ($daemon) {
      if (!$peer_set) {
        $peer_time=time();
        $time = gettime();
        print "    $peer Connected to SARA at $time";
        $peer_set = $peer;
      } elsif ($peer_set ne $peer) {
          $idle_time = time() - $peer_time;
          if ($idle_time > $idle_close) {
            $peer_time=time();
            $idle_time = time() - $peer_time;
            $time = gettime();
            print "    $peer Connected to SARA at $time\n";
            $peer_set = $peer;
          } else {
            error(499, $url, "server busy");
            close(CLIENT);
            return
          }
       }
   

    # Authentication is done on a per-host basis
    # and obviously only if we're in daemon mode
    $idle_time = time() - $peer_time;
    if ($idle_time > $idle_close) {
        $auth_table{$peer}{'authenticated'} = 0;    
        $auth_table{$peer}{'during_auth'} = 0;
        $peer_time=time();
    } else {
        $peer_time = time();
    }
    while (!$auth_table{$peer}{'authenticated'}) {
       if (!$auth_table{$peer}{'during_auth'}) {
		prompt_unauth();
	    }


	    # We want to stay here while they keep trying
	    if (!$auth_table{$peer}{'during_auth'}) {
		$auth_table{$peer}{'during_auth'} = 1;
		return;
	    }

	    if ($auth_table{$peer}{'attempts'} >= 2) {
                 $auth_table{$peer}{'during_auth'} = 0;
                $auth_table{$peer}{'attempts'} = 1;
                $peer_set = 0;
                $time = gettime();
                print "       $peer login rejected to SARA at $time\n";
                return;
	    }
	    else {
		while(<CLIENT>) {
		    if (/^Authorization:/) {
			($junk, $auth_type, $key_code) = split;
			$auth = convert_base64($key_code);
			($user, $pass) = split(/:/, $auth);
			if (validate_user($user,$pass)) {
			    $auth_table{$peer}{'authenticated'} = 1;
			    $auth_table{$peer}{'during_auth'} = 0;
                            $time = gettime();
                            print "       $peer login accepted to SARA at $time\n";
			    last;
			}
			else {
			    $auth_table{$peer}{'authenticated'} = 0;
			    $auth_table{$peer}{'during_auth'} = 0;
			    # We allow each host 3 chances,
			    # after that they are done
			    # must restart SARA to clear auth_table
			    if (!defined($auth_table{$peer}{'attempts'})) {
				$auth_table{$peer}{'attempts'} = 1;
			    }
			    else {
				$auth_table{$peer}{'attempts'}++;
			    }
                            last;
            
			}
		    }
		}
	    }
	}
    }

    # Requests will look like "GET / HTTP\1.0"
    ($method, $url, $proto) = split(/\s+/, $request);
    if ($method eq "" || $method eq "QUIT") {
	return;
    }

    # Okay, so it's not in the RFC, so what?
    ($url, $html_script_args) = split(',', $url, 2);

    ($method =~ /^(GET|POST)$/) || do { error(501, $method); return; };
    ($proto =~ /HTTP\/1\./) || do { error(501, $proto); return; };

#    $url =~ s/\/$/$html_root$start_page/; # URL ending in / get fixed
    $url =~  s/\/$/$start_page/;

    # are you cheating?!!
    $url =~ /\.\./ && do { error(403, $url, "contains go-back"); return; };

    # Yes, we ocassionally use the RFC
    ($url, $query) = split(/\?/, $url);
    $url = "$html_root/$url";
    $method = "POSTT" if $query;


    if ($method eq "GET") {
	if ($url =~ /\.pl$/) {
	    perl_html_script($url);
	}
	else {
	    # This is for all non-script requests
	    (-r "$url") or do { error(404, $url); return; };
	    print CLIENT "HTTP/1.0 200 OK\nMIME-Version: 1.0\nContent-Type: ";
	    CASE:
	    {
		$url =~ /\.html$/ && do { print CLIENT "text/html\n\n"; last CASE; };
		$url =~ /\.htm$/ && do { print CLIENT "text/html\n\n"; last CASE; };
		$url =~ /\.gif$/ && do { print CLIENT "image/gif\n\n"; last CASE; };
		$url =~ /\.jpg$/ && do { print CLIENT "image/jpeg\n\n"; last CASE; };
		$url =~ /\.jpeg$/ && do { print CLIENT "image/jpeg\n\n"; last CASE; };
		print CLIENT "text/plain\n\n";
	    }
	    open(PAGE, "$url") or die "Can't open $url: $!";
	    while (read(PAGE, $buff, 8*2**10)) {
		print CLIENT $buff;
	    }
	}
    }
    elsif ($method eq "POST" || $method eq "POSTT") {
      if ($method eq "POST") {
        $seq = rand();
        $query = "";
        while (<CLIENT>) {
          $length = $1 if (/Content-length:\s*([0-9]+)/i);
          last if (/^\s+$/);
        }
         read CLIENT, $query, $length;
        }
        $_ = $query;
	if ($_) {
	    # spaces at end of line?
	    s/\s+$//;
	    s/^/\n/;
	    s/&/\n/g;
	    $html_post_attributes = '';
	    # This is deprecated, will fix later -- ahp
	    $* = 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{$_};
	    }
	    perl_html_script($url);
	}
	else {
	    bad_html_form($url);
	}
    }
    else {
	error(501, $url, "command not found");
    }
}

# Look at all the interface addresses and grab them
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 patience {
	for (;;) {
		accept(CLIENT, SOCK) || die "accept: $!";
		<CLIENT>;
		print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>Initialization in progress</TITLE>
<LINK REV="made" HREF="mailto:satan\@fish.com">
<LINK REV="update" HREF="mailto:sara\@arc.com">
</HEAD>
<BODY>
<H1>Initialization in progress</H1>
SARA is initializing, please try again later.
</BODY>
</HTML>
EOF
;
		close(CLIENT);
	}
}
#
# Support function
#
sub inet_ntoa {
        local($ip) = @_;
        local($a, $b, $c, $d);
        ($a, $b, $c, $d) = unpack('C4', $ip);
        return "$a.$b.$c.$d";
}


sub get_peer_addr {
    local($peer) = shift;
    local($junk, $inet);

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

sub is_member_of {
    local($elem, $list) = @_;
    $list =~ s/,/ /g;
    for (split(/\s+/, $list)) {
      if (/[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+/) {
	if ($elem eq "$_") {
	    return 1;
	}
      } elsif (/[0-9]+\.[0-9]+\.[0-9]+\./) {
        if ($elem =~ /$_/) {
            return 1;
        }
      }
    }

    return 0;
}

sub perl_html_script {
    local($script) = shift;

    if (! -e $script) {
	print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>File Not Found</TITLE>
</HEAD>
<BODY>
<H1>File not found</H1>
The file <TT>$script</TT> does not exist or is not accessible.
</BODY>
</HTML>
EOF
;		return;
	}
        print CLIENT "HTTP/1.0 200 OK\nContent-Type: text/html\n\n";
	do $script;
	if ($@ && ($@ ne "\n")) {
		print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>Command Failed</TITLE>
</HEAD>
<BODY>
<H1>Command failed</H1>
$@
</BODY>
</HTML>
EOF
	}
return
}

sub bad_html_form {
	local($script) = @_;

	print CLIENT <<EOF
<HTML>
<HEAD>
<TITLE>No Attribute List</TITLE>
</HEAD>
<BODY>
<H1>No attribute list</H1>

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

sub error {
    local($errno) = @_[0];
    local($errmsg) = "$errno $errors{$errno}";

    print CLIENT <<EOF;
HTTP/1.0 $errmsg
MIME-Version: 1.0
Content-type: text/html

<HTML>
<HEAD><TITLE>$errmsg</TITLE></HEAD>
<BODY><H1>$errmsg</H1>
$verrors{$errno}: <PRE> @_[1] </PRE>
<HR>
</BODY>
</HTML>
EOF
}

sub convert_base64 {

    local($^W) = 0; # unpack("u",...) gives bogus warning in 5.001m

    my $str = shift;
    my $res = "";
   
    $str =~ tr|A-Za-z0-9+/||cd;             # remove non-base64 chars (padding)
    $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
    while ($str =~ /(.{1,60})/gs) {
	my $len = chr(32 + length($1)*3/4); # compute length byte
	$res .= unpack("u", $len . $1 );    # uudecode
    }
    $res;

}
sub gettime {
  ($s,$m,$h,$md,$mn,$yr,$wd,$yd,$is) = localtime();
     $yr =~ s/1//;
     $yr = "20$yr";
     $mn = $mn + 1;
     if (length($mn) < 2) {
        $mn = "0$mn";
     }
     if (length($md) < 2) {
        $md = "0$md";
     }
     if (length($h) < 2) {
        $h = "0$h";
     }
     if (length($m) < 2) {
        $m = "0$m";
     }
     if (length($s) < 2) {
        $s = "0$s";
     }
     "$yr/$mn/$md $h:$m:$s\n";
}
sub prompt_unauth {

    print CLIENT "HTTP/1.1 401 Authorization Required\n";
    print CLIENT "WWW-Authenticate: Basic realm=\"SARA\"\n";
    print CLIENT "Content-Type: text/html\n\n";
    print CLIENT "<HTML><HEAD><TITLE>Authorization Required</TITLE>\n";
    print CLIENT "</HEAD><BODY>\n";
    print CLIENT "<H1>Authorization Required</H1>\n";
    print CLIENT "This server could not verify that you\n";
    print CLIENT "are authorized to access the document you\n";
    print CLIENT "requested.  Either you supplied the wrong\n";
    print CLIENT "credentials (e.g., bad password), or your\n";
    print CLIENT "browser doesn't understand how to supply\n";
    print CLIENT "the credentials required.<p>\n";
    print CLIENT "</BODY></HTML>\n";
}


1;
