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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help