--- gforth/httpd.fs 2000/09/23 15:06:01 1.6 +++ gforth/httpd.fs 2007/12/31 19:02:24 1.24 @@ -1,12 +1,12 @@ #! /usr/local/bin/gforth -\ Copyright (C) 2000 Free Software Foundation, Inc. +\ Copyright (C) 2000,2002,2003,2004,2006,2007 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,12 +15,36 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. + +\ This relies on inetd or xinetd: + +\ To run the server on port 4444, do the following: + +\ Add the following line to /etc/services: +\ gforth 4444/tcp + +\ If you use inetd, add the following line to /etc/inetd.conf: +\ gforth stream tcp nowait.10000 wwwrun /usr/users/bernd/bin/httpd + +\ If you use xinetd, create the folliwing service in /etc/xinetd.d: +\ service gforth +\ { +\ socket_type = stream +\ protocol = tcp +\ wait = no +\ user = wwwrun +\ server = /home/bernd/bin/httpd +\ } + +\ If you want port 80, replace the service "gforth" with "http" warnings off -include string.fs +require string.fs + +Variable DocumentRoot s" /srv/www/htdocs/" DocumentRoot $! +Variable UserDir s" public_html/" UserDir $! Variable url Variable posted @@ -83,6 +107,7 @@ value: Connection: value: Referer: value: Content-Type: value: Content-Length: +value: Keep-Alive: definitions @@ -90,14 +115,15 @@ Variable maxnum : ?cr ( -- ) #tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ; -: refill-loop ( -- flag ) - BEGIN refill ?cr WHILE interpret >in @ 0= UNTIL - true ELSE maxnum off false THEN ; +: refill-loop ( -- flag ) base @ >r base off + BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL + true ELSE maxnum off false THEN r> base ! ; : get-input ( -- flag ior ) s" /nosuchfile" url $! s" HTTP/1.0" protocol $! s" close" connection $! infile-id push-file loadfile ! loadline off blk off commands 1 set-order command? on ['] refill-loop catch + Keep-Alive $@ snumber? dup 0> IF nip THEN IF maxnum ! THEN active @ IF s" " posted $! Content-Length $@ snumber? drop posted $!len posted $@ infile-id read-file throw drop THEN only forth also pop-file ; @@ -107,11 +133,13 @@ Variable maxnum Variable htmldir : rework-htmldir ( addr u -- addr' u' / ior ) - htmldir $! - htmldir $@ 1 min s" ~" compare 0= - IF s" /.html-data" htmldir dup $@ 2dup '/ scan + htmldir $! htmldir $@ compact-filename htmldir $!len drop + htmldir $@ s" ../" string-prefix? + IF -1 EXIT THEN \ can't access below current directory + htmldir $@ s" ~" string-prefix? + IF UserDir $@ htmldir dup $@ 2dup '/ scan '/ skip nip - nip $ins - ELSE s" /usr/local/httpd/htdocs/" htmldir 0 $ins THEN + ELSE DocumentRoot $@ htmldir 0 $ins THEN htmldir $@ 1- 0 max + c@ '/ = htmldir $@len 0= or IF s" index.html" htmldir dup $@len $ins THEN htmldir $@ file-status nip ?dup ?EXIT @@ -137,7 +165,7 @@ Variable htmldir : .connection ( -- ) ." Connection: " - connection $@ s" Keep-Alive" compare 0= maxnum @ 0> and + connection $@ s" Keep-Alive" str= maxnum @ 0> and IF connection $@ type cr ." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr -1 maxnum +! ELSE ." close" cr maxnum off THEN ; @@ -152,10 +180,13 @@ Variable htmldir : mime-read ( addr u -- ) r/o open-file throw push-file loadfile ! 0 loadline ! blk off - BEGIN refill WHILE name - BEGIN >in @ >r name nip WHILE - r> >in ! 2dup transparent: REPEAT - 2drop rdrop + BEGIN refill WHILE + char '# <> >in off name nip 0<> and IF + >in off name + BEGIN >in @ >r name nip WHILE + r> >in ! 2dup transparent: REPEAT + 2drop rdrop + THEN REPEAT loadfile @ close-file pop-file throw ; : lastrequest @@ -171,7 +202,14 @@ mime set-current s" application/pgp-signature" transparent: sig s" application/x-bzip2" transparent: bz2 s" application/x-gzip" transparent: gz -s" /etc/mime.types" mime-read +s" /etc/mime.types" ' mime-read catch [IF] 2drop + \ no /etc/mime.types found on this machine, + \ generating the most important types: + s" text/html" transparent: html + s" image/gif" transparent: gif + s" image/png" transparent: png + s" image/jpg" transparent: jpg +[THEN] definitions @@ -179,7 +217,7 @@ s" text/plain" transparent: txt \ http errors 26mar00py -: .server ( -- ) ." Server: Gforth httpd/0.1 (" +: .server ( -- ) ." Server: Gforth httpd/1.0 (" s" os-class" environment? IF type THEN ." )" cr ; : .ok ( -- ) ." HTTP/1.1 200 OK" cr .server ; : html-error ( n addr u -- ) @@ -190,7 +228,7 @@ s" text/plain" transparent: txt ." " cr ."

" type drop ."

" cr ; : .trailer ( -- ) - ."
Gforth httpd 0.1
" cr + ."
Gforth httpd 1.0
" cr ." " cr ; : .nok ( -- ) command? @ IF &405 s" Method Not Allowed" ELSE &400 s" Bad Request" THEN html-error @@ -205,15 +243,20 @@ s" text/plain" transparent: txt \ http server 26mar00py +Defer redirect? ( addr u -- addr' u' t / f ) +Defer redirect ( addr u -- ) +:noname 2drop false ; IS redirect? + : http ( -- ) get-input IF .nok ELSE - IF url $@ 1 /string rework-htmldir + IF url $@ 1 /string 2dup redirect? IF redirect 2drop ELSE + rework-htmldir dup 0< IF drop .nofile ELSE .ok 2dup >mime mime search-wordlist 0= IF ['] txt THEN catch IF maxnum off THEN - THEN THEN THEN outfile-id flush-file throw ; + THEN THEN THEN THEN outfile-id flush-file throw ; -: httpd ( n -- ) maxnum ! - BEGIN ['] http catch maxnum @ 0= or UNTIL ; +: httpd ( n -- ) dup maxnum ! 0 <# #S #> Keep-Alive $! + maxnum @ 0 DO ['] http catch maxnum @ 0= or ?LEAVE LOOP ; script? [IF] :noname &100 httpd bye ; is bootmessage [THEN] @@ -224,3 +267,7 @@ script? [IF] :noname &100 httpd bye ; i type cr refill 0= UNTIL EXIT THEN nip source >in @ /string rot - dup 2 + >in +! type ; : ( -- ) ." " $> ; + +\ provide transparent proxying + +include ./proxy.fs