Return to lonhttpd CVS log

Up to [LON-CAPA] / loncom

Annotation of loncom/lonhttpd, revision 1.1

1.1     ! www         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.3 2002/10/29 19:37: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.3 $ -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: }