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 max quotient)

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 ;; Incremental byte-faithful response streaming

58 http-stream-response

60 ;; API client helpers

61 build-api-url

62 make-response-checker

63 make-json-api

65 ;; Re-export response accessors for convenience

66 http-response?

67 http-response-status

68 http-response-headers

69 http-response-body

71 ;; Internal — exported for testing

72 parse-http-response

73 decode-chunked-body

74 find-header-end-bytes

75 no-body-expected?

76 detect-framing

77 chunked-body-complete?

78 framing-complete?

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

80 build-request-bytes

81 fetch-parse-headers

82 fetch-content-length

83 fetch-assemble

84 fetch-dechunk

85 stream-chunked-state

86 stream-chunked-feed!)

88 (begin

90 ;; ============================================================

91 ;; Lazy TLS Loading

92 ;; ============================================================

93 ;;

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

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

96 ;; compiled without sigil-tls being present.

98 ;; Promise that loads TLS module on first use

99 (define tls-module

100 (delay

101 (guard (exn (else #f))

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

103

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

105 (define (tls-ref sym)

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

107 (if m

108 (module-ref m sym)

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

110

111 ;; Cached TLS function promises

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

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

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

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

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

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

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

119

120 ;; TLS function wrappers

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

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

123

124 (define (tls-connection?* conn)

125 (and (force tls-module)

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

127

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

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

130

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

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

133

134 ;; Variadic so the bounded write loop can pass start/end byte offsets.

135 ;; It was fixed at two arguments, and every HTTPS request with a

136 ;; `timeout:` raised an arity error through this wrapper — invisible to

137 ;; every stall test, because those either use plain HTTP or fail before

138 ;; the write. Only a live TLS request caught it.

139 (define (tls-write* conn data . start-end)

140 (apply (force %tls-write) conn data start-end))

141

142 (define (tls-close* conn)

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

144

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

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

147

148 ;; ============================================================

149 ;; Lazy JSON Loading

150 ;; ============================================================

151 ;;

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

153 ;; requiring sigil-json when not needed.

154

155 (define json-module

156 (delay

157 (guard (exn (else #f))

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

159

160 (define (json-ref sym)

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

162 (if m

163 (module-ref m sym)

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

165

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

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

168

169 (define (json-decode* str)

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

171

172 (define (json-encode* value)

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

174

175 ;; ============================================================

176 ;; URL Record and Parsing

177 ;; ============================================================

178

179 (define-struct url

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

181 (host) ; "example.com"

182 (port) ; 80, 443, or custom

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

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

185

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

187 ;;;

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

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

190 ;;; to access the components.

191 ;;;

192 ;;; ```scheme

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

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

195 ;;; ```

196 (define (parse-url url-string)

197 (: string? -> any?)

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

199 (scheme (if scheme-end

200 (substring url-string 0 scheme-end)

201 "http"))

202 ;; Skip "://" after scheme

203 (rest-start (if scheme-end

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

205 0))

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

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

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

209 (authority (if path-start

210 (substring rest 0 path-start)

211 rest))

212 (path-and-query (if path-start

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

214 "/"))

215 ;; Parse host:port from authority

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

217 (host (if port-sep

218 (substring authority 0 port-sep)

219 authority))

220 (port (cond

221 (port-sep

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

223 (string-length authority))))

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

225 (else 80)))

226 ;; Parse path?query

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

228 (path (if query-start

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

230 path-and-query))

231 (query (if query-start

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

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

234 #f)))

235 (url scheme: scheme

236 host: host

237 port: port

238 path: path

239 query: query)))

240

241 ;; ============================================================

242 ;; Blocking segments: what is bounded, and what is not

243 ;; ============================================================

244 ;;

245 ;; An outbound call passes through six blocking segments. Under Sigil's

246 ;; COOPERATIVE scheduler any one of them blocking blocks the whole

247 ;; process, not just the request: every other task, including anything

248 ;; that might have rescued it. So this table is the safety property, and

249 ;; it is stated here rather than left to be re-derived.

250 ;;

251 ;; segment bounded by

252 ;; ------------------- --------------------------------------------

253 ;; DNS resolution NOTHING. Residual, see below.

254 ;; TCP connect (http) connect-timeout:

255 ;; TCP connect (https) connect-timeout:

256 ;; TLS handshake connect-timeout:

257 ;; request write timeout:

258 ;; response read timeout:

259 ;;

260 ;; Every bound is OPT-IN. With both keywords omitted the behaviour is

261 ;; exactly what it was: blocking connect, blocking write, blocking read.

262 ;;

263 ;; THE TABLE ABOVE DESCRIBES `http-request` AND ITS WRAPPERS, plus

264 ;; `http-fetch-bytes`. It does NOT describe `http-download`, which takes

265 ;; no timeout keywords at all and is blocking end to end: connect, write,

266 ;; header read and body stream. That is the API most likely to be

267 ;; pointed at a large, slow remote, and it is the one still able to

268 ;; freeze the process. Bounding it means bounding a streaming read as

269 ;; well, which is a larger change than this one; until then it is stated

270 ;; here rather than left for someone to discover from the outside.

271 ;;

272 ;; UNBOUNDED SEGMENT: DNS

273 ;;

274 ;; `getaddrinfo(3)` is a blocking C call with no deadline argument and no

275 ;; portable cancellation. Neither of the two paths into it can be bounded

276 ;; from here:

277 ;;

278 ;; * the bounded plain-HTTP connect calls `resolve-hostname` before it

279 ;; can connect per-address, and that call is the resolver's own

280 ;; blocking lookup; and

281 ;; * `tls-connect` resolves internally, inside the same native call

282 ;; that performs the bounded connect.

283 ;;

284 ;; A resolver that stops answering therefore still blocks a request for

285 ;; as long as the system resolver takes to give up, typically its

286 ;; `timeout` x `attempts` from resolv.conf. That is bounded by the

287 ;; RESOLVER, not by this library, and it is not affected by `timeout:`

288 ;; or `connect-timeout:`.

289 ;;

290 ;; This is stated plainly because a silent gap is the whole failure class

291 ;; being eliminated here: a caller must not read "sigil-http honours its

292 ;; timeouts" as "sigil-http cannot block". Callers that need a hard bound

293 ;; across DNS as well have to get it outside this library, by running the

294 ;; request where it can be abandoned (a subprocess with a wall-clock

295 ;; kill), or by resolving ahead of time and requesting by address.

296 ;;

297 ;; What WOULD fix it properly is async resolution in the socket layer.

298 ;; sigil-socket 0.17 grew `%resolve-start` / `%resolve-take` and a

299 ;; `resolve-hostname` that yields to the scheduler instead of blocking it

300 ;; when one is running. sigil-http pins sigil-socket ^0.16, whose

301 ;; `resolve-hostname` is the bare blocking native with no such path.

302 ;; Adopting 0.17 is a real fix and a separate change, because it raises

303 ;; the required floor for every consumer.

304

305 ;; ============================================================

306 ;; Low-level Connection Helpers

307 ;; ============================================================

308

309 ;;; Convert a timeout in seconds to whole milliseconds (at least 1).

310 (define (timeout->ms timeout)

311 (max 1 (exact (round (* timeout 1000)))))

312

313 ;;; Is this a usable positive timeout?

314 (define (timeout-set? timeout)

315 (and timeout (number? timeout) (> timeout 0)))

316

317 ;;; Resolve `host` to a list of IP address strings in the resolver's own

318 ;;; preference order, or #f.

319 ;;;

320 ;;; The list is REVERSED on the way out. `resolve-hostname` walks

321 ;;; getaddrinfo's results forward and conses, so what it returns is the

322 ;;; RFC 6724 preference order backwards. Connecting in that order would

323 ;;; try the least-preferred address first and give it the first slice of

324 ;;; the budget, silently inverting v4/v6 preference on a dual-stack host

325 ;;; whenever a connect timeout is set. The unbounded `tcp-connect` path

326 ;;; gets the order right, so this would also have made the two paths

327 ;;; disagree.

328 ;;;

329 ;;; RESIDUAL: the resolution itself is NOT bounded. See the

330 ;;; "Blocking segments" section above.

331 (define (resolve-addresses host)

332 (let ((r (guard (exn (else #f)) (resolve-hostname host))))

333 (cond

334 ((not r) #f)

335 ((string? r) (list r)) ; older sigil-socket returned one address

336 ((null? r) #f)

337 (else (reverse r)))))

338

339 ;;; Connect to the first address that answers, with the whole attempt

340 ;;; bounded by `total-ms`.

341 ;;;

342 ;;; Each address gets a fair slice of the REMAINING budget rather than

343 ;;; the whole of it, so a blackholed first address cannot consume the

344 ;;; entire deadline and leave a working address untried. Same shape the

345 ;;; TLS connect path already uses.

346 (define (connect-first-address addrs port total-ms)

347 (let ((deadline (timeout->deadline (/ total-ms 1000))))

348 (let loop ((rest addrs) (left (length addrs)))

349 (if (null? rest)

350 #f

351 (let ((remaining (ms-until deadline)))

352 (if (<= remaining 0)

353 #f

354 (let* ((slice (max 1 (quotient remaining (max 1 left))))

355 (sock (guard (exn (else #f))

356 (%tcp-connect-ip-timeout (car rest) port slice))))

357 (or sock (loop (cdr rest) (- left 1))))))))))

358

359 ;;; Connect a plain TCP socket, bounded by `connect-timeout` when one is

360 ;;; given. Without a timeout this is the original blocking `tcp-connect`,

361 ;;; byte for byte.

362 (define (tcp-connect/bounded host port connect-timeout)

363 (if (timeout-set? connect-timeout)

364 (let ((addrs (resolve-addresses host)))

365 (and addrs

366 (connect-first-address addrs port

367 (timeout->ms connect-timeout))))

368 (tcp-connect host port)))

369

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

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

372 ;;;

373 ;;; `connect-timeout` (seconds, or #f) bounds getting to the point where

374 ;;; the request can be sent. For HTTPS that is TWO segments, and both are

375 ;;; bounded by this one value:

376 ;;;

377 ;;; * the TCP connect, so a blackholed address can't hang on the OS

378 ;;; SYN timeout; and

379 ;;; * the TLS handshake, which the connect timeout does NOT reach. Once

380 ;;; a peer has ACCEPTED, the connect phase is over. A peer that then

381 ;;; never sends a ServerHello left the handshake read blocking

382 ;;; forever, which under a cooperative scheduler freezes the whole

383 ;;; process. That is the failure that ran a production service for 55

384 ;;; days with every health surface reporting it healthy.

385 ;;;

386 ;;; Each phase gets the full value rather than a shared split, so a slow

387 ;;; but working connect does not eat the handshake's budget. The worst

388 ;;; case before the request is sent is therefore about twice

389 ;;; `connect-timeout`, not once.

390 ;;;

391 ;;; Plain HTTP has no handshake, and its connect is bounded the same way.

392 ;;;

393 ;;; Omitted or #f keeps the original blocking connect on both paths.

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

395 (let ((host (url-host parsed-url))

396 (port (url-port parsed-url))

397 (scheme (url-scheme parsed-url)))

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

399 (if (timeout-set? connect-timeout)

400 (let ((ms (timeout->ms connect-timeout)))

401 (tls-connect* host port ms ms))

402 (tls-connect* host port))

403 (tcp-connect/bounded host port connect-timeout))))

404

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

406 (define (conn-write conn data)

407 (if (tls-connection?* conn)

408 (tls-write* conn data)

409 (socket-write conn data)))

410

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

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

413 (if (tls-connection?* conn)

414 (if (null? max-bytes)

415 (tls-read* conn)

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

417 (if (null? max-bytes)

418 (socket-read conn)

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

420

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

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

423 (if (tls-connection?* conn)

424 (if (null? max-bytes)

425 (tls-read-bytevector* conn)

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

427 (if (null? max-bytes)

428 (socket-read-bytevector conn)

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

430

431 ;;; Close connection

432 (define (conn-close conn)

433 (if (tls-connection?* conn)

434 (tls-close* conn)

435 (socket-close conn)))

436

437 ;;; Write a byte range of `bv` to the connection, returning the number of

438 ;;; bytes accepted (which may be 0 on a non-blocking connection), or #f.

439 ;;; Both layers take start/end offsets, so a retry after a partial write

440 ;;; never copies the remaining tail.

441 (define (conn-write-bytes conn bv start end)

442 (if (tls-connection?* conn)

443 (tls-write* conn bv start end)

444 (socket-write conn bv start end)))

445

446 ;;; Wait a short tick for a plain socket to accept more bytes.

447 ;;;

448 ;;; `socket-write` returns #f for EAGAIN and for a genuine error alike,

449 ;;; and NOTHING here can tell them apart. An earlier version tried to:

450 ;;; if `select` said the socket was writable, the #f must have been a

451 ;;; real error. That is wrong, and wrong in the destructive direction.

452 ;;; Linux reports a socket writable once half the send buffer is free, so

453 ;;; against a peer that IS draining the sequence EAGAIN-then-writable is

454 ;;; ordinary backpressure, and treating it as an error failed a perfectly

455 ;;; good 4 MiB upload.

456 ;;;

457 ;;; So we wait and retry, and let the DEADLINE end it. The cost is that a

458 ;;; genuine write error surfaces as a write timeout rather than an

459 ;;; immediate failure. That is the safe direction: a slow failure for a

460 ;;; dead socket beats a spurious failure for a live one. The real fix

461 ;;; belongs in `socket-write`, which should distinguish would-block from

462 ;;; error rather than making its callers guess.

463 ;;;

464 ;;; Two things about `socket-select` that its type signature does not

465 ;;; say, and that a plausible-looking call gets wrong in the reassuring

466 ;;; direction:

467 ;;;

468 ;;; * the timeout is an exact integer of MILLISECONDS, not seconds. A

469 ;;; float raises rather than being rounded.

470 ;;; * it returns `(readable writable)`, a two-element list of lists,

471 ;;; NOT a flat list of ready sockets. So `(pair? (socket-select ...))`

472 ;;; is ALWAYS true, which is how the mistake above got written.

473 (define (wait-writable! conn)

474 ;; Blocks up to the poll interval when the socket is NOT writable. When

475 ;; it IS writable the call returns at once, so sleep instead — without

476 ;; that, a socket that is writable but refusing bytes spins hot until

477 ;; the deadline.

478 (if (pair? (cadr (socket-select '() (list conn) *write-poll-interval-ms*)))

479 (sleep *write-poll-interval*)))

480

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

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

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

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

485 (if (tls-connection?* conn)

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

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

488

489 ;; ============================================================

490 ;; Read Timeouts (opt-in)

491 ;; ============================================================

492 ;;

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

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

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

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

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

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

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

500

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

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

503

504 ;; Seconds to sleep between non-blocking writes that accepted nothing

505 ;; (TLS), and the same interval in whole milliseconds for the

506 ;; `socket-select` writability wait (plain sockets), which takes an

507 ;; exact integer of milliseconds.

508 (define *write-poll-interval* 0.02)

509 (define *write-poll-interval-ms* 20)

510

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

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

513 (define (timeout->deadline timeout)

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

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

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

517 ;; lose nanosecond precision at that magnitude.

518 (+ (current-jiffy)

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

520 #f))

521

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

523 (define (deadline-expired? deadline)

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

525

526 ;;; Whole milliseconds left before `deadline`, possibly negative.

527 (define (ms-until deadline)

528 (if (not deadline)

529 0

530 (exact (round (/ (* 1000 (- deadline (current-jiffy)))

531 (jiffies-per-second))))))

532

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

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

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

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

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

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

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

540

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

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

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

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

545 (and (error-object? exn)

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

547 #t))

548

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

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

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

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

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

554 reason)

555 ack-unconfirmed-irritant))

556

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

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

559 (define (raise-http-timeout)

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

561

562 ;;; Raise a clean timeout error for the request WRITE.

563 ;;;

564 ;;; Deliberately NOT marked ack-unconfirmed. The write deadline can only

565 ;;; fire with bytes still unsent, so the server holds a partial request

566 ;;; it cannot act on. That is a never-delivered send and retrying it is

567 ;;; safe, which is the opposite of what the ack-unconfirmed mark tells a

568 ;;; caller to do.

569 (define (raise-http-write-timeout)

570 (error "HTTP request timed out: write deadline exceeded"))

571

572 ;; ============================================================

573 ;; HTTP Request Building

574 ;; ============================================================

575

576 ;;; Build HTTP request string

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

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

579 (query (url-query parsed-url))

580 (uri (if query

581 (string-append path "?" query)

582 path))

583 (host (url-host parsed-url))

584 (port (url-port parsed-url))

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

586 (= port 80))

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

588 (= port 443)))

589 host

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

591 (string-append

592 ;; Request line

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

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

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

596 ;; User-Agent

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

598 ;; Connection

599 "Connection: close\r\n"

600 ;; Additional headers

601 (build-header-lines headers)

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

603 (if body

604 (string-append "Content-Length: "

605 (number->string

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

607 "\r\n")

608 "")

609 ;; End of headers

610 "\r\n"

611 ;; Body

612 (or body ""))))

613

614 ;; Byte-faithful request assembly for http-fetch-bytes. Existing string

615 ;; request behavior stays unchanged; binary bodies never round-trip UTF-8.

616 (define (build-request-bytes method parsed-url headers body)

617 (if (bytevector? body)

618 (let* ((length-value (number->string (bytevector-length body)))

619 (entries (if (dict? headers)

620 (map (lambda (h) (cons (keyword->string (car h)) (cdr h))) (dict-entries headers))

621 headers))

622 (with-length (cons (cons "content-length" length-value)

623 (filter (lambda (h)

624 (not (member (string-downcase (car h)) '("content-length" "transfer-encoding")))) entries))))

625 (bytevector-append (string->utf8 (build-request-string method parsed-url with-length #f)) body))

626 (string->utf8 (build-request-string method parsed-url headers body))))

627

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

629 (define (build-header-lines headers)

630 (cond

631 ;; Empty

632 ((null? headers) "")

633 ;; Dict - convert entries to header lines

634 ((dict? headers)

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

636 (if (null? entries)

637 result

638 (let ((entry (car entries)))

639 (loop (cdr entries)

640 (string-append result

641 (keyword->string (car entry))

642 ": "

643 (cdr entry)

644 "\r\n"))))))

645 ;; Alist - legacy format

646 (else

647 (let loop ((headers headers) (result ""))

648 (if (null? headers)

649 result

650 (let ((h (car headers)))

651 (loop (cdr headers)

652 (string-append result

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

654

655 ;; ============================================================

656 ;; HTTP Response Parsing

657 ;; ============================================================

658

659 ;;; Parse HTTP status line

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

661 (define (parse-status-line line)

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

663 (if (not space1)

664 #f

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

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

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

668 (if (not space2)

669 #f

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

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

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

673

674 ;;; Parse response headers from data

675 ;;; Returns dict with keyword keys

676 (define (parse-response-headers lines)

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

678 (if (null? lines)

679 headers

680 (let* ((line (car lines))

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

682 (if colon-pos

683 (let ((name (string->keyword

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

685 (value (string-trim

686 (substring line (+ colon-pos 1)

687 (string-length line)))))

688 (loop (cdr lines)

689 (dict-set headers name value)))

690 (loop (cdr lines) headers))))))

691

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

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

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

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

696 (let loop ((i 0))

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

698 #f

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

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

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

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

703 i

704 (loop (+ i 1)))))))

705

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

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

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

709 (or (eq? method 'HEAD)

710 (and status

711 (or (= status 204)

712 (= status 304)

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

714

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

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

717 ;;; otherwise a descriptor:

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

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

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

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

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

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

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

725 (define (detect-framing method bv)

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

727 (if (not he)

728 #f

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

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

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

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

733 (status (and status-info (cadr status-info)))

734 (headers (if (pair? lines)

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

736 #{}))

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

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

739 (cond

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

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

742 (list 'chunked body-start))

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

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

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

746

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

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

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

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

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

752 (let loop ((pos start))

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

754 (if (not line-end)

755 #f

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

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

758 (cond

759 ((not sz) #f)

760 ((= sz 0)

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

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

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

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

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

766 (else

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

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

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

770

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

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

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

774 (let ((mode (car framing)))

775 (cond

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

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

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

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

780

781 ;;; Write the whole request, bounded by `deadline` when one is set.

782 ;;;

783 ;;; Returns #t when every byte was accepted, #f on a genuine write error,

784 ;;; and raises a write-timeout error if the deadline passes with bytes

785 ;;; still unsent.

786 ;;;

787 ;;; With `deadline` #f this is the original single blocking write. A

788 ;;; request usually fits the socket buffer, so that write usually returns

789 ;;; immediately — but "usually" is not a bound. A peer that accepts the

790 ;;; connection and never drains its receive queue fills the window, and a

791 ;;; large body (an upload, a big POST) then blocks here indefinitely.

792 ;;;

793 ;;; With a deadline the connection is already non-blocking, so a write

794 ;;; that cannot proceed returns 0 (TLS) or #f-with-the-socket-unwritable

795 ;;; (plain) instead of blocking, and the loop polls until the deadline.

796 (define (write-all-data conn data deadline)

797 (if (not deadline)

798 (and (conn-write conn data) #t)

799 (let* ((bv (if (bytevector? data) data (string->utf8 data)))

800 (len (bytevector-length bv)))

801 (let loop ((sent 0))

802 (cond

803 ((>= sent len) #t)

804 ((deadline-expired? deadline)

805 (conn-close conn)

806 (raise-http-write-timeout))

807 (else

808 (let ((n (conn-write-bytes conn bv sent len)))

809 (cond

810 ;; TLS reports #f only for real errors; a non-blocking

811 ;; TLS write that cannot proceed returns 0.

812 ((and (not n) (tls-connection?* conn)) #f)

813 ;; A plain socket returns #f for EAGAIN and for a real

814 ;; error alike. See `wait-writable!` for why this waits

815 ;; rather than trying to tell them apart.

816 ((not n) (wait-writable! conn) (loop sent))

817 ((= n 0)

818 (sleep *write-poll-interval*)

819 (loop sent))

820 (else (loop (+ sent n)))))))))))

821

822 ;;; Read HTTP response from connection

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

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

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

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

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

828 ;; Read all available data

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

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

831 #f

832 (parse-http-response data))))

833

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

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

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

837 ;;;

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

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

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

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

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

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

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

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

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

847 ;;; back to reading until EOF.

848 ;;;

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

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

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

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

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

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

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

856 (cond

857 ((not chunk)

858 ;; Error

859 (if (null? chunks)

860 #f

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

862 ((eof-object? chunk)

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

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

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

866 (if deadline

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

868 (if (deadline-expired? deadline)

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

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

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

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

873 (else

874 (let* ((chunks* (cons chunk chunks))

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

876 ;; Combine only while detecting headers or scanning a

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

878 ;; byte-count check needing no recombination.

879 (need-bytes (or (not framing)

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

881 (combined (and need-bytes

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

883 (framing* (or framing

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

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

886 (utf8->string (or combined

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

888 (loop chunks* total* framing*))))))))

889

890 ;;; Parse HTTP response from string

891 (define (parse-http-response data)

892 ;; Find end of headers (blank line)

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

894 (if (not header-end)

895 #f

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

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

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

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

900 ""))

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

902 (if (null? lines)

903 #f

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

905 (if (not status-info)

906 #f

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

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

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

910 (body (if (and transfer-encoding

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

912 (decode-chunked-body raw-body)

913 raw-body)))

914 (http-response

915 status: status-code

916 headers: headers

917 body: body)))))))))

918

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

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

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

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

923 (define (decode-chunked-body data)

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

925 (len (bytevector-length bv)))

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

927 (if (>= pos len)

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

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

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

931 (if (not line-end)

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

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

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

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

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

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

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

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

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

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

942 (if (> chunk-end len)

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

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

945 (loop (+ chunk-end 2)

946 (cons chunk chunks)))))))))))))

947

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

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

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

951 (let loop ((i pos))

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

953 #f

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

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

956 i

957 (loop (+ i 1)))))))

958

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

960 (define (find-crlf data pos)

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

962 (let loop ((i pos))

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

964 #f

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

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

967 i

968 (loop (+ i 1)))))))

969

970 ;;; Convert hex string to number

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

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

973 (if (string=? s "")

974 #f

975 (let loop ((i 0) (result 0))

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

977 result

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

979 (digit (cond

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

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

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

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

984 (else #f))))

985 (if (not digit)

986 result ; Stop at non-hex character

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

988

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

990 (define (find-header-end data)

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

992 (let loop ((i 0))

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

994 #f

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

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

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

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

999 i

1000 (loop (+ i 1)))))))

1001

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

1003 (define (skip-crlf data pos)

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

1005 (let loop ((i pos))

1006 (if (>= i len)

1007 i

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

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

1010 (loop (+ i 1))

1011 i)))))

1012

1013 ;; ============================================================

1014 ;; High-Level Client API

1015 ;; ============================================================

1016

1017 ;;; Make an HTTP request.

1018 ;;;

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

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

1021 ;;;

1022 ;;; The optional `timeout:` keyword (seconds) bounds the request WRITE

1023 ;;; and the response READ, each against its own deadline. The connection

1024 ;;; is made non-blocking and a timeout error is raised if the request

1025 ;;; cannot be sent, or no complete response arrives, in time. Omitted,

1026 ;;; both block exactly as before.

1027 ;;;

1028 ;;; A read timeout is marked ack-unconfirmed (`http-ack-unconfirmed?`):

1029 ;;; the request went out, so retrying may re-deliver it. A WRITE timeout

1030 ;;; is not, because it can only fire with bytes still unsent, leaving the

1031 ;;; server a partial request it cannot act on.

1032 ;;;

1033 ;;; The optional `connect-timeout:` keyword (seconds) bounds getting to

1034 ;;; the point where the request can be sent: the TCP connect, so a

1035 ;;; blackholed address can't hang on the OS SYN timeout, AND the TLS

1036 ;;; handshake, which the connect phase does not cover. Each gets the full

1037 ;;; value, so the ceiling before the request is sent is about twice it.

1038 ;;; Omitted/#f keeps the blocking connect and handshake.

1039 ;;;

1040 ;;; NOT bounded by either keyword: DNS resolution. See the

1041 ;;; "Blocking segments" section at the top of this file.

1042 ;;;

1043 ;;; ```scheme

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

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

1046 ;;;

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

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

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

1050 ;;; timeout: 25)

1051 ;;; ```

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

1053 (connect-timeout #f)))

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

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

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

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

1058 (if (not conn)

1059 #f ; connect failed — request never sent

1060 (let ((write-deadline (timeout->deadline timeout))

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

1062 ;; With a timeout in play the connection goes non-blocking

1063 ;; BEFORE the write, so the write is bounded too rather than

1064 ;; only the read. Without one, nothing changes: blocking

1065 ;; connection, single blocking write, blocking read.

1066 (when write-deadline (conn-set-non-blocking! conn))

1067 (let ((wrote (write-all-data conn request-str write-deadline)))

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

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

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

1071 ;; just yields #f).

1072 (if (and write-deadline (not wrote))

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

1074 ;; The read gets its own fresh deadline rather than

1075 ;; sharing the write's. Sharing one would silently

1076 ;; shorten the response window that `timeout:` has always

1077 ;; meant, and that window is what existing callers sized

1078 ;; their value against.

1079 (let* ((read-deadline (timeout->deadline timeout))

1080 (response (read-http-response method conn read-deadline)))

1081 (conn-close conn)

1082 (if (and read-deadline (not response))

1083 ;; Request was written but no usable response

1084 ;; came back → delivered, ack unconfirmed.

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

1086 response))))))))

1087

1088 ;;; HTTP GET request.

1089 ;;;

1090 ;;; ```scheme

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

1092 ;;;

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

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

1095 ;;; ```

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

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

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

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

1100 connect-timeout: connect-timeout))

1101

1102 ;;; HTTP POST request.

1103 ;;;

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

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

1106 ;;;

1107 ;;; ```scheme

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

1109 ;;;

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

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

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

1113 ;;; ```

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

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

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

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

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

1119 headers)))

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

1121 connect-timeout: connect-timeout)))

1122

1123 ;;; HTTP PUT request.

1124 ;;;

1125 ;;; ```scheme

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

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

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

1129 ;;; ```

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

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

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

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

1134 connect-timeout: connect-timeout))

1135

1136 ;;; HTTP DELETE request.

1137 ;;;

1138 ;;; ```scheme

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

1140 ;;;

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

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

1143 ;;; ```

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

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

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

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

1148 connect-timeout: connect-timeout))

1149

1150 ;;; HTTP HEAD request.

1151 ;;;

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

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

1154 ;;;

1155 ;;; ```scheme

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

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

1158 ;;; ```

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

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

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

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

1163 connect-timeout: connect-timeout))

1164

1165 ;;; HTTP OPTIONS request.

1166 ;;;

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

1168 ;;;

1169 ;;; ```scheme

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

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

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

1173 ;;; ```

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

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

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

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

1178 connect-timeout: connect-timeout))

1179

1180 ;;; HTTP PATCH request.

1181 ;;;

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

1183 ;;; resource, PATCH applies partial modifications.

1184 ;;;

1185 ;;; ```scheme

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

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

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

1189 ;;; ```

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

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

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

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

1194 connect-timeout: connect-timeout))

1195

1196 ;; ============================================================

1197 ;; JSON Conveniences

1198 ;; ============================================================

1199

1200 ;;; Parse HTTP response body as JSON.

1201 ;;;

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

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

1204 ;;;

1205 ;;; ```scheme

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

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

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

1209 ;;; ```

1210 (define (http-response-json response)

1211 (: any? -> any?)

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

1213 (guard (exn (else #f))

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

1215 #f))

1216

1217 ;;; HTTP GET request expecting JSON response.

1218 ;;;

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

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

1221 ;;; status is not 2xx.

1222 ;;;

1223 ;;; ```scheme

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

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

1226 ;;;

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

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

1229 ;;; ```

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

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

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

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

1234 connect-timeout: connect-timeout)))

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

1236

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

1238 ;;;

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

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

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

1242 ;;;

1243 ;;; ```scheme

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

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

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

1247 ;;;

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

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

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

1251 ;;; ```

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

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

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

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

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

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

1258 connect-timeout: connect-timeout)))

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

1260

1261 ;; ============================================================

1262 ;; Streaming Download

1263 ;; ============================================================

1264

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

1266 ;;;

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

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

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

1270 (define (read-response-headers conn)

1271 (let loop ((accumulated ""))

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

1273 (cond

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

1275 ;; Connection closed or error before headers complete

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

1277 (string-append accumulated chunk)

1278 accumulated)))

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

1280 (if header-end

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

1282 #f))))

1283 ((string=? chunk "")

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

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

1286 (if header-end

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

1288 (loop accumulated))))

1289 (else

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

1291 (header-end (find-header-end data)))

1292 (if header-end

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

1294 (loop data))))))))

1295

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

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

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

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

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

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

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

1303 ""))

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

1305 (if (null? lines)

1306 #f

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

1308 (if (not status-info)

1309 #f

1310 (list (cadr status-info)

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

1312 leftover))))))

1313

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

1315 ;;;

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

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

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

1319 (let ((written 0))

1320 ;; Write any leftover data from header reading

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

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

1323 (write-bytevector bv port)

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

1325 (when on-progress

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

1327 ;; Stream remaining body

1328 (let loop ()

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

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

1331 (cond

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

1333 ;; Done or error

1334 #t)

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

1336 ;; Non-blocking, no data yet

1337 (loop))

1338 (else

1339 (write-bytevector chunk port)

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

1341 (when on-progress

1342 (on-progress written content-length))

1343 (loop))))))

1344 written))

1345

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

1347 ;;;

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

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

1350 ;;; suitable for large downloads.

1351 ;;;

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

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

1354 ;;; Content-Length.

1355 ;;;

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

1357 ;;;

1358 ;;; ```scheme

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

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

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

1362 ;;;

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

1364 ;;; "/tmp/file.bin"

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

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

1367 ;;; ```

1368 (define (http-download url dest-path

1369 (keys: (headers #{})

1370 (on-progress #f)

1371 (max-redirects 5)))

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

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

1374 (if (not conn)

1375 #f

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

1377 (conn-write conn request-str)

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

1379 (if (not result)

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

1381 (let ((status (car result))

1382 (resp-headers (cadr result))

1383 (leftover (caddr result)))

1384 ;; Handle redirects

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

1386 (> max-redirects 0))

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

1388 (conn-close conn)

1389 (if location

1390 (http-download location dest-path

1391 headers: headers

1392 on-progress: on-progress

1393 max-redirects: (- max-redirects 1))

1394 #f))

1395 ;; Download body

1396 (let* ((content-length-str

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

1398 (content-length

1399 (if content-length-str

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

1401 #f))

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

1403 (bytes-written

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

1405 leftover on-progress)))

1406 (close-output-port port)

1407 (conn-close conn)

1408 (dict status: status

1409 size: bytes-written

1410 path: dest-path))))))))))

1411

1412 ;; ============================================================

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

1414 ;; ============================================================

1415 ;;

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

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

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

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

1420

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

1422 (define fetch-read-chunk 65536)

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

1424

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

1426 ;;; string or bytevector `body`) and return the response as raw bytes:

1427 ;;;

1428 ;;; #{ status: <integer>

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

1430 ;;; body: <bytevector> }

1431 ;;;

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

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

1434 ;;; relay needs:

1435 ;;;

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

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

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

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

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

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

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

1443 ;;;

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

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

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

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

1448 ;;;

1449 ;;; ```

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

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

1452 ;;; ```

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

1454 ;; `secs` is always POSITIVE: the connection below is put into

1455 ;; non-blocking mode unconditionally, and a non-positive value would

1456 ;; produce a #f deadline, which sends the write down the single

1457 ;; blocking-write branch. On a non-blocking socket that is a partial

1458 ;; send whose count is discarded, i.e. a silently truncated request.

1459 ;; Non-blocking and "has a deadline" must not be able to disagree.

1460 (let ((secs (if (and timeout (number? timeout) (> timeout 0))

1461 timeout

1462 fetch-default-timeout)))

1463 (guard (e (#t #f))

1464 (let ((parsed (parse-url url)))

1465 (and parsed

1466 ;; Plain HTTP keeps its ORIGINAL unbounded connect unless the

1467 ;; caller actually asked for a timeout. `secs` defaults to 30

1468 ;; on its own, and routing a caller who passed nothing down

1469 ;; the bounded connect path would change the resolver used,

1470 ;; the address ordering and the failure modes for every

1471 ;; existing consumer. HTTPS keeps passing `secs`, which is

1472 ;; what it always did; that is also what now bounds its

1473 ;; handshake, making this function's documented timeout true

1474 ;; for the first time.

1475 (let* ((https? (string=? (url-scheme parsed) "https"))

1476 (conn (connect-to-server parsed

1477 (and (or https? timeout) secs))))

1478 (and conn

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

1480 ;; The idle-deadline loops below detect "no data

1481 ;; yet" from an EMPTY read, which only a

1482 ;; non-blocking connection ever returns. Without

1483 ;; this the reads block and every deadline check

1484 ;; between them is unreachable: `timeout` looked

1485 ;; like it bounded the fetch and did not.

1486 (conn-set-non-blocking! conn)

1487 (let ((deadline (timeout->deadline secs)))

1488 (write-all-data conn

1489 (build-request-bytes method parsed headers body)

1490 deadline))

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

1492 (fetch-safe-close conn)

1493 result)))))))))

1494

1495 ;;; Stream an HTTP response without buffering its body.

1496 ;;;

1497 ;;; `on-head` is called once with `#{ status: headers: }`. `on-chunk` is

1498 ;;; then called with each available BYTEVECTOR of decoded response-body

1499 ;;; data. HTTP/1.1 chunk framing is removed incrementally; arbitrary

1500 ;;; transport boundaries are preserved safely. Returns the head dict on a

1501 ;;; complete response, or #f on connect, framing, callback, or idle-timeout

1502 ;;; failure. As with `http-fetch-bytes`, timeout is an idle deadline.

1503 (define (http-stream-response method url on-head on-chunk

1504 (keys: (headers #{}) (body #f) (timeout #f)))

1505 (let ((secs (if (and timeout (number? timeout) (> timeout 0))

1506 timeout fetch-default-timeout)))

1507 (guard (e (#t #f))

1508 (let ((parsed (parse-url url)))

1509 (and parsed

1510 (let* ((https? (string=? (url-scheme parsed) "https"))

1511 (conn (connect-to-server parsed

1512 (and (or https? timeout) secs))))

1513 (and conn

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

1515 (conn-set-non-blocking! conn)

1516 (write-all-data conn

1517 (build-request-string method parsed headers body)

1518 (timeout->deadline secs))

1519 (let ((result (stream-read-response

1520 conn method secs on-head on-chunk)))

1521 (fetch-safe-close conn)

1522 result)))))))))

1523

1524 (define (stream-read-response conn method timeout on-head on-chunk)

1525 (let loop ((buf (make-bytevector 0)) (idle 0)

1526 (deadline (+ (current-second) timeout)))

1527 (cond

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

1529 (else

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

1531 (if hidx

1532 (stream-parse conn method timeout buf hidx on-head on-chunk)

1533 (let ((chunk (guard (e (#t 'err))

1534 (conn-read-bytes conn fetch-read-chunk))))

1535 (cond

1536 ((eq? chunk 'err) #f)

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

1538 (zero? (bytevector-length chunk)))

1539 (begin (sleep *read-poll-interval*)

1540 (loop buf (+ idle 1) deadline)))

1541 (else

1542 (loop (bytevector-append buf chunk) 0

1543 (+ (current-second) timeout)))))))))))

1544

1545 (define (stream-parse conn method timeout buf hidx on-head on-chunk)

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

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

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

1549 (status (and (pair? lines)

1550 (let ((si (parse-status-line (car lines))))

1551 (and si (cadr si)))))

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

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

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

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

1556 (head (and status #{ status: status headers: hdrs })))

1557 (and head

1558 (begin

1559 (on-head head)

1560 (cond

1561 ((no-body-expected? method status) head)

1562 (chunked?

1563 (and (stream-chunked-body conn timeout body0 on-chunk) head))

1564 (clen

1565 (and (stream-length-body conn timeout body0 clen on-chunk) head))

1566 (else

1567 (and (stream-until-close-body conn timeout body0 on-chunk) head)))))))

1568

1569 (define (stream-emit-prefix chunk count on-chunk)

1570 (when (> count 0)

1571 (on-chunk (if (= count (bytevector-length chunk))

1572 chunk (bytevector-copy chunk 0 count)))))

1573

1574 (define (stream-length-body conn timeout body0 content-length on-chunk)

1575 (let ((initial (if (< content-length (bytevector-length body0))

1576 content-length (bytevector-length body0))))

1577 (stream-emit-prefix body0 initial on-chunk)

1578 (let loop ((have initial) (idle 0) (deadline (+ (current-second) timeout)))

1579 (cond

1580 ((>= have content-length) #t)

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

1582 (else

1583 (let ((chunk (guard (e (#t 'err))

1584 (conn-read-bytes conn fetch-read-chunk))))

1585 (cond

1586 ((eq? chunk 'err) #f)

1587 ;; Plain non-blocking socket reads use #f for would-block.

1588 ;; A framed body can safely retry it: completion is known

1589 ;; from Content-Length, not connection close.

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

1591 (zero? (bytevector-length chunk)))

1592 (begin (sleep *read-poll-interval*)

1593 (loop have (+ idle 1) deadline)))

1594 (else

1595 (let ((take (if (< (- content-length have)

1596 (bytevector-length chunk))

1597 (- content-length have)

1598 (bytevector-length chunk))))

1599 (stream-emit-prefix chunk take on-chunk)

1600 (loop (+ have take) 0 (+ (current-second) timeout)))))))))))

1601

1602 (define (stream-until-close-body conn timeout body0 on-chunk)

1603 (stream-emit-prefix body0 (bytevector-length body0) on-chunk)

1604 (let loop ((idle 0) (deadline (+ (current-second) timeout)))

1605 (cond

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

1607 (else

1608 (let ((chunk (guard (e (#t 'err))

1609 (conn-read-bytes conn fetch-read-chunk))))

1610 (cond

1611 ((eq? chunk 'err) #f)

1612 ((or (not chunk) (eof-object? chunk)) #t)

1613 ((zero? (bytevector-length chunk))

1614 (begin (sleep *read-poll-interval*)

1615 (loop (+ idle 1) deadline)))

1616 (else

1617 (on-chunk chunk)

1618 (loop 0 (+ (current-second) timeout)))))))))

1619

1620 ;; Mutable incremental chunked-transfer decoder state:

1621 ;; #(pending-bytes remaining-payload-bytes-or-#f complete?)

1622 (define (stream-chunked-state)

1623 (vector (make-bytevector 0) #f #f))

1624

1625 (define (stream-chunked-feed! state incoming on-chunk)

1626 (vector-set! state 0

1627 (bytevector-append (vector-ref state 0) incoming))

1628 (let loop ()

1629 (let ((buf (vector-ref state 0))

1630 (remaining (vector-ref state 1)))

1631 (cond

1632 ((vector-ref state 2) #t)

1633 (remaining

1634 (if (< (bytevector-length buf) (+ remaining 2))

1635 #f

1636 (begin

1637 (stream-emit-prefix buf remaining on-chunk)

1638 (vector-set! state 0

1639 (bytevector-copy buf (+ remaining 2) (bytevector-length buf)))

1640 (vector-set! state 1 #f)

1641 (loop))))

1642 (else

1643 (let ((line-end (fetch-find-crlf buf 0)))

1644 (if (not line-end)

1645 #f

1646 (let ((size (fetch-hex

1647 (utf8->string (bytevector-copy buf 0 line-end)))))

1648 (if (not size)

1649 (error "invalid HTTP chunk size")

1650 (begin

1651 (vector-set! state 0

1652 (bytevector-copy buf (+ line-end 2)

1653 (bytevector-length buf)))

1654 (if (= size 0)

1655 (begin (vector-set! state 2 #t) #t)

1656 (begin (vector-set! state 1 size) (loop)))))))))))))

1657

1658 (define (stream-chunked-body conn timeout body0 on-chunk)

1659 (let ((state (stream-chunked-state)))

1660 (stream-chunked-feed! state body0 on-chunk)

1661 (let loop ((idle 0) (deadline (+ (current-second) timeout)))

1662 (cond

1663 ((vector-ref state 2) #t)

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

1665 (else

1666 (let ((chunk (guard (e (#t 'err))

1667 (conn-read-bytes conn fetch-read-chunk))))

1668 (cond

1669 ((eq? chunk 'err) #f)

1670 ;; As above, #f may be transient would-block. Chunk framing

1671 ;; gives us an unambiguous terminator, so keep polling.

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

1673 (zero? (bytevector-length chunk)))

1674 (begin (sleep *read-poll-interval*)

1675 (loop (+ idle 1) deadline)))

1676 (else

1677 (stream-chunked-feed! state chunk on-chunk)

1678 (loop 0 (+ (current-second) timeout))))))))))

1679

1680 (define (fetch-safe-close conn)

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

1682

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

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

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

1686 ;; before a complete header block arrived.

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

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

1689 (cond

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

1691 (else

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

1693 (if hidx

1694 (fetch-parse conn method timeout buf hidx)

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

1696 (cond

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

1698 ((zero? (bytevector-length chunk))

1699 ;; Non-blocking: no data yet. Sleep before retrying —

1700 ;; an empty read returns instantly, so an unpaced retry

1701 ;; is a hot spin that burns a core while it waits.

1702 (begin (sleep *read-poll-interval*)

1703 (loop buf (+ idle 1) deadline)))

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

1705

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

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

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

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

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

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

1712 (status (and (pair? lines)

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

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

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

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

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

1718 (and status

1719 (let ((bodyv

1720 (cond

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

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

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

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

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

1726

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

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

1729 ;; line with no colon is skipped.

1730 (define (fetch-parse-headers lines)

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

1732 (cond

1733 ((null? ls) (reverse acc))

1734 (else

1735 (let* ((line (car ls))

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

1737 (if cpos

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

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

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

1741 (loop (cdr ls) acc)))))))

1742

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

1744 (define (fetch-header hdrs name)

1745 (let loop ((hs hdrs))

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

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

1748 (else (loop (cdr hs))))))

1749

1750 (define (fetch-content-length hdrs)

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

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

1753

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

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

1756 ;; resets on data.

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

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

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

1760 (cond

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

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

1763 (fetch-assemble (reverse chunks)))

1764 (else

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

1766 (cond

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

1768 ((zero? (bytevector-length chunk))

1769 (begin (sleep *read-poll-interval*)

1770 (loop chunks have (+ idle 1) deadline)))

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

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

1773

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

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

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

1777 (cond

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

1779 (fetch-assemble (reverse chunks)))

1780 (else

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

1782 (cond

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

1784 ((zero? (bytevector-length chunk))

1785 (begin (sleep *read-poll-interval*)

1786 (loop chunks (+ idle 1) deadline)))

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

1788

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

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

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

1792 (define (fetch-assemble chunks)

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

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

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

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

1797 (if (null? cs)

1798 out

1799 (let ((c (car cs)))

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

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

1802

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

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

1805 (define (fetch-dechunk bv)

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

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

1808 (if (>= pos len)

1809 (fetch-assemble (reverse out))

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

1811 (if (not line-end)

1812 (fetch-assemble (reverse out))

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

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

1815 (cond

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

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

1818 (else (loop (+ data size 2)

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

1820

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

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

1823 (let loop ((i pos))

1824 (cond

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

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

1827 (else (loop (+ i 1)))))))

1828

1829 (define (fetch-hex s)

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

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

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

1833 (len (string-length hx)))

1834 (if (= len 0)

1835 #f

1836 (let loop ((i 0) (acc 0))

1837 (if (>= i len)

1838 acc

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

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

1841

1842 (define (fetch-hex-digit ch)

1843 (cond

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

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

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

1847 (else #f)))

1848

1849 ;; ============================================================

1850 ;; API Client Helpers

1851 ;; ============================================================

1852

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

1854 ;;;

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

1856 ;;; slash-separated path parts.

1857 ;;;

1858 ;;; ```scheme

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

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

1861 ;;; ```

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

1863 (apply string-append base-url

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

1865

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

1867 ;;;

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

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

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

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

1872 ;;;

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

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

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

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

1877 ;;; match a specific handler entry.

1878 ;;;

1879 ;;; ```scheme

1880 ;;; (define check-response

1881 ;;; (make-response-checker

1882 ;;; name: "YouTube API"

1883 ;;; handlers: (list

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

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

1886 ;;;

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

1888 ;;; ```

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

1890 (handlers '())

1891 (parse-error #f)))

1892 (lambda (response)

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

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

1895 (let ((status (http-response-status response))

1896 (body (http-response-body response)))

1897 (cond

1898 ;; Check specific status handlers

1899 ((and (>= status 400)

1900 (assv status handlers))

1901 => (lambda (entry)

1902 (error (string-append

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

1904 (cdr entry)

1905 " Response: " (or body "")))))

1906 ;; Generic error for 400+

1907 ((>= status 400)

1908 (if parse-error

1909 (parse-error status body)

1910 (error (string-append

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

1912 (or body "")))))

1913 ;; Success — return parsed JSON or #t

1914 (else

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

1916 (json-decode* body)

1917 #t))))))

1918

1919 ;;; Create authenticated JSON API method wrappers.

1920 ;;;

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

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

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

1924 ;;;

1925 ;;; ```scheme

1926 ;;; (define api (make-json-api

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

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

1929 ;;;

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

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

1932 ;;; ```

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

1934 (let ((json-headers

1935 (lambda ()

1936 (dict-merge (auth-headers)

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

1938 (dict

1939 get: (lambda (url)

1940 (check-response

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

1942 post: (lambda (url body)

1943 (check-response

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

1945 headers: (json-headers))))

1946 put: (lambda (url body)

1947 (check-response

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

1949 headers: (json-headers))))

1950 patch: (lambda (url body)

1951 (check-response

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

1953 headers: (json-headers))))

1954 delete: (lambda (url)

1955 (check-response

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

1957

1958 ))