--- gforth/httpd.fs 2000/04/02 20:18:27 1.2
+++ gforth/httpd.fs 2000/10/29 20:27:02 1.8
@@ -1,19 +1,40 @@
#! /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 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 +44,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 +53,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,11 +81,11 @@ value: X-Forwarded-For:
value: Cache-Control:
value: Connection:
value: Referer:
+value: Content-Type:
+value: Content-Length:
definitions
-s" HTTP/1.0" protocol $!
-
Variable maxnum
: ?cr ( -- )
@@ -66,28 +94,13 @@ Variable maxnum
BEGIN refill ?cr WHILE interpret >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 ;
-: ( -- ) ." " $> ;
+ 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
@@ -114,10 +127,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" 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 ;
: transparent: ( addr u -- ) Create here over 1+ allot place
DOES> >r >file
@@ -156,29 +179,33 @@ 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
+: http ( -- ) get-input IF .nok ELSE
IF url $@ 1 /string rework-htmldir
dup 0< IF drop .nofile
ELSE .ok 2dup >mime mime search-wordlist
@@ -186,6 +213,14 @@ s" text/plain" transparent: txt
THEN THEN THEN outfile-id flush-file throw ;
: httpd ( n -- ) maxnum !
- BEGIN http maxnum @ 0= UNTIL ;
+ BEGIN ['] http catch maxnum @ 0= or UNTIL ;
+
+script? [IF] :noname &100 httpd bye ; is bootmessage [THEN]
+
+\ Use Forth as server-side script language 26mar00py
-script? [IF] &100 httpd bye [THEN]
+: $> ( -- )
+ BEGIN source >in @ /string s" <$" search 0= WHILE
+ type cr refill 0= UNTIL EXIT THEN
+ nip source >in @ /string rot - dup 2 + >in +! type ;
+: ( -- ) ." " $> ;