[gforth] / gforth / proxy.fs  

gforth: gforth/proxy.fs

1 : pazsan 1.1 \ a http proxy
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 :     require unix/socket.fs
22 :    
23 :     Create crlf #cr c, #lf c,
24 :    
25 :     : writeln ( addr u fd -- )
26 :     dup >r write-file throw crlf 2 r> write-file throw ;
27 :    
28 :     : request ( host u request u proxy-host u port -- fid )
29 :     open-socket >r
30 :     2dup type ." HTTP/1.1" cr
31 :     r@ write-file throw s" HTTP/1.1" r@ writeln
32 :     s" Host: " r@ write-file throw r@ writeln
33 :     ." Connection: close" cr
34 :     s" Connection: close" r@ writeln
35 :     s" User-Agent: " r@ write-file throw
36 :     User-Agent @ IF
37 :     User-Agent $@ r@ write-file throw s" via Gforth Proxy 0.1"
38 :     ELSE s" Gforth Proxy 0.1" THEN r@ writeln
39 :     s" " r@ writeln r> ;
40 :    
41 :     Variable proxy s" localhost" proxy $!
42 :     Variable proxy-port 3128 proxy-port !
43 :    
44 :     : proxy-open ( host u request u -- fid )
45 :     proxy $@ proxy-port @ request ;
46 :    
47 :     : http-open ( host u request u -- fid )
48 :     2over 80 request ;
49 :    
50 :     wordlist Constant response
51 :     wordlist Constant response-values
52 :    
53 :     Variable response-string
54 :    
55 :     : response: ( -- ) name
56 :     Forth definitions 2dup 1- nextname Variable
57 :     response-values set-current nextname here cell - Create ,
58 :     DOES> @ get-rest ;
59 :     : >response response-values 1 set-order ;
60 :    
61 :     response set-current
62 :    
63 :     : HTTP/1.1 response-string get-rest >response ;
64 :     : HTTP/1.0 response-string get-rest >response ;
65 :    
66 :     \ response variables
67 :    
68 :     Forth definitions
69 :    
70 :     response: Allow:
71 :     response: Age:
72 :     response: Cache-Control:
73 :     response: Connection:
74 :     response: Proxy-Connection:
75 :     response: Content-Base:
76 :     response: Content-Encoding:
77 :     response: Content-Language:
78 :     response: Content-Length:
79 :     response: Content-Location:
80 :     response: Content-MD5:
81 :     response: Content-Range:
82 :     response: Content-Type:
83 :     response: Date:
84 :     response: ETag:
85 :     response: Expires:
86 :     response: Last-modified:
87 :     response: Location:
88 :     response: Mime-Version:
89 :     response: Proxy-Authenticate:
90 :     response: Public:
91 :     response: Retry-After:
92 :     response: Server:
93 :     response: Transfer-Encoding:
94 :     response: Upgrade:
95 :     response: Via:
96 :     response: Warning:
97 :     response: WWW-Authenticate:
98 :     response: X-Cache:
99 :     response: X-Powered-By:
100 :    
101 :     Forth definitions
102 :    
103 :     \ response handling
104 :    
105 :     : get-response ( fid -- ior )
106 :     push-file loadfile ! loadline off blk off
107 :     response 1 set-order ['] refill-loop catch
108 :     only forth also pop-file ;
109 :    
110 :     \ data handling
111 :    
112 :     Variable data-buffer
113 :    
114 :     : clear-data ( -- )
115 :     s" " data-buffer $! ;
116 :     : add-chunk ( u fid -- u' )
117 :     swap data-buffer $@len dup >r + data-buffer $!len
118 :     data-buffer $@ r@ /string rot read-file throw
119 :     dup r> + data-buffer $!len ;
120 :     : read-sized ( u fid -- )
121 :     add-chunk drop ;
122 :     : read-to-end ( fid -- )
123 :     >r BEGIN $1000 r@ add-chunk $1000 <> UNTIL rdrop ;
124 :    
125 :     : read-chunked ( fid -- ) base @ >r hex >r
126 :     BEGIN pad $100 r@ read-line throw WHILE
127 :     pad swap s>number drop dup WHILE r@ add-chunk drop
128 :     pad 1 r@ read-line throw nip 0= UNTIL
129 :     ELSE drop THEN THEN rdrop r> base ! ;
130 :    
131 :     : read-data ( fid -- ) clear-data >r
132 :     Content-Length @ IF
133 :     Content-Length $@ s>number drop r> read-sized EXIT THEN
134 :     Transfer-Encoding @ IF
135 :     Transfer-Encoding $@ s" chunked" compare 0= IF
136 :     r> read-chunked EXIT THEN THEN
137 :     r> read-to-end ;
138 :    
139 :     \ convert data
140 :    
141 :     : convert-data ( -- )
142 :     \ stub
143 :     ;
144 :    
145 :     \ write response
146 :    
147 :     : write-response ( -- ) \ stub -- we really want to mirror what we got
148 :     .ok
149 :     ." Connection: close" cr
150 :     ." Accept-Ranges: bytes" cr
151 :     ." Content-Type: " Content-Type $@ type cr
152 :     ." Content-Length: " data-buffer $@len 0 .r cr cr ;
153 :    
154 :     \ write data
155 :    
156 :     : write-data ( -- )
157 :     data-buffer $@ type ;
158 :    
159 :     \ handle proxy request
160 :    
161 :     : proxy-request ( host u request u -- )
162 :     proxy-open
163 :     dup >r get-response throw
164 :     r@ read-data r> close-file throw
165 :     convert-data write-response write-data ;
166 :    
167 :     : http-request ( host u request u -- )
168 :     http-open
169 :     dup >r get-response throw
170 :     r@ read-data r> close-file throw
171 :     convert-data write-response write-data ;
172 :    
173 :     \ request redirection
174 :    
175 :     wordlist Constant redirects
176 :    
177 :     Variable redir$
178 :     Variable host$
179 :    
180 :     : redirect: ( "path" host<"> redirecton<"> -- ) Create
181 :     [char] " parse here over char+ allot place
182 :     [char] " parse here over char+ allot place
183 :     DOES> ( -- addr u )
184 :     data @ IF s" GET " ELSE s" HEAD " THEN redir$ $!
185 :     count 2dup host$ $! +
186 :     count redir$ $+!
187 :     source >in @ /string dup >in +!
188 :     2dup bounds ?DO I c@ #lf = IF '/ I c! THEN LOOP
189 :     redir$ $+! redir$ $@ ;
190 :    
191 :     : (redirect?) ( addr u -- addr' u' t / f )
192 :     htmldir $! htmldir $@ bounds ?DO
193 :     I c@ '/ = IF #lf I c! THEN LOOP
194 :     redirects 1 set-order
195 :     htmldir $@ ['] evaluate catch
196 :     IF 2drop false ELSE true THEN ;
197 :    
198 :     : (redirect) ( addr u -- )
199 :     host$ $@ 2swap proxy-request maxnum off ;
200 :    
201 :     ' (redirect?) IS redirect?
202 :     ' (redirect) IS redirect
203 :    
204 :     \ example
205 :    
206 :     redirects set-current
207 :     get-order redirects swap 1+ set-order
208 :    
209 :     Vocabulary systems
210 :    
211 :     also systems definitions
212 :    
213 :     redirect: bigforth www.paysan.nom"http://www.jwdt.com/~paysan/"
214 :    
215 :     previous previous definitions
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help