1\ a http proxy
2
3\ Copyright (C) 2000,2002,2003,2006,2007 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 3
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, see http://www.gnu.org/licenses/.
19
20require unix/socket.fs
21
22Create 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
38Variable proxy          \ s" proxy" proxy $! \ replace that with your proxy host
39Variable proxy-port     \ 8080 proxy-port !  \ replace that with your proxy port
40
41\ set proxy to your local proxy, and proxy-port to your local proxy port
42\ if you need any.
43
44: http-open ( host u request u -- fid )
45    proxy @ 0= IF  2over 80  ELSE  proxy $@ proxy-port @  THEN request ;
46
47wordlist Constant response
48wordlist Constant response-values
49
50Variable response-string
51
52: response:  ( -- )  name
53    Forth definitions 2dup 1- nextname Variable
54    response-values set-current nextname here cell - Create ,
55DOES> @ get-rest ;
56: >response  response-values 1 set-order ;
57
58response 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
65Forth definitions
66
67response: Allow:
68response: Age:
69response: Accept-Ranges:
70response: Cache-Control:
71response: Connection:
72response: Proxy-Connection:
73response: Content-Base:
74response: Content-Encoding:
75response: Content-Language:
76response: Content-Length:
77response: Content-Location:
78response: Content-MD5:
79response: Content-Range:
80response: Content-Type:
81response: Date:
82response: ETag:
83response: Expires:
84response: Last-Modified:
85response: Location:
86response: Mime-Version:
87response: Proxy-Authenticate:
88response: Proxy-Connection:
89response: Public:
90response: Retry-After:
91response: Server:
92response: Transfer-Encoding:
93response: Upgrade:
94response: Via:
95response: Warning:
96response: WWW-Authenticate:
97response: X-Cache:
98response: X-Powered-By:
99
100Forth 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
111Variable 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	Transfer-Encoding $@ s" chunked" str= 0= IF
135	    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: handle-request ( fid -- )
161    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
167wordlist Constant redirects
168
169Variable redir$
170Variable host$
171
172: redirect: ( "path" host<"> redirecton<"> -- )  Create
173    [char] " parse  here over char+ allot  place
174    [char] " parse  here over char+ allot  place
175DOES> ( -- 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    redirects 1 set-order redir$ $off
187    htmldir $@ ['] evaluate catch
188    IF  2drop false  ELSE  redir$ @ 0<>  THEN ;
189
190: (redirect) ( -- )
191    host$ $@ redir$ $@ http-open handle-request maxnum off ;
192
193' (redirect?) IS redirect?
194' (redirect) IS redirect
195
196\ example
197
198redirects set-current
199get-order redirects swap 1+ set-order
200
201Vocabulary systems
202Vocabulary humor
203
204also systems definitions
205
206redirect: bigforth bigforth.sourceforge.net"/"
207
208humor definitions
209
210redirect: bush www.jwdt.com"/~paysan/bush/"
211
212previous previous definitions
213