version 1.4, 2000/04/09 20:57:25
|
version 1.9, 2000/11/19 21:42:05
|
Line 1
|
Line 1
|
#! /usr/local/bin/gforth |
#! /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 |
warnings off |
|
|
include string.fs |
require string.fs |
|
|
Variable url |
Variable url |
Variable posted |
Variable posted |
Line 35 wordlist constant commands
|
Line 53 wordlist constant commands
|
r> 1+ +LOOP url $!len |
r> 1+ +LOOP url $!len |
r> base ! ; |
r> base ! ; |
|
|
: rework-? ( addr -- ) { url } |
: rework-? ( addr -- ) |
url $@ tuck '? scan tuck dup 0<> - url-args $! - url $!len ; |
dup >r $@ '? $split url-args $! nip r> $!len ; |
|
|
: get-url url get protocol get-rest |
: get-url ( -- ) url get protocol get-rest |
url rework-? url rework-% >values ; |
url rework-? url rework-% >values ; |
|
|
commands set-current |
commands set-current |
Line 84 Variable maxnum
|
Line 102 Variable maxnum
|
posted $!len posted $@ infile-id read-file throw drop |
posted $!len posted $@ infile-id read-file throw drop |
THEN only forth also pop-file ; |
THEN 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 ; |
|
: <HTML> ( -- ) ." <HTML>" $> ; |
|
|
|
\ Rework HTML directory 26mar00py |
\ Rework HTML directory 26mar00py |
|
|
Variable htmldir |
Variable htmldir |
Line 132 Variable htmldir
|
Line 133 Variable htmldir
|
$4000 - $4000 +LOOP drop |
$4000 - $4000 +LOOP drop |
free fd close-file throw throw ; |
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 |
: transparent: ( addr u -- ) Create here over 1+ allot place |
DOES> >r >file |
DOES> >r >file |
.connection |
.connection |
Line 169 s" text/plain" transparent: txt
|
Line 179 s" text/plain" transparent: txt
|
|
|
\ http errors 26mar00py |
\ http errors 26mar00py |
|
|
: .server ." Server: Gforth httpd/0.1 (" |
: .server ( -- ) ." Server: Gforth httpd/0.1 (" |
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, POST" 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 0.1</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 -- ) maxnum ! |
: httpd ( n -- ) maxnum ! |
BEGIN ['] http catch maxnum @ 0= or UNTIL ; |
BEGIN ['] http catch maxnum @ 0= or UNTIL ; |
|
|
script? [IF] :noname &100 httpd bye ; is bootmessage [THEN] |
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>" $> ; |
|
|
|
\ provide transparent proxying |
|
|
|
include proxy.fs |