--- gforth/httpd.fs 2000/04/02 20:18:27 1.2 +++ gforth/httpd.fs 2002/09/14 08:20:19 1.12 @@ -1,19 +1,43 @@ #! /usr/local/bin/gforth +\ Copyright (C) 2000 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,52 +84,41 @@ value: X-Forwarded-For: value: Cache-Control: value: Connection: value: Referer: +value: Content-Type: +value: Content-Length: +value: Keep-Alive: definitions -s" HTTP/1.0" protocol $! - Variable maxnum : ?cr ( -- ) #tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ; : refill-loop ( -- flag ) - BEGIN refill ?cr WHILE interpret >in @ 0= UNTIL + BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL true ELSE maxnum off false THEN ; : get-input ( -- flag ior ) - s" /nosuchfile" url $! + s" /nosuchfile" url $! s" HTTP/1.0" protocol $! s" close" connection $! - infile-id push-file loadfile ! 0 loadline ! blk off + 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.. 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 @@ -114,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 @@ -129,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 @@ -156,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 - ."
Your browser sent a request that this server could not understand.
" cr - ."Invalid request in: Your browser sent a request that this server "
+ ." could not understand. Invalid request in: The requested URL " error-stack cell+ 2@ swap type
+ ."
"
+ error-stack cell+ 2@ swap type
."
" url $@ type
."
was not found on this server