[BACK]Return to lonhttpd CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lonhttpd between versions 1.2 and 1.4

version 1.2, 2002/10/29 20:57:31 version 1.4, 2002/10/30 15:32:33
Line 1 Line 1
 #!/usr/bin/perl  #!/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$  # $Id$
   
 # Currently supported: HTTP 1.0/1.1 GET and POST queries  $VERSION = "1.3.2 (Demonic/Linux/LON-CAPA Derivative)";
 # File types of .html and .gif  
   
 $ENV{'SERVER_SOFTWARE'}="TinyHTTPD $Revision$ -ot.0894 (LON-CAPA)";  # HTTPi Hypertext Tiny Truncated Process Implementation
   # Copyright 1999-2001 Cameron Kaiser # All rights reserved
   # Please read LICENSE # Do not strip this copyright message.
   #
   # LON-CAPA: find httpi license and readme at CVS loncom/license
   #
   
   %system_content_types =
    ("html" => "text/html",
    "htm" => "text/html",
    "wml" => "text/vnd.wap.wml",
    "wbmp" => "image/vnd.wap.wbmp",
    "wbm" => "image/vnd.wap.wbmp",
    "xbm" => "image/x-xbitmap",
    "pdf" => "application/pdf",
    "fdf" => "application/vnd.fdf",
    "bin" => "application/octet-stream",
    "class" => "application/octet-stream",
    "jar" => "application/octet-stream",
    "js" => "application/x-javascript",
    "lnk" => "application/x-hyperlink",
    "wav" => "audio/x-wav",
    "mp3" => "audio/x-mpeg",
    "tif" => "image/tiff",
    "tiff" => "image/tiff",
    "mid" => "audio/x-midi",
    "txt" => "text/plain",
    "gif" => "image/gif",
    "sit" => "application/x-stuffit",
    "zip" => "application/x-zip-compressed",
    "lzh" => "application/octet-stream",
    "lha" => "application/octet-stream",
    "gz"  => "application/x-gzip",
    "mov" => "movie/quicktime",
    "mpeg" => "video/mpeg",
    "mpg" => "video/mpeg",
    "jpeg" => "image/jpeg",
    "jpg" => "image/jpeg");
   
   $logfile = "/home/httpd/perl/logs/lonhttpd.log";
   
   # Write out PID
   
   $pidfile="/home/httpd/perl/logs/lonhttpd.pid";
   
   if (-e $pidfile) {
      open(LFH,"$pidfile");
      my $pide=<$LFH>;
      chomp($pide);
      close(LFH);
      if (kill 0 => $pide) { die "already running"; }
   }
   
   $path = "/home/httpd/html";
   $sockaddr = 'S n a4 x8';
   
   
 use POSIX;  %content_types =
    ("html" => "text/html",
    "htm" => "text/html");
   %restrictions =
    ("/"        => "#.##",  # deny everything
            "/res/adm" => ".###",  # allow /res/adm
            "/adm"     => ".###",  # allow /adm
    "/status"  => ".####lonadm:oeRooOvb3HtpI");
    # See documentation for interpreting this string.
   
   $headers = <<"EOF";
   Server: HTTPi/$VERSION
   MIME-Version: 1.0
   EOF
   
   %virtual_files =
    (
   "/adm/lonLCDfont/0.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/0.gif" ] ,
   "/adm/lonLCDfont/1.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/1.gif" ] ,
   "/adm/lonLCDfont/2.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/2.gif" ] ,
   "/adm/lonLCDfont/3.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/3.gif" ] ,
   "/adm/lonLCDfont/4.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/4.gif" ] ,
   "/adm/lonLCDfont/5.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/5.gif" ] ,
   "/adm/lonLCDfont/6.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/6.gif" ] ,
   "/adm/lonLCDfont/7.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/7.gif" ] ,
   "/adm/lonLCDfont/8.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/8.gif" ] ,
   "/adm/lonLCDfont/9.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/9.gif" ] ,
   "/adm/lonLCDfont/a.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/a.gif" ] ,
   "/adm/lonLCDfont/b.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/b.gif" ] ,
   "/adm/lonLCDfont/c.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/c.gif" ] ,
   "/adm/lonLCDfont/d.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/d.gif" ] ,
   "/adm/lonLCDfont/e.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/e.gif" ] ,
   "/adm/lonLCDfont/f.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/f.gif" ] ,
   "/adm/lonLCDfont/g.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/g.gif" ] ,
   "/adm/lonLCDfont/h.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/h.gif" ] ,
   "/adm/lonLCDfont/i.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/i.gif" ] ,
   "/adm/lonLCDfont/j.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/j.gif" ] ,
   "/adm/lonLCDfont/k.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/k.gif" ] ,
   "/adm/lonLCDfont/l.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/l.gif" ] ,
   "/adm/lonLCDfont/m.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/m.gif" ] ,
   "/adm/lonLCDfont/n.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/n.gif" ] ,
   "/adm/lonLCDfont/o.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/o.gif" ] ,
   "/adm/lonLCDfont/p.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/p.gif" ] ,
   "/adm/lonLCDfont/q.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/q.gif" ] ,
   "/adm/lonLCDfont/r.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/r.gif" ] ,
   "/adm/lonLCDfont/s.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/s.gif" ] ,
   "/adm/lonLCDfont/t.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/t.gif" ] ,
   "/adm/lonLCDfont/u.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/u.gif" ] ,
   "/adm/lonLCDfont/v.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/v.gif" ] ,
   "/adm/lonLCDfont/w.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/w.gif" ] ,
   "/adm/lonLCDfont/x.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/x.gif" ] ,
   "/adm/lonLCDfont/y.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/y.gif" ] ,
   "/adm/lonLCDfont/z.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/z.gif" ] ,
   "/adm/lonLCDfont/colon.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/colon.gif" ] ,
   "/adm/lonLCDfont/slash.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/slash.gif" ] ,
   "/adm/lonLCDfont/hyphen.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/hyphen.gif" ] ,
   "/adm/lonLCDfont/space.gif" => [ "image/gif", "FILE",
    "/home/httpd/html/adm/lonLCDfont/space.gif" ] ,
    );
   
   %content_types = (%system_content_types, %content_types);
   undef %system_content_types;
   
   while (($file, $arrayref) = each(%virtual_files)) {
    my ($mime, $type, $block) = (@{ $arrayref });
    next if ($type ne 'FILE');
    if(open(S, "$block")) {
    $j = $/; undef $/; $virtual_files{$file}->[2] = scalar(<S>);
    $/ = $j; close(S);
    } else {
    warn "while getting virtual file $file: $!\n";
    map_delete(%virtual_files, $file);
    }
   }
   if ($pid = fork()) { exit; }
   
   #
   # Store parent PID
   #
   
 $pid=fork;  open (PIDSAVE,">$pidfile");
 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";  print PIDSAVE "$$\n";
 close(PIDSAVE);  close(PIDSAVE);
   
 sub REAPER {  $0 = "dhttpi: binding port ...";
     1 until (-1==waitpid(-1,WNOHANG));  $bindthis = pack($sockaddr, 2, 8080, pack('l', chr(0).chr(0).chr(0).chr(0)));
     $SIG{CHLD}=\&REAPER;  socket(S, 2, 1, 6);
 }  setsockopt(S, 1, 2, 1);
   bind(S, $bindthis) || die("$0: while binding port 8080:\n\"$!\"\n");
 $SIG{CHLD}=\&REAPER;  listen(S, 128);
   $0 = "dhttpi: connected and waiting ANY:8080";
 ## Configuration section  
 $port=8080; # Port on which we listen  $statiosuptime = time();
 $htmldir="/home/httpd/html/"; # Base directory for HTML files  
   ###############################################################
 # the following substitutes "require 'sys/socket.ph';" on ultrix  # WHITE HATS ONLY BELOW THIS POINT -- SEE DOCUMENTATION FIRST #
 # Check if the definitions are correct with /usr/include/sys/socket.h  ###############################################################
 $AF_INET=2; $PF_INET=$AF_INET; $SOCK_STREAM=1;  
   sub sock_to_host {
 # Messages   local($sock) = getpeername(STDIN);
 %errors=  
     (   return (undef, undef, undef) if (!$sock);
      "403", "Forbidden",   local($AFC, $port, $thataddr, $zero) = unpack($sockaddr, $sock);
      "404", "Not Found",   local($ip) = join('.', unpack("C4", $thataddr));
      "500", "Internal Error",   return ($ip, $port, $ip);
      "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";  sub htsponse {
    ($currentcode, $currentstring) = (@_);
    return if (0+$httpver < 1);
    local($what) = <<"EOF";
   HTTP/$httpver $currentcode $currentstring
   ${headers}Date: $rfcdate
   EOF
    $what =~ s/\n/\r\n/g;
    print stdout $what;
    &hthead("Connection: close") if (0+$httpver > 1);
   }
   
 # set up a server socket, redirect stderr to logfile  sub hthead {
 $IPPROTO_TCP=6;   local($header, $term) = (@_);
 $sockaddr = 'S n a4 x8';   return if (0+$httpver < 1);
 $this = pack($sockaddr, $AF_INET, $port, "\0\0\0\0");   print stdout "$header\r\n" , ($term) ? "\r\n" : "";
 socket(S, $PF_INET, $SOCK_STREAM, $IPPROTO_TCP) || die "socket: $!";  }
 bind(S, $this) || die "bind: $!";  
 listen(S, 5) || die "listen: $!";  sub htcontent {
 open(LOG,">>/home/httpd/perl/logs/lonhttpd.log");   local($what, $ctype, $mode) = (@_);
 select(LOG); $|=1;   ($contentlength) = $mode || length($what);
 open(STDERR, ">&LOG") || die "dup2 log->stderr";   &hthead("Content-Length: $contentlength");
    &hthead("Content-Type: $ctype", 1);
    return if ($method eq 'HEAD' || $mode);
    print stdout $what;
   }
   
   sub log {
     if (open(J, ">>$logfile")) {
    local $q = $address . (($variables) ? "?$variables" : "");
    $contentlength += 0;
    $contentlength = 0 if ($method eq 'HEAD');
    local ($hostname, $port, $ip) = &sock_to_host();
    $hostname = $hostname || "-";
    $httpuser = $httpuser || "-";
    print J <<"EOF";
   $hostname - $httpuser [$date] "$method $q HTTP/$httpver" $currentcode $contentlength "$httpref" "$httpua"
   EOF
    close(J); }
    }
   
   
   sub bye { unlink($pidfile); exit; }
   
   sub dead {
    &htsponse(500, "Server Error");
    &hterror("Server Error", <<"EOF");
   While handling a request for resource $address, the server crashed. Please
   attempt to notify the administrators.
   <p>Useful(?) debugging information:
   <pre>
   @_
   </pre>
   EOF
    &log; unlink($pidfile); exit;
   }
   
   $SIG{'__DIE__'} = \&dead;
   $SIG{'ALRM'} = $SIG{'TERM'} = $SIG{'INT'} = \&bye;
   
   sub master {
    $0 = "dhttpi: handling request";
   # $sock = getpeername(STDIN);
   $rfcdate = scalar gmtime;
   ($dow, $mon, $dt, $tm, $yr) = ($rfcdate =~
    m/(...) (...) (..) (..:..:..) (....)/);
   $dt += 0; $yr += 0;
   $rfcdate = "$dow, $dt $mon $yr $tm GMT";
   $date = scalar localtime;
   ($dow, $mon, $dt, $tm, $yr) = ($date =~
    m/(...) (...) (..) (..:..:..) (....)/);
   $dt += 0;
   $dt = substr("0$dt", length("0$dt") - 2, 2);
   $date = "$dt/$mon/$yr:$tm +0000"; 
   
   select(STDOUT); $|=1; $address = 0; 
   alarm 1;
   while (<STDIN>) {
    if(/^([A-Z]+)\s+([^\s]+)\s+([^\s\r\l\n]*)/) {
    $method = $1;
    $address = $2; 
    $httpver = $3;
    $httpref = '';
    $httpua = '';
    $httpver = ($httpver =~ m#HTTP/([0-9]\.[0-9]+)#) ?
    ($1) : (0.9);
    $address =~ s#^http://[^/]+/#/#;
    next unless ($httpver < 1);
    } else {
    s/[\r\l\n\s]+$//;
    (/^Host: (.+)/i) && ($httphost = $1) && ($httphost =~
    s/:\d+$//);
    (/^Referer: (.+)/i) && ($httpref = $1);
    (/^User-agent: (.+)/i) && ($httpua = $1);
    (/^Content-length: (\d+)/i) && ($ENV{'CONTENT_LENGTH'} =
    $httpcl = $1);
    (/^Content-type: (.+)/i) && ($ENV{'CONTENT_TYPE'} =
    $httpct = $1);
    (/^Expect: /) && ($expect = 1);
    (/^Authorization: Basic (.+)/i) && ($httprawu = $1);
    (/^Range: (.+)/i) && ($ENV{'CONTENT_RANGE'} = $1);
    next unless (/^$/);
    }
    if ($expect) {
    &htsponse(417, "Expectation Failed");
    &hterror("Expectation Failed",
    "The server does not support this method.");
    &log; exit;
    }
    if (!$address || (0+$httpver > 1 && !$httphost)) {
    &htsponse(400, "Bad Request");
    &hterror("Bad Request",
    "The server cannot understand your request.");
    &log; exit;
    }
    if ($method !~ /^(GET|HEAD|POST)$/) {
    &htsponse(501, "Illegal Method");
    &hterror("Illegal Method",
    "Only GET, HEAD and POST are supported.");
    &log; exit;
    }
    ($address, $variables) = split(/\?/, $address);
    $address =~ s/%([0-9a-fA-F]{2})/pack("H2", $1)/eg;
    $address=~ s#^/?#/#;
    1 while $address =~ s#/\.(/|$)#\1#;
           1 while $address =~ s#/[^/]*/\.\.(/|$)#\1#;
    1 while $address =~ s#^/\.\.(/|$)#\1#;
    $fail = 0;
   #
   # Heavily customized for LON-CAPA
   #
    $address=~s/\/+/\//g;
    unless ($address=~/^\/(status|adm\/|res\/adm\/)/) { $fail=1; }
   #
   # because existing restriction matrix would not do precedence across rules
   #
   # J: foreach(sort { length $a <=> length $b }
   # keys %restrictions) {
   # next if ($address !~ /^$_/);
   # ($allowip, $denyip, $allowua, $denyua, $auser) =
   # split(/#/, $restrictions{$_});
   # if ($allowip || $denyip) {
   # ($hostname, $port, $ip) = &sock_to_host();
   # ($allowip && $ip !~ /$allowip/) && ($fail = 1,
   # last J);
   # ($denyip && $ip =~ /$denyip/) && ($fail = 1,
   # last J);
   # }
   # ($allowua && $httpua !~ /$allowua/) &&
   # ($fail = 2, last J);
   # ($denyua && $httpua =~ /$denyua/) &&
   # ($fail = 2, last J);
   # }
    if ($fail) {
    &htsponse(403, "Forbidden");
    if ($fail == 1) {
    &hterror("Forbidden (Client Disallowed)", <<"EOF");
   Your network address (<i>$ip</i>) is not allowed to access this resource.
   EOF
    &log; exit;
    } else {
    &hterror("Forbidden (Browser Disallowed)", <<"EOF");
   The browser you are using (<i>$httpua</i>) is not capable of or
   is not allowed access to this resource.
   EOF
    &log; exit;
    }
    }
    if ($auser) {
    $httprawu =~ tr#A-Za-z0-9+/##cd;
    $httprawu =~ tr#A-Za-z0-9+/# -_#;
    $httprawu = unpack("u", pack("c", 32+0.75*length($httprawu))
    . $httprawu);
    ($httpuser, $httppw) = split(/:/, $httprawu);
    $fail = 1;
    foreach $user (split(/,/, $auser)) {
    ($user, $pw) = split(/:/, $user);
    ($fail = 0, last) if ($user eq $httpuser &&
    crypt($httppw, substr($pw, 0, 2)) eq $pw);
    }
    if ($fail) {
    $httpuser = '';
    &htsponse(401, "Authorization Required");
    &hthead("WWW-Authenticate: Basic realm=\"$address\"");
    &hterror("Authorization Required", <<"EOF");
   You must provide a username and password to use this resource. Either you
   entered this information incorrectly, or your browser does not know how to
   present the credentials required.
   EOF
    &log; exit;
    }
    }
   
    alarm 0;
   
    if ($address eq '/status') {
    &htsponse(200, "OK");
    $contentlength = 0; # kludge
    &log;
    if(open(S, $logfile)) {
    seek(S, -5000, 2);
    undef $/;
    $logsnap = <S>;
    $logsnap =~ s/^[^\n]+\n//s if
    (length($logsnap) > 4999);
    close(S);
    }
    $p = (time() - $statiosuptime);
    $rps = $p/$statiosreq;
    $d = int($p / 86400); $p -= $d * 86400;
    $h = int($p / 3600); $p -= $h * 3600;
    $m = int($p / 60); $s = $p - ($m * 60);
    ("0$s" =~ /(\d{2})$/) && ($s = $1);
    ("0$m" =~ /(\d{2})$/) && ($m = $1);
    $h +=0; $d += 0;
    $suptime = scalar localtime $statiosuptime;
    &htcontent(<<"EOF", "text/html");
   <html>
   <head>
   <title>
   HTTPi Status
   </title>
   </head>
   <body bgcolor = "#ffffff" text = "#000000" vlink = "#0000ff" link = "#0000ff">
   <h1>HTTPi Server Status (<code>$VERSION</code>)</h1>
   <h3>lonhttpd on port 8080</h3>
   <b>Started at:</b> $suptime<br>
   <b>Uptime:</b> $d days, $h:$m:$s<br>
   <b>Last request time:</b> $statiosltr<p>
   <b>Requests received:</b> $statiosreq<br>
   <b>Average time between requests:</b> ${rps}s
   <p>
   <b>Most recent requests:</b>
   <form action = "/status" method = "post">
   <textarea name = "bletch" rows = "8" cols = "70">
   $logsnap
   </textarea>
   </form>
   <hr>
   <address>maintained by <a href =
   "http://httpi.floodgap.com/">httpi/$VERSION</a></address>
   </body>
   </html>
   EOF
    exit;
    }
    if (defined $virtual_files{$address}) {
    $virt_buffer = 1;
    $mtime = $statiosuptime; # thus always needed
    goto SERVEIT; # yes, it's bad but it's fast
    }
    $raddress = "$path$address"
    ;
    &hterror301("$address/")
    if ($address !~ m#/$# && -d $raddress);
    $raddress = "${raddress}index.html" if (-d $raddress);
    if(!sysopen(S, $raddress, 0)) { &hterror404; } else {
    if (-x $raddress) {
    $currentcode = 100;
    &log;
    if (!$<) {
    ($x,$x,$x,$x,$uid,$gid) = stat(S);
    (!$uid || !$gid) &&
    die "executable is root-owned";
    $> = $uid || die "can't set effuid";
    $) = $gid || die "can't set effgid";
    }
    ($hostname, $port, $ip) = &sock_to_host() if (!$port);
    $ENV{'REQUEST_METHOD'} = $method;
    $ENV{'SERVER_NAME'} = "localhost";
    $ENV{'SERVER_PROTOCOL'} = "HTTP/$httpver";
    $ENV{'SERVER_SOFTWARE'} = "HTTPi/$VERSION";
    $ENV{'SERVER_PORT'} = "8080";
    $ENV{'SERVER_URL'} = "http://localhost:8080/";
    $ENV{'SCRIPT_FILENAME'} = $raddress;
    $ENV{'SCRIPT_NAME'} = $address;
    $ENV{'REMOTE_HOST'} = $hostname;
    $ENV{'REMOTE_ADDR'} = $ip;
    $ENV{'REMOTE_PORT'} = $port;
    $ENV{'QUERY_STRING'} = $variables;
    $ENV{'HTTP_USER_AGENT'} = $httpua;
    $ENV{'HTTP_REFERER'} = $httpref;
    if ($pid = fork()) { exit; } else {
    if ($method eq 'POST') { # needs stdin
    open(W, "|$raddress") || die
    "can't POST to $raddress";
    read(STDIN, $buf, $httpcl);
    print W $buf;
    exit;
    }
    exec "$raddress", "$variables";
    die "exec() returned -1";
    }
    }
    ($x,$x,$x,$x,$x,$x,$x,$length,$x,$mtime) = stat(S);
    $ctype = 0;
    foreach(keys %content_types) {
    if ($raddress =~ /\.$_$/i) {
    $ctype = $content_types{$_};
    }
    }
   SERVEIT: $ctype ||= 'text/plain';
    &htsponse(200, "OK");
    $mtime = scalar gmtime $mtime;
    ($dow, $mon, $dt, $tm, $yr) =
    ($mtime =~ m/(...) (...) (..) (..:..:..) (....)/);
    $dt += 0; $yr += 0;
    &hthead("Last-Modified: $dow, $dt $mon $yr $tm GMT");
    if ($pid = fork()) { exit; }
    if ($virt_buffer) {
    &htcontent($virtual_files{$address}->[2],
    $virtual_files{$address}->[0], 0);
    } else {
    &htcontent("", $ctype, $length);
    unless ($method eq 'HEAD') {
    while(!eof(S)) {
    read(S, $q, 16384);
    print stdout $q;
    }
    }
    }
    alarm 0;
    }
    &log;
    exit;
   }
   
   exit;
   }
   
   
   sub hterror {
    local($errstr, $expl) = (@_);
    &htcontent(<<"EOF", "text/html");
   <html>
   <body>
   <h1>$errstr</h1>
   $expl
   <hr>
   <address><a href = "http://httpi.floodgap.com/">httpi/$VERSION</a>
   by Cameron Kaiser</address>
   </body>
   </html>
   EOF
    }
   
   sub hterror404 {
    &htsponse(404, "File Not Found");
    &hterror("File Not Found",
    "The resource $address was not found on this system.");
   }
   
   sub hterror301 {
    &htsponse(301, "Moved Permanently");
    &hthead("Location: @_");
    &hterror("Resource Moved Permanently",
    "This resource has moved <a href = \"@_\">here</a>.");
    $keep = 0; &log; exit;
   }
   
 # accept incoming calls  
 for (;;) {  for (;;) {
     ($addr=accept(NS,S)) || die "accept: $!";   $addr=accept(NS,S);
     next if $pid=fork;   $statiosltr = scalar localtime;
     die "fork: $!" unless defined $pid;   $statiosreq++;
     close(S);   if ($pid = fork()) {
     ($a,$p,$inetaddr) = unpack($sockaddr, $addr);   $0 = "dhttpi: waiting for child process";
     @inetaddr = unpack('C4', $inetaddr);   waitpid($pid, 0);
     ($host,$aliases) = gethostbyaddr($inetaddr, $AF_INET);   $0 = "dhttpi: on ANY:8080, last request " .
     $inetaddr = join(".", @inetaddr);   scalar localtime;
     @host=split(' ', "$host $aliases");   } else {
     $host || do { $host = $inetaddr; };   $0 = "dhttpi: child switching to socket";
     @t=localtime;   open(STDIN, "<&NS");
     open(STDIN, "+<&NS") || die "dup2 ns->stdin";   open(STDOUT, ">&NS");
     open(STDOUT, "+>&NS") || die "dup2 ns->stdout";   &master;
     select(STDOUT); $|=1;   exit;
     &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  
 }  }
Removed from v.1.2  
changed lines
  Added in v.1.4

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