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