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

# #########################
# Changelog
# #########################
# Need to thread/fork/whatever?
#
# 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
#
# Jun.23.2000: v 0.3
#       Handles paths and default path safely
#       Added support for images
#	Added directory listings (with sorting!)
#
# - Taken over by Dave www.davesource.com -
#
# Original:	pure perl httpd. (c) Paul Tchistopolskii 1998, 99
# 		http://www.pault.com  e-mail: paul@qub.com
#
# Apr.29.1998: v 0.2
#	'Support' for 'POST'. It was useful for debugging uploads.
#
# Nov.27.1998: v 0.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	= `hostname`;	chomp $HOSTNAME;
my $DOMAIN	= "$HOSTNAME:$PORT";
my $ROOT	= '.';
my $PERL	= '/usr/bin/perl';
my $ICONS	= "/icons";
my $DEFAULT_FILE = 'index.html';
my $DEFAULT_FILE2 = 'index.shtml';
my $HTML = '\.s?html?$';
my $BUFSIZE	= 256;

# 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..
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 = "$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
	css	text/css
	mpe	video/mpeg
	mpg	video/mpeg
	mpeg	video/mpeg
	mov	video/quicktime
	avi	video/x-msvideo
END_EXTRA_MIME_TYPES

##################################################
# Code
##################################################
$|=1;
chdir $ROOT || die("Couldn't go to root directory [$ROOT]\n");

#########################
# Mime types
#########################
my %MIME_TYPES;
sub init_types {
  open(MIME_TYPES,"<$MIME_TYPES") || return;
  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 "$detail : $msg";
  print "HTTP/1.0 $msg\nContent-type: text/html\n";
  print $extra if $extra;
  print "\n";
  print "<I>HttpDave</I> : $detail : $msg\n";
}

#########################
# Requests
#########################
sub cat ($$$) {
  my ($file,$url,$args) = @_;

  my $type = type($file);
  if ($type) {
    print "HTTP/1.0 200 OK\n";
    print "Content-type: $type\n\n";
  }

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

  open IN, "<$file" || return 0;
unless ($SUPERKLUDGE) {
  # 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;
    }
  }
  # Dump out the file
  my $buf;
  while (read(IN,$buf,$BUFSIZE)) { last unless print $buf; }
} else {
  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;
  }
}

  close IN;

  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 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,$mod,$size]);
  }

  my $parent = ["..","back.gif","DIR",(stat("$dir/.."))[9],(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,$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";

    # Last modified
    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];
    my $last_mod = sprintf("%0.2d-$mon-%s %0.2d:%0.2d ",$mday+1,$year+1900,$hour,$min);

    # 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";

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;
  }

  # Default file (index.html)
  $path.="/$DEFAULT_FILE" if (-d $path && -f "$path/$DEFAULT_FILE");
  $path.="/$DEFAULT_FILE2" if (-d $path && -f "$path/$DEFAULT_FILE2");

  ($path,$args);
}


for ( ; $addr = accept(Client,Server); close Client) {
  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>;
  my ($method, $url, $proto, $garbage) = split;
  my %info;
  while ( <STDIN> ) {
    last if (/^\s*$/);
    s/[\r\n]//g;
    $info{uc($1)} = $2 if (/^(\S+):\s*(.*)$/);
  }

  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 {

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

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

      $ENV{REQUEST_URI}       = $url;
      $ENV{SERVER_PROTOCOL}   = $proto;
      $ENV{REQUEST_METHOD}    = $method;
      $ENV{REMOTE_ADDR}       = $inetaddr;
      $ENV{HTTP_REFERER}      = $info{REFERER} if defined $info{REFERER};
      $ENV{HTTP_COOKIE}       = $info{COOKIE} if defined $info{COOKIE};
      $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'";
          $ENV{SCRIPT_URI} = "http://$DOMAIN/$file";	# Kludgy..
          $ENV{SCRIPT_URL} = $url;
          $ENV{SCRIPT_NAME} = $file;
          $ENV{SCRIPT_FILENAME} = $file;	# Should be abs path
          my @res;
          if ($method eq "POST") {
#my $data = <STDIN>;
#my $len = length($data);
#print STDERR "Content-Length lied! [$info{'CONTENT-LENGTH'} vs actual $len]\n"
#if (defined $info{'CONTENT-LENGTH'} &&
#$info{'CONTENT-LENGTH'} != $len);
#$ENV{'CONTENT_LENGTH'} = $len;
            my $data;  read STDIN,$data,$info{'CONTENT-LENGTH'};
            $! = 0;
            @res = `echo \Q$data\E | $file`;
          } else {
            $! = 0;
            @res = `$file`;
          }
          if ($? & 127) {
            logerr 500, $file,"Couldn't run cgi: [$!]\n";
          } else {
            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;
          }
        } elsif (-d $file) {
          logmsg "Dumping directory contents '$file'";
          cat_directory($file,$url,$args) || logerr 500,$file,undef;
        } else {
          logmsg "Dumping '$file'";
          cat($file,$url,$args) || logerr 500,$file,undef;
        }

#{
#    			} elsif ( $file =~ m/$HTML/ ) {
#    				logmsg "Dumping '$file'";
#    				cat $file || logerr 500,$file,undef;
#    			} else {
#    				logerr 501, $file,undef;
#    			}
      }
    }
  }
  close STDIN;
  close STDOUT;
}