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