#!/usr/bin/perl -w
# Filename:	httpdave
# Author:	David Ljung Madison <DaveSource.com>
# See License:	http://MarginalHacks.com/License/
my $VERSION=	1.0;
# Description:	A simple web server
use strict;
use Socket;
use IO::File;

# #########################
# Changelog
# #########################
# Need to thread/fork/whatever?
# Because right now it can only serve one request at a time.
#
# 2012-12-01: v0.9
# Cleaned up CGI code (now does chdir)
# Fixed 301 moved (now 'a' -> 'a/' works properly)
#
# 2005-01-27: v0.8
#	shtml (Server Side Includes) support!
# Small mime-types fix
#
# 2004-10-24: v0.7
#	Cookie support
#
# 2004-04-19: v0.6
#	Better mime-types handling
#
# 2003-05-19: v0.5
#	Environment vars, other stuff
#
# ??: v 0.4
#	Real POST support, lots of other stuff
#
# 2000-06-23: v 0.3
# Handles paths and default path safely
# Added support for images
#	Added directory listings (with sorting!)
#
# --------------------------------------------
# - Taken over by Dave http://DaveSource.com -
# --------------------------------------------
#
# Original:	pure perl httpd. (c) Paul Tchistopolskii 1998, 99
# 		http://www.pault.com  e-mail: paul@qub.com
#
# 1998-04-29: v0.2
#	'Support' for 'POST'. It was useful for debugging uploads.
#
# 1998-11-27: v0.1
# Supports only .htm(l) and .cgi in one directory
# Not all ENV's are set. No 'index.html'. Only 'GET' yet.
#

##################################################
# Variables
##################################################
my $PORT	= $ARGV[0] || 3001;
my $HOSTNAME = $ARGV[1] || `hostname`;	chomp $HOSTNAME;
my $DOMAIN	= "$HOSTNAME:$PORT";
my $ROOT	= '.';
my $PERL	= '/usr/bin/perl';
my $ICONS	= "/icons";
my @DEFAULT_FILES = qw(index.html index.shtml index.cgi index.htm);
my $HTML = '\.s?html?$';
my $BUFSIZE	= 512;

chdir $ROOT || die("Couldn't go to root directory [$ROOT]\n");
$ROOT = `pwd`;
chomp($ROOT);

# Setup ENV variables
my $path = $ENV{PATH};	# Save path?
my $home = $ENV{HOME};
#my $path = "/sbin:/usr/sbin:/bin:/usr/bin";	# Or, use this - more secure
undef %ENV;
$ENV{PATH} = $path;
$ENV{DOCUMENT_ROOT} = $ROOT;
$ENV{HTTP_HOST} = $HOSTNAME;
$ENV{SERVER_ADDR} = $HOSTNAME;	# Should be I.P. number, actually
$ENV{SERVER_NAME} = $HOSTNAME;
$ENV{SERVER_PORT} = $PORT;
$ENV{SERVER_SOFTWARE} = "$0 $VERSION";
$ENV{SERVER_SIGNATURE} = "<ADDRESS>$ENV{SERVER_SOFTWARE}</ADDRESS>\n";
$ENV{SERVER_PROTOCOL} = "HTTP/1.0";	# I must confess I don't know if it's 1.1..

# Example variables for SUPERKLUDGE rename testing below
my $SUPERKLUDGE=0;	# currently off, so don't worry about it.. (always off for .shtml)
my @DOMAINS = qw(Daveola DavidLjung GetDave DaveSource GetBert GetMadison DavePics DaveFAQ SaintVitus EveryScene DaveDomain imwriter ParkerLjung);

# Where mime types are kept
my $MIME_TYPES = '/usr/local/lib/mime-types';
   $MIME_TYPES = '/usr/lib/mime-types' unless -r $MIME_TYPES;
   $MIME_TYPES = '/etc/mime-types' unless -r $MIME_TYPES;
   $MIME_TYPES = '/etc/mime.types' unless -r $MIME_TYPES;
   $MIME_TYPES = "$home/.mime-types" unless -r $MIME_TYPES;
   $MIME_TYPES = "$home/.mime.types" unless -r $MIME_TYPES;

# Other types not found in mime-types
my $EXTRA_MIME_TYPES = <<END_EXTRA_MIME_TYPES;
	cgi	text/html
	htm	text/html
	html	text/html
	shtm	text/html
	shtml	text/html
	gif	image/gif
	jpeg	image/jpeg
	jpg	image/jpeg
	JPG	image/jpeg
	css	text/css
	mpe	video/mpeg
	mpg	video/mpeg
	mpeg	video/mpeg
	mov	video/quicktime
	avi	video/x-msvideo
	swf	application/x-shockwave-flash
	rdf	application/rdf+xml
	rss	application/rss+xml
	js application/javascript
END_EXTRA_MIME_TYPES


##################################################
# Code
##################################################
$|=1;

#########################
# Mime types
#########################
my %MIME_TYPES;
sub init_types {
  if (open(MIME_TYPES,"<$MIME_TYPES")) {
    while (<MIME_TYPES>) {
      chomp;
      s/#.*//;
      next unless /\S/;
      my ($post,$type) = split(/\s+/,$_,2);
      $MIME_TYPES{$post} = $type unless $MIME_TYPES{$post};
    }
    close MIME_TYPES;
  }

  foreach ( split(/\n/,$EXTRA_MIME_TYPES) ) {
    s/^\s+//;
    s/#.*//;
    next unless /\S/;
    my ($post,$type) = split(/\s+/,$_,2);
    $MIME_TYPES{$post} = $type unless $MIME_TYPES{$post};
  }

}
init_types();

sub type {
  my ($post) = @_;
  $post =~ s/.*\.//;
  $MIME_TYPES{$post} || "text/plain";
}

#########################
# Errors
#########################
sub logmsg { print STDERR scalar localtime, ": $$: @_\n"; }

# Just close our output end of the pipe so whatever we were doing will stop
sub broken_pipe { my ($sig) = @_; close STDOUT; }
$SIG{'PIPE'} = 'broken_pipe';

my %codes = (
	'200', 'OK',
	'201', 'Created',
	'202', 'Accepted',
	'204', 'No Content',
	'301', 'Moved Permanently',
	'302', 'Moved Temporarily',
	'304', 'Not Modified',
	'400', 'Bad Request',
	'401', 'Unauthorized',
	'403', 'Forbidden',
	'404', 'Not Found',
	'500', 'Internal Server Error',
	'501', 'Not Implemented',
	'502', 'Bad Gateway',
	'503', 'Service Unavailable',
);

sub logerr ($$$) { 
  my ($code, $detail, $extra) = @_;
  my $msg = "$code " . $codes{$code};
  logmsg "".($extra||$detail)." : $msg";

  print "HTTP/1.0 $msg\n";
	print "Content-type: text/html\n" unless $code==301;
	print "Session-ID: ".sessionID()."\n";
  print "Server: HttpDave/$VERSION\n";
  print "$extra\n" if $extra;
  print "\n";
  print "<I>HttpDave</I> : $detail : $msg\n";
}

#########################
# Requests
#########################
my $SHTML_ERR = undef;
# http://httpd.apache.org/docs/mod/mod_include.html
sub shtml {
  my ($file,$url,$element,$attr,$Val) = @_;
  my $val = $Val;
  $val =~ s/^["'](.*)["']$/$1/g;

  if ($element eq "exec" && $attr eq "cmd") {
    chdir $1 if $file =~ m|^(.+/)[^/]+$|;
    my $out = `$val`;
    chdir $ROOT || die("Couldn't go to root directory [$ROOT]\n");
    return $out || "";
  }

  return $ENV{$val} if $element eq "echo" && $attr eq "var";

  if ($element eq "include" && ($attr eq "file" || $attr eq "virtual")) {
    flush_out();	# Kludge: Need to flush STDOUT first
    my $include = $val;

    if ($attr eq 'file') {
      $include =~ s#(^|/)\.\.(/|$)#/#g;	# No '..' in path
      my $dir = ($file !~ m|^(.+/)[^/]+$|) ? '.' : $1;
      $include = "$dir/$include";
      $include =~ s|/+|/|g;
    } else {
      my $path = $url =~ (m|(.+)/[^/]+$|) ? $1 : '/';
      $include = "$path/$include" unless $include =~ m|^/|;
      ($include, undef) = clean_url($include);
    }
    dump_file($include);
    return "";
  }

  return last_mod($val) if $element eq "flastmod" && $attr eq "file";

  if ($element eq "config" && $attr eq "errmsg") {
    $SHTML_ERR = $val;
    return "";
  }

  # Unsupported shtml constructs:
  #   <!--#set var="name" value="Rich" -->
  #   <!--#if expr="test_condition" -->
  #   <!--#elif expr="test_condition" -->
  #   <!--#else -->
  #   <!--#endif -->
  #   <!--#config timefmt="%D" -->
  #   fsize file/virtual
  #   <!--#printenv-->
  if (grep($element eq $_, qw(set if elif else endif config fsize printenv))) {
    return "[unsupported shtml directive: $element]";
  }

  return $SHTML_ERR || "[an error occurred while processing this directive: $element, $attr=$val]";
}

sub flush_out {
  my $sel = select(STDOUT);
  my $save = $|; $|=1; $|=$save;
  select($sel);
}

sub sessionID() {
	my $s = "sessID:httpdave:";
	map { $s .= sprintf("%0.4x",rand(0xffff)) } (1..8);
	print "$s\n";
}

sub dump_file ($$$) {
  my ($file,$url,$args) = @_;

  my $type = type($file);
  if ($type && $url) {
    print "HTTP/1.0 200 OK\n";
		print "Session-ID: ".sessionID()."\n";
    print "Content-type: $type\n\n";
  }

  #my $search = $1 if ($type =~ /text/ && $args =~ m|\?/=(.+)|);

  my $in = new IO::File;

  $in->open("< $file") || return 0;
  my $ssi = ($file =~ /\.shtml?$/) ? 1 : 0;

  # Handle normal files.  Just dump them.
  if (!$ssi && !($SUPERKLUDGE && $url)) {
## I don't use this, although it only happened if $search was defined and only until the search was found..
#    # Search hack.  You can automatically jump to any regexp in a page
#    # with this weird ugliness:   page.html?/=<regexp>#/
#    if (defined $search) {
#      while (<$in>) {
#        if (/($search)/) {
#          # Actually - we should make sure we aren't in an html tag.  Rats.
#          print "$`<a name=/><blink>$1</blink></a>$'";
#          last;
#        }
#        print;
#      }
#    }

    my $a;
    flush_out();	# Kludge: Need to flush STDOUT first
    # Fast.
    while (sysread($in,$a,$BUFSIZE)) {
      last unless syswrite(STDOUT, $a);
    }
    $in->close;
    return 1;
  }

  # Handle Server Side Includes
  if ($ssi) {
    # shtml environment vars
    $ENV{DOCUMENT_NAME} = ($file =~ m|.*/([^/]+)$|) ? $1 : $file;
    $ENV{LAST_MODIFIED} = last_mod($file);
    # Not including: DATE_GMT, DATE_LOCAL, DOCUMENT_URI, USER_NAME
    while (<$in>) {
      # Not quite right, doesn't handle multi-lines
      s/<!--#(\S+)\s+(\S+)=(.+)-->/shtml($file,$url,$1,$2,$3)/eg;
      print;
    }
    $in->close;
    undef $SHTML_ERR;
    return 1;
  }

  # Superkludge.  Weirdness for just my setup...
  while (<$in>) {
#    # Search support in SUPERKLUDGE format
#    if (defined $search && /($search)/) {
#      print "$`<a name=/><blink>$1</blink></a>$'";
#      undef $search;
#      next;
#    }
    # Dave kludges
    # Look for href=/... and try to fixup fake domain
    if (/href=\//) {
      my ($pre,$post) = ($`,$');
      # Assume domain is current URL directory
      my $domain = $url;  $domain =~ s|(.)/.*|$1|;
      $_ = $pre."href=".$domain."/".$post;
    }
    s|http://63\.204\.157\.4||ig;
    my $re;
    # Convert specific domains to local directories
    foreach $re ( @DOMAINS ) {
      $re = lc($re);
      s|http://(www\.)?$re\.com|/$re\.com|ig;
    }
    print;
  }

  $in->close;

  return 1;
}

# Sort the directory contents
# Pointers: [$file,$img,$alt,$mod,$size]);
sub dir_contents {
  my ($dir,$method) = @_;

  # By last mod
  if ($method eq "M") {
    return $a->[3] <=> $b->[3] unless ($a->[3] == $b->[3]);
  }

  # By size
  if ($method eq "S") {
    return $a->[4] <=> $b->[4]
      unless (-d "$dir/$a->[0]" || -d "$dir/$b->[0]" || $a->[4] == $b->[4]);
    return -1 if (-d "$dir/$a->[0]" && ! -d "$dir/$b->[0]");
    return 1 if (! -d "$dir/$a->[0]" && -d "$dir/$b->[0]");
  }

  # By name
  return $a->[0] cmp $b->[0];
}

sub do_cgi {
  my ($cgi,$method,$url,$info) = @_;
  # Setup the variables
  $ENV{SCRIPT_URI} = "http://$DOMAIN/$cgi";	# Kludgy..
  $ENV{SCRIPT_URL} = $url;
  $ENV{SCRIPT_NAME} = $cgi;
  $ENV{SCRIPT_FILENAME} = $cgi;	# Should be abs path
  my $dir;
  $dir = ($cgi =~ s|(.*/)||g) ? $1 : '.';

  # Setup the input (if any)
  my ($run,$ret,@res);
  if ($method eq "POST") {
    my $data;  read STDIN,$data,$info->{'CONTENT-LENGTH'};
    $run = "echo \Q$data\E | $cgi";
  } else {
    $run = $cgi;
  }

  # Run it
  chdir $dir;
  $! = 0;
  @res = `$run`;
  $ret = $?;
  chdir $ROOT;

  # Check the results
  return 0 if $ret & 127;
  logmsg "Sending results...";
  if (@res && $res[0] =~ /^Location:\s/) {
    print "HTTP/1.1 301 Moved Permanently\n";
  } else {
    print "HTTP/1.0 200 OK\n";
  }

# More info to print?? (http/1.1?)
#HTTP/1.1 200 OK
#Date: Sun, 02 Jul 2000 02:25:17 GMT
#Server: httpdave/$version (Unix)
#Connection: close
  print @res;
  1;
}

sub cat_directory($$$) {
  my ($dir,$url,$args) = @_;

  print "HTTP/1.0 200 OK\n";
  print "Content-type: text/html\n\n";

  my $sort_by = ($args =~ /^\?(.)/) ? $1 : "N";

  my $blank = (-f "$ICONS/blank.gif") ? "<IMG SRC=\"$ICONS/blank.gif\" ALT=\"     \">" : "     ";

  my $pdir = "<a href=/>/</a>";		# Print directory, broken down
  if ($dir ne ".") {
    my @dir = split("/",$dir);
    my @tmp;
    foreach my $d ( @dir ) {
      push(@tmp,$d);
      $pdir .= "<a href=/".join("/",@tmp)."/>$d</a>/";
    }
  }

  print <<END_OF_DIR_HEADER;
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">
<html>
 <head>
  <title>Index of $dir</title>
 </head>
 <style type="text/css">
body {
font-size: 12px;
font-family: Lucida console, Courier New, monospace;
background-color: Window;
color: black;
}

a:link, a:visited {
background-color: transparent;
text-decoration: none;
color: #009;
}

table {
border: 0;
border-spacing: 0;
font-size: 13px;
border-collapse: collapse;
border-bottom: 1px solid Scrollbar;
}

td {
vertical-align: top;
white-space: nowrap;
border-right: 1px solid Scrollbar;
border-left: 1px solid Scrollbar;
padding-left: 1em;
padding-right: 1em;
padding-bottom: 1px;
}

.nameh, .typeh, .sizeh, .timeh {
background-color: Scrollbar;
font-family: Verdana, Arial, sans-serif;
font-size: 12px;
padding-left: 1em;
padding-bottom: 2px;
}

.timeh, .sizeh {
text-align: center;
}

.size {
text-align: right;
}
 </style>
 <body>
<p>$pdir</p>
<table>
  <tr>
    <td class="nameh">$blank <a href="?N=D">Name</a></td>
    <td class="timeh"><a href="?M=A">Last modified</a></td>
    <td class="sizeh"><a href="?S=A">Size</a></td>
    <td class="typeh"><a href="?D=A">Description</a></td>
  </tr>

END_OF_DIR_HEADER


  # Get all the filenames (ignore .files)
  opendir(DIR, $dir) || return logerr 403,"Can't read directory $dir: $!",undef;
  my @files = grep(!/^\./, readdir(DIR));
  closedir DIR;

  # Build up the file information for the directory listing
  my @file_info;
  foreach my $file ( @files ) {
    my ($img,$alt) = ("unknown.gif","&nbsp;&nbsp;&nbsp;");
    ($img,$alt)=("image2.gif","img") if ($file =~ /\.(gif|jpe?g|tiff?)$/);
    ($img,$alt)=("text.gif","TXT") if ($file =~ /\.s?html?$/);
    ($img,$alt)=("compressed.gif","&nbsp;&nbsp;&nbsp;") if ($file =~ /\.(g?z|Z)$/);
    ($img,$alt)=("folder.gif","DIR") if (-d "$dir/$file");

#    # Last modified
#    my $mod=(stat("$dir/$file"))[9];

    # Size
    my $size=(stat(_))[7];

    push(@file_info, [$file,$img,$alt,last_mod(),$size]);
  }

  my $parent = ["..","back.gif","DIR",last_mod("$dir/.."),(stat(_))[7]];

  # Sort
  @file_info = sort { dir_contents($dir,$sort_by) } @file_info;

  # Print it out
  foreach my $finfo ( $parent, @file_info ) {
    my ($file,$img,$alt,$last_mod,$size) = @$finfo;

    my $name=$file;  $name="Parent Directory" if ($file eq "..");
    $name=substr($name,0,30)."..>" if length($name)>33;
    my $type = ((-f "$ICONS/$img") ? "<IMG SRC='$ICONS/$img' ALT='[$alt]'> " : "[$alt] ");
    my $url = $file;  $url .= "/" if -d "$dir/$url";

    # Size
    $size=int($size/1024) || 1;
    my $unit="k";
    ($size,$unit)=(int($size/1024),"M") if ($size > 1024);
    ($size,$unit)=(int($size/1024),"G") if ($size > 1024);
    #printf "%6s", (-d "$dir/$file") ? "-" : $size.$unit;
    $size = (-d "$dir/$file") ? "-" : $size.$unit;

    # Print
    print <<END_DIR_ENTRY;
  <tr>
    <td class="name">$type <a href='$url'>$name</a></td>
    <td class="time">$last_mod</td>
    <td class="size" align="right">$size</td>
    <td class="type">&nbsp;</td>
  </tr>
END_DIR_ENTRY
  }

  print "</table>\n</body>\n</html>\n";
  return 1;
}

my $tcp = getprotobyname('tcp');
socket(Server, PF_INET, SOCK_STREAM, $tcp)      || die "socket: $!";
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
                                pack("l", 1))   || die "setsockopt: $!";
bind(Server, sockaddr_in($PORT, INADDR_ANY))    || die "bind: $!";
listen(Server,SOMAXCONN)                        || die "listen: $!";

logmsg "server started on port $PORT [hostname $HOSTNAME]";

my $addr; my @inetaddr;

sub clean_url {
  my ($path) = @_;
  my $args = "";

  # Remove ?args (the second one is for intra-file searching)
  ($path,$args)=($`,$1) if ($path =~ m|([\?&][^/]+)$| || $path =~ m|(\?/=[^/]+)|);

  # Remove all // and /./
  #$path="/$path";       # Temporarily make matches easier
  while ($path =~ s|/\.?/|/|) {}
  $path =~ s|/\.$||;

  # Remove all */dir/../*
  while ($path =~ s|/[^/]+/\.\./|/|) {}
  # SECURITY:  Make sure we didn't have too many /../
  # Example:   /bob/../../../../../../etc/passwd
  $path =~ s|^/\.\./|/|;		# /../blah  -> /blah
  $path = "/" if $path eq "/..";	# /..       -> /
  $path =~ s|[^/]+/\.\.$||;		# */some/.. -> *

  # SECURITY:  Remove any leading /
  $path =~ s|^/||g;

  $path = $path || ".";

  # We need to redirect them if they asked for a directory and didn't
  # specify the end '/' (otherwise they won't know how to resolve links)
  if (-d $path && $path !~ m|/$| && $path ne ".") {
    logerr 301,"The document has moved <a href='http://$DOMAIN/$path/'>here</a>.","Location: http://$DOMAIN/$path/";
    return undef;
  }

  return ($path,$args) unless -d $path;

  # Default file (index.html)
  foreach my $def ( @DEFAULT_FILES ) {
    return ($path."/$def",$args) if -f "$path/$def";
  }

  ($path,$args);
}

sub last_mod {
  my ($file) = @_;
  my $mod = $file ? (stat($file))[9] : (stat(_))[9];
  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($mod);
  $mon=(qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon];
  sprintf("%0.2d-$mon-%s %0.2d:%0.2d ",$mday+1,$year+1900,$hour,$min);
}


sub newConnection {
	my ($addr) = @_;
  my($undef, $undef2, $inetaddr) = unpack('S n a4 x8', $addr);
  @inetaddr = unpack('C4', $inetaddr);

  logmsg "incoming connection from: " , join(".", @inetaddr);

  *STDIN = *Client;
  *STDOUT = *Client;

  $_ = <STDIN>;
	return unless defined $_;
#print STDERR "HD0: $_";
  my ($method, $url, $proto, $garbage) = (split, "","","","","");
  my %info;
  while ( <STDIN> ) {
    last if (/^\s*$/);
    s/[\r\n]//g;
    $info{uc($1)} = $2 if (/^(\S+):\s*(.*)$/);
#print STDERR "HDR: $_\n";
  }

  if ($garbage ne '') { 
    logerr 400, $_,undef;
  } else {
    $url =~ s/%([\dA-Fa-f]{2})/chr(hex($1))/eg; # unescape.
    logmsg "Req: mthd=$method, url=$url, prot=$proto";

    if ($method ne 'GET' && $method ne 'POST') {
      logerr 501, $method,undef;
    } else {

    	undef $ENV{DOCUMENT_NAME};
    	undef $ENV{LAST_MODIFIED};
      $ENV{QUERY_STRING} = "";
#      if ($url =~ /(.*)\.cgi\?(.*)/) {
#        $url = "$1.cgi";
#        $ENV{QUERY_STRING} = $2;
#      }
      ($url,$ENV{QUERY_STRING}) = ($1,$2) if $url =~ /(.*)\?(.*)/;

      my ($file,$args) = clean_url($url);

      if ($file) {
      	$ENV{REQUEST_URI}     = $url;
      	$ENV{SERVER_PROTOCOL} = $proto;
      	$ENV{REQUEST_METHOD}  = $method;
      	$ENV{REMOTE_ADDR}     = join('.', @inetaddr);
      	$ENV{REMOTE_HOST}     = join('.', @inetaddr);
      	$ENV{HTTP_USER_AGENT} = $info{'USER-AGENT'}; # if defined $info{'USER-AGENT'};
      	$ENV{HTTP_REFERER}    = $info{REFERER}; # if defined $info{REFERER};
      	$ENV{HTTP_COOKIE}     = $info{COOKIE}; # if defined $info{COOKIE};
#print STDERR "COOKIE: $ENV{HTTP_COOKIE}\n";

      	$ENV{CONTENT_LENGTH}    = $info{'CONTENT-LENGTH'}; # if defined $info{'CONTENT-LENGTH'};

      	if ( not -e $file ) {
        	logerr 404, $file,undef;
      	} else {
        	if ( $file =~ m/\.cgi$/ ) {
          	logmsg "Executing '$file'";
          	do_cgi($file,$method,$url,\%info) || logerr 500, $file,"Couldn't run cgi: [$!]\n";
        	} elsif (-d $file) {
          	logmsg "Dumping directory contents '$file'";
          	cat_directory($file,$url,$args) || logerr 500,$file,undef;
        	} else {
          	logmsg "Dumping '$file'";
          	dump_file($file,$url,$args) || logerr 500,$file,undef;
        	}
      	}
      }
    }
  }
  close STDIN;
  close STDOUT;
}

for ( ; $addr = accept(Client,Server); close Client) {
	newConnection($addr);
}