| #! /usr/local/bin/gforth |
#! /usr/local/bin/gforth |
| |
|
| |
\ Copyright (C) 2000,2002,2003,2004,2006 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. |
| |
|
| |
\ 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 |
warnings off |
| |
|
| include string.fs |
require string.fs |
| |
|
| |
Variable DocumentRoot s" /srv/www/htdocs/" DocumentRoot $! |
| |
Variable UserDir s" public_html/" UserDir $! |
| |
|
| Variable url |
Variable url |
| |
Variable posted |
| |
Variable url-args |
| Variable protocol |
Variable protocol |
| Variable data |
Variable data |
| |
Variable active |
| Variable command? |
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 values |
wordlist constant values |
| Table constant commands |
wordlist constant commands |
| |
|
| : value: ( -- ) name |
: value: ( -- ) name |
| Forth definitions 2dup 1- nextname Variable |
Forth definitions 2dup 1- nextname Variable |
| |
|
| \ HTTP protocol commands 26mar00py |
\ HTTP protocol commands 26mar00py |
| |
|
| : rework-% ( -- ) base @ >r hex |
: rework-% ( add -- ) { url } base @ >r hex |
| 0 url $@len 0 ?DO |
0 url $@len 0 ?DO |
| url $@ drop I + c@ dup '% = IF |
url $@ drop I + c@ dup '% = IF |
| drop 0. url $@ I 1+ /string |
drop 0. url $@ I 1+ /string |
| r> 1+ +LOOP url $!len |
r> 1+ +LOOP url $!len |
| r> base ! ; |
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 |
commands set-current |
| |
|
| : GET url get rework-% protocol get-rest >values data on ; |
: GET get-url data on active off ; |
| : HEAD url get rework-% protocol get-rest >values data off ; |
: POST get-url data on active on ; |
| |
: HEAD get-url data off active off ; |
| |
|
| \ HTTP protocol values 26mar00py |
\ HTTP protocol values 26mar00py |
| |
|
| value: Cache-Control: |
value: Cache-Control: |
| value: Connection: |
value: Connection: |
| value: Referer: |
value: Referer: |
| |
value: Content-Type: |
| |
value: Content-Length: |
| |
value: Keep-Alive: |
| |
|
| definitions |
definitions |
| |
|
| |
|
| Variable maxnum |
Variable maxnum |
| |
|
| : ?cr ( -- ) |
: ?cr ( -- ) |
| #tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ; |
#tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ; |
| : refill-loop ( -- flag ) |
: refill-loop ( -- flag ) base @ >r base off |
| BEGIN refill ?cr WHILE interpret >in @ 0= UNTIL |
BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL |
| true ELSE maxnum off false THEN ; |
true ELSE maxnum off false THEN r> base ! ; |
| : get-input ( -- flag ior ) |
: get-input ( -- flag ior ) |
| s" /nosuchfile" url $! s" HTTP/1.0" protocol $! |
s" /nosuchfile" url $! s" HTTP/1.0" protocol $! |
| s" close" connection $! |
s" close" connection $! |
| infile-id push-file loadfile ! loadline off blk off |
infile-id push-file loadfile ! loadline off blk off |
| commands 1 set-order command? on ['] refill-loop catch |
commands 1 set-order command? on ['] refill-loop catch |
| only forth also pop-file ; |
Keep-Alive $@ snumber? dup 0> IF nip THEN IF maxnum ! THEN |
| |
active @ IF s" " posted $! Content-Length $@ snumber? drop |
| \ Keep-Alive handling 26mar00py |
posted $!len posted $@ infile-id read-file throw drop |
| |
THEN only forth also pop-file ; |
| : .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 ; |
|
| : <HTML> ( -- ) ." <HTML>" $> ; |
|
| |
|
| \ Rework HTML directory 26mar00py |
\ Rework HTML directory 26mar00py |
| |
|
| Variable htmldir |
Variable htmldir |
| |
|
| : rework-htmldir ( addr u -- addr' u' / ior ) |
: rework-htmldir ( addr u -- addr' u' / ior ) |
| htmldir $! |
htmldir $! htmldir $@ compact-filename htmldir $!len drop |
| htmldir $@ 1 min s" ~" compare 0= |
htmldir $@ s" ../" string-prefix? |
| IF s" /.html-data" htmldir dup $@ 2dup '/ scan |
IF -1 EXIT THEN \ can't access below current directory |
| |
htmldir $@ s" ~" string-prefix? |
| |
IF UserDir $@ htmldir dup $@ 2dup '/ scan '/ skip |
| nip - nip $ins |
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 |
htmldir $@ 1- 0 max + c@ '/ = htmldir $@len 0= or |
| IF s" index.html" htmldir dup $@len $ins THEN |
IF s" index.html" htmldir dup $@len $ins THEN |
| htmldir $@ file-status nip ?dup ?EXIT |
htmldir $@ file-status nip ?dup ?EXIT |
| r@ file-size throw drop |
r@ file-size throw drop |
| ." Accept-Ranges: bytes" cr |
." Accept-Ranges: bytes" cr |
| ." Content-Length: " dup 0 .r cr r> ; |
." Content-Length: " dup 0 .r cr r> ; |
| : transparent ( size fd -- ) >r |
: transparent ( size fd -- ) { fd } |
| dup allocate throw swap |
$4000 allocate throw swap dup 0 ?DO |
| over swap r@ read-file throw over swap type |
2dup over swap $4000 min fd read-file throw type |
| free r> close-file throw throw ; |
$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 |
: transparent: ( addr u -- ) Create here over 1+ allot place |
| DOES> >r >file |
DOES> >r >file |
| |
|
| : mime-read ( addr u -- ) r/o open-file throw |
: mime-read ( addr u -- ) r/o open-file throw |
| push-file loadfile ! 0 loadline ! blk off |
push-file loadfile ! 0 loadline ! blk off |
| BEGIN refill WHILE name |
BEGIN refill WHILE |
| |
char '# <> >in off name nip 0<> and IF |
| |
>in off name |
| BEGIN >in @ >r name nip WHILE |
BEGIN >in @ >r name nip WHILE |
| r> >in ! 2dup transparent: REPEAT |
r> >in ! 2dup transparent: REPEAT |
| 2drop rdrop |
2drop rdrop |
| |
THEN |
| REPEAT loadfile @ close-file pop-file throw ; |
REPEAT loadfile @ close-file pop-file throw ; |
| |
|
| : lastrequest |
: lastrequest |
| s" application/pgp-signature" transparent: sig |
s" application/pgp-signature" transparent: sig |
| s" application/x-bzip2" transparent: bz2 |
s" application/x-bzip2" transparent: bz2 |
| s" application/x-gzip" transparent: gz |
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 |
definitions |
| |
|
| |
|
| \ http errors 26mar00py |
\ http errors 26mar00py |
| |
|
| : .server ." Server: Gforth httpd/0.1 (" |
: .server ( -- ) ." Server: Gforth httpd/1.0 (" |
| s" os-class" environment? IF type THEN ." )" cr ; |
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 -- ) |
: html-error ( n addr u -- ) |
| ." HTTP/1.1 " 2 pick . 2dup type cr .server |
." HTTP/1.1 " 2 pick . 2dup type cr .server |
| 2 pick &405 = IF ." Allow: GET, HEAD" cr THEN lastrequest |
2 pick &405 = IF ." Allow: GET, HEAD, POST" cr THEN |
| ." <HTML><HEAD><TITLE>" 2 pick . 2dup type ." </TITLE></HEAD>" cr |
lastrequest |
| |
." <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 1.0</ADDRESS>" cr |
| ." </BODY></HTML>" cr ; |
." </BODY></HTML>" 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 |
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 " |
| ." <P>Invalid request in: <CODE>" error-stack cell+ 2@ swap type |
." could not understand.</P>" cr |
| |
." <P>Invalid request in: <CODE>" |
| |
error-stack cell+ 2@ swap type |
| ." </CODE></P>" cr .trailer ; |
." </CODE></P>" cr .trailer ; |
| : .nofile &404 s" Not Found" html-error |
: .nofile ( -- ) &404 s" Not Found" html-error |
| ." <P>The requested URL <CODE>" url $@ type |
." <P>The requested URL <CODE>" url $@ type |
| ." </CODE> was not found on this server</P>" cr .trailer ; |
." </CODE> was not found on this server</P>" cr .trailer ; |
| |
|
| \ http server 26mar00py |
\ http server 26mar00py |
| |
|
| : http get-input IF .nok ELSE |
Defer redirect? ( addr u -- addr' u' t / f ) |
| IF url $@ 1 /string rework-htmldir |
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 |
dup 0< IF drop .nofile |
| ELSE .ok 2dup >mime mime search-wordlist |
ELSE .ok 2dup >mime mime search-wordlist |
| 0= IF ['] txt THEN catch IF maxnum off THEN |
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 ; |
| |
: <HTML> ( -- ) ." <HTML>" $> ; |
| |
|
| : httpd ( n -- ) maxnum ! |
\ provide transparent proxying |
| BEGIN ['] http catch maxnum @ 0= or UNTIL ; |
|
| |
|
| script? [IF] &100 httpd bye [THEN] |
include ./proxy.fs |
