#!/usr/bin/perl
# plexus -- HyperText Tranfer Protocol Daemon
#
# plexus,v 2.19 1993/10/02 07:13:16 sanders Exp
#
# This code forms the core of a multi-threaded HTTP deamon, with the
# primary emphasis being on responsiveness; thus, things like exec()
# and parsing are kept to a minimum when responding to requests.
#
# by Tony Sanders <sanders@bsdi.com>, August 1993

# For debugging run:
# HTTPD_SDIR=`pwd` ./plexus -i -c `pwd`/plexus.conf -l /dev/tty -D /dev/tty

# -c config       override default config file [$plexus_conf]
# -d topdir       override default directory to serve [$plexus_top]
# -i              Use stdin/stdout (e.g., running under inetd) [$plexus_mode]
# -l log          override default logfile [$plexus_log]
# -p port         specify port to open [$plexus_port]
# -P pidfile      override default pidfile output file [$plexus_pidfile]
# -D diag         specify diagnosic output file [$plexus_diag] (enables debug)
# -I sockfd       use specified socket (mostly for server restarts) [$plexus_mode]
$usage = "Usage: plexus [-c config] [-d topdir] [-i | -I sockfd] [-l log] [-p port] [-P pidfile] [-D diag]";

require 'ctime.pl';

eval '&plexus';
&log_error('internal_error', $@) if ($@);
die $@ if $@;
exit 0;

# ============================ PRIVATE ROUTINES ============================

sub plexus {
    # option init:
    $plexus_top = "/usr/local/www";
    $plexus_conf = "server/plexus.conf";
    $plexus_log = undef;
    $plexus_diag = undef;
    $plexus_port = undef;
    $plexus_mode = undef;	# undef = daemon, 0 = inetd, >0 = restart fd

    $running_as_root = ($< == 0);
    @sockets = ();

    &parse_args(@ARGV);

    open(STDERR, ">>$plexus_diag") if defined $plexus_diag;
    select((select(STDERR), $| = 1)[0]);
    &debug("plexus pid=$$ -d $plexus_top -D $plexus_diag:fd=", fileno(STDERR));

    # don't chdir in restart mode
    (defined($plexus_mode) && ($plexus_mode > 0)) ||
        chdir($plexus_top) || die "chdir: $plexus_top: $!";
    require $plexus_conf unless defined($plexus_configured);
    require 'site.pl';

    $ENV{'TZ'} = 'GMT';		# be network friendly
    $SIG{'INT'} = 'cleanup';
    $SIG{'QUIT'} = $debug ? 'restart_daemon' : 'cleanup';
    $SIG{'USR1'} = 'restart_daemon';
    $SIG{'CHLD'} = 'reaper'; 
    $SIG{'PIPE'} = 'IGNORE'; 
    &clear_timeout;

    if (! defined $plexus_mode) {
	# must setup port before switching from root because of ports <1024
	&debug("plexus running in daemon mode");
	$plexus_port = $plexus_port || ($running_as_root?$http_service:$http_userport);
	$plexus_port = &getserv($plexus_port, $http_proto) || $http_defaultport;
	&bind_port(S, $plexus_port, $http_proto);
	push(@sockets, "S");
    } elsif ($plexus_mode > 0) {
        open(S, "+>&$plexus_mode") || die "dup: couldn't reattach $plexus_mode: $!";
        &setfd(1, fileno(S));			# close new S on exec
        &setfd(0, $plexus_mode);		# keep orig
        push(@sockets, "S");
        &debug("socket $plexus_mode reattached to fd: ", fileno(S));
        $plexus_port = (unpack($sockaddr, getsockname(S)))[1];
    } else {
	&debug("plexus running on stdin/stdout");
	($sockname = getsockname(STDIN)) &&
	    ($plexus_port = (unpack($sockaddr, $sockname))[1]);
	$plexus_port = "filter" unless defined $plexus_port;
	select(STDOUT); $| = 1;
    }

    if ($running_as_root) {
	# get gid and uid before chroot()
	$gid = (getgrnam("$http_group"))[2] || die "getgrnam: $http_group: $!";
	$uid = (getpwnam("$http_user"))[2] || die "getpwnam: $http_user: $!";
	&debug("uid: $uid, gid: $gid");
	$http_chroot &&
	    (chroot($plexus_top) || die "chroot: $plexus_top: $!", chdir("/"));
	# set user and group id's
	$( = $) = $gid;
	$< = $> = $uid;
    }

    #
    # Everything before this point is configured in plexus.conf
    # This is where we read the users config file, after we aren't
    # root and have setup a "secure" environment (just in case).
    #
    &process_config(CFG, $http_localcfg);

    $pidfile = $plexus_pidfile || $plexus{'pidfile'};
    open(ID, "> $pidfile"); print ID $$, "\n"; close(ID);

    &logger'message("----Server #$$ on port $main'plexus_port started at " . &main'ctime(time));

    if ((defined $plexus_mode) && ($plexus_mode == 0)) {
	# if peer is not remote, fake address 0.0.0.0 for log
	$peeraddr = (getpeername(STDIN) ||
	    pack($sockaddr, &AF_INET, $plexus_port, "\0\0\0\0"));
	&client_connect(0, $peeraddr);			# 0 means mystery guest
    } else {
	&debug("starting plexus daemon mode");
	&daemon(@sockets);
        die "whoa, something went wrong: $!";
    }
}

sub daemon {
    local(@fds) = @_;
    local($rin, $rout) = &fhbits(@fds);
    local($fd);
    $restart_daemon = 0;
CONNECTION:
    until ($restart_daemon) {
	if (($nfound = select($rout=$rin, undef, undef, undef)) < 0) {
	    next CONNECTION if $! == &EINTR;
	    &logger'message("----Server exiting: $@\n");
	    &logger'close();
	    die "select: $!";
	}
        foreach (@fds) {
            $fd = fileno($_);
            if (vec($rout, $fd, 1)) {
                &debug("connection on $_, fd: $fd");
                $peeraddr = accept(NS, $_);
		if (fork == 0) {	# fork immediately to prevent delays
		    &debug("inside fork: pid=$$");
		    open(STDIN, '<& NS');
		    open(STDOUT, '>& NS');
		    select(STDOUT); $| = 1;
		    close(NS); close($_);
		    $SIG{'INT'} = $SIG{'QUIT'} = $SIG{'USR1'} = $SIG{'CHLD'} = 'DEFAULT';
		    $SIG{'PIPE'} = 'cleanup';		# client closes socket
		    &client_connect($fd, $peeraddr);
		    exit 0;
		}
		close(NS);			# continue in parent thread
            }
        }
    }
    # dropped out of loop, so we restart ourselves
    &logger'message("----Server #$$ restarting at " . &ctime(time));
    &logger'close();

    # detect restarts, can't be inetd mode since this is &daemon
    if (defined($plexus_mode)) {
	exec "$http_server", @ARGV;			# have -I already
    } else {
	exec "$http_server", "-I", fileno(S), @ARGV;	# add -I
    }
    die "$http_server: $!";  
}

# deal with the client connection and returning errors properly
sub client_connect {
    local($fromfd, $peeraddr) = @_;
    local($version);
    eval '&process_input($fromfd, $peeraddr)';
    if ($@) {
	(($exception, $__error_msg) = ('internal_error', $@))
	    unless ($exception = &thrown);
	&report_error($exception, $__error_msg);
	$@ = undef;				# never mind
    }
}

sub parse_args {
    local($_);
    while ($_ = shift) {
        /^-c$/ && do { $plexus_conf = shift || die "-c requires an argument\n"; next; };
        /^-d$/ && do { $plexus_top = shift || die "-d requires an argument\n"; next; };
        /^-l$/ && do { $plexus_log = shift || die "-l requires an argument\n"; next; };
        /^-p$/ && do { $plexus_port = shift || die "-p requires an argument\n"; next; };
        /^-P$/ && do { $plexus_pidfile = shift || die "-P requires an argument\n"; next; };
        /^-D$/ && do { $debug++; $plexus_diag = shift || die "-D requires an argument\n"; next; };

        /^-i$/ && do { die "-i conflicts with -I\n" unless ! defined $plexus_mode; $plexus_mode = 0; next; };
        /^-I$/ && do { die "-I conflicts with -i\n" unless ! defined $plexus_mode; $plexus_mode = shift || die "-I requires an argument\n"; next; };
	die "Unrecognized argument: $_\n$usage\n";
    }
}

# You only have to add the p_ for a new command.
# It will automatically be picked up by &process_config
# The best way to add new p_ commands is to add a
# require in site.pl that points to your local extensions
sub p_set { split(/\s+/, $_, 2); $plexus{$_[0]} = (eval qq/"$_[1]"/); &debug("set $_[0] = ", $plexus{$_[0]}); }
sub p_hide { $hidden{(eval qq/"$_"/)} = 1; }
sub p_load { split(/\s+/, $_); foreach (@_) { require (eval qq/"$_"/); } }
sub p_translate { split(/\s+/, $_, 3); $trans{$_[1]} = "$_[2]:$_[0]"; }
sub p_map { split(/\s+/, $_, 3); $map{(eval qq/"$_[0]"/)} = "require \"$_[1]\"; $_[2]"; }
sub p_content { split(/\s+/, $_); local($c, $_) = shift(@_); foreach (@_) { $content{$_} = $c; } }
sub p_encoding { split(/\s+/, $_); local($c, $_) = shift(@_); foreach (@_) { $encoding{$_} = $c; } }
sub p_loadpath { split(/\s+/, $_); local($_); foreach (@_) { unshift(@INC, (eval qq/"$_"/)); } }
sub p_eval { (eval qq/"$_"/); }

sub process_config {
    local($FH, $cfg) = @_;
    local($cmd, $_);

    &open($FH, $cfg) || die "$cfg: $!";
    while (<$FH>) {
        chop; s/#.*//; s/^\s*//; s/\s*$//; next if /^$/;	# cleanup
        ($cmd, $_) = split(/\s+/, $_, 2);
        if (eval "defined &p_$cmd") {
	    eval "&p_$cmd";
	    die $@ if $@;
	} else {
	    warn "process_config ignored: $cmd $_\n";
	}
    }
    close($FH);
}

# Returns:
#   $_     The complete path after preprocessing (basically $top/$rest)
#   $top   The first directory level (for matching mapped entries)
#   $rest  The remainder of path
#   $query Any query data sent along (data after a question mark)
sub filter_request {
    local ($_) = @_;
    local ($top, $rest, $query) = (undef, undef, undef);

    #
    # preprocess the request
    #
    s:\?(.*):: && ($query = $1);		# extract query (if any)
    s/%([\da-f]{1,2})/pack(C,hex($1))/eig;	# convert %## escapes
    s:.*:/$&/:;					# force leading and trailing /
    s:/+:/:g;					# fold multiple slashes
    ($plexus{'relative'} ne 'enabled') && m:/\.+/: && &error('bad_request',
	    "No backward directory references permitted: $_");
    $_ = "/$plexus{'homepage'}/" if $_ eq "/";	# special case home page
    s:^/::; s:/$::;				# cleanup
    ($top, $rest) = split("/", $_, 2);

    return ($_, $top, $rest, $query);
}

sub reaper {
    while(waitpid(-1,&WNOHANG) > 0) { ; }
    $SIG{'CHLD'} = "reaper";
}

sub timeout_error {
    &error('timed_out', "Server timed out after $plexus{'timeout'} seconds.");
}

sub fhbits {
    local($bits, $_);
    for (@_) { vec($bits, fileno($_), 1) = 1; }
    $bits;
}

sub restart_daemon { $restart_daemon++; }

sub cleanup { exit 0; }

sub thrown { $@ =~ /^(EXCEPTION: )+(.+)/ && $2; }

sub log_request {
    local($peeraddr, $_) = @_;
    local($af, $port, $inetaddr) = unpack($main'sockaddr, $peeraddr);
    local($ctime) = &main'ctime(time); chop $ctime;
    local($msg) = sprintf("%-15s %s %s\n", &main'hostname($inetaddr), $ctime, $_);
    &logger'message($msg);
    &logger'close();
}

sub log_error {
    return if $main'debug;
    local($status, $msg) = @_;
    &logger'error($status, $msg);
}

# report error to client and server
sub report_error {
    local($status, $msg) = @_;
    $status = 'internal_error' unless defined($main'code{$status});
    &log_error($status, $msg) if ($status eq 'internal_error');
    select(STDOUT); $| = 1;
    &main'debug('in report_error, about to call MIME_header');
    &main'MIME_header($status, 'text/html');
    print <<EOM;
<HEAD><TITLE>Server Error: $code{$status}</TITLE></HEAD>
<BODY><H1>Server Error: $code{$status}</H1>
$msg <P>
If you feel this is a server problem and wish to report it, please
include the error code, the requested URL, which and what version
browser you are using, and any other facts that might be relevant to: <P>
$'plexus{'support'}
</BODY>
EOM
}

sub getserv { ($_[0] =~ m/^\d+$/) ? $_[0] : (getservbyname($_[0], $_[1]))[2]; }

# ============================ GLOBAL ROUTINES ============================

sub printable {
    local($_) = @_;
    s/([\000-\040+\177-\377])/sprintf('%%%02x',ord($1))/eg;
    $_;
}
sub splitquery {
    local($query) = @_;
    grep((s/%([\da-f]{1,2})/pack(C,hex($1))/eig, 1), split(/\+/, $query));
}

sub error {
    local($exception, $msg) = @_;
    $main'__error_msg = $msg;			# export message to global
    die "EXCEPTION: $exception\n";
}

# return FQDN if possible
sub hostname {
    local($ip) = @_;
    local($fqdn) = (gethostbyaddr($ip,&AF_INET))[0] ||
        join(".", unpack("C4", $ip));
    $fqdn =~ y/[A-Z]/[a-z]/;
    $fqdn;
}
sub set_timeout {
    $SIG{'ALRM'} = "timeout_error";
    alarm($_[0] || $plexus{'timeout'});
}
sub clear_timeout {
    $SIG{'ALRM'} = '';
    alarm(0);
}
sub debug { print STDERR @_, "\n" if $debug; }
sub caller {
    local($p,$f,$l,$s) = caller(1);
    &debug("backtrace $s:$f:$l");
}
sub safeopen {
    local($fh, $_) = @_;
    s#^\s#./$&#;				# protect leading spaces
    $plexus{'relative'} ne 'enabled'
        && (m#/\.+/# || m#/\.+$#)
        && &error('bad_request',
                "No backward directory references permitted: $_");
    open($fh, "< $_\0");
}
sub open {
    local($fh, $file, $pre, $path, $_) = @_;
    foreach $pre (@INC) {
	$path = "$pre/$file";
	return &safeopen($fh, $path) if -f $path;
    }
    $! = &ENOENT; undef;
}
# Converts a fileglob to a perl regexp
sub globpat {
    local($_) = @_;
    s/\\([\*\?\[\]])/\377$1/g;			# escapes
    s/([^A-Za-z0-9\-\*\?\[\]\377])/\\$1/g;	# protect
    $_ = join('', '^', $_, '$');		# ^ required below
    s/([^\377])\*/$1.*/g;			# *
    s/([^\377])\?/$1./g;			# ?
    s/\[\\\^/[^/g;				# [^...]
    s/\377/\\/g;
    $_;
}

sub bind_port {
    local($fd, $port, $proto, $this) = @_;
    &debug("binding $port to $fd\n");
    $proto = (getprotobyname($proto))[2] || $http_defaultproto;
    socket($fd, &AF_INET, &SOCK_STREAM, $proto) || die "socket: $!";
    setsockopt($fd, &SOL_SOCKET, &SO_REUSEADDR, pack("l", 1));
    $this = pack($sockaddr, &AF_INET, $port, "\0\0\0\0");
    bind($fd, $this) || die "bind: $!";
    listen($fd, &SOMAXCONN) || die "listen: $!";
    select((select($fd), $| = 1)[0]);
    &setfd(0, fileno($fd));			# keep alive
}

# This is the child process main routine.
# From here all I/O is through STDIN/STDOUT.
# We inherit %in_headers and %out_headers from the parent so they
# can be augmented in the config file.
# Also, inherits $version
sub process_input {
    &debug("in process_input");
    local($fromfd, $peeraddr) = @_;
    local($action, $path, $top, $rest, $query, $authuser);

    &request;					# process the request
    &debug("version is $version");

    # Authenticate the user (doesn't validate request).
    # NOTE: may redirect STDIN/STDOUT and redo &request;

    ($authuser = &auth()) if ((defined &auth) && ($plexus_mode != 0));

    # validates the request (e.g., can this user access $path)
    # if $authuser isn't set then the request is anonymous
    &access($fromfd, $peeraddr, $action, $path, $version, $authuser)
        if ((defined &access) && ($plexus_mode != 0));

    &set_timeout();
    &log_request($peeraddr, $_);
    &set_timeout();

    # We add in some standard output headers here
    &main'add_header(*main'out_headers, "Date: " . &main'fmt_date(time));
    &main'add_header(*main'out_headers, "Server: " . $main'server_version);
    eval "&$method{$action}(\$path, \$top, \$rest, \$query, \$version)";
    die $@ if $@;
}

sub request {
    &set_timeout();
    $_ = <STDIN>;				# get request
    &debug("got request $_");
    s/[ \t\r\n]*$//;				# remove trailing white-space
    ($action, $path, $version) = split(" ", $_, 4);
    $action =~ y/A-Z/a-z/; $version =~ y/A-Z/a-z/;
    &error('not_implemented', "Invalid Action: $action")
	unless (defined $method{$action});
    &parse_headers(*in_headers) if $version;	# XXX: =~ m/$htrq_version/i;
    ($path, $top, $rest, $query) = &filter_request($path);
}
