Return to fget.fs CVS log

Up to [gforth] / gforth

updated copyright years

    1: \ a http get command
    2: 
    3: \ Copyright (C) 2000,2002,2003,2006,2007,2010 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= IF
  142: 	    r> read-chunked  EXIT  THEN  THEN
  143:     r> read-to-end ;
  144: 
  145: : fslurp ( addr u -- addr u response )
  146:     '/' $split -1 /string
  147:     http-open dup >r get-response throw r> read-data  data-buffer $@
  148:     response-string $@ bl $split 2drop s>number drop ;
  149: 
  150: \ download file