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