version 1.1, 2000/03/26 20:38:17
|
version 1.2, 2000/04/02 20:18:27
|
Line 6 include string.fs
|
Line 6 include string.fs
|
|
|
Variable url |
Variable url |
Variable protocol |
Variable protocol |
|
Variable data |
|
Variable command? |
|
|
: get ( addr -- ) name rot $! ; |
: get ( addr -- ) name rot $! ; |
: get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ; |
: get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ; |
|
|
Table constant http/1.0 |
Table constant values |
|
Table constant commands |
|
|
: rest: ( -- ) name |
: value: ( -- ) name |
Forth definitions 2dup 1- nextname Variable |
Forth definitions 2dup 1- nextname Variable |
http/1.0 set-current nextname here cell - Create , |
values set-current nextname here cell - Create , |
DOES> @ get-rest ; |
DOES> @ get-rest ; |
|
: >values values 1 set-order command? off ; |
|
|
\ HTTP protocol 26mar00py |
\ HTTP protocol commands 26mar00py |
|
|
http/1.0 set-current |
: rework-% ( -- ) base @ >r hex |
|
0 url $@len 0 ?DO |
: GET url get protocol get-rest ; |
url $@ drop I + c@ dup '% = IF |
rest: User-Agent: |
drop 0. url $@ I 1+ /string |
rest: Pragma: |
2 min dup >r >number r> swap - >r 2drop |
rest: Host: |
ELSE 0 >r THEN over url $@ drop + c! 1+ |
rest: Accept: |
r> 1+ +LOOP url $!len |
rest: Accept-Encoding: |
r> base ! ; |
rest: Accept-Language: |
|
rest: Accept-Charset: |
commands set-current |
rest: Via: |
|
rest: X-Forwarded-For: |
: GET url get rework-% protocol get-rest >values data on ; |
rest: Cache-Control: |
: HEAD url get rework-% protocol get-rest >values data off ; |
rest: Connection: |
|
rest: Referer: |
\ HTTP protocol values 26mar00py |
|
|
|
values set-current |
|
|
|
value: User-Agent: |
|
value: Pragma: |
|
value: Host: |
|
value: Accept: |
|
value: Accept-Encoding: |
|
value: Accept-Language: |
|
value: Accept-Charset: |
|
value: Via: |
|
value: X-Forwarded-For: |
|
value: Cache-Control: |
|
value: Connection: |
|
value: Referer: |
|
|
definitions |
definitions |
|
|
s" close" connection $! |
|
s" /nosuchfile" url $! |
|
s" HTTP/1.0" protocol $! |
s" HTTP/1.0" protocol $! |
|
|
Variable maxnum |
Variable maxnum |
Line 49 Variable maxnum
|
Line 66 Variable maxnum
|
BEGIN refill ?cr WHILE interpret >in @ 0= UNTIL |
BEGIN refill ?cr WHILE interpret >in @ 0= UNTIL |
true ELSE maxnum off false THEN ; |
true ELSE maxnum off false THEN ; |
: get-input ( -- flag ior ) |
: get-input ( -- flag ior ) |
|
s" /nosuchfile" url $! |
|
s" close" connection $! |
infile-id push-file loadfile ! 0 loadline ! blk off |
infile-id push-file loadfile ! 0 loadline ! blk off |
http/1.0 1 set-order ['] refill-loop catch |
commands 1 set-order command? on ['] refill-loop catch |
only forth also pop-file ; |
only forth also pop-file ; |
|
|
\ Keep-Alive handling 26mar00py |
\ Keep-Alive handling 26mar00py |
Line 100 Variable htmldir
|
Line 119 Variable htmldir
|
over swap r@ read-file throw over swap type |
over swap r@ read-file throw over swap type |
free r> close-file throw throw ; |
free r> close-file throw throw ; |
|
|
: transparent: Create ," DOES> >r >file |
: transparent: ( addr u -- ) Create here over 1+ allot place |
|
DOES> >r >file |
.connection |
.connection |
." Content-Type: " r> count type cr cr |
." Content-Type: " r> count type cr cr |
transparent ; |
data @ IF transparent ELSE nip close-file throw THEN ; |
|
|
\ mime types 26mar00py |
\ mime types 26mar00py |
|
|
|
: 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 |
|
REPEAT loadfile @ close-file pop-file throw ; |
|
|
: lastrequest |
: lastrequest |
." Connection: close" cr maxnum off |
." Connection: close" cr maxnum off |
." Content-Type: text/html" cr cr ; |
." Content-Type: text/html" cr cr ; |
Line 114 Variable htmldir
|
Line 142 Variable htmldir
|
wordlist constant mime |
wordlist constant mime |
mime set-current |
mime set-current |
|
|
: shtml ( addr u -- ) lastrequest included ; |
: shtml ( addr u -- ) lastrequest |
|
data @ IF included ELSE 2drop THEN ; |
|
|
transparent: html text/html" |
s" application/pgp-signature" transparent: sig |
transparent: gif image/gif" |
s" application/x-bzip2" transparent: bz2 |
transparent: jpg image/jpeg" |
s" application/x-gzip" transparent: gz |
transparent: png image/png" |
s" /etc/mime.types" mime-read |
transparent: gz application/x-gzip" |
|
transparent: bz2 application/x-bzip2" |
|
transparent: exe application/octet-stream" |
|
transparent: class application/octet-stream" |
|
transparent: sig application/pgp-signature" |
|
transparent: txt text/plain" |
|
|
|
definitions |
definitions |
|
|
lastxt @ Alias txt |
s" text/plain" transparent: txt |
|
|
\ http errors 26mar00py |
\ http errors 26mar00py |
|
|
: .ok ." HTTP/1.1 200 OK" cr ; |
: .server ." Server: Gforth httpd/0.1 (" |
|
s" os-class" environment? IF type THEN ." )" cr ; |
|
: .ok ." HTTP/1.1 200 OK" cr .server ; |
: html-error ( n addr u -- ) |
: html-error ( n addr u -- ) |
." HTTP/1.1 " 2 pick . 2dup type cr lastrequest |
." HTTP/1.1 " 2 pick . 2dup type cr .server |
|
2 pick &405 = IF ." Allow: GET, HEAD" cr THEN lastrequest |
." <HTML><HEAD><TITLE>" 2 pick . 2dup type ." </TITLE></HEAD>" cr |
." <HTML><HEAD><TITLE>" 2 pick . 2dup type ." </TITLE></HEAD>" cr |
." <BODY><H1>" type drop ." </H1>" cr ; |
." <BODY><H1>" type drop ." </H1>" cr ; |
: .trailer ( -- ) |
: .trailer ( -- ) |
." <HR><ADDRESS>Gforth httpd 0.1</ADDRESS>" cr |
." <HR><ADDRESS>Gforth httpd 0.1</ADDRESS>" cr |
." </BODY></HTML>" cr ; |
." </BODY></HTML>" cr ; |
: .nok &400 s" Bad Request" html-error |
: .nok command? @ IF &405 s" Method Not Allowed" |
|
ELSE &400 s" Bad Request" THEN html-error |
." <P>Your browser sent a request that this server could not understand.</P>" cr |
." <P>Your browser sent a request that this server could not understand.</P>" cr |
." <P>Invalid request in: <CODE>" error-stack cell+ 2@ swap type |
." <P>Invalid request in: <CODE>" error-stack cell+ 2@ swap type |
." </CODE></P>" cr .trailer ; |
." </CODE></P>" cr .trailer ; |
Line 155 lastxt @ Alias txt
|
Line 182 lastxt @ Alias txt
|
IF url $@ 1 /string rework-htmldir |
IF url $@ 1 /string rework-htmldir |
dup 0< IF drop .nofile |
dup 0< IF drop .nofile |
ELSE .ok 2dup >mime mime search-wordlist |
ELSE .ok 2dup >mime mime search-wordlist |
IF catch IF maxnum off THEN ELSE txt THEN |
0= IF ['] txt THEN catch IF maxnum off THEN |
THEN THEN THEN outfile-id flush-file throw ; |
THEN THEN THEN outfile-id flush-file throw ; |
|
|
: httpd ( n -- ) maxnum ! |
: httpd ( n -- ) maxnum ! |
BEGIN http maxnum @ 0= UNTIL ; |
BEGIN http maxnum @ 0= UNTIL ; |
|
|
( script? [IF] ) &100 httpd bye ( [THEN] ) |
script? [IF] &100 httpd bye [THEN] |