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: r@ write-file throw s" HTTP/1.1" r@ writeln
31: s" Host: " r@ write-file throw r@ writeln
32: s" Connection: close" r@ writeln
33: s" User-Agent: " r@ write-file throw
34: User-Agent @ IF
35: User-Agent $@ r@ write-file throw s" via Gforth Proxy 0.1"
36: ELSE s" Gforth Proxy 0.1" THEN r@ writeln
37: s" " r@ writeln r> ;
38:
39: Variable proxy s" localhost" proxy $!
40: Variable proxy-port 3128 proxy-port !
41:
42: : proxy-open ( host u request u -- fid )
43: proxy $@ proxy-port @ request ;
44:
45: : http-open ( host u request u -- fid )
46: 2over 80 request ;
47:
48: wordlist Constant response
49: wordlist Constant response-values
50:
51: Variable response-string
52:
53: : response: ( -- ) name
54: Forth definitions 2dup 1- nextname Variable
55: response-values set-current nextname here cell - Create ,
56: DOES> @ get-rest ;
57: : >response response-values 1 set-order ;
58:
59: response set-current
60:
61: : HTTP/1.1 response-string get-rest >response ;
62: : HTTP/1.0 response-string get-rest >response ;
63:
64: \ response variables
65:
66: Forth definitions
67:
68: response: Allow:
69: response: Age:
70: response: Accept-Ranges:
71: response: Cache-Control:
72: response: Connection:
73: response: Proxy-Connection:
74: response: Content-Base:
75: response: Content-Encoding:
76: response: Content-Language:
77: response: Content-Length:
78: response: Content-Location:
79: response: Content-MD5:
80: response: Content-Range:
81: response: Content-Type:
82: response: Date:
83: response: ETag:
84: response: Expires:
85: response: Last-Modified:
86: response: Location:
87: response: Mime-Version:
88: response: Proxy-Authenticate:
89: response: Proxy-Connection:
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.jwdt.com"http://www.jwdt.com/~paysan/"
214:
215: previous previous definitions
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>