Annotation of gforth/fget.fs, revision 1.1

1.1     ! pazsan      1: \ a http get command
        !             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: 
        !            20: require unix/socket.fs
        !            21: require string.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:     s" GET " r@ write-file throw 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:     s" Gforth Proxy 0.1" r@ writeln
        !            35:     s" " r@ writeln r> ;
        !            36: 
        !            37: Variable proxy          \ s" proxy" proxy $! \ replace that with your proxy host
        !            38: Variable proxy-port     \ 8080 proxy-port !  \ replace that with your proxy port
        !            39: 
        !            40: \ set proxy to your local proxy, and proxy-port to your local proxy port
        !            41: \ if you need any.
        !            42: 
        !            43: : http-open ( host u request u -- fid )
        !            44:     proxy @ 0= IF  2over 80  ELSE  proxy $@ proxy-port @  THEN request ;
        !            45: 
        !            46: wordlist Constant response
        !            47: wordlist Constant response-values
        !            48: 
        !            49: Variable response-string
        !            50: Variable maxnum
        !            51: 
        !            52: : get-rest ( addr -- )  source >in @ /string dup >in +! rot $! ;
        !            53: : ?cr ( -- )
        !            54:   #tib @ 1 >= IF  source 1- + c@ #cr = #tib +!  THEN ;
        !            55: : refill-loop ( -- flag ) base @ >r base off
        !            56:   BEGIN  refill ?cr  WHILE  ['] interpret catch drop  >in @ 0=  UNTIL
        !            57:   true  ELSE  maxnum off false  THEN  r> base ! ;
        !            58: 
        !            59: : response:  ( -- )  name
        !            60:     Forth definitions 2dup 1- nextname Variable
        !            61:     response-values set-current nextname here cell - Create ,
        !            62: DOES> @ get-rest ;
        !            63: : >response  response-values 1 set-order ;
        !            64: 
        !            65: response set-current
        !            66: 
        !            67: : HTTP/1.1 response-string get-rest >response ;
        !            68: : HTTP/1.0 response-string get-rest >response ;
        !            69: 
        !            70: \ response variables
        !            71: 
        !            72: Forth definitions
        !            73: 
        !            74: response: Allow:
        !            75: response: Age:
        !            76: response: Accept-Ranges:
        !            77: response: Cache-Control:
        !            78: response: Connection:
        !            79: response: Proxy-Connection:
        !            80: response: Content-Base:
        !            81: response: Content-Encoding:
        !            82: response: Content-Language:
        !            83: response: Content-Length:
        !            84: response: Content-Location:
        !            85: response: Content-MD5:
        !            86: response: Content-Range:
        !            87: response: Content-Type:
        !            88: response: Date:
        !            89: response: ETag:
        !            90: response: Expires:
        !            91: response: Last-Modified:
        !            92: response: Location:
        !            93: response: Mime-Version:
        !            94: response: Proxy-Authenticate:
        !            95: response: Proxy-Connection:
        !            96: response: Public:
        !            97: response: Retry-After:
        !            98: response: Server:
        !            99: response: Transfer-Encoding:
        !           100: response: Upgrade:
        !           101: response: Via:
        !           102: response: Warning:
        !           103: response: WWW-Authenticate:
        !           104: response: X-Cache:
        !           105: response: X-Powered-By:
        !           106: 
        !           107: Forth definitions
        !           108: 
        !           109: \ response handling
        !           110: 
        !           111: : get-response ( fid -- ior )
        !           112:     push-file loadfile !  loadline off  blk off
        !           113:     response 1 set-order  ['] refill-loop catch
        !           114:     only forth also  pop-file ;
        !           115: 
        !           116: \ data handling
        !           117: 
        !           118: Variable data-buffer
        !           119: 
        !           120: : clear-data ( -- )
        !           121:     s" " data-buffer $! ;
        !           122: : add-chunk ( u fid -- u' )
        !           123:     swap data-buffer $@len dup >r + data-buffer $!len
        !           124:     data-buffer $@ r@ /string rot read-file throw
        !           125:     dup r> + data-buffer $!len ;
        !           126: : read-sized ( u fid -- )
        !           127:     add-chunk drop ;
        !           128: : read-to-end ( fid -- )
        !           129:     >r BEGIN  $1000 r@ add-chunk $1000 <> UNTIL  rdrop ;
        !           130: 
        !           131: : read-chunked ( fid -- ) base @ >r hex >r
        !           132:     BEGIN  pad $100 r@ read-line throw  WHILE
        !           133:        pad swap s>number drop dup WHILE  r@ add-chunk drop
        !           134:        pad 1 r@ read-line throw  nip 0= UNTIL
        !           135:     ELSE  drop  THEN  THEN  rdrop r> base ! ;
        !           136: 
        !           137: : read-data ( fid -- ) clear-data >r
        !           138:     Content-Length @ IF
        !           139:        Content-Length $@ s>number drop r> read-sized  EXIT  THEN
        !           140:     Transfer-Encoding @ IF
        !           141:        Transfer-Encoding $@ s" chunked" str= 0= IF
        !           142:            r> read-chunked  EXIT  THEN  THEN
        !           143:     r> read-to-end ;
        !           144: 
        !           145: : fslurp ( addr u -- addr u )
        !           146:     '/ $split -1 /string
        !           147:     http-open dup >r get-response throw r> read-data  data-buffer $@ ;

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>