--- gforth/httpd.fs 2000/04/02 21:48:54 1.3 +++ gforth/httpd.fs 2004/12/31 13:23:57 1.18 @@ -1,19 +1,43 @@ #! /usr/local/bin/gforth +\ Copyright (C) 2000,2002,2003,2004 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 +\ of the License, or (at your option) any later version. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +\ 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., 59 Temple Place, Suite 330, Boston, MA 02111, USA. + warnings off -include string.fs +require string.fs + +Variable DocumentRoot s" /usr/local/httpd/htdocs/" DocumentRoot $! +Variable UserDir s" .html-data/" UserDir $! Variable url +Variable posted +Variable url-args Variable protocol Variable data +Variable active Variable command? : get ( addr -- ) name rot $! ; : get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ; -Table constant values -Table constant commands +wordlist constant values +wordlist constant commands : value: ( -- ) name Forth definitions 2dup 1- nextname Variable @@ -23,7 +47,7 @@ Table constant commands \ HTTP protocol commands 26mar00py -: rework-% ( -- ) base @ >r hex +: rework-% ( add -- ) { url } base @ >r hex 0 url $@len 0 ?DO url $@ drop I + c@ dup '% = IF drop 0. url $@ I 1+ /string @@ -32,10 +56,17 @@ Table constant commands r> 1+ +LOOP url $!len r> base ! ; +: rework-? ( addr -- ) + dup >r $@ '? $split url-args $! nip r> $!len ; + +: get-url ( -- ) url get protocol get-rest + url rework-? url rework-% >values ; + commands set-current -: GET url get rework-% protocol get-rest >values data on ; -: HEAD url get rework-% protocol get-rest >values data off ; +: GET get-url data on active off ; +: POST get-url data on active on ; +: HEAD get-url data off active off ; \ HTTP protocol values 26mar00py @@ -53,51 +84,41 @@ value: X-Forwarded-For: value: Cache-Control: value: Connection: value: Referer: +value: Content-Type: +value: Content-Length: +value: Keep-Alive: definitions - 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 - only forth also pop-file ; - -\ Keep-Alive handling 26mar00py - -: .connection ( -- ) - ." Connection: " - connection $@ s" Keep-Alive" compare 0= maxnum @ 0> and - IF connection $@ type cr - ." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr - -1 maxnum +! ELSE ." close" cr maxnum off THEN ; - -\ Use Forth as server-side script language 26mar00py - -: $> ( -- ) - BEGIN source >in @ /string s" <$" search 0= WHILE - type cr refill 0= UNTIL EXIT THEN - nip source >in @ /string rot - dup 2 + >in +! type ; -: ( -- ) ." " $> ; + 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 ; \ Rework HTML directory 26mar00py 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 @@ -113,10 +134,20 @@ Variable htmldir r@ file-size throw drop ." Accept-Ranges: bytes" cr ." Content-Length: " dup 0 .r cr r> ; -: transparent ( size fd -- ) >r - dup allocate throw swap - over swap r@ read-file throw over swap type - free r> close-file throw throw ; +: transparent ( size fd -- ) { fd } + $4000 allocate throw swap dup 0 ?DO + 2dup over swap $4000 min fd read-file throw type + $4000 - $4000 +LOOP drop + free fd close-file throw throw ; + +\ Keep-Alive handling 26mar00py + +: .connection ( -- ) + ." Connection: " + 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 ; : transparent: ( addr u -- ) Create here over 1+ allot place DOES> >r >file @@ -128,10 +159,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 @@ -155,36 +189,57 @@ s" text/plain" transparent: txt \ http errors 26mar00py -: .server ." Server: Gforth httpd/0.1 (" +: .server ( -- ) ." Server: Gforth httpd/0.1 (" s" os-class" environment? IF type THEN ." )" cr ; -: .ok ." HTTP/1.1 200 OK" cr .server ; +: .ok ( -- ) ." HTTP/1.1 200 OK" cr .server ; : html-error ( n addr u -- ) ." HTTP/1.1 " 2 pick . 2dup type cr .server - 2 pick &405 = IF ." Allow: GET, HEAD" cr THEN lastrequest - ." " 2 pick . 2dup type ." " cr + 2 pick &405 = IF ." Allow: GET, HEAD, POST" cr THEN + lastrequest + ." " 2 pick . 2dup type + ." " cr ."

" type drop ."

" cr ; : .trailer ( -- ) ."
Gforth httpd 0.1
" cr ." " cr ; -: .nok command? @ IF &405 s" Method Not Allowed" +: .nok ( -- ) command? @ IF &405 s" Method Not Allowed" ELSE &400 s" Bad Request" THEN html-error - ."

Your browser sent a request that this server could not understand.

" cr - ."

Invalid request in: " error-stack cell+ 2@ swap type + ."

Your browser sent a request that this server " + ." could not understand.

" cr + ."

Invalid request in: " + error-stack cell+ 2@ swap type ."

" cr .trailer ; -: .nofile &404 s" Not Found" html-error +: .nofile ( -- ) &404 s" Not Found" html-error ."

The requested URL " url $@ type ." was not found on this server

" cr .trailer ; \ http server 26mar00py -: http get-input IF .nok ELSE - IF url $@ 1 /string rework-htmldir +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 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 -- ) 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] + +\ Use Forth as server-side script language 26mar00py + +: $> ( -- ) + BEGIN source >in @ /string s" <$" search 0= WHILE + type cr refill 0= UNTIL EXIT THEN + nip source >in @ /string rot - dup 2 + >in +! type ; +: ( -- ) ." " $> ; -: httpd ( n -- ) maxnum ! - BEGIN ['] http catch maxnum @ 0= or UNTIL ; +\ provide transparent proxying -script? [IF] &100 httpd bye [THEN] +include ./proxy.fs