#!/usr/bin/perl -w
# compact HTTP web-server with CGI support
# Copyright 2002 Bernhard M. Wiedemann <httpdbmw@lsmod.de>
# 
# this is is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License

use strict;
our (%options,%denv,%clientdata,
$cgi,$sel,$path,@shorterror,@longerror);

%options=qw(
port		80
serverstring	bmw-tiny-0.2.5
admin		webmaster@lsmod.de
name		lsmod.de
root		/var/www/html/
default		index.html
userdir		public_html
logfile		/var/log/httpd/tiny
uid		48
keepalive	1
teergrube	0
debug		1
proto		HTTP/1.1
);

our $haveinet6=0;
use IO::Socket;
eval{require IO::Socket::INET6;} and ($haveinet6=1);
use IO::Select;
use IO::Pipe;
use Getopt::Long;
use FileHandle;
use English;
use CGI $cgi=new CGI("");
($path=$0)=~s+[^/]*$++;$path="./" if($path eq "");
#require $path.'blib.pl';

our %passwd_cache;
our @month=qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
our $hdrend="\015\012";
sub defaults1 ($$) {$_[0]=$_[1] unless(defined($_[0]))}
sub defaults2 ($$) {$_[0]=$_[1] unless(defined($_[0]) and $_[0] ne "")}
sub diag ($;$) {my($m,$l)=@_;print STDERR "DIAGNOSTIC: $m\n" if($options{debug} || $l);}
sub accesslog($) {
	my ($client)=@_;
	my @elem=();
	$elem[0]=${${$clientdata{$client}}{ENV}}{"REMOTE_ADDR"};
	$elem[1]=${${$clientdata{$client}}{ENV}}{"HTTP_HOST"};
	my @l=localtime(${$clientdata{$client}}{time});
	$elem[3]=sprintf("[%i/%s/%.2i:%.2i:%.2i:%.2i %s]",$l[3],$month[$l[4]],$l[5]+1900,$l[2],$l[1],$l[0],$options{timezone});
	if(${$clientdata{$client}}{inheaders}=~m/^(.*)/) { $elem[4]=$1; }
	$elem[5]=${$clientdata{$client}}{returncode};
	$elem[6]=${$clientdata{$client}}{size};
	$elem[7]=${${$clientdata{$client}}{ENV}}{"HTTP_REFERER"};
	$elem[8]=${${$clientdata{$client}}{ENV}}{"HTTP_USER_AGENT"};
	foreach(@elem) {unless($_){$_="-"}}
	foreach(@elem[4,7,8]) {$_="\"$_\"";}
	print LOG "@elem\n";
}

sub verify_basic($) { my($str)=@_;
   use MIME::Base64;
   if((my $u=$passwd_cache{$str})) {return $u}
   my $s=decode_base64($str);
   my ($user,$pass)=($s=~/^([a-zA-z0-9_]*):(.*)/);
   my $pwdentry;
   open(PASSWD, "<", $options{htpasswd}) or die $!;
   while(<PASSWD>) {
      if(/^$user:(.*)/) {$pwdentry=$1;last;}
   }
   close PASSWD;
#diag("testing $user $pass $pwdentry");
   if(!$pwdentry || crypt($pass,$pwdentry) ne $pwdentry) {return undef}
   $passwd_cache{$str}=$user;
   diag("added to passwd cache: $s=$str");
   return $user;
}

sub parseoptions()
{
 my @options=qw(port=i uid=i keepalive! debug|d! teergrube=i root=s serverstring=s logfile:s htpasswd:s
 pw=s admin=s userdir:s default:s help|h|?
);
 my($paramfile)=($path."bmwhttpdrc");
 local @ARGV=@ARGV;
 use Config;
 if(@ARGV and substr($ARGV[0],0,1) ne "-") {$paramfile=shift @ARGV}
 if(open(S, "< $paramfile")) {
   local(@ARGV)=<S>;close(S);
   foreach(@ARGV) {if(s/^#.*//s){next} s/\015?\012|\n//; s/^/--/; s/ /=/;}
   if(!GetOptions(\%options, @options) || (@ARGV && $ARGV[0] ne "")) {die "invalid option in $paramfile. @ARGV\n"}
 }
 if(!GetOptions(\%options, @options) || (@ARGV && $ARGV[0] ne "")) {die "invalid option on commandline. @ARGV\n"}
 if($options{help}) {foreach(@options){m/([a-z]*)(.*)/;print "$1=$options{$1} ($2)\n"}; exit(0);}
 while(my @a=each(%options)) {if($a[1] eq "-"){$options{$a[0]}=""}}
 my $time=time();
 my @local=localtime($time);
 my @gmt=gmtime($time);
 my $diff=($local[2]-$gmt[2]+24+11)%24-11;
 my $mdiff=$local[1]-$gmt[1];
 if($mdiff<0 && $diff>0) {$mdiff+=60; $diff--;}
 if($mdiff>0 && $diff<0) {$mdiff-=60; $diff++;}
 $options{timezone}=sprintf("%s%.4i", ($diff>=0?"+":""),$diff*100+$mdiff);
}

sub openlog() {
	if($options{logfile}) {open(LOG, ">> $options{logfile}") or die "error opening $options{logfile}: $!";}
	select((select(LOG), $| = 1)[0]); #imediately flush log
}

sub closecon($) {
	my ($client)=@_;
   diag($client->peerhost.":".$client->peerport." connection closed");
	$sel->remove(${$clientdata{$client}}{handle});
	delete($clientdata{$client});
	$sel->remove($client);
	close($client);
	return 0;
}

sub httpheader($$$) {
	my($client,$code,$errormessage)=@_;
	my @a;
	my $ret="$options{proto} $code $errormessage\015\012";
	${$clientdata{$client}}{returncode}=$code;
	while(@a=each(%{${$clientdata{$client}}{outheaders}})) {
		#diag(join " ",@a);
		$ret.=$a[0].": ".$a[1]."\015\012";
	}
	return $ret;
}

sub errormessage($$;$) {
	my($e,$client,$headers)=@_;
	unless($shorterror[$e]) {$e=0}
	defaults1($headers,"");
	print $client httpheader($client,$e,$shorterror[$e]).$headers.$hdrend.$longerror[$e];
	closecon($client);
}

sub keepalivecheck($) {
	my($client)=@_;
	if(${$clientdata{$client}}{inheaders}=~/^Connection: (.*)/mi) {
		my $tokens=$1;
		if($tokens=~/Keep-Alive/i && ${$clientdata{$client}}{outheaders}{Connection}=~/Keep-Alive/ && ${$clientdata{$client}}{outheaders}{"Content-Length"}) {
			my $x="";
			if(${$clientdata{$client}}{inheaders}=~/^Keep-Alive: (.*)/mi) {$x=$1}
			diag "$tokens $x";
			${$clientdata{$client}}{inheaders}="";
			${$clientdata{$client}}{status}="header";
			$sel->remove(${$clientdata{$client}}{handle});
			close(${$clientdata{$client}}{handle});
			delete ${$clientdata{$client}}{handle};
			return 1;
		}
	}
	return 0;
}

sub mimetype($) {
	my ($type)=@_;
	if($type=~m/(?:X|HT)ML/) {
		return "text/html"
	} elsif($type=~m/text/) {
 		return "text/plain"
	} elsif($type=~m/([A-Z]+) image data/) { 
		return "image/\L$1"
	} else {
		return "application/octet-stream"
	}
}

sub filehandler($$$) {
	my($file,$querystring,$client)=@_;
	my $done=0;
	my $in=${$clientdata{$client}}{handle};
	my $closecon=1;
	$file=~s!/{2,}!/!g;
	$ENV{SCRIPT_FILENAME}=$file;
	if(($file=~m!/cgi-bin/! || $file=~m/\.pl$/ || $file=~m/\.cgi$/) && -x $file) {
		my $line=<$in>;chomp($line);
		delete(${$clientdata{$client}}{outheaders}{"Content-Type"});
		delete(${$clientdata{$client}}{outheaders}{"Connection"}); # this is rather dirty
		print $client httpheader($client,200,"OK");
		if($line eq "#!inline") {
			local $/=undef;
			my $script=<$in>;
			select $client;
			my $request=new CGI($querystring);
			eval($script);
         diag("close: $closecon");
			$done=1;
		}
		close($in);
		$client->flush();
		if(!$done) {
		  ${$clientdata{$client}}{inheaders} =~ /\n\n(.*)/m;
		  my $body=$1 || "";
		  my $cgipipe=new IO::Pipe;
		  if (fork()==0) { # child
		  	(my $scriptpath=$file)=~s!/[^/]*$!!;
			chdir $scriptpath;
			my $fc=fileno($client);
			$cgipipe->reader();
			my $fp=fileno($cgipipe);
#			close(STDIN);close(STDOUT);close(STDERR);
			open(STDIN, "<&=$fp") or die $!;
			open(STDOUT, ">&$fc") or die $!;
			open(STDERR, ">&$fc") or die $!;
			select(STDOUT);
			exec($file,"");
			exit(0);
		  } else {
		  	$cgipipe->writer();
			print $cgipipe $body;
			close($cgipipe);
		  }
		}
	} else {
		${$clientdata{$client}}{outheaders}{"Content-Length"}= -s $file;
		if($options{keepalive}) {${$clientdata{$client}}{outheaders}{Connection}="Keep-Alive";}
		my $type=`file $file`;
		${$clientdata{$client}}{outheaders}{"Content-Type"}=mimetype($type);
		print $client httpheader($client,200,"OK").$hdrend;
		${$clientdata{$client}}{status}="body";
		$closecon=0;
		$sel->add($in);
#		print $client (<$in>);
#		print $client "text";
	}
	if($closecon && keepalivecheck($client)) {$closecon=0}
	${$clientdata{$client}}{size}=${$clientdata{$client}}{outheaders}{"Content-Length"};
	accesslog($client);
	closecon($client) if $closecon;
}



sub teergrube($)
{
	my($client)=@_;
	my $peer=$client->peerhost.":".$client->peerport;
	diag "teergrubing $peer";
	my $pid=fork();
	if(defined($pid) && $pid==0) {
		my $n=0;
		my $ret=syswrite $client, "HTTP/1.1 200 OK";
		while($ret) {
			$ret=syswrite $client, "Error: Error";
			sleep($options{teergrube});
			$n++;
		}
		diag "teergrubing $peer finished after $n turns";
		exit(0);
	}
	closecon($client);
}




parseoptions();

my $class="IO::Socket::INET".($haveinet6?"6":"");
my $new_client=$class->new(Proto=>"tcp", LocalPort=> $options{port}, Listen=>2, Reuse=>1) 
  or die "Can not open listen port $options{port}\n";

if(!$options{debug} && $EUID==0 ) {
   eval {
	require Net::Server::Daemonize;
   	Net::Server::Daemonize::daemonize($options{uid}, "nobody", "/var/run/bmwtinyhttpd.pid");
   };
}
if($EUID==0 && $options{uid}) {
  umask(0002);
  $EUID=$EGID=$options{uid};
  $options{uid} == $EUID or 
       die "unable to setuid($options{uid})";
}
openlog();
diag("listening on port $options{port}");

if($options{root}=~/^\./) {
	(my $pwd=`pwd`)=~s!\n!/!;
	$options{root}=~s!^\./|^\.$!!;
	$options{root}=$pwd.$options{root};
}
%denv=(PATH=>"/usr/local/bin:/usr/bin:/bin:/usr/X11R6/bin", "GATEWAY_INTERFACE"=>"CGI/1.1");
$denv{DOCUMENT_ROOT}=$options{root};
$denv{SERVER_SOFTWARE}=$options{serverstring};
$denv{SERVER_ADMIN}=$options{admin};
$denv{SERVER_INTERFACE}=$options{proto};
$denv{SERVER_NAME}=$options{name};


$/="\012";
{
	my $s=$Config{sig_name};
	if($s=~m/\bHUP\b/) {$SIG{HUP} = sub{parseoptions();openlog()};}
	if($s=~m/\bPIPE\b/) {$SIG{PIPE} = 'IGNORE';}
	if($s=~m/\bCHLD\b/) {$SIG{CHLD} = sub{wait()} }
}

for(400..599) {$shorterror[$_]="Error $_"; $longerror[$_]="Error $_ occurred\n<br>Aus irgendeinem Grunde ist Fehler $_ aufgetreten.\n"; }
if(open(ERR, "< $path/errormessages")) {
  while(<ERR>) {
		chomp();
		s/#.*//;
    next unless m/^(\d+)\s(.*?)\s+-\s+(.*)/;
		$shorterror[$1]=$2;
		$longerror[$1]=$3;
		$longerror[$1]=~s/\\n/<br>\n/g;
  }
} else {diag "errormessages: $!";}

$sel = IO::Select->new($new_client);

MAINLOOP:
while (1) {
  my @ready = $sel->can_read(1);
  my @writeable = $sel->can_write(0);
  foreach my $client (@writeable) {
    my $in=${$clientdata{$client}}{handle};
    if($in) {
      my $data;
      my $read=sysread($in,$data,1400);
      unless($read>0) {unless(keepalivecheck($client)){closecon($client)};next;}
      my $written=syswrite($client,$data,$read);
      unless($written) {closecon($client);next;}
      if($written<$read) { diag "wrote $written but should be $read" }
    }
  }
  CLIENTLOOP:
  foreach my $client (@ready) {
   if($client == $new_client) {
     my $add = $client->accept;
     $sel->add($add);
     diag($add->peerhost.":".$add->peerport." connected");
     my $client=$add;
     my %cenv=%denv;
	$cenv{SERVER_ADDR}=$client->sockhost;
	$cenv{SERVER_PORT}=$client->sockport;
	$cenv{REMOTE_ADDR}=$client->peerhost;
	$cenv{REMOTE_PORT}=$client->peerport;
     ${$clientdata{$client}}{time}=time();
     ${$clientdata{$client}}{inheaders}="";
     ${$clientdata{$client}}{status}="header";
     ${$clientdata{$client}}{ENV}=\%cenv;
   }
   elsif(${$clientdata{$client}}{status} && ${$clientdata{$client}}{status} eq "header") {
     $_=undef;
     my $nr=sysread $client, $_, 65000;
     if((!defined $_) || $nr==0) {
	closecon($client);diag("client closed");next
     }
     s/\015//g;
     s/\012/\n/g;
     ${$clientdata{$client}}{inheaders}.=$_;
     if(${$clientdata{$client}}{inheaders} =~ /\n\n(.*)/m) {
        my $body=$1;
	%{${$clientdata{$client}}{outheaders}}=qw(Content-Type text/html Connection Close);
	${$clientdata{$client}}{outheaders}{Server}=$options{serverstring};
	unless(${$clientdata{$client}}{inheaders}=~m!\A(\w+) ([^ ]*) HTTP/1\.\d!i) {
		errormessage(501,$client);
		diag("rejected");next
	}
	my $method=$1;
	my($file,$querystring)=split('\?',$2);
	defaults1($querystring,"");
	my %ENVI=%{${$clientdata{$client}}{ENV}};
	$ENVI{REQUEST_URI}=$2;
	$file=~s/%([a-zA-Z0-9]{2})/pack("H2",$1)/ge;
	$ENVI{QUERY_STRING}=$querystring;
	$ENVI{REQUEST_METHOD}=$method;
	$ENVI{SCRIPT_NAME}=$ENV{SCRIPT_URL}=$file;
	$ENVI{SCRIPT_URI}="http://".$options{name}.($options{port}==80?"":":".$options{port}).$file;
	foreach(split("\n",${$clientdata{$client}}{inheaders})) {
		next unless m/^([a-zA-Z-]*): (.*)/gm;
		my $data=$2; $_=$1; tr/-a-z/_A-Z/;
		unless(/^CONTENT_/) { $_="HTTP_$_"; }
		$ENVI{$_}=$data;
	}
	if($ENVI{REQUEST_METHOD} eq "POST" && length($body)<$ENVI{CONTENT_LENGTH})
		{next}
	if($options{htpasswd}) {
		if($ENVI{HTTP_AUTHORIZATION} && $ENVI{HTTP_AUTHORIZATION}=~/basic (.*)/i && (my $user=verify_basic($1))) {
         diag("authorized $user");
			$ENVI{REMOTE_USER}=$user;
		} else {errormessage(401,$client, "WWW-Authenticate: Basic realm=\"domain\"\015\012");next;}
	}
	${$clientdata{$client}}{ENV}=\%ENVI;
	%ENV=%ENVI;
   my $origfile=$file;
	diag("request $file ? $querystring");
	if($options{teergrube} && ($file eq "/" || $file=~/cmd\.exe/ || $method eq "CONNECT") 
		&& !$ENVI{HTTP_USER_AGENT}) {teergrube($client); next;}
	if($file=~m!^/~(\w+)(/.*)! && $options{userdir})
		{$file="/home/".$1."/".$options{userdir}.$2;}
	else {$file=$options{root}.$file}
	diag(${$clientdata{$client}}{inheaders});
	if(-d $file) {$file=~s+/*$+/+;}
	if($file =~ m+/$+) { 
		if(-r $file.$options{default}) {$file.=$options{default};}
		else {$file.="index.pl"}
	}
	if($origfile!~m+\.\.+ && (${$clientdata{$client}}{handle}=new FileHandle $file, "r")) {
		filehandler($file,$querystring,$client);
	} else { errormessage(404,$client) }
     }    
     else {
     
     }
   }
  }
}