[gforth] / gforth / httpd.fs  

gforth: gforth/httpd.fs

1 : pazsan 1.1 #! /usr/local/bin/gforth
2 :    
3 : anton 1.18 \ Copyright (C) 2000,2002,2003,2004 Free Software Foundation, Inc.
4 : anton 1.6
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 : anton 1.7 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20 : anton 1.6
21 : pazsan 1.1 warnings off
22 :    
23 : pazsan 1.8 require string.fs
24 : pazsan 1.1
25 : pazsan 1.11 Variable DocumentRoot s" /usr/local/httpd/htdocs/" DocumentRoot $!
26 : pazsan 1.19 Variable UserDir s" public_html/" UserDir $!
27 : pazsan 1.11
28 : pazsan 1.1 Variable url
29 : pazsan 1.4 Variable posted
30 :     Variable url-args
31 : pazsan 1.1 Variable protocol
32 : pazsan 1.2 Variable data
33 : pazsan 1.4 Variable active
34 : pazsan 1.2 Variable command?
35 : pazsan 1.1
36 :     : get ( addr -- ) name rot $! ;
37 :     : get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ;
38 :    
39 : pazsan 1.4 wordlist constant values
40 :     wordlist constant commands
41 : pazsan 1.1
42 : pazsan 1.2 : value: ( -- ) name
43 : pazsan 1.1 Forth definitions 2dup 1- nextname Variable
44 : pazsan 1.2 values set-current nextname here cell - Create ,
45 : pazsan 1.1 DOES> @ get-rest ;
46 : pazsan 1.2 : >values values 1 set-order command? off ;
47 : pazsan 1.1
48 : pazsan 1.2 \ HTTP protocol commands 26mar00py
49 : pazsan 1.1
50 : pazsan 1.4 : rework-% ( add -- ) { url } base @ >r hex
51 : pazsan 1.2 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 :    
59 : pazsan 1.5 : rework-? ( addr -- )
60 :     dup >r $@ '? $split url-args $! nip r> $!len ;
61 : pazsan 1.4
62 : pazsan 1.5 : get-url ( -- ) url get protocol get-rest
63 : pazsan 1.4 url rework-? url rework-% >values ;
64 :    
65 : pazsan 1.2 commands set-current
66 :    
67 : pazsan 1.4 : GET get-url data on active off ;
68 :     : POST get-url data on active on ;
69 :     : HEAD get-url data off active off ;
70 : pazsan 1.2
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:
87 : pazsan 1.4 value: Content-Type:
88 :     value: Content-Length:
89 : pazsan 1.11 value: Keep-Alive:
90 : pazsan 1.1
91 :     definitions
92 :    
93 :     Variable maxnum
94 :    
95 :     : ?cr ( -- )
96 :     #tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ;
97 : pazsan 1.17 : refill-loop ( -- flag ) base @ >r base off
98 : pazsan 1.11 BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL
99 : pazsan 1.17 true ELSE maxnum off false THEN r> base ! ;
100 : pazsan 1.1 : get-input ( -- flag ior )
101 : pazsan 1.3 s" /nosuchfile" url $! s" HTTP/1.0" protocol $!
102 : pazsan 1.2 s" close" connection $!
103 : pazsan 1.3 infile-id push-file loadfile ! loadline off blk off
104 : pazsan 1.2 commands 1 set-order command? on ['] refill-loop catch
105 : pazsan 1.11 Keep-Alive $@ snumber? dup 0> IF nip THEN IF maxnum ! THEN
106 : pazsan 1.4 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 ;
109 : pazsan 1.1
110 :     \ Rework HTML directory 26mar00py
111 :    
112 :     Variable htmldir
113 :    
114 :     : rework-htmldir ( addr u -- addr' u' / ior )
115 : anton 1.16 htmldir $! htmldir $@ compact-filename htmldir $!len drop
116 : anton 1.12 htmldir $@ s" ../" string-prefix?
117 : pazsan 1.11 IF -1 EXIT THEN \ can't access below current directory
118 : anton 1.12 htmldir $@ s" ~" string-prefix?
119 : pazsan 1.11 IF UserDir $@ htmldir dup $@ 2dup '/ scan '/ skip
120 : pazsan 1.1 nip - nip $ins
121 : pazsan 1.11 ELSE DocumentRoot $@ htmldir 0 $ins THEN
122 : pazsan 1.1 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> ;
137 : pazsan 1.4 : 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 ;
142 : pazsan 1.1
143 : pazsan 1.5 \ Keep-Alive handling 26mar00py
144 :    
145 :     : .connection ( -- )
146 :     ." Connection: "
147 : anton 1.12 connection $@ s" Keep-Alive" str= maxnum @ 0> and
148 : pazsan 1.5 IF connection $@ type cr
149 :     ." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr
150 :     -1 maxnum +! ELSE ." close" cr maxnum off THEN ;
151 :    
152 : pazsan 1.2 : transparent: ( addr u -- ) Create here over 1+ allot place
153 :     DOES> >r >file
154 : pazsan 1.1 .connection
155 :     ." Content-Type: " r> count type cr cr
156 : pazsan 1.2 data @ IF transparent ELSE nip close-file throw THEN ;
157 : pazsan 1.1
158 :     \ mime types 26mar00py
159 :    
160 : pazsan 1.2 : mime-read ( addr u -- ) r/o open-file throw
161 :     push-file loadfile ! 0 loadline ! blk off
162 : pazsan 1.11 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
169 : pazsan 1.2 REPEAT loadfile @ close-file pop-file throw ;
170 :    
171 : pazsan 1.1 : lastrequest
172 :     ." Connection: close" cr maxnum off
173 :     ." Content-Type: text/html" cr cr ;
174 :    
175 :     wordlist constant mime
176 :     mime set-current
177 :    
178 : pazsan 1.2 : shtml ( addr u -- ) lastrequest
179 :     data @ IF included ELSE 2drop THEN ;
180 : pazsan 1.1
181 : pazsan 1.2 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
185 : pazsan 1.1
186 :     definitions
187 :    
188 : pazsan 1.2 s" text/plain" transparent: txt
189 : pazsan 1.1
190 :     \ http errors 26mar00py
191 :    
192 : pazsan 1.5 : .server ( -- ) ." Server: Gforth httpd/0.1 ("
193 : pazsan 1.2 s" os-class" environment? IF type THEN ." )" cr ;
194 : pazsan 1.5 : .ok ( -- ) ." HTTP/1.1 200 OK" cr .server ;
195 : pazsan 1.1 : html-error ( n addr u -- )
196 : pazsan 1.2 ." HTTP/1.1 " 2 pick . 2dup type cr .server
197 : pazsan 1.5 2 pick &405 = IF ." Allow: GET, HEAD, POST" cr THEN
198 :     lastrequest
199 :     ." <HTML><HEAD><TITLE>" 2 pick . 2dup type
200 :     ." </TITLE></HEAD>" cr
201 : pazsan 1.1 ." <BODY><H1>" type drop ." </H1>" cr ;
202 :     : .trailer ( -- )
203 :     ." <HR><ADDRESS>Gforth httpd 0.1</ADDRESS>" cr
204 :     ." </BODY></HTML>" cr ;
205 : pazsan 1.5 : .nok ( -- ) command? @ IF &405 s" Method Not Allowed"
206 : pazsan 1.2 ELSE &400 s" Bad Request" THEN html-error
207 : pazsan 1.5 ." <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
211 : pazsan 1.1 ." </CODE></P>" cr .trailer ;
212 : pazsan 1.5 : .nofile ( -- ) &404 s" Not Found" html-error
213 : pazsan 1.1 ." <P>The requested URL <CODE>" url $@ type
214 :     ." </CODE> was not found on this server</P>" cr .trailer ;
215 :    
216 :     \ http server 26mar00py
217 :    
218 : pazsan 1.9 Defer redirect? ( addr u -- addr' u' t / f )
219 :     Defer redirect ( addr u -- )
220 :     :noname 2drop false ; IS redirect?
221 :    
222 : pazsan 1.5 : http ( -- ) get-input IF .nok ELSE
223 : pazsan 1.9 IF url $@ 1 /string 2dup redirect? IF redirect 2drop ELSE
224 :     rework-htmldir
225 : pazsan 1.1 dup 0< IF drop .nofile
226 :     ELSE .ok 2dup >mime mime search-wordlist
227 : pazsan 1.2 0= IF ['] txt THEN catch IF maxnum off THEN
228 : pazsan 1.9 THEN THEN THEN THEN outfile-id flush-file throw ;
229 : pazsan 1.1
230 : pazsan 1.11 : httpd ( n -- ) dup maxnum ! 0 <# #S #> Keep-Alive $!
231 : pazsan 1.15 maxnum @ 0 DO ['] http catch maxnum @ 0= or ?LEAVE LOOP ;
232 : pazsan 1.1
233 : pazsan 1.4 script? [IF] :noname &100 httpd bye ; is bootmessage [THEN]
234 : pazsan 1.5
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>" $> ;
242 : pazsan 1.9
243 :     \ provide transparent proxying
244 :    
245 : pazsan 1.10 include ./proxy.fs
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help