#!/usr/bin/perl -w

# WARNING!
#
# Before starting to use mephistoles httpd, be sure to check
# whether you don't prefer mini_httpd (http://www.acme.com/software/mini_httpd)
# or boa (http://www.boa.org)

# ABOUT
#
# This is Mephistoles HTTPd, a little insecure http/proxy-server,
# written entirely in perl (a write-only programming language)!
# Now support for virtual hosts, CGIs + PHP and 
# Source code for the initial release has been taken from a example
# perl program (a time of the day server by Larry Wall) and another
# lightweight perl-httpd program (TinyHTTPD by Olaf Titz).
# Some inspiration concerning POST-requests was gained by looking
# at HTTPi (by Cameron Kaiser).
# This program is placed under the GNU General Public License (GPL).
# Enjoy and send bugfixes to: Ruwen Böhm <kwench79@yahoo.de> !

# INSTALLATION
#
# Set up a directory for your content (preferably /var/www/),
# change (or don't change) some preferences, and your set!
# Simply run httpd-m and have fun!
# 
# PREREQUISITES
#
# Perl5 + standard modules (obviously...)
# php-cgi for php-support
# file for enhanced mime-type-support

# RANDOM FEATURES (=BUGS AND CAVEATS)
#
# - http-proxying is buggy (no cookie support, etc.)
# - all configuration should be rewritten and moved to /etc/http-m.conf
#   (or the likes)
# - HTTP AUTH support is missing
#   (but the framework is looking very professional... ;-) )
# - proprietary logging instead of syslog

# ROADMAP & TODO
#
# - 0.7 is expected to become a total rewrite (yes, third rewrite!)
#       with external config file in /etc and perhaps syslog-support
# - 1.0 just a version bump from 0.7 to mark the final release of this daemon
# - perhaps, one time, a C-version will appear
# - this daemon will be included into a super-server for http, ftp, dns
#   mail and other things

# HISTORY (CHANGES SINCE LAST VERSION)
#
#
# 0.6.3pre2 (2004-05-20)
#   - finally, POST-requests are working! (at least for CGI.pm and phpnuke)
#   - $cdtoexec is now 1 (as everybody else... although not in CGI/1.1 spec)
#   - fixed wrong order of request processing
#   - more work on HTTP AUTH
#   - standard security is: drop root privileges, do not chroot
#
# 0.6.3pre1 (2004-05-20)
#   - added php-support
#   - added PDF- and preliminary MS-Office-mimetypes
#   - added support for customized error pages
#   - drop "root" privileges when serving/CGIing
#   - document root again reverted to "/var/www/"
#   - framework for HTTP AUTH
#
# 0.6.2pre1 (2004-05-13)
#   - changes Content-Types-handling back to mephistoles (broken sometimes)
#   - added "Host: <name>" feature
#
# 0.6.1pre1
#   - fixed bug in newly introduced CGI file ext. handling ;-}
#   - added Content-Types, but changed default to use "file" ($useextfile=1)
#   - default document root is now "/var/www/html/" (like everybody else)
#   - default is now never to forget IPs ($age_ip=0)
#   - added $cdtoexec (default 0) to get CGI.pm working
#   - fixed a bug that allowed to execute javascript when an error occurred
#
# 0.6.0final:
#   - fixed bug that held connection open
#   - $cgi changed to @cgi to handle several CGI file extensions
#   - proxy'ing is no OFF by default (security issue)

$rid="Mephistoles HTTPd 0.6.3pre2 (2004-05-20)";

use POSIX;
use Socket;
use Carp;
use Fcntl;

### server configuration ##################################################

### identity and filepaths ################################################

@cgi=(".pl");				# suffices for files to be exec'd
$enablephp=1;				# enable php-cgi support
$phppath="php-cgi";			# php-interpreter (CGI-enabled)

$id="Mephistoles HTTP Server";		# server id string to display
$droot="/var/www/";			# document root

$userhtml=1;				# enable /home/user/public_html?
$roothtml=1;				# enable /root/public_html?
$secureuserhtml=1;			# chroot/login as user?

$errorpath="";				# if set, use path/###.html

$sport=80;				# which tcp-port to connect to

### extensions ############################################################

$hproxy=0;				# add HTTP proxy functionality

### log file options ######################################################

$logfile="/var/log/httpd.log";		# where to log
$logpolicy=3;				# 1: overwrite, 2: backup, 3: add
$loglocal=1;				# log local accesses (1: yes)
@nolog=("");				# do not log those reqs

### server performance and options ########################################

$children=30;				# limit number of children
$maxreqlen=300;				# limit max. req-string length

$useextfile=0;				# use "file -ib" to get MIME-type

$allowhosts=0;				# use $droot+HOSTNAME (virtual hosts)

### security options ######################################################

$secure=0;				# use chroot() and new session
					# (does not work for most CGIs!)

$securedaemon=1;			# drop privileges:
$daemonuser="nobody";			# run as this user (e.g. www-data)
#$daemongroup="www";			# ... in this group

$enableauth=1;				# activate reading from .htaccess

$showdir=1;				# show dir if no index? (1: yes)
$hidedotfiles=1;			# do not show/upload files with .
$hidebackups=1;				# do not show/upload files with ~

$ipignore="";				# drop requests from these IPs
$ipallow="";				# allow only these IPs

@shields=("");				# immediatly drop these reqs

sub onnewip {  };
					# run on new IP connecting
$multitask=1;				# run above command as thread? (1: yes)
$firsttimeverbosity=1;			# log full first session
$vcons="127.0.0.1";			# known IPs (backup copy)
$cons=$vcons;				# known IPs (work copy)

$cgiholes=0;				# protect CGI-scripts from ".." ?
$postreq=1;				# post: 0: none, 1: only cgi, 2: all
$cdtoexec=1;				# chdir to cgi-file?

$age_ip=0;				# erase known IPs after...
$age_timeout=600;			# ...this timeout (sec)

### end of config #########################################################

### subroutines ###########################################################

### sub: cgi check ########################################################

sub isphp {
	my $stba=shift;

	if (substr($stba,-4) eq ".php") {
		return 1 unless ($enablephp==0);
	}
	return 0;
}

sub iscgi {
	my $stba=shift;
	my $suf;
	
	foreach (@cgi) {
		$suf=$_;
		if (substr($stba,0-length($suf)) eq $suf) {
			return 1;
		}
	}
	return 0;
}

### sub: logging functions ################################################

sub logmsg {
	print LOG scalar localtime,": @_\n";
}

sub logacc {
	my $buf;
	my $iaddr=shift;
	my $page=shift;

	# check for requests which shall not be logged (e.g. often used pages)
	foreach $buf (@nolog) {
		next if (length($buf)==0);
		if (index($page,$buf)>-1) {	# do not log this
			return;
		}
	}
	logmsg "$iaddr - $page";
}

sub loglocal {
	my $iaddr=shift;
	my $page=shift;
	if ($loglocal==0) {		# hmmm... I wonder whether one could
		if ($iaddr ne "127.0.0.1") {	# do this in a nicer way?
			logacc($iaddr,$page);
		}
	} else {
		logacc($iaddr,$page);
	}
}

### sub: print HTTP errors ################################################

sub enchtml {
	my %htmlchar=('"'=>'&quot','<'=>'&lt','>'=>'&gt');
	my $string=shift;
	$string =~ s/([\"\<\>])/$htmlchar{$1}/eg;
	return $string;
}

sub serr {
	# generate error response
	my $errorc=shift;
	my $desc=shift;

	$desc=enchtml($desc);
	logmsg "error $errorc - $desc";
 
 	my %errlist;
	$errlist{"404"}="File not found";
	$errlist{"403"}="Access denied";
	$errlist{"500"}="Internal error";
	$errlist{"501"}="Not implemented";
 
 	my $errorn=$errlist{$errorc} || "unknown error";
 
	print <<TheEnd;
HTTP/1.0 $errorc
MIME-version: 1.0
Content-type: text/html

TheEnd

	if (-e $errorpath."/".$errorc.".html") {
		$0="httpd child [sending error $errorc]";
		open(SRC,"<$errorpath/$errorc.html");
		while(<SRC>) {
			print STDOUT $_;
		}
		close(SRC);
	} else {
		print <<TheEnd2;
<HTML>
<HEAD><TITLE>$errorc $errorn</TITLE></HEAD>
<BODY><H1>Error $errorc $errorn</H1>
$errorn ( $errorc ) occurred ( $desc )<BR>
<BR>
<HR>
<ADDRESS>$id</ADDRESS>
</BODY>
</HTML>
TheEnd2
	}
}

sub redirect {		# generate a redirect
	my $newpage=shift;
	print <<TheEnd;
HTTP/1.1 301 Moved Permanently
Location: $newpage
Content-Type: text/html

<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
<HTML><HEAD>
<TITLE>301 Moved Permanently</TITLE>
</HEAD><BODY>
<H1>Moved Permanently</H1>
The document has moved <A HREF="$newpage">here</A>.<P>
<HR>
</BODY></HTML>
TheEnd
}

### sub: file/directory handling ##########################################

sub sdir {
	my $public=shift;
	my $trdr=shift;
	my $page=shift;
	my $hs;
	my @files;
	my $file;
 	my $parent;
	my $len;
 	my $tlen;
	my $fpath;
	my @dlist;
	my $ic;

	if (opendir(DIR,$trdr.$public)) { } else {
		serr(404,$page);
		return;
		}
	
	print "HTTP/1.0\nMIME-version: 1.0\nContent-type: text/html\n\n";
	print "<HTML><HEAD><TITLE>Directory listing</TITLE></HEAD>\n";
	print "<BODY><H1>Directory listing of $page</H1>\n";

	@files = readdir(DIR);
	closedir(DIR);

	if ($page=~/^(.*)\/(.*)\/$/) {	# beautiful, isn't it?
		$parent=$1."/";
	} else {
		$parent="";
	}

	print "<A HREF=\"$parent\">.. (to parent directory)</A><BR><BR>";

	print "<table BORDER CELLSPACING=0 WIDTH=\"100\%\" NOSAVE >";

	$ic=0;
	$tlen=0;
	
	foreach $file (@files) {
		next if ($file eq ".");
		next if ($file eq "..");
		next if (($hidedotfiles==1) && ($file=~/^\.(.*)$/));
		next if (($hidebackups==1) && ($file=~/^(.*)\~$/));

		$len=-s $trdr.$public.$file;
		$len=int($len/1024);
		$hs=$page.$file;

		$fpath=$trdr.$public.$file;
		if (-d $fpath) {
			$dlist[$ic]="<A HREF=\"$hs/\">$file</A></td><td>directory";
		} else {
			$dlist[$ic]="<A HREF=\"$hs\">$file</A></td><td>$len kb";
		}
		$ic=$ic+1;
		$tlen=$tlen+$len;
	}     

	my @slist = sort @dlist;
	my $elem;
	my $switch=0;
	
	foreach $elem (@slist) {
		if ($switch==1) {
			print "<tr BGCOLOR=\"#FFFFDD\"><td>";
			$switch=0;
		} else {
			print "<tr BGCOLOR=\"#DDFFFF\"><td>";
			$switch=1;
		}
		print $elem;
		print "</td></tr>\n";
	}
		
	print "</table><p>\n";  
	print "$ic entries ($tlen kb total) showed.\n";
 	print "<BR><HR><ADDRESS>$id</ADDRESS>\n";
	print "</BODY></HTML>\n";  
}

### sub: string converting / validation ###################################

sub conv {
	my $sr=shift;
	$sr =~ s/\%([A-Fa-f\d]{2})/chr hex $1/eg;
	# nice, eh? replace all occurences with % followed by two
	# numbers and/or characters a-f with the corresponding
	# ASCII-character after hex-converting
	return $sr;
}

sub evilhacker {		# check whether a string may be passed to a system-call with fs-access
	my $sr=shift;
	return 1 if (substr($sr,-1) eq "|"); # a trailing "|" commands perl to use the file as pipe
	return 1 if (index($sr,"\0")>-1); # a NULL byte is not POSIX compliant
	return 1 if (index($sr,"/../")>-1); # we don't want our script to go one dir up!
}

### sub: request server ###################################################

sub serve_http {
	my $iaddr = shift;
	my $trdr;
	my $trp;
	my $page="";
	my $usag="";
	my $buf;
	my @run;
	my $getstr="";
	my $reqt=0;
	my $contd=0;
	my $posthead="";
	my $postbody="";
	my $referer="";
	my $reqcontlen="";
	my $cookie="";
	my $hostn="";
	my $pageonly="";
	my $pathonly="";
	my $ipath;

	while ($buf = <STDIN>) {
		last if (!defined $buf);
		last if (length($buf)<3);		# drop \r\n string
		if (length($buf)>$maxreqlen) {	# drop too long strings (fixes 100% load)
			logmsg "$iaddr - overflow with ",length($buf), " bytes";
			return;
		}
		$posthead=$posthead.$buf;
		# check for bad requests immediatly
		foreach (@shields) {
			next if (length($_)==0);
			if (index($buf,$_)>-1) {	# illegal request
				logmsg "illegal input matching \"$_\" filtered!!!";
				return;
			}
		}
		$buf=substr($buf,0,-2);
		if (($firsttime==1) && ($firsttimeverbosity==1)) {  # log first connect
			logmsg "1st: $buf";
		}
		if ($buf =~ /^(GET|Get|get|HEAD|Head|head)(\s*)(.*?)( HTTP\/1|$)/g) {
			$page=$3;
			$reqt=1;
		}
		if ($buf =~ /^(POST|Post|post)(\s*)(.*?)( HTTP\/1|$)/g) {
			$page=$3;
			$reqt=2;
		}
		if ($buf =~ /^(User-Agent: )(.*?)$/g) {
			$usag=$2;
			$ENV{"HTTP_USER_AGENT"}=$usag;
		}
		if ($buf =~ /^(Host: )(.*?)$/g) {
			$hostn=$2;
		}
		if ($buf =~ /^(Content-length: )(\d+)$/i) {
			$reqcontlen=$2;
			$ENV{"CONTENT_LENGTH"}=$reqcontlen;
		}
		if ($buf =~ /^(Cookie: )(.+)$/i) {
			$cookie=$2;
			$ENV{"HTTP_COOKIE"}=$cookie;
		}
		if ($buf =~ /^(Referer: http:\/\/)(.*?)\/(.*?)\/(.*?)$/g) {
			$referer=$3;
			#chop($referer);
		}
		if ($buf =~ /^(Range: bytes=)(.*?)-/g) {
			$contd=$2;
		}
	}

	if ($reqt==0) {			# immediatly log & return on empty reqs
		serr(501,"Only GET and POST, please!");
		return;
	}

	loglocal($iaddr,$page);			# log this request

	if ($hproxy==1) {			# proxy'ing without security checks
		$psite="";
		$ppage="/index.html";
		if ($page =~ /^(http:\/\/)(.*?)$/g) {		# plain site
			$psite=$2;
		}
		if ($page =~ /^(http:\/\/)(.*?)(\/)$/g) {		# trailing /
			$psite=$2;
		}	
		if ($page =~ /^(http:\/\/)(.*?)(\/)(.*?)$/g) {	# site and page
			$psite=$2;
			$ppage="/".$4;
		}
		if ($psite eq "") {
		} else	{			# request found?
			my $proto = getprotobyname('tcp');
			my $opponent = gethostbyname($psite);
			socket(P, AF_INET, SOCK_STREAM, $proto) || serr(500,"socket");
			bind(P, sockaddr_in(0, INADDR_ANY)) || serr(500,"bind");
			connect(P, sockaddr_in(80, $opponent)) || serr(500,"connect $opponent");
			select(P); $| = 1; select(STDOUT);

			print P "GET $ppage HTTP/1.0\n\n";
			while(<P>) {
				print $_;
			}
			close(P);
			return;			# done (at least I hope so...)
		}				# no proxy req? go on...
	}					# no proxy allowed? go on...

	$page="/".$referer.$page unless (substr($page,0,1) eq "/");	# we add a "/" to protect ourselves
	while (substr($page,0,2) eq "//") {	# and we remove double ones...
		$page=substr($page,1);
	}

	if ($page =~ /^(.*?)\?(.*?)$/g) {	# split when "?" in name
		$page = $1;
		$getstr = $2;
	} 
	
	$page=conv($page);			# convert $page from %XX-encoding to plain ASCII

	if (evilhacker($page)) {		# illegal filename
		serr(403,$page);
		return;
	}

	if (($cgiholes==1) && (defined $getstr)) {	# minimal protection for bad cgi-scripts!
		if (evilhacker($getstr)) {
			serr(403,$page);
			return;
		}
	}

	# detect document root (default or user)
	$trdr=$droot;
	$trp=$page;

	if ($allowhosts==1)  {				# allow and use "Host: " to change document path
		if (length($hostn)>2) {			# but is a host given?
			if (evilhacker($hostn)) {		# $hostn should be sane...
				serr(403,$page);
				return;
			}
			if (-e "$droot/$hostn") {		# ... and exist ...
				$trdr=$droot."/".$hostn."/";	# then go for it!
			} else {
				serr(404,"$page on $hostn");		# otherwise no one is at home
				return;
			}
		} else {
			$trdr=$droot."/default/";		# no host -> default
		}
	}
	if ($userhtml==1) {
		if (substr($page,1,1) eq "~") {
			if (substr($page,1,6) eq "~root/") {
				if ($roothtml==1) {
					$page =~ /^\/\~(.*?)\/(.*?)$/g;
					$trdr="/root/public_html/";
					$trp=$2;
				} else {
					serr(403,$page);
				}
			} else {
				$page =~ /^\/\~(.+?)\/(.*?)$/g;
				$trdr="/home/$1/public_html/";
				$trp=$2;
			}
			if ($secureuserhtml==1) {
				chroot($trdr) && ($trdr="/") || warn "warning: couldn't chroot() to $trdr";
				POSIX::setsid() || warn "warning: can't start a new session: $!";
			}
		}

	}

	if ($trp=~/^(.*)\/(.*)$/) {
		$pageonly=$2;
		$pathonly=$1;
	} else {
		$pageonly=$trp;
		$pathonly="./";
	}
	
	if ($enableauth==1) {				# HTTP AUTH codeblock
		if (-e "$trdr/$pathonly/.htaccess") {
			# here we parse the .htaccess-file
			$realm="pseudo";
			#
			print "HTTP/1.1 401 Authorization Required\n";
			print "WWW-Authenticate: Basic realm=$realm\n";
			print "Content-type: text/html\n";
			print "\n";
			print <<EndOfAuth;
<HTML>
<HEAD><TITLE>Authorization Required</TITLE></HEAD>
<BODY><H1>Login failure - Authorization Required</H1>
You are not allowed to access this page.<BR>
<BR>
<HR>
<ADDRESS>$id</ADDRESS>
</BODY>
</HTML>
EndOfAuth
			return;
		} else {
		}
	}
	
	if ($hidedotfiles==1) {				# .files downloadable?
		if (substr($pageonly,0,1) eq ".") {
			serr(403,$page);
			return;
		}
	}

	# check, if we need to add index.html
	if (substr($trp,-1) eq "/") {		# or if the luser wants a dir listing
		if (($showdir==1) && (!-e $trdr.$trp."index.html")) {
			sdir($trp,$trdr,$page);	# list a directory...
			return;			# and quit this connection!
		}				# otherwise...
		$trp = $trp . "index.html";	# add "index.html" and go on...
	} else {
		if (-d $trdr.$trp) {		# directory without trailing "/" ?
			redirect("$page/");	# issue "permanently moved" with trailing "/" !
			return;
		}
	}
	
	# some variables need to be initialized
	# CGIs depend on QUERY_STRING when using GET-requests
	# php is picky about SCRIPT_FILENAME
	# ... and CGI.pm seems to need some extra variables to know about the location of the script
	$ENV{"SCRIPT_NAME"}=$pageonly;
	$ENV{"REMOTE_ADDR"}=$iaddr;
	$ENV{"REQUEST_URI"}=$page;
	$ENV{"QUERY_STRING"}=$getstr;
	$ENV{"SCRIPT_FILENAME"}=$trdr.$trp;
	$ENV{"CONTENT_TYPE"}="application/x-www-form-urlencoded";
	
	if ($reqt==2) {				# POST-requests
		$ENV{"REQUEST_METHOD"}="POST";
		if ($postreq==0) {
			serr(403,"$page");
		} else {
			if ($postreq==1) {
				if (!iscgi($trp) && !isphp($trp)) {
					serr(403,"$page");
					return;
				}
			}
			$0="httpd child [serving POST request from $iaddr]";
			chdir($trdr);

			my $fexec="";
			if ($cdtoexec==1) {
				$trp=~/^(.*)\/(.*)$/;
				chdir($trdr.$1);		# chdir to destination
				$fexec="./$2";
			} else {
				$fexec="./$trp";
			}
			serr(404,$page) && return unless (-e $fexec);
			serr(403,"file $page not executable") && return unless ((-x $fexec) || isphp($trp));
			print "HTTP/1.0 200 OK\n";
			$fexec="$phppath $fexec" if (isphp($trp));
			if (open(PR,"| $fexec")) {
				#print PR $posthead;
				#print PR "\n";
				read(STDIN,$postbody,$reqcontlen || 500);
				print PR $postbody;
				close(PR);
			} else {
				serr(500,"could not execute POST request");
			}
		}
		return;
	}

	# GET-requests

	if (iscgi($trp) || isphp($trp)) {		# found a cgi-file?
		
		$0="httpd child [executing CGI $trp for $iaddr]";
			 
		$ENV{"REQUEST_METHOD"}="GET";
				
		if (!(-e $trdr.$trp)) {
			serr(404,$page);
			return;
		}
			
		print "HTTP/1.0 200 OK\nMIME-Version: 1.0\n";

		chdir($trdr);				# execute to droot
		if ($cdtoexec==1) {
			$trp=~/^(.*)\/(.*)$/;
			chdir($trdr.$1);		# chdir to destination
			if (isphp($trp)) {
				@run=($phppath,"-n",$trdr.$trp);			# execute in local dir
			} else {
				@run=("./".$2);
			}
			system(@run);
		} else {
			if (isphp($trp)) {
				@run=($phppath,"-n",$trdr.$trp);
			} else {
				@run=("./".$trp);		# run from droot as home
			}
			system(@run);
		}
		return;
	} 

	# only static file requests below...

	$ENV{"CONTENT_TYPE"}="";		# fix me...
	
	my $nlen;
	my $len;

	if (open(SRC,$trdr.$trp)) {
		$len=-s $trdr.$trp;
		if ($contd>0) {			# continued download
			seek(SRC,$contd,0); 
			$nlen=$len-$contd;
			print "HTTP/1.1 206 Partial Content\n";
			print "Content-Range: $contd-$len/$len\n";
			print "Content-Length: $nlen\n";
		} else {
			print "HTTP/1.0 200 OK\n";
			print "Content-Length: $len\n";
			print "Content-Type: ";
			if ($useextfile==1) {	# get MIME-type (external via UNIX cmd "file")
				if (open(CMD,"file -bi $trdr$trp |")) {
					print <CMD>;
					close(CMD);
				} else {
					print "text/plain\n";
				}
			} else {		# internal guess according to extension
				CASE:
				{
				  lc($trp)=~/\.html$/ && do { print "text/html\n"; last CASE; };
				  lc($trp)=~/\.htm$/ && do { print "text/html\n"; last CASE; };
				  lc($trp)=~/\.shtml$/ && do { print "text/html\n"; last CASE; };
				  lc($trp)=~/\.gif$/ && do { print "image/gif\n"; last CASE; };
				  lc($trp)=~/\.jpg$/ && do { print "image/jpeg\n"; last CASE; };
				  lc($trp)=~/\.png$/ && do { print "image/png\n"; last CASE; };              
				  lc($trp)=~/\.jpeg$/ && do { print "image/jpeg\n"; last CASE; }; 
				  lc($trp)=~/\.mpeg$/ && do { print "video/mpeg\n"; last CASE; };
				  lc($trp)=~/\.mpg$/ && do { print "video/mpeg\n"; last CASE; };
				  lc($trp)=~/\.mp3$/ && do { print "audio/mpeg\n"; last CASE; };
				  lc($trp)=~/\.avi$/ && do { print "video/avi\n"; last CASE; };
				  lc($trp)=~/\.mov$/ && do { print "video/avi\n"; last CASE; };		  
				  lc($trp)=~/\.wav$/ && do { print "audio/wav\n"; last CASE; }; 
				  lc($trp)=~/\.swf$/ && do { print "application/x-shockwave-flash\n"; last CASE; }; 
				  lc($trp)=~/\.pdf$/ && do { print "application/pdf\n"; last CASE; }; 
				  lc($trp)=~/\.doc$/ && do { print "text/rtf\n"; last CASE; };
				  lc($trp)=~/\.rtf$/ && do { print "application/msword\n"; last CASE; };
				  lc($trp)=~/\.ppt$/ && do { print "application/msword\n"; last CASE; };
				  lc($trp)=~/\.xls$/ && do { print "application/msword\n"; last CASE; };
				  print "text/plain\n";
				}
			}
		}
		print "\n";
		$0="httpd child [transmitting file for $iaddr]";
		while(<SRC>) {
			print STDOUT $_;
		}
		close(SRC);
	} else {
		serr(404,$page);
	}

}

### sub: threading functions ##############################################

sub spawn {
	my $coderef = shift;
		unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
			confess "usage: spawn CODEREF";
		}
	my $pid;
	if (!defined($pid = fork)) {
		logmsg "cannot fork: $!";
		return;
	} elsif ($pid) {
		return; # I'm the parent
	}
	# else I'm the child -- go spawn
	open(STDIN,  "+<&Client")   || die "can't dup client to stdin";
	open(STDOUT, "+>&Client")   || die "can't dup client to stdout";
	select(STDOUT); $|=1;
	exit &$coderef();
	close(STDIN); close(STDOUT);

}

### main ##################################################################

$firsttime=0;		# just some inits...
$0="$rid [startup]";	# explain, what we're doing

my $proto = getprotobyname('tcp');
my $mpid;

# open logfile
my $buf;
$buf=">".$logfile if (($logpolicy==1) || ($logpolicy==2));
$buf=">>".$logfile if ($logpolicy==3);
system(("cp",$logfile,$logfile.".old")) if ($logpolicy==2); # quick 'n' dirty!
open(LOG,$buf) || print "WARNING! No logging possible because of file error!\n";
select(LOG); $|=1; select(STDOUT);		# no buffering!

# make us secure...

if ($secure==1) {
	chroot($droot) && ($droot="/") || warn "warning: couldn't chroot() to $droot";
	POSIX::setsid() || warn "warning: can't start a new session: $!";
}

# fork to background (daemon mode)
if (!defined($mpid=fork)) {                                                  
	warn "warning: couldn't fork to background!\n";                                         
} elsif ($mpid) {
	print "http daemon forked to background\n";                                                       
	exit; # I'm the parent                                 
}  

# ideally, the child is now chroot()ed to the document root and can't access
# anything else...

# open listening TCP networking socket
socket(Server, PF_INET, SOCK_STREAM, $proto)        || die "ABORT: socket: $!";
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,pack("l", 1))   || die "ABORT: setsockopt: $!";
bind(Server, sockaddr_in($sport, INADDR_ANY))        || die "ABORT: bind: $!";
listen(Server,SOMAXCONN)                            || die "ABORT: listen: $!";

logmsg "$rid @ $sport";
$0="httpd father [accepting connections]";

$SIG{"CHLD"}=sub { while(waitpid(-1,1) > 0) { ; } $childcnt=$childcnt-1; }; # reap and count
$SIG{"ALRM"}=sub { $cons=$vcons; alarm($age_timeout); }; # make known IPs new
alarm($age_timeout) if ($age_ip==1);

$childcnt=0;

my $cip="";

while(1) {
	my $paddr = accept(Client,Server);
	next if not $paddr;			# shouldn't happen
	
	my($port,$iaddr) = sockaddr_in($paddr);
	my $name = gethostbyaddr($iaddr,AF_INET);
	$cip=inet_ntoa($iaddr);

	if (index($cons,$cip)==-1) {		# new connect
		logmsg "first connect of host $cip in this session";
		$firsttime=1;
		if ($multitask==1) {
			if (!defined($mpid=fork)) {
				print "note: cannot fork to background, on-new-ip not multithreaded!\n";
				system(@onnewip);
			} else {
				if ($mpid) {
					# I'm the parent
				} else {
					$0="httpd [registering new connect]";
					onnewip; # I'm the child!
					exit;
				}
			}
		} else {
			system(@onnewip);
		}
		$cons=$cons." ".$cip;
	} else {
		$firsttime=0;
	}   
	if (index($ipignore,$cip)>-1) {	# if this IP is to ignore
		logmsg "blocking req from $cip:$port ($name) - on ignore-list";
		next;
	}
	if (length($ipallow)>0) {		# only certain IPs allowed
		if (index($ipallow,$cip)==-1) {	# this is not allowed
		logmsg "blocking req from $cip:$port ($name) - not on allowed-list";
			next;
		}
	}

	if ($childcnt>$children) {
		logmsg "server load to high - refused connect";
		next;
	}

	$childcnt=$childcnt+1;  
	
	spawn sub {
		$0="httpd child [serving $cip]";
		if ($securedaemon==1) {
			# permanently drops privs
			($<,$>) = ((scalar getpwnam($daemonuser)),(scalar getpwnam($daemonuser)));
			# ($(,$)) = (getuinam($daemongroup),getuinam($daemongroup));	# change group???
		}
		serve_http($cip);
		close(Client);
	};
	close(Client);			# child has it's own
	
	# collect our dead children...
	while(waitpid(-1,1) > 0) { ; } # don't loathe SysV, love BSD! 8-)
}

### The End.