File:  [LON-CAPA] / loncom / lonhttpd
Revision 1.2: download - view: text, annotated - select for diffs
Tue Oct 29 20:57:31 2002 UTC (21 years, 5 months ago) by www
Branches: MAIN
CVS tags: HEAD
Get small GIFs from lonhttpd

#!/usr/bin/perl
# The LearningOnline Network with CAPA
# lonhttpd server (port 8080)
# based on
# TinyHTTPD - a minimum-functional HTTP server written in -*- Perl -*-
# -ot.0894
# $Id: lonhttpd,v 1.2 2002/10/29 20:57:31 www Exp $

# Currently supported: HTTP 1.0/1.1 GET and POST queries
# File types of .html and .gif

$ENV{'SERVER_SOFTWARE'}="TinyHTTPD $Revision: 1.2 $ -ot.0894 (LON-CAPA)";


use POSIX;

$pid=fork;
exit if $pid;
die "Could not fork: $!" unless defined($pid);
POSIX::setsid() or die "Can't start new session: $!";
open (PIDSAVE,">/home/httpd/perl/logs/lonhttpd.pid");
print PIDSAVE "$$\n";
close(PIDSAVE);

sub REAPER {
    1 until (-1==waitpid(-1,WNOHANG));
    $SIG{CHLD}=\&REAPER;
}

$SIG{CHLD}=\&REAPER;

## Configuration section
$port=8080;			# Port on which we listen
$htmldir="/home/httpd/html/";	# Base directory for HTML files

# the following substitutes "require 'sys/socket.ph';" on ultrix
# Check if the definitions are correct with /usr/include/sys/socket.h
$AF_INET=2; $PF_INET=$AF_INET; $SOCK_STREAM=1;

# Messages
%errors=
    (
     "403", "Forbidden",
     "404", "Not Found",
     "500", "Internal Error",
     "501", "Not Implemented",
     );
%verrors=
    (
     "403", "Your client is not allowed to request this item",
     "404", "The requested item was not found on this server",
     "500", "An error occurred while trying to retrieve item",
     "501", "This server does not support the given request type",
     );

(($>)&&($<==$>)&&($(==$))) || die "Don't run this program with privileges!\n";

# set up a server socket, redirect stderr to logfile
$IPPROTO_TCP=6;
$sockaddr = 'S n a4 x8';
$this = pack($sockaddr, $AF_INET, $port, "\0\0\0\0");
socket(S, $PF_INET, $SOCK_STREAM, $IPPROTO_TCP) || die "socket: $!";
bind(S, $this) || die "bind: $!";
listen(S, 5) || die "listen: $!";
open(LOG,">>/home/httpd/perl/logs/lonhttpd.log");
select(LOG); $|=1;
open(STDERR, ">&LOG") || die "dup2 log->stderr";

# accept incoming calls
for (;;) {
    ($addr=accept(NS,S)) || die "accept: $!";
    next if $pid=fork;
    die "fork: $!" unless defined $pid;
    close(S);
    ($a,$p,$inetaddr) = unpack($sockaddr, $addr);
    @inetaddr = unpack('C4', $inetaddr);
    ($host,$aliases) = gethostbyaddr($inetaddr, $AF_INET);
    $inetaddr = join(".", @inetaddr);
    @host=split(' ', "$host $aliases");
    $host || do { $host = $inetaddr; };
    @t=localtime;
    open(STDIN, "+<&NS") || die "dup2 ns->stdin";
    open(STDOUT, "+>&NS") || die "dup2 ns->stdout";
    select(STDOUT); $|=1;
    &serve_request;
    close(STDIN); close(STDOUT);
    exit;
}

# Read request from stdin and produce output
sub serve_request {

    # Analyze HTTP input.
    $_=<STDIN>;
    ($method, $url, $proto) = split;
    if ($proto) {
	while (<STDIN>) { 
	    s/\n|\r//g; # kill CR and NL chars
	    /^Content-Length: (\S*)/i && ($content_length=$1);
	    /^Content-Type: (\S*)/i && ($content_type=$1);
	    length || last; # empty line - end of header
	}
    } else {
	$proto="HTTP/0.9";
    }
    ($method=~/^(GET|POST)$/) || do { &error(501,$method); return; };

    # prevent directory go-back
    $url=~/\.\./ && do { &error(403,$url,"contains go-back"); return; };

   # Multiple slashes do happen 
   $url=~s/\/+/\//g;

    # Check access control
    unless (($url=~/^\/res\/adm\//) || ($url=~/^\/adm\//)) {
        do { &error(403,$url,"not on allow list"); return; };
    }
    print LOG "$$: $url\n";

# Get and return file

	$file="$htmldir$url";
	(-r "$file") || do { &error(404,$url); return; };
	# output the file
	print "HTTP/1.0 200 OK\nMIME-Version: 1.0\nContent-Type: ";
        CASE:	
	{
	    $url=~/\.html$/ && do { print "text/html\n\n"; last CASE; };
	    $url=~/\.gif$/ && do { print "image/gif\n\n"; last CASE; };
	    print "text/plain\n\n";
	}
	system("cat $file");
}

sub error {
    # generate error response
    local($errno) = @_[0];
    local($errmsg) = "$errno $errors{$errno}";
    print LOG "$$ $errmsg (@_[1,2])\n";
    print <<TheEnd;
HTTP/1.0 $errmsg
MIME-version: 1.0
Content-type: text/html

<HTML>
<HEAD><TITLE>$errmsg</TITLE></HEAD>
<BODY><H1>$errmsg</H1>
$verrors{$errno}: <PRE> @_[1] </PRE>
<HR>
<ADDRESS><A HREF="http://www.lon-capa.org/">
$ENV{'SERVER_SOFTWARE'} by Olaf Titz, modified by LON-CAPA</A></ADDRESS>
</BODY>
</HTML>
TheEnd
}

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>