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