f

Forth package manager for theForthNet



\ HTTP client implementation for GForth
\ This is a very hacky implementation, but it works.
\ (c)copyright 2015-2016 by Gerald Wodni <gerald.wodni@gmail.com>

include unix/socket.fs

80 constant http-port
1 constant buffer-max       \ receiving buffer length ( yes we only care about single chars )
buffer-max buffer: rbuffer  \ receiving buffer
variable buffer-len         \ chars in receiving buffer

\ some helpers
: str>num ( c-addr n -- n )
    2>r 0 0 2r> >number 2drop drop ;

: str-to-lower ( c-addr n -- c-addr n )
    2dup bounds ?do
        i c@ dup [CHAR] A >= over [CHAR] Z <= and if
            $20 + i c!
        else
            drop
        then
    loop ;

: skip-bl ( c-addr n -- c-addr 2 n2 )
    2>r \ save start address
    2r@ bounds do
        i c@ bl <> if
            i leave
        then
    loop 2r>
    >r over swap - r> \ number of skipped blanks
    swap - ; \ change length

\ data in receiving socket
: skey? ( socket -- f )
    buffer-len @ 0<> ;

\ attempt to refill
: (srefill) ( socket -- )
    rbuffer buffer-max read-socket nip buffer-len ! ;

\ make sure we refill and get at least 1 char
: srefill ( socket -- )
    begin
        skey? 0=
    while
        dup (srefill)
    repeat drop ;

\ read char from socket
: skey ( socket -- c )
    srefill rbuffer c@
    0 buffer-len ! ;

\ strip \r
: skey-no\r ( socket -- c )
    begin
        dup skey dup 13 =
    while
        drop
    repeat nip ;

: sline ( c-addr n socket -- c-addr n )
    -rot    \ save socket
    over >r \ save buffer
    bounds do
        dup skey-no\r dup 10 = if \ leave on newline
            2drop i leave \ push current buffer-offset
        then
        i c!
    loop
    r@ - r> swap ; \ return buffer with read size

\ I might fall for locals some day, this is far easier than plain sline
: sline-until { c-addr-buf n-buf socket c-until -- c-addr n }
    c-addr-buf n-buf bounds do
        socket skey-no\r dup c-until = over 10 = or if
            drop i leave
        then
        i c!
    loop
    c-addr-buf - c-addr-buf swap ;

80 constant header-max
header-max buffer: header-buffer

: header-buf ( s -- c-addr n s )
    >r header-buffer header-max r> ;

: header-line ( s -- c-addr n )
    header-buf sline ;

: header-name ( s -- c-addr n )
    header-buf [CHAR] : sline-until str-to-lower ;

: http-status ( s -- n )
    header-line s"  " search if
        3 >= if
            1+ 3 str>num
        else \ return one on invalid string length
            1
        then
    else \ return zero if no space was found
        0
    then ;

80 constant slines-max
slines-max buffer: slines-buffer
: slines ( socket -- )
    101 0 do
        dup >r slines-buffer slines-max r> sline ." LINE:" i . type cr
    loop drop ;

: http-open ( c-addr-path n-path c-addr-host n-host -- socket )
    2dup \ save host
    http-port open-socket >r
        s" GET " r@ write-socket    \ start get request
        2swap r@ write-socket       \ send path 
        s\"  HTTP/1.1\r\nHost: " r@ write-socket
        r@ write-socket             \ send host
        s\" \r\nConnection: Close\r\n\r\n" r@ write-socket
        r>
    ;

\ parse all headers and return content length
: http-length ( s -- n-content-length )
    0
    locals| length |
    begin
        dup header-name
        dup 0<>
    while
        s" content-length" compare 0= if
            dup header-line
            skip-bl str>num to length
        else
            dup header-line 2drop
        then
    repeat 2drop drop length ;

: http-body ( socket c-addr n -- )
    bounds ?do
        dup skey i c!
    loop drop ;

: http-slurp ( c-addr-path n-path c-addr-host n-host -- c-addr-response n-response n-status )
    http-open
    dup http-status >r

    >r \ socket
    
    r@ http-length
    dup allocate throw swap \ c-addr n-len

    2dup r@ -rot http-body  \ read body into buffer

    r> close-socket
    r> \ status
    ;


\ directories
-529 constant error-exists

: create-directories ( c-addr n -- ior )
    $1FF mkdir-parents      \ add mask
    dup error-exists = if   \ ignore error-exists
        drop 0
    then ;

by GeraldWodni

avatar of GeraldWodni

Versions

0.2.4, 0.2.2, 0.2.1, 0.2.0, 0.1.0

Download current as zip

Tags

gforth, theforth.net

Dependencies

None

Dependents

None