test/test-client.sgl

1;;; Tests for (sigil http client) — chunked decoding and response parsing

3(import (sigil test)

4 (sigil core)

5 (sigil io)

6 (sigil string)

7 (sigil time)

8 (sigil socket)

9 (sigil http client)

10 (sigil http response))

13;; ============================================================

14;; Chunked Decoding

15;; ============================================================

17(test-group "decode-chunked-body"

19 (test "single ASCII chunk"

20 (let ((body (decode-chunked-body "5\r\nhello\r\n0\r\n\r\n")))

21 (assert-equal body "hello")))

23 (test "multiple ASCII chunks"

24 (let ((body (decode-chunked-body "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\n")))

25 (assert-equal body "hello world")))

27 (test "empty body"

28 (let ((body (decode-chunked-body "0\r\n\r\n")))

29 (assert-equal body "")))

31 (test "UTF-8 multi-byte characters"

32 ;; "héllo" is 6 bytes in UTF-8 (é = 2 bytes), 5 characters

33 (let ((body (decode-chunked-body "6\r\nhéllo\r\n0\r\n\r\n")))

34 (assert-equal body "héllo")))

36 (test "mixed ASCII and UTF-8 chunks"

37 ;; First chunk: "hello " = 6 bytes

38 ;; Second chunk: "wörld" = 6 bytes (ö = 2 bytes)

39 (let ((body (decode-chunked-body "6\r\nhello \r\n6\r\nwörld\r\n0\r\n\r\n")))

40 (assert-equal body "hello wörld")))

42 (test "CJK characters"

43 ;; "日本語" = 9 bytes in UTF-8 (3 bytes each)

44 (let ((body (decode-chunked-body "9\r\n日本語\r\n0\r\n\r\n")))

45 (assert-equal body "日本語")))

47 (test "Greek text"

48 ;; "Γειά" = 8 bytes in UTF-8 (2 bytes each)

49 (let ((body (decode-chunked-body "8\r\nΓειά\r\n0\r\n\r\n")))

50 (assert-equal body "Γειά"))))

53;; ============================================================

54;; Full HTTP Response Parsing

55;; ============================================================

57(test-group "parse-http-response"

59 (test "simple response"

60 (let ((res (parse-http-response

61 "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\nhello")))

62 (assert-true (http-response? res))

63 (assert-equal (http-response-status res) 200)

64 (assert-equal (http-response-body res) "hello")))

66 (test "chunked response with ASCII"

67 (let ((res (parse-http-response

68 (string-append

69 "HTTP/1.1 200 OK\r\n"

70 "Transfer-Encoding: chunked\r\n\r\n"

71 "5\r\nhello\r\n0\r\n\r\n"))))

72 (assert-true (http-response? res))

73 (assert-equal (http-response-body res) "hello")))

75 (test "chunked response with UTF-8 body"

76 (let ((res (parse-http-response

77 (string-append

78 "HTTP/1.1 200 OK\r\n"

79 "Transfer-Encoding: chunked\r\n\r\n"

80 "6\r\nhéllo\r\n0\r\n\r\n"))))

81 (assert-true (http-response? res))

82 (assert-equal (http-response-body res) "héllo"))))

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

85;; build-api-url

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

88(test-group "build-api-url"

90 (test "base URL only"

91 (assert-equal (build-api-url "https://api.example.com") "https://api.example.com"))

93 (test "single path part"

94 (assert-equal (build-api-url "https://api.example.com" "users")

95 "https://api.example.com/users"))

97 (test "multiple path parts"

98 (assert-equal (build-api-url "https://api.example.com" "v1" "users" "123")

99 "https://api.example.com/v1/users/123"))

100

101 (test "no trailing slash on base"

102 (assert-equal (build-api-url "https://api.twitch.tv/helix" "channels")

103 "https://api.twitch.tv/helix/channels"))

104

105 (test "forgejo-style with api/v1 prefix"

106 (assert-equal (build-api-url "https://codeberg.org" "api" "v1" "repos")

107 "https://codeberg.org/api/v1/repos")))

108

109

110;; ============================================================

111;; make-response-checker

112;; ============================================================

113

114(test-group "make-response-checker"

115

116 (test "success returns parsed JSON"

117 (let ((checker (make-response-checker name: "Test")))

118 (assert-equal

119 (checker (http-response status: 200 body: "{\"ok\":true}"))

120 #{ ok: #t })))

121

122 (test "success with empty body returns #t"

123 (let ((checker (make-response-checker name: "Test")))

124 (assert-equal

125 (checker (http-response status: 204 body: ""))

126 #t)))

127

128 (test "generic error for 400+"

129 (let ((checker (make-response-checker name: "Test API")))

130 (assert-error

131 (checker (http-response status: 500 body: "server error")))))

132

133 (test "specific handler for status code"

134 (let ((checker (make-response-checker

135 name: "YouTube API"

136 handlers: (list

137 (cons 401 "Access token expired.")

138 (cons 403 "Quota exceeded.")))))

139 (assert-error

140 (checker (http-response status: 401 body: "unauthorized")))))

141

142 (test "no response raises error"

143 (let ((checker (make-response-checker name: "Test")))

144 (assert-error

145 (checker #f))))

146

147 (test "custom parse-error handler"

148 (let ((checker (make-response-checker

149 name: "Custom"

150 parse-error: (lambda (status body)

151 (error (string-append "custom: " (number->string status)))))))

152 (assert-error

153 (checker (http-response status: 422 body: "bad"))))))

154

155

156;; ============================================================

157;; make-json-api

158;; ============================================================

159

160(test-group "make-json-api"

161

162 (test "returns dict with all method keys"

163 (let ((api (make-json-api

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

165 check-response: (lambda (r) r))))

166 (assert-true (dict? api))

167 (assert-true (procedure? (dict-ref api get:)))

168 (assert-true (procedure? (dict-ref api post:)))

169 (assert-true (procedure? (dict-ref api put:)))

170 (assert-true (procedure? (dict-ref api patch:)))

171 (assert-true (procedure? (dict-ref api delete:))))))

172

173

174;; ============================================================

175;; HTTP Response Framing (Content-Length / chunked / no-body)

176;; ============================================================

177;;

178;; The read loop must terminate as soon as the framed body is fully

179;; received, NOT wait for the peer to close (EOF). A keep-alive or

180;; half-open peer can send a complete response and then hold the

181;; connection open indefinitely — which previously hung the read (or,

182;; with a timeout, tripped a spurious deadline on an already-delivered

183;; request, causing duplicate retries).

184

185(test-group "find-header-end-bytes"

186

187 (test "locates the \\r\\n\\r\\n boundary"

188 (let* ((bv (string->utf8 "HTTP/1.1 200 OK\r\nContent-Length: 5\r\n\r\nhello"))

189 (pos (find-header-end-bytes bv)))

190 (assert-true (and pos (> pos 0)))

191 ;; bytes at pos must be \r \n \r \n

192 (assert-equal (bytevector-u8-ref bv pos) 13)

193 (assert-equal (bytevector-u8-ref bv (+ pos 1)) 10)

194 (assert-equal (bytevector-u8-ref bv (+ pos 2)) 13)

195 (assert-equal (bytevector-u8-ref bv (+ pos 3)) 10)))

196

197 (test "returns #f when headers are incomplete"

198 (assert-false (find-header-end-bytes

199 (string->utf8 "HTTP/1.1 200 OK\r\nContent-Len")))))

200

201(test-group "no-body-expected?"

202 (test "HEAD never has a body" (assert-true (no-body-expected? 'HEAD 200)))

203 (test "204 No Content" (assert-true (no-body-expected? 'GET 204)))

204 (test "304 Not Modified" (assert-true (no-body-expected? 'GET 304)))

205 (test "1xx informational" (assert-true (no-body-expected? 'GET 100)))

206 (test "200 GET does have a body" (assert-false (no-body-expected? 'GET 200))))

207

208(test-group "detect-framing"

209

210 (test "Content-Length response"

211 (let ((f (detect-framing 'GET

212 (string->utf8 "HTTP/1.1 200 OK\r\nContent-Length: 5\r\n\r\nhel"))))

213 (assert-equal (car f) 'length)

214 (assert-equal (caddr f) 5)))

215

216 (test "chunked response"

217 (let ((f (detect-framing 'GET

218 (string->utf8 "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n5\r\nhello\r\n"))))

219 (assert-equal (car f) 'chunked)))

220

221 (test "HEAD with Content-Length is still body-less"

222 (let ((f (detect-framing 'HEAD

223 (string->utf8 "HTTP/1.1 200 OK\r\nContent-Length: 100\r\n\r\n"))))

224 (assert-equal (car f) 'no-body)))

225

226 (test "no Content-Length and not chunked falls back to until-close"

227 (let ((f (detect-framing 'GET

228 (string->utf8 "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\nhi"))))

229 (assert-equal (car f) 'until-close)))

230

231 (test "incomplete headers yield #f"

232 (assert-false (detect-framing 'GET

233 (string->utf8 "HTTP/1.1 200 OK\r\nContent-Len")))))

234

235(test-group "framing-complete?"

236

237 (test "length: complete when body bytes reach Content-Length"

238 (assert-true (framing-complete? (list 'length 10 5) 15 #f)))

239 (test "length: incomplete when short"

240 (assert-false (framing-complete? (list 'length 10 5) 12 #f)))

241 (test "no-body: always complete"

242 (assert-true (framing-complete? (list 'no-body) 0 #f)))

243 (test "until-close: never complete (relies on EOF)"

244 (assert-false (framing-complete? (list 'until-close) 9999 #f)))

245

246 (test "chunked: complete with full 0-terminated stream"

247 (let ((bv (string->utf8 "5\r\nhello\r\n0\r\n\r\n")))

248 (assert-true (framing-complete? (list 'chunked 0) (bytevector-length bv) bv))))

249 (test "chunked: incomplete without terminator"

250 (let ((bv (string->utf8 "5\r\nhello\r\n")))

251 (assert-false (framing-complete? (list 'chunked 0) (bytevector-length bv) bv)))))

252

253;; ============================================================

254;; Read Timeout (opt-in)

255;; ============================================================

256;;

257;; Demonstrates that the `timeout:` keyword bounds a stalled read: we

258;; bind a listening socket but never accept the connection. The kernel

259;; still completes the TCP handshake (via the listen backlog), so the

260;; client connects and writes the request successfully, then blocks

261;; waiting for a response that never comes — exactly the half-open

262;; wedge the timeout is meant to break. With `timeout:` the read must

263;; raise a timeout error within the deadline instead of hanging.

264

265(test-group "http read timeout"

266

267 (test "stalled read raises an ack-unconfirmed timeout within the deadline"

268 (let ((listener (tcp-listen 0 host: "127.0.0.1")))

269 (assert-true (socket? listener))

270 (let* ((port (cadr (socket-local-address listener)))

271 (url (string-append "http://127.0.0.1:" (number->string port) "/"))

272 (start (current-second))

273 (raised #f)

274 (ack-unconfirmed #f))

275 ;; Never accept on `listener`; the request is sent into the kernel

276 ;; backlog (so it WAS written/delivered) and the response read

277 ;; stalls — a delivered-but-ack-unconfirmed condition.

278 (guard (exn (else (set! raised #t)

279 (set! ack-unconfirmed (http-ack-unconfirmed? exn))))

280 (http-get url timeout: 1))

281 (let ((elapsed (- (current-second) start)))

282 (socket-close listener)

283 (assert-true raised)

284 ;; The request was written before the read stalled, so it's

285 ;; classified as ack-unconfirmed (delivered), NOT a never-sent

286 ;; failure.

287 (assert-true ack-unconfirmed)

288 (assert-true (>= elapsed 0.5))

289 (assert-true (< elapsed 5))))))

290

291 (test "connect failure returns #f (never sent), not ack-unconfirmed"

292 ;; Bind+immediately-close a listener to obtain a port with nothing

293 ;; listening → connect is refused → request never sent.

294 (let* ((tmp (tcp-listen 0 host: "127.0.0.1"))

295 (port (cadr (socket-local-address tmp))))

296 (socket-close tmp)

297 (let ((res (guard (exn (else (cons 'raised exn)))

298 (http-get (string-append "http://127.0.0.1:"

299 (number->string port) "/")

300 timeout: 1))))

301 ;; A never-sent failure surfaces as #f (the caller's tg-api-call

302 ;; turns that into a retryable error), NOT an ack-unconfirmed raise.

303 (assert-false res)))))

304

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

306;; Bounding the remaining blocking segments

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

308;;

309;; An outbound HTTP call passes through six blocking segments. Five are

310;; bounded; DNS is a documented residual. See "Unbounded segment: DNS" in

311;; client.sgl for why.

312;;

313;; THE RIG, and why it is the discriminating one: `tcp-listen` and then

314;; never `tcp-accept`. The kernel completes the TCP three-way handshake from

315;; the listen backlog, so connect() SUCCEEDS and the socket is ESTABLISHED.

316;; A connect-phase timeout therefore provably cannot fire against it, and any

317;; bound observed comes from the segment under test and nothing else.

318;;

319;; This is the shape that wedged a production monitoring service for 55 days.

320

321(define (with-stalled-listener proc)

322 (let* ((listener (tcp-listen 0 host: "127.0.0.1"))

323 (port (cadr (socket-local-address listener))))

324 (let ((result (proc port)))

325 (socket-close listener)

326 result)))

327

328(define (seconds-taken thunk)

329 (let* ((t0 (current-second))

330 (outcome (guard (exn (else (cons 'raised exn))) (cons 'value (thunk)))))

331 (cons (- (current-second) t0) outcome)))

332

333(test-group "bounded blocking segments"

334

335 ;; --- Segment: TLS handshake -------------------------------------------

336 ;;

337 ;; The one that actually killed a service. `connect-timeout:` used to stop

338 ;; at the moment the peer accepted, leaving the handshake read unbounded.

339

340 (test "https handshake against an accept-and-stall peer is bounded by connect-timeout"

341 (with-stalled-listener

342 (lambda (port)

343 (let* ((url (string-append "https://127.0.0.1:" (number->string port) "/"))

344 (measured (seconds-taken (lambda () (http-get url connect-timeout: 1))))

345 (elapsed (car measured))

346 (outcome (cdr measured)))

347 ;; The connection could not be established, so the request was

348 ;; never sent: #f, not a raise.

349 (assert-true (eq? 'value (car outcome)))

350 (assert-false (cdr outcome))

351 ;; Bounded, not merely eventual. Each phase gets the full value,

352 ;; so the ceiling is about two connect-timeouts plus slack.

353 (assert-true (< elapsed 6))))))

354

355 ;; POSITIVE CONTROL for the assertion above. Without this, "returned #f

356 ;; quickly" is satisfied by a client that cannot do HTTPS at all, or that

357 ;; rejects the URL before opening a socket. Here the peer is refusing

358 ;; connections outright, which must ALSO be fast, and must be reached by a

359 ;; different path.

360 (test "https to a refused port also returns #f, so speed alone proves nothing"

361 (let* ((tmp (tcp-listen 0 host: "127.0.0.1"))

362 (port (cadr (socket-local-address tmp))))

363 (socket-close tmp)

364 (let* ((url (string-append "https://127.0.0.1:" (number->string port) "/"))

365 (measured (seconds-taken (lambda () (http-get url connect-timeout: 1))))

366 (outcome (cdr measured)))

367 (assert-true (eq? 'value (car outcome)))

368 (assert-false (cdr outcome))

369 ;; Connection refused is immediate: well under the deadline. So the

370 ;; stall test's elapsed time, which sits near its deadline rather

371 ;; than near zero, is measuring a real wait.

372 (assert-true (< (car measured) 1)))))

373

374 ;; --- Segment: request write -------------------------------------------

375 ;;

376 ;; A request usually fits the socket buffer, so this usually returns at

377 ;; once. "Usually" is not a bound: a peer that never drains its receive

378 ;; queue fills the window, and a large body then blocks forever.

379

380 (test "a large body into a never-drained peer is bounded by timeout"

381 (with-stalled-listener

382 (lambda (port)

383 ;; 6 MiB is chosen between two constraints, both measured on this

384 ;; host.

385 ;;

386 ;; It must EXCEED the socket buffers, or the kernel simply absorbs

387 ;; the body and the write never blocks: 512 KiB, 2 MiB and 4 MiB were

388 ;; all absorbed here (tcp_wmem max is 4 MiB).

389 ;;

390 ;; And it must stay small enough that handling it does not swamp the

391 ;; timing assertion. At 8 MiB this call measured 46 s against a 1 s

392 ;; deadline, all of it spent before the write loop's first deadline

393 ;; check. Large-string allocation in the runtime is seconds-slow

394 ;; (make-string of 8 MiB takes ~6 s standalone), and the collections

395 ;; that provokes land wherever they land. At 6 MiB the same call

396 ;; measures 1.02 s, so the assertion is measuring the deadline.

397 ;;

398 ;; If this ever fails as an ack-unconfirmed READ timeout rather than

399 ;; a write timeout, the host's socket buffers are bigger than the

400 ;; body: raise the size. It fails loudly rather than skipping.

401 (let* ((url (string-append "http://127.0.0.1:" (number->string port) "/"))

402 (body (make-string (* 6 1024 1024) #\x))

403 (measured (seconds-taken (lambda () (http-post url body timeout: 1))))

404 (elapsed (car measured))

405 (outcome (cdr measured)))

406 (assert-true (eq? 'raised (car outcome)))

407 ;; A write deadline can only fire with bytes still unsent, so the

408 ;; server holds a partial request it cannot act on. That is a

409 ;; never-delivered send and it must NOT carry the ack-unconfirmed

410 ;; mark, or a caller will decline to retry a request that never

411 ;; arrived.

412 (assert-false (http-ack-unconfirmed? (cdr outcome)))

413 (assert-true (>= elapsed 0.5))

414 (assert-true (< elapsed 5))))))

415

416 ;; POSITIVE CONTROL for the write bound: the same call with a body that

417 ;; fits must succeed at the write and fail LATER, at the read, with the

418 ;; other classification. If the write loop were simply broken, this would

419 ;; fail as a write timeout too.

420 (test "a small body still writes, then stalls at the read as ack-unconfirmed"

421 (with-stalled-listener

422 (lambda (port)

423 (let* ((url (string-append "http://127.0.0.1:" (number->string port) "/"))

424 (measured (seconds-taken (lambda () (http-post url "small=1" timeout: 1))))

425 (outcome (cdr measured)))

426 (assert-true (eq? 'raised (car outcome)))

427 ;; Written and delivered, response never came: ack-unconfirmed.

428 (assert-true (http-ack-unconfirmed? (cdr outcome)))))))

429

430 ;; --- Segment: plain-HTTP connect --------------------------------------

431

432 ;; --- Segment: plain-HTTP connect --------------------------------------

433 ;;

434 ;; READ THIS BEFORE ADDING TO THIS SECTION. The two tests below assert a

435 ;; FALSY result, and a falsy result is the cheapest thing in the world to

436 ;; produce: `connect-first-address` wraps its native call in a guard, so an

437 ;; unbound procedure, a wrong arity, a wrong argument type or the whole

438 ;; bounded path being deleted ALL yield #f as well. AN ASSERTION THAT ONLY

439 ;; CHECKS FOR A FALSY RESULT CANNOT DISTINGUISH "CORRECTLY FALSE" FROM

440 ;; "NOTHING RAN". On their own these two would pass against no

441 ;; implementation at all.

442 ;;

443 ;; What makes them mean something is the LIVE control that has to hold at

444 ;; the same time: "plain http with both bounds armed still works" in

445 ;; test/integration/live-timeouts-main.sgl fetches a 200 through this exact

446 ;; path from a real listener. Failure here plus success there is the pair

447 ;; that pins the behaviour. Neither half is worth much alone, and the live

448 ;; half is named in run-timeout-tests.sh's required-controls list so it

449 ;; cannot quietly stop running.

450

451 (test "plain-http connect-timeout returns a clean #f for a refused port"

452 (let* ((tmp (tcp-listen 0 host: "127.0.0.1"))

453 (port (cadr (socket-local-address tmp))))

454 (socket-close tmp)

455 (let* ((url (string-append "http://127.0.0.1:" (number->string port) "/"))

456 (measured (seconds-taken (lambda () (http-get url connect-timeout: 1))))

457 (outcome (cdr measured)))

458 (assert-true (eq? 'value (car outcome)))

459 (assert-false (cdr outcome))

460 (assert-true (< (car measured) 2)))))

461

462 (test "an unresolvable host fails without hanging on the bounded connect path"

463 (let* ((measured (seconds-taken

464 (lambda () (http-get "http://no-such-host-xyz.invalid/"

465 connect-timeout: 1))))

466 (outcome (cdr measured)))

467 (assert-true (eq? 'value (car outcome)))

468 (assert-false (cdr outcome)))))

469

470(test-group "incremental response-body streaming"

471

472 (test "chunked decoder survives every transport split and emits raw UTF-8 bytes"

473 (let* ((payload "data: Γειά 👋\n\n")

474 (payload-bytes (string->utf8 payload))

475 (wire (bytevector-append

476 (string->utf8

477 (string-append (number->string (bytevector-length payload-bytes) 16)

478 "\r\n"))

479 payload-bytes

480 (string->utf8 "\r\n0\r\n\r\n")))

481 (wire-length (bytevector-length wire)))

482 (let split-loop ((at 1))

483 (when (< at wire-length)

484 (let ((state (stream-chunked-state))

485 (chunks (vector '())))

486 (define (receive chunk)

487 (vector-set! chunks 0 (append (vector-ref chunks 0) (list chunk))))

488 (stream-chunked-feed! state (bytevector-copy wire 0 at) receive)

489 (stream-chunked-feed! state (bytevector-copy wire at wire-length) receive)

490 (assert-equal

491 (utf8->string (fetch-assemble (vector-ref chunks 0))) payload)

492 (split-loop (+ at 1)))))))

493

494 (test "chunked decoder emits multiple chunks in order and stops at terminator"

495 (let ((state (stream-chunked-state))

496 (chunks (vector '())))

497 (stream-chunked-feed!

498 state (string->utf8 "3\r\none\r\n3\r\ntwo\r\n0\r\n\r\n")

499 (lambda (chunk)

500 (vector-set! chunks 0 (append (vector-ref chunks 0) (list chunk)))))

501 (assert-equal (utf8->string (fetch-assemble (vector-ref chunks 0))) "onetwo")))

502

503 (test "invalid chunk size is rejected"

504 (assert-error

505 (stream-chunked-feed! (stream-chunked-state)

506 (string->utf8 "nope\r\n")

507 (lambda (chunk) #t)))))

508

509(run-tests)