#!/usr/bin/perl
#
# mhttpd: A personal web server for unix systems. 
# Author: Jerry LeVan (levan@eagle.eku.edu)
# Date:   March 25, 1996
# Ver:	  0.1
# Env:    Perl 5.002
#
# Note:   This program was directly inspired by Bob Diertens simple
#         cgi "Get" server for executables( aka bobd ). 
#         Bob's Address: <bobd@fwi.uva.nl> URL: http://www.fwi.uva.nl/~bobd/ 
#	  Another source of inspiration was Pratap Pereira's phttpd, Prataps
#	  address http://eewww.eng.ohio-state.edu/~pereira". I have shamelessly
#	  "borrowed" code from these two programs. They are entirely blameless
#         for any flaws in this code.
# Usage:
#       mhttpd {-p nnnn} {-c file} &  # read the documentation!!!
#
# WARNING:
#	I take no responsibility for any problems arising from the use
#	of this code. I have taken all of the steps that I know of to
#	ensure the reliability and security of the data that this program
#	can access, regretably there are many more persons that are much
#	more clever than I prowling the Net. If you find a security hole
#	please tell me, and I would greatly appreciate any hole plugging
#	infomation that you can provide.
# Version: 0.1
#
# User Configuration Section
#
require 5.0;
use Socket;
use Getopt::Std;

#If the following variable is defined and the -c option is
# not used, then $defaultConfigFile will be used.
$defaultConfigFile = "/home1/faculty/levan/cgiserver/mhttpd.conf";

getopt('pc');
$port = $opt_p if defined $opt_p ;

$opt_c = $defaultConfigFile if defined($defaultConfigFile) && !defined($opt_c);

print( "No Configuration file specified!\n"),exit(1) unless defined $opt_c ;
#unshift( @INC,$opt_c);
require $opt_c ;

$version = "0.1";
$program = "mhttpd";
# if this program has (zombie) problems try uncommenting this 
# and the waitpid command near the bottom of the main loop
#use POSIX "sys_wait_h";
#use POSIX "unistd_h";

open(LOG,">>$logfile") || die "Can't open log file" ;
select(LOG) ; $| = 1; select(STDOUT);

$port = $defaultport unless defined $port;

$login = getlogin || (getpwuid($<))[0] || "Intruder!" ; 
$0 = "mhttpd($login:$port)";  # new name for the "ps" program

# End of User Configuration Section
#
# Set up the mime types
$defaultmimetype = 'text/plain';
$EXT{'txt'}='text/plain';
$EXT{'html'}='text/html';
$EXT{'gif'}='image/gif';
$EXT{'jpeg'}='image/jpeg';
$EXT{'au'}='audio/basic';
$EXT{'snd'}='audio/basic';
$EXT{'mpeg'}='image/mpeg';
$EXT{'tiff'}='image/tiff';
$EXT{'xbm'}='image/xbm';

# Set up SIG vector
$SIG{'CHLD'} = 'IGNORE'; ### Warning, this won't work on some systems
$SIG{'KILL'} = "SigHandler";
$SIG{'TERM'} = "SigHandler";
$SIG{'QUIT'} = "SigHandler";
$SIG{'HUP'} = "SigHandler";


# Initialize port, standard perl server boilerplate
$sockaddr = 'S n a4 x8';
($name, $aliases, $proto) = getprotobyname('tcp');
$thisport = pack($sockaddr, &AF_INET, $port, "\0\0\0\0"); # wildcard addr

socket(S, &PF_INET, &SOCK_STREAM, $proto)
			|| die "can't create socket: $!\n";
setsockopt(S, &SOL_SOCKET, &SO_REUSEADDR, pack('i', 1))
			|| die "can't setsockopt: $!\n";
bind(S,$thisport)
			|| die "can't bind socket: $!\n";
listen(S,5)
			|| die "can't listen to socket: $!\n";

# Don't show the environment of the invoker of this server.
#undef %ENV; 
foreach $key (keys %ENV) {
   delete $ENV{$key};
}



# Become a daemon, grrr none of this seems to work with linux
# start daemon with "mhttp -c file  &" See the documentation!

#if(POSIX::setsid() == -1){ print LOG "Cannot set pgrp: $!\n"};
#setpgid(0,$$);
$SIG{'HUP'}='IGNORE';
close STDIN; close STDOUT; close STDERR;
#if(POSIX::setsid() == -1){ print LOG "Cannot set pgrp: $!\n"};

print LOG &timestamp, " Starting mhttpd on port $port\n";

# Answer if someone knocks on the port.
for (;;) {
  
  if(!accept(NS,S)) {
     print LOG "Accept Failure, shutting down mhttpd, error: $!\n";
     exit 1;
  }

  if(($child =fork()) == 0) {
    # this is the child

    # Set the environment and get the method and command
    ($method,$command) = SetupCommand(NS); 

    # Check to see if they can access the server.
    if(!CheckAccess($ENV{REMOTE_ADDR},@accesslist)) {
       &ErrorMessage(NS,400,"Access Denied");
       exit 0; # Bail out
    }

    # Check to see if the caller is explicitly denied access to the server.
    if(CheckAccess($ENV{REMOTE_ADDR},@denylist)) {
       &ErrorMessage(NS,400,"Access Denied");
       exit 0; # Bail out
    }

    if($method eq 'GET'){
         &ProcessGet(NS,$command);  # NS closed by sub
    }
    elsif($method eq 'POST') {
         &ProcessPost(NS,$command); # NS closed by sub
    }
    else { # I wish I knew what HEAD does?
	&ErrorMessage(NS,400,"Bad Request.");
    }
    exit 0;  #kill child
  }
  else {
    #parent code...some systems will have to worry about waiting
    close NS ;
#    waitpid(0,&WNOHANG); ### not available on all systems 
   }
}

# Invoke "ident" protocol to try to get remote user id. (from bobd) 
sub get_userid {
    my($connected_socket) = $_[0];

    my $auth_port = 113;

    my ($remote_port, $remote_ip_addr) =
	    (unpack($sockaddr, getpeername($connected_socket)))[1..2];

    my $local_port = (unpack($sockaddr, getsockname($connected_socket)))[1];

    socket(AUTH, &PF_INET, &SOCK_STREAM, $proto);
    my $old_fh=select(AUTH);
    $|=1;
    select($old_fh);
    my $auth_addr = pack($sockaddr, &AF_INET, $auth_port, $remote_ip_addr);
    connect(AUTH, $auth_addr) || return "no-connect";
    print AUTH "$remote_port, $local_port\r\n";
    my $answer = <AUTH>;
    close AUTH;

    my ($ports, $response_type, $remote_os, $remote_user) =
  	   split(/\s*:\s*/, $answer);
    if ($response_type ne "USERID") {
	return "no-userid";
    }
    $remote_user =~ s/\s*\n//g;
    return $remote_user;
}
#
# Grab a line without using buffered input... Important for
# Post methods since they have to read the stream.
#
sub readline {
  my $fd = $_[0];
  my $ch;
  my $string='';
  alarm 120 ;	# prevent deadly spin if other end goes away
  for(;;){
    if(sysread($fd,$ch,1)){ # returns undef or 1
     $string .= $ch unless $ch eq "\r"; # skip <cr>
     last if $ch eq "\n";
    }
  }
  alarm 0;    # clear alarm
  return $string;
}

sub sendfile {
   my ($fd,$file)=@_;
   local *DF;  # can't use my on type globs
   my $buffer;

# resist attempts to move up the directory tree
    $file=~s/((\.\.\/)|(\/\.\.$)|(\/\.$))//g;
    $file =~s/\/\.$//g;

    if (( -d $file) && (-f "$file/$default")) {
         $file = "$file/$default"; # directory specified and default file was present
     }
    if ( -d $file ) { #directory specified and default file not present
      &PrintDirectory($fd,$file); # fd closed there
      return;
    }

    if (open(DF,"<$file"))
    {
       my ($n,$e)=split(/\./,$file);
         print $fd "HTTP/1.0 200 OK\n";
         if(defined $EXT{$e}){
           print $fd "Content-type: $EXT{$e}\n\n";
         }
         else {
           print $fd "Content-type: $defaultmimetype\n\n";
         }
#	while (<DF>)
#	{	     
#	    print $fd $_;
#	}
        while(read(DF,$buffer,2*1024)) { # may be easier if binary file
            print $fd $buffer;
        }
    }			       
    else			
    {
	&ErrorMessage($fd,404,"The requested file was not found.");
    }
    close DF;
    close $fd;
}

# Ugly code to process a GET request.
sub ProcessGet {
 my ($fd,$command) = @_;
 my $args;

 ErrorMessage($fd,404,"The requested file was not found.")
      if $command =~ m#^cgi-bin(/)?$# ; # don't let'em look at cgi-bin

 if($command =~ /^cgi-bin/){ # rewrite command
    $command = $ENV{SCRIPT_NAME};
    $command =~s#^/##; # strip leading slash
 }

 $command =~ s#/$##g ; #strip trailing slashes
 $command=~s/((\.\.\/)|(\/\.\.$)|(\/\.$))//g;  # try to take out ../ etc...
 $command =~s/\/\.$//g;

 # check and process a "cgi-bin" type command
 if($command =~ /^cgi-bin/){
   $command =~s/^cgi-bin//;
   if($ENV{QUERY_STRING} =~/=/ || $ENV{QUERY_STRING} eq "") { # It's not a query
        @output = `/$cgibin$command` ;  # This is scary...
   }
   else { # NCSA's imagemap and other query's expect command line args
       @output = `/$cgibin$command \'$ENV{QUERY_STRING}\'` ;  # This is scary...
   }
   # check first line for a relocation request.
   if ($output[0] =~ /Location:/i){
      $output[0] =~ s#Location:\s*/#"Location: http://$ENV{SERVER_NAME}:$ENV{SERVER_PORT}/"#ei;
      print $fd "HTTP/1.0 302 OK\n"; # This is a relocation return
   }
   else {
     print $fd "HTTP/1.0 200 OK\n";  # Everything else until something bad happens
   }   
   # return output of command to client
   print $fd @output;
  }
  else { # Process a non-cgi-bin GET request
   $command = $default if $command eq '' ;
   &sendfile($fd,"$root/$command");
  }
  close($fd);
} 

# Process a POST request
sub ProcessPost {
 my($fd,$command) = @_;

    if($command =~ /^cgi-bin/){ # rewrite command
       $command = $ENV{SCRIPT_NAME};
       $command =~s#^/##; # strip leading slash
    }
     $command =~s/^cgi-bin//;  # erase cgi-bin if present
     $command =~ s#/$##g ; #strip trailing slashes

     # resist attempts to move up the directory tree.
     $command=~s/((\.\.\/)|(\/\.\.$)|(\/\.$))//g;
     $command =~s/\/\.$//g;
# Many of these comments must be reactivated if you want to leave
# STDIN and STDOUT open in the "main" program.
#     open(SAVEOUT,">&STDOUT") || die "saving stdout";
#     open(SAVEIN, "<&STDIN")  || die "saving stdin" ;
#     close(STDIN);
#     close(STDOUT);
     
#redirect stdin and stdout to the open socket so the
# requested service can properly function.
     $inputstr = "<&".fileno($fd);
     $outputstr = ">&".fileno($fd);
     open(STDIN,$inputstr) || die "open stdin"; # need to use LOG here
     open(STDOUT,$outputstr)|| die "open stdout"; # but no reason to ever get an error
     select(STDIN); $|=1;
     select(STDOUT);$|=1;

     #execute the command!
     @output = `$cgibin$command`;

     # return the output to the caller
     print STDOUT "HTTP/1.0 200 OK\n";  # is this needed? (Yes)
     print STDOUT @output;
     close(STDIN); 
     close (STDOUT);
#     open(STDIN,"<&SAVEIN");
#     open(STDOUT,">&SAVEOUT");
#     close(SAVEIN);
#     close(SAVEOUT);
     
    close $fd;
}

sub Parse { # set useful cgi environmental variables
 my $command=$_[0];
 my ($a,$b,$c);
  if ($command =~/^cgi-bin/) {
    ($a, $b, $c ) = split('/',$command,3);
    if (defined $b) { # There was a slash after cgi-bin, if thats all there is
    		      # then it does not matter cuz they want a dir listing
    		      return if length($b) == 0;
    		      $ENV{SCRIPT_NAME} = "/cgi-bin/$b";
	            }
    if (defined $c) { # there was a slash after the scriptname
    		      $ENV{PATH_INFO} = "/$c";
    		      $ENV{PATH_TRANSLATED}="$root/$c";
	            }
  }
}

# Sets many enviromental variables, processes prolog from client
# and returns $method and $command to main loop
sub SetupCommand {

    my $sock= $_[0];
    my @accept =();
    my $args ;
    my $inp ;
    my ($method,$command);

    #Get first line from client
    chomp($inp = &readline($sock));

    $inp =~ /^([A-Z]*) \/(.*) (\w*)\/(\d*\.\d*)/;
	# We should check if the match failed!
    $method = $1;
    my $commandline = $2;
    my $protocol = $3;
    my $protocol_version = $4;
    if ($commandline =~ /(.*)\?(.*)/) { # it's a query/form request
	$command = $1;
	$args = $2;
    } else {
	$command = $commandline;
	$args = '';
    }
    # to be safe, quote shell metacharacters
    $command =~ s/([;<>\*\|`&\$!#\(\)\[\]\{\}:'"])/\\$1/g;

    Parse($command);

    $ENV{SERVER_SOFTWARE} = "$program/$version";
    my $rem_ip_addr = (unpack($sockaddr, getsockname($sock)))[2];
    $ENV{SERVER_NAME} = (gethostbyaddr($rem_ip_addr, &AF_INET))[0];
    $ENV{GATEWAY_INTERFACE} = "CGI/1.1";
    $ENV{SERVER_PROTOCOL} = "$protocol/$protocol_version";
    $ENV{SERVER_PORT} = "$port";
    $ENV{REQUEST_METHOD} = "$method";
    $ENV{QUERY_STRING} = $args;
    $rem_ip_addr = (unpack($sockaddr, getpeername($sock)))[2];
    $ENV{REMOTE_HOST} = (gethostbyaddr($rem_ip_addr, &AF_INET))[0];
    $ENV{REMOTE_ADDR} = join(".", unpack("C4", $rem_ip_addr));
    $ENV{REMOTE_IDENT} = &get_userid($sock);
    print LOG &timestamp," $inp From:$ENV{REMOTE_ADDR} User:($ENV{REMOTE_IDENT})\n";

    for(;;){ # read until we get a blank line
      chomp($string = &readline($sock));
      print LOG &timestamp, " $ENV{REMOTE_ADDR} id:$$  PROLOG: $string\n" if $verbose == 1;
      last if $string eq "";
      $ENV{'CONTENT_LENGTH'}= (split(':',$string))[1] 
         if $string =~ /Content-Length:/i;
      (undef,$ENV{'CONTENT_TYPE'})=split(" ",$string) 
         if $string =~ /Content-type:/i;
      push(@accept,(split(':',$string))[1])
         if $string =~ /Accept:/i;
    }
    $ENV{'HTTP_ACCEPT'} = join(",",@accept) if $#accept >= 0;
    return ($method,$command);
}

# Generate a 'clickable' directory listing
sub PrintDirectory {
 my ($fd,$dir) = @_;
 my ($file,$filelist);
 local *DIR;

  opendir(DIR,$dir );
  @filelist = readdir(DIR); #slurp files

# Check to see if directory is accessible
ErrorMessage($fd,401,"Access Denied"),exit 0 if grep($_ eq $private, @filelist); 

#print the prolog
print $fd  "HTTP/1.0 200 OK\n";
print $fd  "Content-type: text/html\n\n";
print $fd "<HTML><BODY><H1>Index of Directory</H1>\n";
print $fd "<PRE>     Name                       Last Modification         Size     \n";
print $fd "<HR>\n";

for $file (@filelist) {
  next if $file =~ /^(\.|\.\.)$/;
  $size = -s "$dir/$file";
  $type = &GetType("$dir/$file");

  printf $fd "[%s] <A NAME=\"%s\" HREF=\"%s\">%s</A>", $type,$file,$file,$file;
  print $fd " " x (30 - (6+length($file)));
  print $fd scalar(localtime((stat("$dir/$file"))[9])) ;
  printf $fd "%8d\n", $size;
}
closedir(DIR);
print $fd "</PRE></BODY></HTML>\n";
close($fd);
}

# Get kind of directory entry
sub GetType {
  my $file = $_[0];
  return "dir" if -d $file;
  return "txt" if  -T $file;
  return "bin" if -B $file;
  return "unk" ;
}

# Print an error message to the client
sub ErrorMessage {
 my($fd,$error,$message) =@_;
 print $fd  "HTTP/1.0 200 OK\n";
 print $fd  "Content-type: text/html\n\n";
 print $fd "<HTML><TITLE>Error Message</TITLE><BODY>";
 print $fd "<H1>Error $error</H1>";
 print $fd "<HR>\n";
 print $fd $message;
 print $fd "<HR></BODY></HTML>\n";
 close($fd);
}

# Match client IP against access lists, returns true if match else false
sub CheckAccess {
   my ($who,@list) = @_;
   my $pattern;
   foreach $pattern (@list) {
     $pattern =~ s/\./\\./g ; # replace . by \.
     $pattern =~ s/\*/\\d\+/g; # replace * by \d+ 
     return 1 if $who =~ /$pattern/;
   }
   return 0;	# search failed
}

# Generate a time stamp for the log files...
sub timestamp {
    my @months =("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep",
                "Oct","Nov","Dec");
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime(time);
    sprintf("[%02u/%s/%02u:%02u:%02u:%02u]",$mday,$months[$mon],$year,
            $hour,$min,$sec);
}

# Interupt handler for shutting down
sub SigHandler {
   my $sig =$_[0];
   print LOG &timestamp ," Caught signal SIG$sig, mhttpd shutting down.\n";
   exit 1;
}
