Return to proxy.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/proxy.fs, revision 1.1

1.1     ! pazsan      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