\ a http get command
\ Copyright (C) 2000,2002,2003,2006,2007 Free Software Foundation, Inc.
\ This file is part of Gforth.
\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation, either version 3
\ of the License, or (at your option) any later version.
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see http://www.gnu.org/licenses/.
require unix/socket.fs
require string.fs
Create crlf #cr c, #lf c,
: writeln ( addr u fd -- )
dup >r write-file throw crlf 2 r> write-file throw ;
: request ( host u request u proxy-host u port -- fid )
open-socket >r
s" GET " r@ write-file throw r@ write-file throw s" HTTP/1.1" r@ writeln
s" Host: " r@ write-file throw r@ writeln
s" Connection: close" r@ writeln
s" User-Agent: " r@ write-file throw
s" Gforth Proxy 0.1" r@ writeln
s" " r@ writeln r> ;
Variable proxy \ s" proxy" proxy $! \ replace that with your proxy host
Variable proxy-port \ 8080 proxy-port ! \ replace that with your proxy port
\ set proxy to your local proxy, and proxy-port to your local proxy port
\ if you need any.
: http-open ( host u request u -- fid )
proxy @ 0= IF 2over 80 ELSE proxy $@ proxy-port @ THEN request ;
wordlist Constant response
wordlist Constant response-values
Variable response-string
Variable maxnum
: get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ;
: ?cr ( -- )
#tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ;
: refill-loop ( -- flag ) base @ >r base off
BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL
true ELSE maxnum off false THEN r> base ! ;
: response: ( -- ) name
Forth definitions 2dup 1- nextname Variable
response-values set-current nextname here cell - Create ,
DOES> @ get-rest ;
: >response response-values 1 set-order ;
response set-current
: HTTP/1.1 response-string get-rest >response ;
: HTTP/1.0 response-string get-rest >response ;
\ response variables
Forth definitions
response: Allow:
response: Age:
response: Accept-Ranges:
response: Cache-Control:
response: Connection:
response: Proxy-Connection:
response: Content-Base:
response: Content-Encoding:
response: Content-Language:
response: Content-Length:
response: Content-Location:
response: Content-MD5:
response: Content-Range:
response: Content-Type:
response: Date:
response: ETag:
response: Expires:
response: Last-Modified:
response: Location:
response: Mime-Version:
response: Proxy-Authenticate:
response: Proxy-Connection:
response: Public:
response: Retry-After:
response: Server:
response: Transfer-Encoding:
response: Upgrade:
response: Via:
response: Warning:
response: WWW-Authenticate:
response: X-Cache:
response: X-Powered-By:
Forth definitions
\ response handling
: get-response ( fid -- ior )
push-file loadfile ! loadline off blk off
response 1 set-order ['] refill-loop catch
only forth also pop-file ;
\ data handling
Variable data-buffer
: clear-data ( -- )
s" " data-buffer $! ;
: add-chunk ( u fid -- u' )
swap data-buffer $@len dup >r + data-buffer $!len
data-buffer $@ r@ /string rot read-file throw
dup r> + data-buffer $!len ;
: read-sized ( u fid -- )
add-chunk drop ;
: read-to-end ( fid -- )
>r BEGIN $1000 r@ add-chunk $1000 <> UNTIL rdrop ;
: read-chunked ( fid -- ) base @ >r hex >r
BEGIN pad $100 r@ read-line throw WHILE
pad swap s>number drop dup WHILE r@ add-chunk drop
pad 1 r@ read-line throw nip 0= UNTIL
ELSE drop THEN THEN rdrop r> base ! ;
: read-data ( fid -- ) clear-data >r
Content-Length @ IF
Content-Length $@ s>number drop r> read-sized EXIT THEN
Transfer-Encoding @ IF
Transfer-Encoding $@ s" chunked" str= IF
r> read-chunked EXIT THEN THEN
r> read-to-end ;
: fslurp ( addr u -- addr u response )
'/' $split -1 /string
http-open dup >r get-response throw r> read-data data-buffer $@
response-string $@ bl $split 2drop s>number drop ;
\ download file
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>