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