[gforth] / gforth / httpd.fs  

gforth: gforth/httpd.fs

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help