Annotation of gforth/wordlibs/httpclient.fs, revision 1.1
1.1 ! jwilke 1: #! /usr/local/bin/gforth031
! 2:
! 3: \ make our directory the search directory
! 4: sourcefilename extractpath fpath only-path
! 5:
! 6: require wlibs/unixlib.fs
! 7: require wlibs/netlib.fs
! 8: require jflib/tools/fieldscan.fs
! 9:
! 10: : usage
! 11: ." httpclient.fs [ -p port ] [ -t timeout ] [ -s ] [ -r ] [ -b filename ] [ -e filename ]" cr
! 12: ." -h host resource-name" cr
! 13: ." Options:" cr
! 14: ." -p N Set portnumber to N (default is 80)" cr
! 15: ." -t N Set timeout to N (default is no timeout)" cr
! 16: ." -b name Save body (data) of response to file named name" cr
! 17: ." -e name Save header of response to file name" cr
! 18: ." -h host set host to host (dault is localhost)" cr
! 19: ." -r make an report" cr
! 20: ." -s silent operation, don't view requested data" cr
! 21: bye
! 22: ;
! 23:
! 24: Create hostname ," localhost" 300 chars allot
! 25: Variable port 80 port !
! 26: Variable timeout 0 timeout !
! 27: Variable silent-flag silent-flag off
! 28: Variable result-flag result-flag off
! 29:
! 30: Create crlf 13 c, 10 c, 13 c, 10 c,
! 31: Create wbuffer 300 chars allot
! 32: Create rbuffer 1000 chars allot
! 33:
! 34: Variable Headerbytes 0 Headerbytes !
! 35: Variable Databytes 0 Databytes !
! 36: Variable StatusCode
! 37: Create Protocol 100 chars allot
! 38: Create ReasonPhrase 100 chars allot
! 39: 0 Value header-fd
! 40: 0 Value data-fd
! 41:
! 42: : .args
! 43: argc @ 0 DO
! 44: ." arg " i . ." : " i arg type cr
! 45: LOOP ;
! 46:
! 47: 0 Value optind
! 48:
! 49: : end? ( -- flag)
! 50: optind argc @ u>= ;
! 51:
! 52: : arg? ( -- adr len )
! 53: \G get next argument
! 54: end? ABORT" too few arguments!"
! 55: optind arg
! 56: 1 optind + to optind ;
! 57:
! 58: : scanarg
! 59: 2 to optind
! 60: end? IF usage THEN
! 61: BEGIN end? 0=
! 62: WHILE optind arg
! 63: IF c@ [char] - =
! 64: IF
! 65: optind arg
! 66: 1 optind + to optind
! 67: forth-wordlist search-wordlist
! 68: 0= ABORT" wrong option!"
! 69: execute -1
! 70: ELSE false
! 71: THEN
! 72: ELSE true
! 73: THEN
! 74: WHILE
! 75: REPEAT THEN
! 76: ;
! 77:
! 78: : -? usage ;
! 79: : -h arg? hostname place ;
! 80: : -p 0.0 arg? >number 2drop d>s port ! ;
! 81: : -t 0.0 arg? >number 2drop d>s port ! ;
! 82: : -s silent-flag on ;
! 83: : -r result-flag on ;
! 84: : -b arg? r/w bin create-file throw to data-fd ;
! 85: : -e arg? r/w bin create-file throw to header-fd ;
! 86:
! 87: : fd-readline ( adr len fd -- u ior )
! 88: >r over + r> { startadr endadr fd }
! 89: startadr
! 90: BEGIN
! 91: dup 1 fd uread
! 92: ?dup IF nip startadr - EXIT THEN
! 93: IF dup c@
! 94: CASE 10 OF startadr - 0 EXIT ENDOF
! 95: 13 OF ENDOF
! 96: dup OF char+ ENDOF
! 97: ENDCASE
! 98: THEN
! 99: dup endadr =
! 100: UNTIL
! 101: startadr - 0 ;
! 102:
! 103: : http-header ( sd -- ior ) { sd }
! 104:
! 105: \ read 1st line
! 106: rbuffer 1000 sd fd-readline ?dup ?EXIT
! 107: rbuffer swap
! 108: bl fieldscan 100 min Protocol place
! 109: bl fieldscan 0 -rot 0 -rot >number 2drop d>s StatusCode !
! 110: bl fieldscan 100 min ReasonPhrase place
! 111: 2drop
! 112:
! 113: \ read until empty line
! 114: BEGIN rbuffer 1000 sd fd-readline ?dup IF nip EXIT THEN
! 115: dup
! 116: WHILE dup 2 + HeaderBytes +!
! 117: rbuffer swap
! 118: silent-flag @ 0= IF 2dup type cr THEN
! 119: header-fd IF header-fd write-line drop ELSE 2drop THEN
! 120: REPEAT
! 121: silent-flag @ 0= IF cr THEN
! 122: ;
! 123:
! 124: : http-body ( sd -- ior ) { sd }
! 125: BEGIN rbuffer 200 sd uread -39 <>
! 126: WHILE dup DataBytes +!
! 127: rbuffer swap
! 128: silent-flag @ 0= IF 2dup type cr THEN
! 129: data-fd IF data-fd write-file drop ELSE 2drop THEN
! 130: REPEAT 0 ;
! 131:
! 132: : http-data ( sd -- ior ) { sd }
! 133: sd http-header ?dup ?EXIT
! 134: sd http-body ;
! 135:
! 136: : main
! 137: end? ABORT" no file specified!"
! 138: timeout @ ?dup IF alarm THEN
! 139: hostname count port @ connect-tcp-name { sd }
! 140: s" GET " wbuffer place
! 141: optind arg wbuffer +place
! 142: s" HTTP/1.0" wbuffer +place
! 143: crlf 4 wbuffer +place
! 144: wbuffer count sd uwrite throw drop
! 145: sd http-data drop
! 146: sd uclose throw
! 147: result-flag @
! 148: IF
! 149: ." returnstatus=okay" cr
! 150: ." statuscode=" StatusCode @ 0 u.r cr
! 151: ." reasonphrase=" [char] " emit ReasonPhrase count type [char] " emit cr
! 152: ." headerbytes=" HeaderBytes @ 0 u.r cr
! 153: ." databytes=" DataBytes @ 0 u.r cr
! 154: THEN
! 155: header-fd ?dup IF close-file throw THEN
! 156: data-fd ?dup IF close-file throw THEN ;
! 157:
! 158: : (DoError2) ( throw-code -- )
! 159: Result-Flag @
! 160: IF ." returnstatus=failed" cr THEN
! 161: outfile-id dup flush-file drop >r
! 162: stderr to outfile-id
! 163: dup -2 =
! 164: IF
! 165: "error @ ?dup
! 166: IF
! 167: cr count type
! 168: THEN
! 169: drop
! 170: ELSE
! 171: .error
! 172: THEN
! 173: normal-dp dpp !
! 174: r> to outfile-id
! 175: ;
! 176:
! 177: ' (DoError2) IS DoError
! 178: scanarg
! 179: main
! 180:
! 181: bye
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>