src/sigil/http/client.sgl

1;;; (sigil http client) - HTTP Client Implementation

2;;;

3;;; Provides HTTP/1.1 client functionality for making requests to HTTP

4;;; and HTTPS servers.

5;;;

6;;; Example:

7;;; (import (sigil http client))

8;;; (let ((response (http-get "https://example.com/")))

9;;; (display (http-response-body response)))

11(define-library (sigil http client)

12 (import (sigil core)

13 (sigil string)

14 (sigil struct)

15 (sigil io)

16 (sigil time)

17 (only (sigil math) exact round)

18 (sigil socket)

19 (sigil http request)

20 (sigil http response))

22 ;; TLS is loaded lazily to allow HTTP-only usage without TLS dependency

24 (export

25 ;; URL parsing

26 parse-url

27 url-scheme

28 url-host

29 url-port

30 url-path

31 url-query

33 ;; High-level client API

34 http-get

35 http-post

36 http-put

37 http-delete

38 http-head

39 http-options

40 http-patch

41 http-request

43 ;; JSON conveniences (requires sigil-json)

44 http-response-json

45 http-get/json

46 http-post/json

48 ;; Send-status classification (for timeout: callers)

49 http-ack-unconfirmed?

51 ;; Streaming download

52 http-download

54 ;; Byte-faithful in-memory fetch (status + headers + raw body bytes)

55 http-fetch-bytes

57 ;; API client helpers

58 build-api-url

59 make-response-checker

60 make-json-api

62 ;; Re-export response accessors for convenience

63 http-response?

64 http-response-status

65 http-response-headers

66 http-response-body

68 ;; Internal — exported for testing

69 parse-http-response

70 decode-chunked-body

71 find-header-end-bytes

72 no-body-expected?

73 detect-framing

74 chunked-body-complete?

75 framing-complete?

76 ;; http-fetch-bytes internals — exported for testing

77 fetch-parse-headers

78 fetch-content-length

79 fetch-assemble

80 fetch-dechunk)

82 (begin

84 ;; ============================================================

85 ;; Lazy TLS Loading

86 ;; ============================================================

87 ;;

88 ;; TLS is loaded on first HTTPS request to avoid requiring the

89 ;; TLS library at compile time. This allows sigil-http to be

90 ;; compiled without sigil-tls being present.

92 ;; Promise that loads TLS module on first use

93 (define tls-module

94 (delay

95 (guard (exn (else #f))

96 (load-module '(sigil tls)))))

98 ;; Helper to get a TLS function, with error on missing TLS

99 (define (tls-ref sym)

100 (let ((m (force tls-module)))

101 (if m

102 (module-ref m sym)

103 (error "HTTPS requires TLS support. Install sigil-tls package."))))

104

105 ;; Cached TLS function promises

106 (define %tls-connect (delay (tls-ref 'tls-connect)))

107 (define %tls-connection? (delay (tls-ref 'tls-connection?)))

108 (define %tls-read (delay (tls-ref 'tls-read)))

109 (define %tls-read-bytevector (delay (tls-ref 'tls-read-bytevector)))

110 (define %tls-write (delay (tls-ref 'tls-write)))

111 (define %tls-close (delay (tls-ref 'tls-close)))

112 (define %tls-set-non-blocking! (delay (tls-ref 'tls-set-non-blocking!)))

113

114 ;; TLS function wrappers

115 (define (tls-connect* host port . connect-timeout-ms)

116 (apply (force %tls-connect) host port connect-timeout-ms))

117

118 (define (tls-connection?* conn)

119 (and (force tls-module)

120 ((force %tls-connection?) conn)))

121

122 (define (tls-read* conn . args)

123 (apply (force %tls-read) conn args))

124

125 (define (tls-read-bytevector* conn . args)

126 (apply (force %tls-read-bytevector) conn args))

127

128 (define (tls-write* conn data)

129 ((force %tls-write) conn data))

130

131 (define (tls-close* conn)

132 ((force %tls-close) conn))

133

134 (define (tls-set-non-blocking!* conn enable)

135 ((force %tls-set-non-blocking!) conn enable))

136

137 ;; ============================================================

138 ;; Lazy JSON Loading

139 ;; ============================================================

140 ;;

141 ;; JSON is loaded on first use of JSON conveniences to avoid

142 ;; requiring sigil-json when not needed.

143

144 (define json-module

145 (delay

146 (guard (exn (else #f))

147 (load-module '(sigil json)))))

148

149 (define (json-ref sym)

150 (let ((m (force json-module)))

151 (if m

152 (module-ref m sym)

153 (error "JSON functions require sigil-json package."))))

154

155 (define %json-decode (delay (json-ref 'json-decode)))

156 (define %json-encode (delay (json-ref 'json-encode)))

157

158 (define (json-decode* str)

159 ((force %json-decode) str))

160

161 (define (json-encode* value)

162 ((force %json-encode) value))

163

164 ;; ============================================================

165 ;; URL Record and Parsing

166 ;; ============================================================

167

168 (define-struct url

169 (scheme) ; "http" or "https"

170 (host) ; "example.com"

171 (port) ; 80, 443, or custom

172 (path) ; "/path/to/resource"

173 (query)) ; "foo=bar" or #f

174

175 ;;; Parse a URL string into a url record.

176 ;;;

177 ;;; Supports `http://host:port/path?query` and `https://...`.

178 ;;; Use `url-scheme`, `url-host`, `url-port`, `url-path`, `url-query`

179 ;;; to access the components.

180 ;;;

181 ;;; ```scheme

182 ;;; (let ((u (parse-url "https://example.com:8080/api?key=val")))

183 ;;; (url-host u)) ; => "example.com"

184 ;;; ```

185 (define (parse-url url-string)

186 (: string? -> any?)

187 (let* ((scheme-end (string-index url-string (lambda (c) (char=? c #\:))))

188 (scheme (if scheme-end

189 (substring url-string 0 scheme-end)

190 "http"))

191 ;; Skip "://" after scheme

192 (rest-start (if scheme-end

193 (+ scheme-end 3) ; Skip "://"

194 0))

195 (rest (substring url-string rest-start (string-length url-string)))

196 ;; Find end of host:port (first / or end of string)

197 (path-start (string-index rest (lambda (c) (char=? c #\/))))

198 (authority (if path-start

199 (substring rest 0 path-start)

200 rest))

201 (path-and-query (if path-start

202 (substring rest path-start (string-length rest))

203 "/"))

204 ;; Parse host:port from authority

205 (port-sep (string-index authority (lambda (c) (char=? c #\:))))

206 (host (if port-sep

207 (substring authority 0 port-sep)

208 authority))

209 (port (cond

210 (port-sep

211 (string->number (substring authority (+ port-sep 1)

212 (string-length authority))))

213 ((string=? scheme "https") 443)

214 (else 80)))

215 ;; Parse path?query

216 (query-start (string-index path-and-query (lambda (c) (char=? c #\?))))

217 (path (if query-start

218 (substring path-and-query 0 query-start)

219 path-and-query))

220 (query (if query-start

221 (substring path-and-query (+ query-start 1)

222 (string-length path-and-query))

223 #f)))

224 (url scheme: scheme

225 host: host

226 port: port

227 path: path

228 query: query)))

229

230 ;; ============================================================

231 ;; Low-level Connection Helpers

232 ;; ============================================================

233

234 ;;; Connect to a server, using TLS if scheme is https.

235 ;;; Returns connection object or #f on failure.

236 ;;;

237 ;;; `connect-timeout` (seconds, or #f) bounds the TLS connect phase

238 ;;; so a blackholed address can't hang on the OS SYN timeout. It is

239 ;;; only honored for HTTPS (the TLS connect path); plain HTTP uses

240 ;;; the socket layer's blocking connect (no timeout knob there yet).

241 (define (connect-to-server parsed-url connect-timeout)

242 (let ((host (url-host parsed-url))

243 (port (url-port parsed-url))

244 (scheme (url-scheme parsed-url)))

245 (if (string=? scheme "https")

246 (if (and connect-timeout (> connect-timeout 0))

247 (tls-connect* host port

248 (exact (round (* connect-timeout 1000))))

249 (tls-connect* host port))

250 (tcp-connect host port))))

251

252 ;;; Write data to connection (socket or TLS)

253 (define (conn-write conn data)

254 (if (tls-connection?* conn)

255 (tls-write* conn data)

256 (socket-write conn data)))

257

258 ;;; Read data from connection (socket or TLS)

259 (define (conn-read conn . max-bytes)

260 (if (tls-connection?* conn)

261 (if (null? max-bytes)

262 (tls-read* conn)

263 (tls-read* conn (car max-bytes)))

264 (if (null? max-bytes)

265 (socket-read conn)

266 (socket-read conn (car max-bytes)))))

267

268 ;;; Read binary data from connection as bytevector (socket or TLS)

269 (define (conn-read-bytes conn . max-bytes)

270 (if (tls-connection?* conn)

271 (if (null? max-bytes)

272 (tls-read-bytevector* conn)

273 (tls-read-bytevector* conn (car max-bytes)))

274 (if (null? max-bytes)

275 (socket-read-bytevector conn)

276 (socket-read-bytevector conn (car max-bytes)))))

277

278 ;;; Close connection

279 (define (conn-close conn)

280 (if (tls-connection?* conn)

281 (tls-close* conn)

282 (socket-close conn)))

283

284 ;;; Put a connection (socket or TLS) into non-blocking mode.

285 ;;; Used by the timeout path so reads return immediately when no

286 ;;; data is available, letting the read loop enforce a deadline.

287 (define (conn-set-non-blocking! conn)

288 (if (tls-connection?* conn)

289 (tls-set-non-blocking!* conn #t)

290 (socket-set-non-blocking! conn #t)))

291

292 ;; ============================================================

293 ;; Read Timeouts (opt-in)

294 ;; ============================================================

295 ;;

296 ;; By default (timeout: omitted/#f) all reads are blocking and

297 ;; behave exactly as before. When a positive timeout is supplied,

298 ;; the connection is switched to non-blocking after the request is

299 ;; written and the read loop polls until data arrives, the peer

300 ;; closes, or a wall-clock deadline passes — at which point a clean

301 ;; timeout error is raised so callers can reconnect instead of

302 ;; blocking forever on a half-open/blackholed connection.

303

304 ;; Seconds to sleep between empty (no-data-yet) non-blocking reads.

305 (define *read-poll-interval* 0.02)

306

307 ;;; Compute an absolute deadline in jiffies from a timeout in

308 ;;; seconds, or #f when no (positive) timeout was requested.

309 (define (timeout->deadline timeout)

310 (if (and timeout (number? timeout) (> timeout 0))

311 ;; Keep the deadline an exact integer: `current-jiffy` is a

312 ;; large exact value, and adding an inexact offset to it would

313 ;; lose nanosecond precision at that magnitude.

314 (+ (current-jiffy)

315 (exact (round (* timeout (jiffies-per-second)))))

316 #f))

317

318 ;;; Has the (jiffy) deadline passed?

319 (define (deadline-expired? deadline)

320 (and deadline (>= (current-jiffy) deadline)))

321

322 ;; Irritant marking an exception as "the request was written to the

323 ;; server (so it was likely delivered/processed) but reading the

324 ;; response failed" — as opposed to a connect/write failure where the

325 ;; request never left. Callers can use `http-ack-unconfirmed?` to

326 ;; treat the send as best-effort success (no retry) rather than a

327 ;; failed send (retry would re-deliver an already-delivered request).

328 (define ack-unconfirmed-irritant 'http-ack-unconfirmed)

329

330 ;;; Is `exn` an "ack unconfirmed" error (request sent, response read

331 ;;; failed)? Distinguishes a delivered-but-unconfirmed send from a

332 ;;; genuine never-sent failure (the latter does not carry this mark).

333 (define (http-ack-unconfirmed? exn)

334 (and (error-object? exn)

335 (memq ack-unconfirmed-irritant (error-object-irritants exn))

336 #t))

337

338 ;;; Raise an "ack unconfirmed" error: the request was sent but the

339 ;;; response could not be read (read deadline, empty/closed read, or

340 ;;; unparseable response). Carries `ack-unconfirmed-irritant`.

341 (define (raise-http-ack-unconfirmed reason)

342 (error (string-append "HTTP request sent but response read failed: "

343 reason)

344 ack-unconfirmed-irritant))

345

346 ;;; Raise a clean timeout error (read deadline). Marked ack-unconfirmed

347 ;;; because the deadline only fires after the request was written.

348 (define (raise-http-timeout)

349 (raise-http-ack-unconfirmed "read deadline exceeded"))

350

351 ;; ============================================================

352 ;; HTTP Request Building

353 ;; ============================================================

354

355 ;;; Build HTTP request string

356 (define (build-request-string method parsed-url headers body)

357 (let* ((path (url-path parsed-url))

358 (query (url-query parsed-url))

359 (uri (if query

360 (string-append path "?" query)

361 path))

362 (host (url-host parsed-url))

363 (port (url-port parsed-url))

364 (host-header (if (or (and (string=? (url-scheme parsed-url) "http")

365 (= port 80))

366 (and (string=? (url-scheme parsed-url) "https")

367 (= port 443)))

368 host

369 (string-append host ":" (number->string port)))))

370 (string-append

371 ;; Request line

372 (symbol->string method) " " uri " HTTP/1.1\r\n"

373 ;; Host header (required for HTTP/1.1)

374 "Host: " host-header "\r\n"

375 ;; User-Agent

376 "User-Agent: Sigil/1.0\r\n"

377 ;; Connection

378 "Connection: close\r\n"

379 ;; Additional headers

380 (build-header-lines headers)

381 ;; Content-Length if body present (use byte length for UTF-8)

382 (if body

383 (string-append "Content-Length: "

384 (number->string

385 (bytevector-length (string->utf8 body)))

386 "\r\n")

387 "")

388 ;; End of headers

389 "\r\n"

390 ;; Body

391 (or body ""))))

392

393 ;;; Build header lines from headers (dict or alist)

394 (define (build-header-lines headers)

395 (cond

396 ;; Empty

397 ((null? headers) "")

398 ;; Dict - convert entries to header lines

399 ((dict? headers)

400 (let loop ((entries (dict-entries headers)) (result ""))

401 (if (null? entries)

402 result

403 (let ((entry (car entries)))

404 (loop (cdr entries)

405 (string-append result

406 (keyword->string (car entry))

407 ": "

408 (cdr entry)

409 "\r\n"))))))

410 ;; Alist - legacy format

411 (else

412 (let loop ((headers headers) (result ""))

413 (if (null? headers)

414 result

415 (let ((h (car headers)))

416 (loop (cdr headers)

417 (string-append result

418 (car h) ": " (cdr h) "\r\n"))))))))

419

420 ;; ============================================================

421 ;; HTTP Response Parsing

422 ;; ============================================================

423

424 ;;; Parse HTTP status line

425 ;;; Returns (version status-code reason) or #f

426 (define (parse-status-line line)

427 (let ((space1 (string-index line (lambda (c) (char=? c #\space)))))

428 (if (not space1)

429 #f

430 (let* ((version (substring line 0 space1))

431 (rest (substring line (+ space1 1) (string-length line)))

432 (space2 (string-index rest (lambda (c) (char=? c #\space)))))

433 (if (not space2)

434 #f

435 (let ((status-str (substring rest 0 space2))

436 (reason (substring rest (+ space2 1) (string-length rest))))

437 (list version (string->number status-str) reason)))))))

438

439 ;;; Parse response headers from data

440 ;;; Returns dict with keyword keys

441 (define (parse-response-headers lines)

442 (let loop ((lines lines) (headers #{}))

443 (if (null? lines)

444 headers

445 (let* ((line (car lines))

446 (colon-pos (string-index line (lambda (c) (char=? c #\:)))))

447 (if colon-pos

448 (let ((name (string->keyword

449 (string-downcase (substring line 0 colon-pos))))

450 (value (string-trim

451 (substring line (+ colon-pos 1)

452 (string-length line)))))

453 (loop (cdr lines)

454 (dict-set headers name value)))

455 (loop (cdr lines) headers))))))

456

457 ;;; Find the end of the header block (\r\n\r\n) in a bytevector.

458 ;;; Returns the index of the first \r, or #f if not yet present.

459 (define (find-header-end-bytes bv)

460 (let ((len (bytevector-length bv)))

461 (let loop ((i 0))

462 (if (> (+ i 3) (- len 1))

463 #f

464 (if (and (= (bytevector-u8-ref bv i) 13)

465 (= (bytevector-u8-ref bv (+ i 1)) 10)

466 (= (bytevector-u8-ref bv (+ i 2)) 13)

467 (= (bytevector-u8-ref bv (+ i 3)) 10))

468 i

469 (loop (+ i 1)))))))

470

471 ;;; Does this method/status combination forbid a response body?

472 ;;; HEAD never has a body; 1xx/204/304 never have a body (RFC 9112).

473 (define (no-body-expected? method status)

474 (or (eq? method 'HEAD)

475 (and status

476 (or (= status 204)

477 (= status 304)

478 (and (>= status 100) (< status 200))))))

479

480 ;;; Inspect the accumulated response bytes and determine how the body

481 ;;; is framed. Returns #f while the header block is still incomplete,

482 ;;; otherwise a descriptor:

483 ;;; (no-body) — no body permitted; complete at headers

484 ;;; (length <body-start> <n>) — fixed Content-Length body

485 ;;; (chunked <body-start>) — chunked transfer-encoding

486 ;;; (until-close) — unframed; read until the peer closes

487 ;;; This lets the reader stop as soon as the full body has arrived

488 ;;; instead of waiting for the connection to close (EOF), which a

489 ;;; keep-alive/half-open peer may never do.

490 (define (detect-framing method bv)

491 (let ((he (find-header-end-bytes bv)))

492 (if (not he)

493 #f

494 (let* ((body-start (+ he 4))

495 (header-str (utf8->string (bytevector-copy bv 0 he)))

496 (lines (string-split header-str "\r\n"))

497 (status-info (and (pair? lines) (parse-status-line (car lines))))

498 (status (and status-info (cadr status-info)))

499 (headers (if (pair? lines)

500 (parse-response-headers (cdr lines))

501 #{}))

502 (te (dict-ref headers transfer-encoding: #f))

503 (cl (dict-ref headers content-length: #f)))

504 (cond

505 ((no-body-expected? method status) (list 'no-body))

506 ((and te (string-contains? (string-downcase te) "chunked"))

507 (list 'chunked body-start))

508 (cl (let ((n (string->number (string-trim cl))))

509 (if n (list 'length body-start n) (list 'until-close))))

510 (else (list 'until-close)))))))

511

512 ;;; Is the chunked body starting at `start` fully present in `bv`?

513 ;;; Walks chunk-size lines until the terminating 0-size chunk and its

514 ;;; closing CRLF (no trailers). Returns #f if more data is needed.

515 (define (chunked-body-complete? bv start)

516 (let ((len (bytevector-length bv)))

517 (let loop ((pos start))

518 (let ((line-end (find-crlf-bytes bv pos)))

519 (if (not line-end)

520 #f

521 (let* ((size-str (utf8->string (bytevector-copy bv pos line-end)))

522 (sz (hex-string->number size-str)))

523 (cond

524 ((not sz) #f)

525 ((= sz 0)

526 ;; Final chunk: need the closing CRLF after "0\r\n".

527 (let ((after (+ line-end 2)))

528 (and (<= (+ after 2) len)

529 (= (bytevector-u8-ref bv after) 13)

530 (= (bytevector-u8-ref bv (+ after 1)) 10))))

531 (else

532 ;; size-line CRLF + data + trailing CRLF

533 (let ((next (+ line-end 2 sz 2)))

534 (if (> next len) #f (loop next)))))))))))

535

536 ;;; Is the response complete per its framing descriptor?

537 ;;; `combined` is the accumulated bytevector (only needed for chunked).

538 (define (framing-complete? framing total combined)

539 (let ((mode (car framing)))

540 (cond

541 ((eq? mode 'no-body) #t)

542 ((eq? mode 'length) (>= (- total (cadr framing)) (caddr framing)))

543 ((eq? mode 'chunked) (chunked-body-complete? combined (cadr framing)))

544 (else #f)))) ; until-close — rely on EOF

545

546 ;;; Read HTTP response from connection

547 ;;; Returns http-response or #f on error.

548 ;;; `method` is the request method (HEAD responses carry no body).

549 ;;; `deadline` is a jiffy deadline (or #f). When set, the read loop

550 ;;; enforces a timeout instead of blocking on a stalled read.

551 (define (read-http-response method conn deadline)

552 ;; Read all available data

553 (let ((data (read-all-data method conn deadline)))

554 (if (or (not data) (string=? data ""))

555 #f

556 (parse-http-response data))))

557

558 ;;; Read a full HTTP response from the connection.

559 ;;; Reads as bytevectors and converts to string once at the end to

560 ;;; avoid splitting multi-byte UTF-8 characters across chunks.

561 ;;;

562 ;;; Termination is HTTP-framing-aware: once the header block has

563 ;;; arrived, the response is considered complete as soon as the body

564 ;;; is fully received per its framing (Content-Length, the chunked

565 ;;; 0-terminator, or a body-less status/method). The reader does NOT

566 ;;; wait for the connection to close — a keep-alive or half-open peer

567 ;;; may hold it open indefinitely even after sending a complete

568 ;;; response, which previously hung the read (or, with a deadline,

569 ;;; tripped a spurious timeout on an already-delivered request).

570 ;;; Only an unframed response (no Content-Length, not chunked) falls

571 ;;; back to reading until EOF.

572 ;;;

573 ;;; When `deadline` is #f, reads block. When set, the connection is

574 ;;; non-blocking: an empty read means "no data yet", so we sleep

575 ;;; briefly and retry until the response completes, the peer closes,

576 ;;; or the deadline passes (which raises a timeout error).

577 (define (read-all-data method conn deadline)

578 (let loop ((chunks '()) (total 0) (framing #f))

579 (let ((chunk (conn-read-bytes conn 8192)))

580 (cond

581 ((not chunk)

582 ;; Error

583 (if (null? chunks)

584 #f

585 (utf8->string (apply bytevector-append (reverse chunks)))))

586 ((eof-object? chunk)

587 ;; Peer closed — done (the only terminator for until-close).

588 (utf8->string (apply bytevector-append (reverse chunks))))

589 ((= (bytevector-length chunk) 0)

590 (if deadline

591 ;; Non-blocking: no data yet — enforce the deadline.

592 (if (deadline-expired? deadline)

593 (begin (conn-close conn) (raise-http-timeout))

594 (begin (sleep *read-poll-interval*) (loop chunks total framing)))

595 ;; Blocking (no timeout): no data available, done.

596 (utf8->string (apply bytevector-append (reverse chunks)))))

597 (else

598 (let* ((chunks* (cons chunk chunks))

599 (total* (+ total (bytevector-length chunk)))

600 ;; Combine only while detecting headers or scanning a

601 ;; chunked body; Content-Length completion is a cheap

602 ;; byte-count check needing no recombination.

603 (need-bytes (or (not framing)

604 (eq? (car framing) 'chunked)))

605 (combined (and need-bytes

606 (apply bytevector-append (reverse chunks*))))

607 (framing* (or framing

608 (and combined (detect-framing method combined)))))

609 (if (and framing* (framing-complete? framing* total* combined))

610 (utf8->string (or combined

611 (apply bytevector-append (reverse chunks*))))

612 (loop chunks* total* framing*))))))))

613

614 ;;; Parse HTTP response from string

615 (define (parse-http-response data)

616 ;; Find end of headers (blank line)

617 (let ((header-end (find-header-end data)))

618 (if (not header-end)

619 #f

620 (let* ((header-section (substring data 0 header-end))

621 (body-start (skip-crlf data header-end))

622 (raw-body (if (< body-start (string-length data))

623 (substring data body-start (string-length data))

624 ""))

625 (lines (string-split header-section "\r\n")))

626 (if (null? lines)

627 #f

628 (let ((status-info (parse-status-line (car lines))))

629 (if (not status-info)

630 #f

631 (let* ((status-code (cadr status-info))

632 (headers (parse-response-headers (cdr lines)))

633 (transfer-encoding (dict-ref headers transfer-encoding: #f))

634 (body (if (and transfer-encoding

635 (string-contains? (string-downcase transfer-encoding) "chunked"))

636 (decode-chunked-body raw-body)

637 raw-body)))

638 (http-response

639 status: status-code

640 headers: headers

641 body: body)))))))))

642

643 ;;; Decode chunked transfer encoding using byte-level operations.

644 ;;; Chunk sizes in HTTP are byte counts, so we must work with bytes

645 ;;; to correctly handle multi-byte UTF-8 content.

646 ;;; Format: <hex-size>\r\n<data>\r\n ... 0\r\n\r\n

647 (define (decode-chunked-body data)

648 (let* ((bv (string->utf8 data))

649 (len (bytevector-length bv)))

650 (let loop ((pos 0) (chunks '()))

651 (if (>= pos len)

652 (utf8->string (apply bytevector-append (reverse chunks)))

653 ;; Find end of chunk size line (\r\n)

654 (let ((line-end (find-crlf-bytes bv pos)))

655 (if (not line-end)

656 (utf8->string (apply bytevector-append (reverse chunks)))

657 ;; Extract size string (ASCII, safe to convert)

658 (let* ((size-bv (bytevector-copy bv pos line-end))

659 (size-str (utf8->string size-bv))

660 (chunk-size (hex-string->number size-str)))

661 (if (or (not chunk-size) (= chunk-size 0))

662 (utf8->string (apply bytevector-append (reverse chunks)))

663 ;; Read chunk data (byte-level offsets)

664 (let ((chunk-start (+ line-end 2))

665 (chunk-end (+ line-end 2 chunk-size)))

666 (if (> chunk-end len)

667 (utf8->string (apply bytevector-append (reverse chunks)))

668 (let ((chunk (bytevector-copy bv chunk-start chunk-end)))

669 (loop (+ chunk-end 2)

670 (cons chunk chunks)))))))))))))

671

672 ;;; Find position of \r\n in a bytevector starting at pos

673 (define (find-crlf-bytes bv pos)

674 (let ((len (bytevector-length bv)))

675 (let loop ((i pos))

676 (if (>= i (- len 1))

677 #f

678 (if (and (= (bytevector-u8-ref bv i) 13) ; \r

679 (= (bytevector-u8-ref bv (+ i 1)) 10)) ; \n

680 i

681 (loop (+ i 1)))))))

682

683 ;;; Find position of \r\n in a string starting at pos

684 (define (find-crlf data pos)

685 (let ((len (string-length data)))

686 (let loop ((i pos))

687 (if (>= i (- len 1))

688 #f

689 (if (and (char=? (string-ref data i) #\return)

690 (char=? (string-ref data (+ i 1)) #\newline))

691 i

692 (loop (+ i 1)))))))

693

694 ;;; Convert hex string to number

695 (define (hex-string->number str)

696 (let ((s (string-trim str)))

697 (if (string=? s "")

698 #f

699 (let loop ((i 0) (result 0))

700 (if (>= i (string-length s))

701 result

702 (let* ((c (char-downcase (string-ref s i)))

703 (digit (cond

704 ((and (char>=? c #\0) (char<=? c #\9))

705 (- (char->integer c) (char->integer #\0)))

706 ((and (char>=? c #\a) (char<=? c #\f))

707 (+ 10 (- (char->integer c) (char->integer #\a))))

708 (else #f))))

709 (if (not digit)

710 result ; Stop at non-hex character

711 (loop (+ i 1) (+ (* result 16) digit)))))))))

712

713 ;;; Find the end of HTTP headers (position of \r\n\r\n)

714 (define (find-header-end data)

715 (let ((len (string-length data)))

716 (let loop ((i 0))

717 (if (>= i (- len 3))

718 #f

719 (if (and (char=? (string-ref data i) #\return)

720 (char=? (string-ref data (+ i 1)) #\newline)

721 (char=? (string-ref data (+ i 2)) #\return)

722 (char=? (string-ref data (+ i 3)) #\newline))

723 i

724 (loop (+ i 1)))))))

725

726 ;;; Skip CRLF sequence(s) at position

727 (define (skip-crlf data pos)

728 (let ((len (string-length data)))

729 (let loop ((i pos))

730 (if (>= i len)

731 i

732 (if (or (char=? (string-ref data i) #\return)

733 (char=? (string-ref data i) #\newline))

734 (loop (+ i 1))

735 i)))))

736

737 ;; ============================================================

738 ;; High-Level Client API

739 ;; ============================================================

740

741 ;;; Make an HTTP request.

742 ;;;

743 ;;; Low-level function for making HTTP requests. Prefer the convenience

744 ;;; functions (http-get, http-post, etc.) for common cases.

745 ;;;

746 ;;; The optional `timeout:` keyword bounds the response read. When

747 ;;; given a positive number of seconds, the read is made

748 ;;; non-blocking and a timeout error is raised if no complete

749 ;;; response arrives before the deadline (so a half-open/blackholed

750 ;;; connection fails cleanly instead of hanging). When omitted (the

751 ;;; default), reads block exactly as before.

752 ;;;

753 ;;; The optional `connect-timeout:` keyword (seconds) bounds the

754 ;;; HTTPS connect phase, so a blackholed address can't hang on the

755 ;;; OS SYN timeout. Omitted/#f keeps the blocking connect.

756 ;;;

757 ;;; ```scheme

758 ;;; (http-request 'GET "https://api.example.com/users"

759 ;;; headers: #{ authorization: "Bearer token" })

760 ;;;

761 ;;; (http-request 'POST "https://api.example.com/users"

762 ;;; headers: #{ content-type: "application/json" }

763 ;;; body: "{\"name\": \"Alice\"}"

764 ;;; timeout: 25)

765 ;;; ```

766 (define (http-request method url (keys: (headers #{}) (body #f) (timeout #f)

767 (connect-timeout #f)))

768 (: symbol? string? (headers: dict?) (body: (maybe string?))

769 (timeout: (maybe number?)) (connect-timeout: (maybe number?)) -> any?)

770 (let* ((parsed-url (parse-url url))

771 (conn (connect-to-server parsed-url connect-timeout)))

772 (if (not conn)

773 #f ; connect failed — request never sent

774 (let ((deadline (timeout->deadline timeout))

775 (request-str (build-request-string method parsed-url headers body)))

776 ;; Write the request while still blocking (requests are

777 ;; small and fit the socket buffer), then switch to

778 ;; non-blocking so the read loop can enforce the deadline.

779 (let ((wrote (conn-write conn request-str)))

780 ;; Phase distinction is only surfaced when a timeout is in

781 ;; use (opt-in); without it, behavior is byte-identical to

782 ;; before (the write result is ignored and a failed read

783 ;; just yields #f).

784 (if (and deadline (not wrote))

785 (begin (conn-close conn) #f) ; write failed — never (fully) sent

786 (begin

787 (when deadline (conn-set-non-blocking! conn))

788 (let ((response (read-http-response method conn deadline)))

789 (conn-close conn)

790 (if (and deadline (not response))

791 ;; Request was written but no usable response

792 ;; came back → delivered, ack unconfirmed.

793 (raise-http-ack-unconfirmed "no response read")

794 response)))))))))

795

796 ;;; HTTP GET request.

797 ;;;

798 ;;; ```scheme

799 ;;; (http-get "https://example.com/")

800 ;;;

801 ;;; (http-get "https://api.example.com/users"

802 ;;; headers: #{ authorization: "Bearer token" })

803 ;;; ```

804 (define (http-get url (keys: (headers #{}) (timeout #f) (connect-timeout #f)))

805 (: string? (headers: dict?) (timeout: (maybe number?))

806 (connect-timeout: (maybe number?)) -> any?)

807 (http-request 'GET url headers: headers timeout: timeout

808 connect-timeout: connect-timeout))

809

810 ;;; HTTP POST request.

811 ;;;

812 ;;; If no Content-Type header is provided, defaults to

813 ;;; application/x-www-form-urlencoded.

814 ;;;

815 ;;; ```scheme

816 ;;; (http-post "https://api.example.com/data" "key=value")

817 ;;;

818 ;;; (http-post "https://api.example.com/data"

819 ;;; "{\"key\": \"value\"}"

820 ;;; headers: #{ content-type: "application/json" })

821 ;;; ```

822 (define (http-post url body (keys: (headers #{}) (timeout #f) (connect-timeout #f)))

823 (: string? any? (headers: dict?) (timeout: (maybe number?))

824 (connect-timeout: (maybe number?)) -> any?)

825 (let ((hdrs (if (and (dict? headers) (not (dict-contains? headers content-type:)))

826 (dict-set headers content-type: "application/x-www-form-urlencoded")

827 headers)))

828 (http-request 'POST url headers: hdrs body: body timeout: timeout

829 connect-timeout: connect-timeout)))

830

831 ;;; HTTP PUT request.

832 ;;;

833 ;;; ```scheme

834 ;;; (http-put "https://api.example.com/users/123"

835 ;;; "{\"name\": \"Alice\"}"

836 ;;; headers: #{ content-type: "application/json" })

837 ;;; ```

838 (define (http-put url body (keys: (headers #{}) (timeout #f) (connect-timeout #f)))

839 (: string? any? (headers: dict?) (timeout: (maybe number?))

840 (connect-timeout: (maybe number?)) -> any?)

841 (http-request 'PUT url headers: headers body: body timeout: timeout

842 connect-timeout: connect-timeout))

843

844 ;;; HTTP DELETE request.

845 ;;;

846 ;;; ```scheme

847 ;;; (http-delete "https://api.example.com/users/123")

848 ;;;

849 ;;; (http-delete "https://api.example.com/users/123"

850 ;;; headers: #{ authorization: "Bearer token" })

851 ;;; ```

852 (define (http-delete url (keys: (headers #{}) (timeout #f) (connect-timeout #f)))

853 (: string? (headers: dict?) (timeout: (maybe number?))

854 (connect-timeout: (maybe number?)) -> any?)

855 (http-request 'DELETE url headers: headers timeout: timeout

856 connect-timeout: connect-timeout))

857

858 ;;; HTTP HEAD request.

859 ;;;

860 ;;; Like GET but only retrieves headers, not body.

861 ;;; Useful for checking if a resource exists or getting metadata.

862 ;;;

863 ;;; ```scheme

864 ;;; (let ((res (http-head "https://example.com/file.pdf")))

865 ;;; (http-response-header res "Content-Length"))

866 ;;; ```

867 (define (http-head url (keys: (headers #{}) (timeout #f) (connect-timeout #f)))

868 (: string? (headers: dict?) (timeout: (maybe number?))

869 (connect-timeout: (maybe number?)) -> any?)

870 (http-request 'HEAD url headers: headers timeout: timeout

871 connect-timeout: connect-timeout))

872

873 ;;; HTTP OPTIONS request.

874 ;;;

875 ;;; Query server for allowed methods on a resource.

876 ;;;

877 ;;; ```scheme

878 ;;; (let ((res (http-options "https://api.example.com/users")))

879 ;;; (http-response-header res "Allow"))

880 ;;; ; => "GET, POST, OPTIONS"

881 ;;; ```

882 (define (http-options url (keys: (headers #{}) (timeout #f) (connect-timeout #f)))

883 (: string? (headers: dict?) (timeout: (maybe number?))

884 (connect-timeout: (maybe number?)) -> any?)

885 (http-request 'OPTIONS url headers: headers timeout: timeout

886 connect-timeout: connect-timeout))

887

888 ;;; HTTP PATCH request.

889 ;;;

890 ;;; Partially update a resource. Unlike PUT which replaces the entire

891 ;;; resource, PATCH applies partial modifications.

892 ;;;

893 ;;; ```scheme

894 ;;; (http-patch "https://api.example.com/users/123"

895 ;;; "{\"email\": \"[email protected]\"}"

896 ;;; headers: #{ content-type: "application/json" })

897 ;;; ```

898 (define (http-patch url body (keys: (headers #{}) (timeout #f) (connect-timeout #f)))

899 (: string? any? (headers: dict?) (timeout: (maybe number?))

900 (connect-timeout: (maybe number?)) -> any?)

901 (http-request 'PATCH url headers: headers body: body timeout: timeout

902 connect-timeout: connect-timeout))

903

904 ;; ============================================================

905 ;; JSON Conveniences

906 ;; ============================================================

907

908 ;;; Parse HTTP response body as JSON.

909 ;;;

910 ;;; Returns the parsed JSON value, or #f if the response is #f

911 ;;; or parsing fails. Requires sigil-json package.

912 ;;;

913 ;;; ```scheme

914 ;;; (let ((res (http-get "https://api.example.com/data")))

915 ;;; (http-response-json res))

916 ;;; ; => #{ users: #[...] count: 42 }

917 ;;; ```

918 (define (http-response-json response)

919 (: any? -> any?)

920 (if (and response (http-response-body response))

921 (guard (exn (else #f))

922 (json-decode* (http-response-body response)))

923 #f))

924

925 ;;; HTTP GET request expecting JSON response.

926 ;;;

927 ;;; Makes a GET request and parses the response body as JSON.

928 ;;; Returns the parsed JSON value, or #f if request fails or

929 ;;; status is not 2xx.

930 ;;;

931 ;;; ```scheme

932 ;;; (http-get/json "https://api.example.com/users")

933 ;;; ; => #{ users: #[...] }

934 ;;;

935 ;;; (http-get/json "https://api.example.com/users"

936 ;;; headers: #{ authorization: "Bearer token" })

937 ;;; ```

938 (define (http-get/json url (keys: (headers #{}) (timeout #f) (connect-timeout #f)))

939 (: string? (headers: dict?) (timeout: (maybe number?))

940 (connect-timeout: (maybe number?)) -> any?)

941 (let ((res (http-get url headers: headers timeout: timeout

942 connect-timeout: connect-timeout)))

943 (and res (http-response-json res))))

944

945 ;;; HTTP POST request with JSON body, expecting JSON response.

946 ;;;

947 ;;; Encodes the body as JSON, sets Content-Type to application/json,

948 ;;; and parses the response as JSON. Returns parsed JSON on any status

949 ;;; code, or #f if the request failed entirely.

950 ;;;

951 ;;; ```scheme

952 ;;; (http-post/json "https://api.example.com/users"

953 ;;; #{ name: "Alice" email: "[email protected]" })

954 ;;; ; => #{ id: 123 name: "Alice" }

955 ;;;

956 ;;; (http-post/json "https://api.example.com/users"

957 ;;; #{ name: "Alice" }

958 ;;; headers: #{ authorization: "Bearer token" })

959 ;;; ```

960 (define (http-post/json url body (keys: (headers #{}) (timeout #f) (connect-timeout #f)))

961 (: string? any? (headers: dict?) (timeout: (maybe number?))

962 (connect-timeout: (maybe number?)) -> any?)

963 (let* ((json-body (json-encode* body))

964 (hdrs (dict-set headers content-type: "application/json"))

965 (res (http-request 'POST url headers: hdrs body: json-body timeout: timeout

966 connect-timeout: connect-timeout)))

967 (and res (http-response-json res))))

968

969 ;; ============================================================

970 ;; Streaming Download

971 ;; ============================================================

972

973 ;;; Read HTTP response headers only, without consuming the body.

974 ;;;

975 ;;; Returns a list: (status-code headers leftover-string)

976 ;;; where leftover-string is any body data already read past the

977 ;;; header boundary. Returns #f on failure.

978 (define (read-response-headers conn)

979 (let loop ((accumulated ""))

980 (let ((chunk (conn-read conn 8192)))

981 (cond

982 ((or (not chunk) (eof-object? chunk))

983 ;; Connection closed or error before headers complete

984 (let ((data (if (and chunk (not (eof-object? chunk)))

985 (string-append accumulated chunk)

986 accumulated)))

987 (let ((header-end (find-header-end data)))

988 (if header-end

989 (parse-header-result data header-end)

990 #f))))

991 ((string=? chunk "")

992 ;; Non-blocking, no data yet - check what we have

993 (let ((header-end (find-header-end accumulated)))

994 (if header-end

995 (parse-header-result accumulated header-end)

996 (loop accumulated))))

997 (else

998 (let* ((data (string-append accumulated chunk))

999 (header-end (find-header-end data)))

1000 (if header-end

1001 (parse-header-result data header-end)

1002 (loop data))))))))

1003

1004 ;;; Parse headers from data at the given header-end position.

1005 ;;; Returns (status-code headers leftover-string).

1006 (define (parse-header-result data header-end)

1007 (let* ((header-section (substring data 0 header-end))

1008 (body-start (skip-crlf data header-end))

1009 (leftover (if (< body-start (string-length data))

1010 (substring data body-start (string-length data))

1011 ""))

1012 (lines (string-split header-section "\r\n")))

1013 (if (null? lines)

1014 #f

1015 (let ((status-info (parse-status-line (car lines))))

1016 (if (not status-info)

1017 #f

1018 (list (cadr status-info)

1019 (parse-response-headers (cdr lines))

1020 leftover))))))

1021

1022 ;;; Stream response body from connection to an output port.

1023 ;;;

1024 ;;; Writes leftover bytes (from header read) first, then reads

1025 ;;; remaining data as bytevectors and writes them to the port.

1026 (define (stream-body-to-port conn port content-length leftover-string on-progress)

1027 (let ((written 0))

1028 ;; Write any leftover data from header reading

1029 (when (and leftover-string (not (string=? leftover-string "")))

1030 (let ((bv (string->utf8 leftover-string)))

1031 (write-bytevector bv port)

1032 (set! written (+ written (bytevector-length bv)))

1033 (when on-progress

1034 (on-progress written content-length))))

1035 ;; Stream remaining body

1036 (let loop ()

1037 (when (or (not content-length) (< written content-length))

1038 (let ((chunk (conn-read-bytes conn 65536)))

1039 (cond

1040 ((or (not chunk) (eof-object? chunk))

1041 ;; Done or error

1042 #t)

1043 ((= (bytevector-length chunk) 0)

1044 ;; Non-blocking, no data yet

1045 (loop))

1046 (else

1047 (write-bytevector chunk port)

1048 (set! written (+ written (bytevector-length chunk)))

1049 (when on-progress

1050 (on-progress written content-length))

1051 (loop))))))

1052 written))

1053

1054 ;;; Download a URL to a file, streaming data directly to disk.

1055 ;;;

1056 ;;; Unlike `http-get` which loads the entire response into memory,

1057 ;;; `http-download` streams the response body to a file, making it

1058 ;;; suitable for large downloads.

1059 ;;;

1060 ;;; The `on-progress` callback receives `(bytes-received total-bytes)`

1061 ;;; where `total-bytes` may be `#f` if the server didn't send

1062 ;;; Content-Length.

1063 ;;;

1064 ;;; Returns a dict with download info on success, or `#f` on failure.

1065 ;;;

1066 ;;; ```scheme

1067 ;;; (http-download "https://example.com/large-file.bin"

1068 ;;; "/tmp/file.bin")

1069 ;;; ; => #{ status: 200 size: 12345 path: "/tmp/file.bin" }

1070 ;;;

1071 ;;; (http-download "https://example.com/file.bin"

1072 ;;; "/tmp/file.bin"

1073 ;;; on-progress: (lambda (received total)

1074 ;;; (display (str received "/" total "\r"))))

1075 ;;; ```

1076 (define (http-download url dest-path

1077 (keys: (headers #{})

1078 (on-progress #f)

1079 (max-redirects 5)))

1080 (let* ((parsed-url (parse-url url))

1081 (conn (connect-to-server parsed-url #f)))

1082 (if (not conn)

1083 #f

1084 (let ((request-str (build-request-string 'GET parsed-url headers #f)))

1085 (conn-write conn request-str)

1086 (let ((result (read-response-headers conn)))

1087 (if (not result)

1088 (begin (conn-close conn) #f)

1089 (let ((status (car result))

1090 (resp-headers (cadr result))

1091 (leftover (caddr result)))

1092 ;; Handle redirects

1093 (if (and (member status '(301 302 303 307 308))

1094 (> max-redirects 0))

1095 (let ((location (dict-ref resp-headers location: #f)))

1096 (conn-close conn)

1097 (if location

1098 (http-download location dest-path

1099 headers: headers

1100 on-progress: on-progress

1101 max-redirects: (- max-redirects 1))

1102 #f))

1103 ;; Download body

1104 (let* ((content-length-str

1105 (dict-ref resp-headers content-length: #f))

1106 (content-length

1107 (if content-length-str

1108 (string->number content-length-str)

1109 #f))

1110 (port (open-binary-output-file dest-path))

1111 (bytes-written

1112 (stream-body-to-port conn port content-length

1113 leftover on-progress)))

1114 (close-output-port port)

1115 (conn-close conn)

1116 (dict status: status

1117 size: bytes-written

1118 path: dest-path))))))))))

1119

1120 ;; ============================================================

1121 ;; Byte-faithful fetch (raw response bytes)

1122 ;; ============================================================

1123 ;;

1124 ;; `http-request` utf8->strings the whole body (corrupting any non-UTF-8

1125 ;; payload — wasm, images, archives), and `http-download` streams to a

1126 ;; file. `http-fetch-bytes` returns the response IN MEMORY as raw bytes so

1127 ;; a caller such as a reverse proxy can relay it byte-for-byte.

1128

1129 (define fetch-default-timeout 30) ; seconds

1130 (define fetch-read-chunk 65536)

1131 (define fetch-max-idle-polls 6000)

1132

1133 ;;; Fetch `url` (a `method` symbol, optional request `headers` dict and

1134 ;;; string `body`) and return the response as raw bytes:

1135 ;;;

1136 ;;; #{ status: <integer>

1137 ;;; headers: <ordered alist of (lowercased-name . value)>

1138 ;;; body: <bytevector> }

1139 ;;;

1140 ;;; or #f if the upstream could not be reached / the response was

1141 ;;; unparseable. Distinct from `http-request` in three ways a byte-exact

1142 ;;; relay needs:

1143 ;;;

1144 ;;; * the body is a BYTEVECTOR, never decoded to a string;

1145 ;;; * `headers` is an ORDERED alist that preserves order AND duplicates

1146 ;;; (e.g. multiple Set-Cookie), which a dict would silently collapse;

1147 ;;; * REDIRECTS ARE NOT FOLLOWED — a 3xx is returned untouched (status +

1148 ;;; Location intact) so the caller decides whether to chase it. A

1149 ;;; reverse proxy must relay redirects, not follow them; a

1150 ;;; redirect-following wrapper can layer on top.

1151 ;;;

1152 ;;; `timeout` (seconds, or #f -> 30) bounds the TLS connect and is the

1153 ;;; IDLE read deadline (it resets whenever bytes arrive, so a large but

1154 ;;; steadily-flowing body never times out). Sends `Connection: close`, so

1155 ;;; a body with no Content-Length is read to EOF.

1156 ;;;

1157 ;;; ```

1158 ;;; (let ((r (http-fetch-bytes 'GET "https://example.com/app.wasm")))

1159 ;;; (and r (bytevector-length (dict-ref r body: #f))))

1160 ;;; ```

1161 (define (http-fetch-bytes method url (keys: (headers #{}) (body #f) (timeout #f)))

1162 (let ((secs (or timeout fetch-default-timeout)))

1163 (guard (e (#t #f))

1164 (let ((parsed (parse-url url)))

1165 (and parsed

1166 (let ((conn (connect-to-server parsed secs)))

1167 (and conn

1168 (guard (e (#t (begin (fetch-safe-close conn) #f)))

1169 (conn-write conn (build-request-string method parsed headers body))

1170 (let ((result (fetch-read-response conn method secs)))

1171 (fetch-safe-close conn)

1172 result)))))))))

1173

1174 (define (fetch-safe-close conn)

1175 (guard (e (#t #f)) (conn-close conn)))

1176

1177 ;; Phase 1: accumulate bytes until the CRLFCRLF header terminator (headers

1178 ;; are small, so the bounded append here is cheap), then hand off to the

1179 ;; body reader. Returns the result dict, or #f if the connection closed

1180 ;; before a complete header block arrived.

1181 (define (fetch-read-response conn method timeout)

1182 (let loop ((buf (make-bytevector 0)) (idle 0) (deadline (+ (current-second) timeout)))

1183 (cond

1184 ((or (>= (current-second) deadline) (> idle fetch-max-idle-polls)) #f)

1185 (else

1186 (let ((hidx (find-header-end-bytes buf)))

1187 (if hidx

1188 (fetch-parse conn method timeout buf hidx)

1189 (let ((chunk (guard (e (#t 'err)) (conn-read-bytes conn fetch-read-chunk))))

1190 (cond

1191 ((or (eq? chunk 'err) (not chunk) (eof-object? chunk)) #f)

1192 ((zero? (bytevector-length chunk)) (loop buf (+ idle 1) deadline))

1193 (else (loop (bytevector-append buf chunk) 0 (+ (current-second) timeout)))))))))))

1194

1195 ;; Parse the head, then read the body per its framing. `body0` is whatever

1196 ;; body bytes already arrived with the header block.

1197 (define (fetch-parse conn method timeout buf hidx)

1198 (let* ((head-bytes (bytevector-copy buf 0 hidx))

1199 (body0 (bytevector-copy buf (+ hidx 4) (bytevector-length buf)))

1200 (lines (string-split (utf8->string head-bytes) "\r\n"))

1201 (status (and (pair? lines)

1202 (let ((si (parse-status-line (car lines)))) (and si (cadr si)))))

1203 (hdrs (fetch-parse-headers (if (pair? lines) (cdr lines) '())))

1204 (clen (fetch-content-length hdrs))

1205 (te (fetch-header hdrs "transfer-encoding"))

1206 (chunked? (and te (string-contains? (string-downcase te) "chunked"))))

1207 (and status

1208 (let ((bodyv

1209 (cond

1210 ((no-body-expected? method status) (make-bytevector 0))

1211 ((and clen (not chunked?)) (fetch-body-clen conn timeout body0 clen))

1212 (chunked? (fetch-dechunk (fetch-body-eof conn timeout body0)))

1213 (else (fetch-body-eof conn timeout body0)))))

1214 #{ status: status headers: hdrs body: bodyv }))))

1215

1216 ;; Header lines -> ordered alist of (lowercased-name . value), preserving

1217 ;; ORDER and DUPLICATES (a relay must keep multiple Set-Cookie etc.). A

1218 ;; line with no colon is skipped.

1219 (define (fetch-parse-headers lines)

1220 (let loop ((ls lines) (acc '()))

1221 (cond

1222 ((null? ls) (reverse acc))

1223 (else

1224 (let* ((line (car ls))

1225 (cpos (string-index line (lambda (c) (char=? c #\:)))))

1226 (if cpos

1227 (let ((name (string-downcase (string-trim (substring line 0 cpos))))

1228 (value (string-trim (substring line (+ cpos 1) (string-length line)))))

1229 (loop (cdr ls) (cons (cons name value) acc)))

1230 (loop (cdr ls) acc)))))))

1231

1232 ;; First value for a (lowercased) header name, or #f.

1233 (define (fetch-header hdrs name)

1234 (let loop ((hs hdrs))

1235 (cond ((null? hs) #f)

1236 ((string=? (car (car hs)) name) (cdr (car hs)))

1237 (else (loop (cdr hs))))))

1238

1239 (define (fetch-content-length hdrs)

1240 (let ((v (fetch-header hdrs "content-length")))

1241 (and v (let ((n (string->number (string-trim v)))) (and (integer? n) (>= n 0) n)))))

1242

1243 ;; Identity body of known Content-Length: read until `clen` bytes (or a

1244 ;; stall / EOF). Chunks accumulate in a list; assembled once. IDLE deadline

1245 ;; resets on data.

1246 (define (fetch-body-clen conn timeout body0 clen)

1247 (let loop ((chunks (list body0)) (have (bytevector-length body0))

1248 (idle 0) (deadline (+ (current-second) timeout)))

1249 (cond

1250 ((>= have clen) (fetch-assemble (reverse chunks)))

1251 ((or (>= (current-second) deadline) (> idle fetch-max-idle-polls))

1252 (fetch-assemble (reverse chunks)))

1253 (else

1254 (let ((chunk (guard (e (#t 'err)) (conn-read-bytes conn fetch-read-chunk))))

1255 (cond

1256 ((or (eq? chunk 'err) (not chunk) (eof-object? chunk)) (fetch-assemble (reverse chunks)))

1257 ((zero? (bytevector-length chunk)) (loop chunks have (+ idle 1) deadline))

1258 (else (loop (cons chunk chunks) (+ have (bytevector-length chunk))

1259 0 (+ (current-second) timeout)))))))))

1260

1261 ;; Chunked or no Content-Length: read to EOF (we send Connection: close).

1262 (define (fetch-body-eof conn timeout body0)

1263 (let loop ((chunks (list body0)) (idle 0) (deadline (+ (current-second) timeout)))

1264 (cond

1265 ((or (>= (current-second) deadline) (> idle fetch-max-idle-polls))

1266 (fetch-assemble (reverse chunks)))

1267 (else

1268 (let ((chunk (guard (e (#t 'err)) (conn-read-bytes conn fetch-read-chunk))))

1269 (cond

1270 ((or (eq? chunk 'err) (not chunk) (eof-object? chunk)) (fetch-assemble (reverse chunks)))

1271 ((zero? (bytevector-length chunk)) (loop chunks (+ idle 1) deadline))

1272 (else (loop (cons chunk chunks) 0 (+ (current-second) timeout)))))))))

1273

1274 ;; Concatenate a list of bytevectors with a SINGLE allocation. NOT

1275 ;; `(apply bytevector-append …)`: a multi-MB body arrives as hundreds of

1276 ;; chunks, and splatting that many args silently produced an EMPTY result.

1277 (define (fetch-assemble chunks)

1278 (let ((total (let sum ((cs chunks) (n 0))

1279 (if (null? cs) n (sum (cdr cs) (+ n (bytevector-length (car cs))))))))

1280 (let ((out (make-bytevector total 0)))

1281 (let copy ((cs chunks) (pos 0))

1282 (if (null? cs)

1283 out

1284 (let ((c (car cs)))

1285 (bytevector-copy! out pos c 0 (bytevector-length c))

1286 (copy (cdr cs) (+ pos (bytevector-length c)))))))))

1287

1288 ;; Byte-exact chunked-transfer decode: strip the hex size lines + CRLFs.

1289 ;; Stops at the 0-size terminator or a truncated tail (best-effort).

1290 (define (fetch-dechunk bv)

1291 (let ((len (bytevector-length bv)))

1292 (let loop ((pos 0) (out '()))

1293 (if (>= pos len)

1294 (fetch-assemble (reverse out))

1295 (let ((line-end (fetch-find-crlf bv pos)))

1296 (if (not line-end)

1297 (fetch-assemble (reverse out))

1298 (let* ((size (fetch-hex (utf8->string (bytevector-copy bv pos line-end))))

1299 (data (+ line-end 2)))

1300 (cond

1301 ((or (not size) (<= size 0)) (fetch-assemble (reverse out)))

1302 ((> (+ data size) len) (fetch-assemble (reverse out)))

1303 (else (loop (+ data size 2)

1304 (cons (bytevector-copy bv data (+ data size)) out)))))))))))

1305

1306 (define (fetch-find-crlf bv pos)

1307 (let ((len (bytevector-length bv)))

1308 (let loop ((i pos))

1309 (cond

1310 ((> (+ i 2) len) #f)

1311 ((and (= (bytevector-u8-ref bv i) 13) (= (bytevector-u8-ref bv (+ i 1)) 10)) i)

1312 (else (loop (+ i 1)))))))

1313

1314 (define (fetch-hex s)

1315 (let* ((t (string-trim s))

1316 (semi (string-index t (lambda (c) (char=? c #\;))))

1317 (hx (if semi (substring t 0 semi) t))

1318 (len (string-length hx)))

1319 (if (= len 0)

1320 #f

1321 (let loop ((i 0) (acc 0))

1322 (if (>= i len)

1323 acc

1324 (let ((d (fetch-hex-digit (string-ref hx i))))

1325 (if d (loop (+ i 1) (+ (* acc 16) d)) #f)))))))

1326

1327 (define (fetch-hex-digit ch)

1328 (cond

1329 ((and (char>=? ch #\0) (char<=? ch #\9)) (- (char->integer ch) 48))

1330 ((and (char>=? ch #\a) (char<=? ch #\f)) (+ 10 (- (char->integer ch) 97)))

1331 ((and (char>=? ch #\A) (char<=? ch #\F)) (+ 10 (- (char->integer ch) 65)))

1332 (else #f)))

1333

1334 ;; ============================================================

1335 ;; API Client Helpers

1336 ;; ============================================================

1337

1338 ;;; Build an API URL from a base URL and path segments.

1339 ;;;

1340 ;;; Common pattern across API clients: concatenate a base URL with

1341 ;;; slash-separated path parts.

1342 ;;;

1343 ;;; ```scheme

1344 ;;; (build-api-url "https://api.example.com" "v1" "users" "123")

1345 ;;; ; => "https://api.example.com/v1/users/123"

1346 ;;; ```

1347 (define (build-api-url base-url . parts)

1348 (apply string-append base-url

1349 (map (lambda (p) (string-append "/" p)) parts)))

1350

1351 ;;; Create a response checker function for an API client.

1352 ;;;

1353 ;;; Takes a name for error messages and an optional list of

1354 ;;; (status-code . message) pairs for specific error handling.

1355 ;;; Returns a function that checks an HTTP response and either

1356 ;;; returns parsed JSON on success or raises an error.

1357 ;;;

1358 ;;; The optional `parse-error` keyword accepts a function

1359 ;;; `(lambda (status body) ...)` for custom error body parsing

1360 ;;; (e.g., JSON:API error extraction). When provided, it is called

1361 ;;; instead of the default handler for status >= 400 that don't

1362 ;;; match a specific handler entry.

1363 ;;;

1364 ;;; ```scheme

1365 ;;; (define check-response

1366 ;;; (make-response-checker

1367 ;;; name: "YouTube API"

1368 ;;; handlers: (list

1369 ;;; (cons 401 "Access token may be expired.")

1370 ;;; (cons 403 "Possible quota exceeded."))))

1371 ;;;

1372 ;;; (check-response (http-get url headers: auth))

1373 ;;; ```

1374 (define (make-response-checker (keys: (name "API")

1375 (handlers '())

1376 (parse-error #f)))

1377 (lambda (response)

1378 (if (not (http-response? response))

1379 (error (string-append name " request failed: no response")))

1380 (let ((status (http-response-status response))

1381 (body (http-response-body response)))

1382 (cond

1383 ;; Check specific status handlers

1384 ((and (>= status 400)

1385 (assv status handlers))

1386 => (lambda (entry)

1387 (error (string-append

1388 name " " (number->string status) ". "

1389 (cdr entry)

1390 " Response: " (or body "")))))

1391 ;; Generic error for 400+

1392 ((>= status 400)

1393 (if parse-error

1394 (parse-error status body)

1395 (error (string-append

1396 name " error " (number->string status) ": "

1397 (or body "")))))

1398 ;; Success — return parsed JSON or #t

1399 (else

1400 (if (and body (not (string=? body "")))

1401 (json-decode* body)

1402 #t))))))

1403

1404 ;;; Create authenticated JSON API method wrappers.

1405 ;;;

1406 ;;; Takes a function that returns auth headers and a response checker,

1407 ;;; and returns a dict with `get`, `post`, `put`, `patch`, and `delete`

1408 ;;; functions that handle JSON encoding/decoding and authentication.

1409 ;;;

1410 ;;; ```scheme

1411 ;;; (define api (make-json-api

1412 ;;; auth-headers: (lambda () #{ authorization: "Bearer tok" })

1413 ;;; check-response: my-checker))

1414 ;;;

1415 ;;; ((dict-ref api get:) "https://api.example.com/users")

1416 ;;; ((dict-ref api post:) "https://api.example.com/users" #{ name: "Alice" })

1417 ;;; ```

1418 (define (make-json-api (keys: auth-headers check-response))

1419 (let ((json-headers

1420 (lambda ()

1421 (dict-merge (auth-headers)

1422 #{ content-type: "application/json" }))))

1423 (dict

1424 get: (lambda (url)

1425 (check-response

1426 (http-get url headers: (auth-headers))))

1427 post: (lambda (url body)

1428 (check-response

1429 (http-post url (if (string? body) body (json-encode* body))

1430 headers: (json-headers))))

1431 put: (lambda (url body)

1432 (check-response

1433 (http-put url (if (string? body) body (json-encode* body))

1434 headers: (json-headers))))

1435 patch: (lambda (url body)

1436 (check-response

1437 (http-patch url (if (string? body) body (json-encode* body))

1438 headers: (json-headers))))

1439 delete: (lambda (url)

1440 (check-response

1441 (http-delete url headers: (auth-headers)))))))

1442

1443 ))