[gforth] / gforth / proxy.fs  

gforth: gforth/proxy.fs

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help