Return to lonhttpd CVS log

Up to [LON-CAPA] / loncom

The little server that could (on port 8080).

    1: #!/usr/bin/perl
    2: # The LearningOnline Network with CAPA
    3: # lonhttpd server (port 8080)
    4: # based on
    5: # TinyHTTPD - a minimum-functional HTTP server written in -*- Perl -*-
    6: # -ot.0894
    7: # $Id: lonhttpd,v 1.1 2002/10/29 20:21:32 www Exp $
    8: 
    9: # Currently supported: HTTP 1.0/1.1 GET and POST queries
   10: # File types of .html and .gif
   11: 
   12: $ENV{'SERVER_SOFTWARE'}="TinyHTTPD $Revision: 1.1 $ -ot.0894 (LON-CAPA)";
   13: 
   14: 
   15: use POSIX;
   16: 
   17: $pid=fork;
   18: exit if $pid;
   19: die "Could not fork: $!" unless defined($pid);
   20: POSIX::setsid() or die "Can't start new session: $!";
   21: open (PIDSAVE,">/home/httpd/perl/logs/lonhttpd.pid");
   22: print PIDSAVE "$$\n";
   23: close(PIDSAVE);
   24: 
   25: sub REAPER {
   26:     1 until (-1==waitpid(-1,WNOHANG));
   27:     $SIG{CHLD}=\&REAPER;
   28: }
   29: 
   30: $SIG{CHLD}=\&REAPER;
   31: 
   32: ## Configuration section
   33: $port=8080;			# Port on which we listen
   34: $htmldir="/home/httpd/html/";	# Base directory for HTML files
   35: 
   36: # the following substitutes "require 'sys/socket.ph';" on ultrix
   37: # Check if the definitions are correct with /usr/include/sys/socket.h
   38: $AF_INET=2; $PF_INET=$AF_INET; $SOCK_STREAM=1;
   39: 
   40: # Messages
   41: %errors=
   42:     (
   43:      "403", "Forbidden",
   44:      "404", "Not Found",
   45:      "500", "Internal Error",
   46:      "501", "Not Implemented",
   47:      );
   48: %verrors=
   49:     (
   50:      "403", "Your client is not allowed to request this item",
   51:      "404", "The requested item was not found on this server",
   52:      "500", "An error occurred while trying to retrieve item",
   53:      "501", "This server does not support the given request type",
   54:      );
   55: 
   56: (($>)&&($<==$>)&&($(==$))) || die "Don't run this program with privileges!\n";
   57: 
   58: # set up a server socket, redirect stderr to logfile
   59: $IPPROTO_TCP=6;
   60: $sockaddr = 'S n a4 x8';
   61: $this = pack($sockaddr, $AF_INET, $port, "\0\0\0\0");
   62: socket(S, $PF_INET, $SOCK_STREAM, $IPPROTO_TCP) || die "socket: $!";
   63: bind(S, $this) || die "bind: $!";
   64: listen(S, 5) || die "listen: $!";
   65: open(LOG,">>/home/httpd/perl/logs/lonhttpd.log");
   66: select(LOG); $|=1;
   67: open(STDERR, ">&LOG") || die "dup2 log->stderr";
   68: 
   69: # accept incoming calls
   70: for (;;) {
   71:     ($addr=accept(NS,S)) || die "accept: $!";
   72:     next if $pid=fork;
   73:     die "fork: $!" unless defined $pid;
   74:     close(S);
   75:     ($a,$p,$inetaddr) = unpack($sockaddr, $addr);
   76:     @inetaddr = unpack('C4', $inetaddr);
   77:     ($host,$aliases) = gethostbyaddr($inetaddr, $AF_INET);
   78:     $inetaddr = join(".", @inetaddr);
   79:     @host=split(' ', "$host $aliases");
   80:     $host || do { $host = $inetaddr; };
   81:     @t=localtime;
   82:     open(STDIN, "+<&NS") || die "dup2 ns->stdin";
   83:     open(STDOUT, "+>&NS") || die "dup2 ns->stdout";
   84:     select(STDOUT); $|=1;
   85:     &serve_request;
   86:     close(STDIN); close(STDOUT);
   87:     exit;
   88: }
   89: 
   90: # Read request from stdin and produce output
   91: sub serve_request {
   92: 
   93:     # Analyze HTTP input.
   94:     $_=<STDIN>;
   95:     ($method, $url, $proto) = split;
   96:     if ($proto) {
   97: 	while (<STDIN>) { 
   98: 	    s/\n|\r//g; # kill CR and NL chars
   99: 	    /^Content-Length: (\S*)/i && ($content_length=$1);
  100: 	    /^Content-Type: (\S*)/i && ($content_type=$1);
  101: 	    length || last; # empty line - end of header
  102: 	}
  103:     } else {
  104: 	$proto="HTTP/0.9";
  105:     }
  106:     ($method=~/^(GET|POST)$/) || do { &error(501,$method); return; };
  107: 
  108:     # prevent directory go-back
  109:     $url=~/\.\./ && do { &error(403,$url,"contains go-back"); return; };
  110: 
  111:     # Check access control
  112:     unless (($url=~/^\/res\/adm\//) || ($url=~/^\/adm\//)) {
  113:         do { &error(403,$url,"not on allow list"); return; };
  114:     }
  115:     print LOG "$$: $url\n";
  116: 
  117: # Get and return file
  118: 
  119: 	$file="$htmldir$url";
  120: 	(-r "$file") || do { &error(404,$url); return; };
  121: 	# output the file
  122: 	print "HTTP/1.0 200 OK\nMIME-Version: 1.0\nContent-Type: ";
  123:         CASE:	
  124: 	{
  125: 	    $url=~/\.html$/ && do { print "text/html\n\n"; last CASE; };
  126: 	    $url=~/\.gif$/ && do { print "image/gif\n\n"; last CASE; };
  127: 	    print "text/plain\n\n";
  128: 	}
  129: 	system("cat $file");
  130: }
  131: 
  132: sub error {
  133:     # generate error response
  134:     local($errno) = @_[0];
  135:     local($errmsg) = "$errno $errors{$errno}";
  136:     print LOG "$$ $errmsg (@_[1,2])\n";
  137:     print <<TheEnd;
  138: HTTP/1.0 $errmsg
  139: MIME-version: 1.0
  140: Content-type: text/html
  141: 
  142: <HTML>
  143: <HEAD><TITLE>$errmsg</TITLE></HEAD>
  144: <BODY><H1>$errmsg</H1>
  145: $verrors{$errno}: <PRE> @_[1] </PRE>
  146: <HR>
  147: <ADDRESS><A HREF="http://www.lon-capa.org/">
  148: $ENV{'SERVER_SOFTWARE'} by Olaf Titz, modified by LON-CAPA</A></ADDRESS>
  149: </BODY>
  150: </HTML>
  151: TheEnd
  152: }