| #! /usr/local/bin/gforth |
#! /usr/local/bin/gforth |
| |
|
| \ Copyright (C) 2000 Free Software Foundation, Inc. |
\ Copyright (C) 2000,2002,2003,2004,2006,2007,2008 Free Software Foundation, Inc. |
| |
|
| \ This file is part of Gforth. |
\ This file is part of Gforth. |
| |
|
| \ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
| \ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
| \ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
| \ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
| |
|
| \ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
| \ GNU General Public License for more details. |
\ GNU General Public License for more details. |
| |
|
| \ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
| \ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
| \ 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 |
| |
|
| require string.fs |
require string.fs |
| |
|
| Variable DocumentRoot s" /usr/local/httpd/htdocs/" DocumentRoot $! |
Variable DocumentRoot s" /srv/www/htdocs/" DocumentRoot $! |
| Variable UserDir s" .html-data/" UserDir $! |
Variable UserDir s" public_html/" UserDir $! |
| |
|
| Variable url |
Variable url |
| Variable posted |
Variable posted |
| |
|
| : ?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 catch drop >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 $! |
| Variable htmldir |
Variable htmldir |
| |
|
| : rework-htmldir ( addr u -- addr' u' / ior ) |
: rework-htmldir ( addr u -- addr' u' / ior ) |
| htmldir $! htmldir $@ compact.. htmldir $!len drop |
htmldir $! htmldir $@ compact-filename htmldir $!len drop |
| htmldir $@ 3 min s" ../" compare 0= |
htmldir $@ s" ../" string-prefix? |
| IF -1 EXIT THEN \ can't access below current directory |
IF -1 EXIT THEN \ can't access below current directory |
| htmldir $@ 1 min s" ~" compare 0= |
htmldir $@ s" ~" string-prefix? |
| IF UserDir $@ htmldir dup $@ 2dup '/ scan '/ skip |
IF UserDir $@ htmldir dup $@ 2dup '/ scan '/ skip |
| nip - nip $ins |
nip - nip $ins |
| ELSE DocumentRoot $@ htmldir 0 $ins THEN |
ELSE DocumentRoot $@ htmldir 0 $ins THEN |
| |
|
| : .connection ( -- ) |
: .connection ( -- ) |
| ." Connection: " |
." Connection: " |
| connection $@ s" Keep-Alive" compare 0= maxnum @ 0> and |
connection $@ s" Keep-Alive" str= maxnum @ 0> and |
| IF connection $@ type cr |
IF connection $@ type cr |
| ." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr |
." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr |
| -1 maxnum +! ELSE ." close" cr maxnum off THEN ; |
-1 maxnum +! ELSE ." close" cr maxnum off THEN ; |
| mime set-current |
mime set-current |
| |
|
| : shtml ( addr u -- ) lastrequest |
: shtml ( addr u -- ) lastrequest |
| data @ IF included ELSE 2drop THEN ; |
data @ IF also forth included previous ELSE 2drop THEN ; |
| |
|
| 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 -- ) |
| ." </TITLE></HEAD>" cr |
." </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 |
| 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 $! |
: httpd ( n -- ) dup maxnum ! 0 <# #S #> Keep-Alive $! |
| BEGIN ['] http catch maxnum @ 0= or UNTIL ; |
maxnum @ 0 DO ['] http catch maxnum @ 0= or ?LEAVE LOOP ; |
| |
|
| script? [IF] :noname &100 httpd bye ; is bootmessage [THEN] |
script? [IF] :noname &100 httpd bye ; is bootmessage [THEN] |
| |
|
