1: #! /usr/local/bin/gforth
2:
3: \ Copyright (C) 2000,2002,2003,2004,2006 Free Software Foundation, Inc.
4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
9: \ as published by the Free Software Foundation; either version 2
10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
18: \ along with this program; if not, write to the Free Software
19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21: \ This relies on inetd or xinetd:
22:
23: \ To run the server on port 4444, do the following:
24:
25: \ Add the following line to /etc/services:
26: \ gforth 4444/tcp
27:
28: \ If you use inetd, add the following line to /etc/inetd.conf:
29: \ gforth stream tcp nowait.10000 wwwrun /usr/users/bernd/bin/httpd
30:
31: \ If you use xinetd, create the folliwing service in /etc/xinetd.d:
32: \ service gforth
33: \ {
34: \ socket_type = stream
35: \ protocol = tcp
36: \ wait = no
37: \ user = wwwrun
38: \ server = /home/bernd/bin/httpd
39: \ }
40:
41: \ If you want port 80, replace the service "gforth" with "http"
42:
43: warnings off
44:
45: require string.fs
46:
47: Variable DocumentRoot s" /srv/www/htdocs/" DocumentRoot $!
48: Variable UserDir s" public_html/" UserDir $!
49:
50: Variable url
51: Variable posted
52: Variable url-args
53: Variable protocol
54: Variable data
55: Variable active
56: Variable command?
57:
58: : get ( addr -- ) name rot $! ;
59: : get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ;
60:
61: wordlist constant values
62: wordlist constant commands
63:
64: : value: ( -- ) name
65: Forth definitions 2dup 1- nextname Variable
66: values set-current nextname here cell - Create ,
67: DOES> @ get-rest ;
68: : >values values 1 set-order command? off ;
69:
70: \ HTTP protocol commands 26mar00py
71:
72: : rework-% ( add -- ) { url } base @ >r hex
73: 0 url $@len 0 ?DO
74: url $@ drop I + c@ dup '% = IF
75: drop 0. url $@ I 1+ /string
76: 2 min dup >r >number r> swap - >r 2drop
77: ELSE 0 >r THEN over url $@ drop + c! 1+
78: r> 1+ +LOOP url $!len
79: r> base ! ;
80:
81: : rework-? ( addr -- )
82: dup >r $@ '? $split url-args $! nip r> $!len ;
83:
84: : get-url ( -- ) url get protocol get-rest
85: url rework-? url rework-% >values ;
86:
87: commands set-current
88:
89: : GET get-url data on active off ;
90: : POST get-url data on active on ;
91: : HEAD get-url data off active off ;
92:
93: \ HTTP protocol values 26mar00py
94:
95: values set-current
96:
97: value: User-Agent:
98: value: Pragma:
99: value: Host:
100: value: Accept:
101: value: Accept-Encoding:
102: value: Accept-Language:
103: value: Accept-Charset:
104: value: Via:
105: value: X-Forwarded-For:
106: value: Cache-Control:
107: value: Connection:
108: value: Referer:
109: value: Content-Type:
110: value: Content-Length:
111: value: Keep-Alive:
112:
113: definitions
114:
115: Variable maxnum
116:
117: : ?cr ( -- )
118: #tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ;
119: : refill-loop ( -- flag ) base @ >r base off
120: BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL
121: true ELSE maxnum off false THEN r> base ! ;
122: : get-input ( -- flag ior )
123: s" /nosuchfile" url $! s" HTTP/1.0" protocol $!
124: s" close" connection $!
125: infile-id push-file loadfile ! loadline off blk off
126: commands 1 set-order command? on ['] refill-loop catch
127: Keep-Alive $@ snumber? dup 0> IF nip THEN IF maxnum ! THEN
128: active @ IF s" " posted $! Content-Length $@ snumber? drop
129: posted $!len posted $@ infile-id read-file throw drop
130: THEN only forth also pop-file ;
131:
132: \ Rework HTML directory 26mar00py
133:
134: Variable htmldir
135:
136: : rework-htmldir ( addr u -- addr' u' / ior )
137: htmldir $! htmldir $@ compact-filename htmldir $!len drop
138: htmldir $@ s" ../" string-prefix?
139: IF -1 EXIT THEN \ can't access below current directory
140: htmldir $@ s" ~" string-prefix?
141: IF UserDir $@ htmldir dup $@ 2dup '/ scan '/ skip
142: nip - nip $ins
143: ELSE DocumentRoot $@ htmldir 0 $ins THEN
144: htmldir $@ 1- 0 max + c@ '/ = htmldir $@len 0= or
145: IF s" index.html" htmldir dup $@len $ins THEN
146: htmldir $@ file-status nip ?dup ?EXIT
147: htmldir $@ ;
148:
149: \ MIME type handling 26mar00py
150:
151: : >mime ( addr u -- mime u' ) 2dup tuck over + 1- ?DO
152: I c@ '. = ?LEAVE 1- -1 +LOOP /string ;
153:
154: : >file ( addr u -- size fd )
155: r/o bin open-file throw >r
156: r@ file-size throw drop
157: ." Accept-Ranges: bytes" cr
158: ." Content-Length: " dup 0 .r cr r> ;
159: : transparent ( size fd -- ) { fd }
160: $4000 allocate throw swap dup 0 ?DO
161: 2dup over swap $4000 min fd read-file throw type
162: $4000 - $4000 +LOOP drop
163: free fd close-file throw throw ;
164:
165: \ Keep-Alive handling 26mar00py
166:
167: : .connection ( -- )
168: ." Connection: "
169: connection $@ s" Keep-Alive" str= maxnum @ 0> and
170: IF connection $@ type cr
171: ." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr
172: -1 maxnum +! ELSE ." close" cr maxnum off THEN ;
173:
174: : transparent: ( addr u -- ) Create here over 1+ allot place
175: DOES> >r >file
176: .connection
177: ." Content-Type: " r> count type cr cr
178: data @ IF transparent ELSE nip close-file throw THEN ;
179:
180: \ mime types 26mar00py
181:
182: : mime-read ( addr u -- ) r/o open-file throw
183: push-file loadfile ! 0 loadline ! blk off
184: BEGIN refill WHILE
185: char '# <> >in off name nip 0<> and IF
186: >in off name
187: BEGIN >in @ >r name nip WHILE
188: r> >in ! 2dup transparent: REPEAT
189: 2drop rdrop
190: THEN
191: REPEAT loadfile @ close-file pop-file throw ;
192:
193: : lastrequest
194: ." Connection: close" cr maxnum off
195: ." Content-Type: text/html" cr cr ;
196:
197: wordlist constant mime
198: mime set-current
199:
200: : shtml ( addr u -- ) lastrequest
201: data @ IF included ELSE 2drop THEN ;
202:
203: s" application/pgp-signature" transparent: sig
204: s" application/x-bzip2" transparent: bz2
205: s" application/x-gzip" transparent: gz
206: s" /etc/mime.types" ' mime-read catch [IF] 2drop
207: \ no /etc/mime.types found on this machine,
208: \ generating the most important types:
209: s" text/html" transparent: html
210: s" image/gif" transparent: gif
211: s" image/png" transparent: png
212: s" image/jpg" transparent: jpg
213: [THEN]
214:
215: definitions
216:
217: s" text/plain" transparent: txt
218:
219: \ http errors 26mar00py
220:
221: : .server ( -- ) ." Server: Gforth httpd/1.0 ("
222: s" os-class" environment? IF type THEN ." )" cr ;
223: : .ok ( -- ) ." HTTP/1.1 200 OK" cr .server ;
224: : html-error ( n addr u -- )
225: ." HTTP/1.1 " 2 pick . 2dup type cr .server
226: 2 pick &405 = IF ." Allow: GET, HEAD, POST" cr THEN
227: lastrequest
228: ." <HTML><HEAD><TITLE>" 2 pick . 2dup type
229: ." </TITLE></HEAD>" cr
230: ." <BODY><H1>" type drop ." </H1>" cr ;
231: : .trailer ( -- )
232: ." <HR><ADDRESS>Gforth httpd 1.0</ADDRESS>" cr
233: ." </BODY></HTML>" cr ;
234: : .nok ( -- ) command? @ IF &405 s" Method Not Allowed"
235: ELSE &400 s" Bad Request" THEN html-error
236: ." <P>Your browser sent a request that this server "
237: ." could not understand.</P>" cr
238: ." <P>Invalid request in: <CODE>"
239: error-stack cell+ 2@ swap type
240: ." </CODE></P>" cr .trailer ;
241: : .nofile ( -- ) &404 s" Not Found" html-error
242: ." <P>The requested URL <CODE>" url $@ type
243: ." </CODE> was not found on this server</P>" cr .trailer ;
244:
245: \ http server 26mar00py
246:
247: Defer redirect? ( addr u -- addr' u' t / f )
248: Defer redirect ( addr u -- )
249: :noname 2drop false ; IS redirect?
250:
251: : http ( -- ) get-input IF .nok ELSE
252: IF url $@ 1 /string 2dup redirect? IF redirect 2drop ELSE
253: rework-htmldir
254: dup 0< IF drop .nofile
255: ELSE .ok 2dup >mime mime search-wordlist
256: 0= IF ['] txt THEN catch IF maxnum off THEN
257: THEN THEN THEN THEN outfile-id flush-file throw ;
258:
259: : httpd ( n -- ) dup maxnum ! 0 <# #S #> Keep-Alive $!
260: maxnum @ 0 DO ['] http catch maxnum @ 0= or ?LEAVE LOOP ;
261:
262: script? [IF] :noname &100 httpd bye ; is bootmessage [THEN]
263:
264: \ Use Forth as server-side script language 26mar00py
265:
266: : $> ( -- )
267: BEGIN source >in @ /string s" <$" search 0= WHILE
268: type cr refill 0= UNTIL EXIT THEN
269: nip source >in @ /string rot - dup 2 + >in +! type ;
270: : <HTML> ( -- ) ." <HTML>" $> ;
271:
272: \ provide transparent proxying
273:
274: include ./proxy.fs
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>