test/test-response.sgl

1;;; Test suite for (sigil http response)

3(import (sigil test)

4 (sigil string)

5 (sigil async)

6 (sigil channels)

7 (sigil time)

8 (sigil fs)

9 (sigil http response))

11;; ============================================================

12;;; Status Code Tests

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

15(test "status code constants"

16 (assert-equal HTTP-OK 200)

17 (assert-equal HTTP-CREATED 201)

18 (assert-equal HTTP-NO-CONTENT 204)

19 (assert-equal HTTP-MOVED-PERMANENTLY 301)

20 (assert-equal HTTP-FOUND 302)

21 (assert-equal HTTP-NOT-MODIFIED 304)

22 (assert-equal HTTP-BAD-REQUEST 400)

23 (assert-equal HTTP-UNAUTHORIZED 401)

24 (assert-equal HTTP-FORBIDDEN 403)

25 (assert-equal HTTP-NOT-FOUND 404)

26 (assert-equal HTTP-INTERNAL-SERVER-ERROR 500))

28(test "status message lookup"

29 (assert-equal (http-status-message 200) "OK")

30 (assert-equal (http-status-message 201) "Created")

31 (assert-equal (http-status-message 204) "No Content")

32 (assert-equal (http-status-message 301) "Moved Permanently")

33 (assert-equal (http-status-message 302) "Found")

34 (assert-equal (http-status-message 400) "Bad Request")

35 (assert-equal (http-status-message 401) "Unauthorized")

36 (assert-equal (http-status-message 403) "Forbidden")

37 (assert-equal (http-status-message 404) "Not Found")

38 (assert-equal (http-status-message 500) "Internal Server Error")

39 (assert-equal (http-status-message 999) "Unknown"))

41;; ============================================================

42;;; Response Record Tests

43;; ============================================================

45(test "create response with all fields"

46 (let ((res (http-response

47 status: 200

48 headers: #{ content-type: "text/html" }

49 body: "<h1>Hello</h1>")))

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

51 (assert-equal (dict-ref (http-response-headers res) content-type:) "text/html")

52 (assert-equal (http-response-body res) "<h1>Hello</h1>")))

54(test "response defaults"

55 (let ((res (http-response status: 204)))

56 (assert-equal (http-response-status res) 204)

57 (assert-true (dict? (http-response-headers res)))

58 (assert-true (dict-empty? (http-response-headers res)))

59 (assert-equal (http-response-body res) #f)))

61;; ============================================================

62;;; Convenience Constructor Tests

63;; ============================================================

65(test "http-response/text creates text response"

66 (let ((res (http-response/text 200 "Hello, World!")))

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

68 (assert-equal (http-response-body res) "Hello, World!")

69 ;; Check Content-Type header

70 (let ((ct (dict-ref (http-response-headers res) content-type: #f)))

71 (assert-true ct)

72 (assert-true (string-contains? ct "text/plain")))))

74(test "http-response/html creates HTML response"

75 (let ((res (http-response/html 200 "<h1>Title</h1>")))

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

77 (assert-equal (http-response-body res) "<h1>Title</h1>")

78 (let ((ct (dict-ref (http-response-headers res) content-type: #f)))

79 (assert-true ct)

80 (assert-true (string-contains? ct "text/html")))))

82(test "http-response/json creates JSON response"

83 (let ((res (http-response/json 200 "{\"key\": \"value\"}")))

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

85 (assert-equal (http-response-body res) "{\"key\": \"value\"}")

86 (let ((ct (dict-ref (http-response-headers res) content-type: #f)))

87 (assert-true ct)

88 (assert-true (string-contains? ct "application/json")))))

90(test "http-response/not-found creates 404 response"

91 (let ((res (http-response/not-found)))

92 (assert-equal (http-response-status res) 404)

93 (assert-true (http-response-body res))))

95(test "http-response/redirect creates redirect response"

96 (let ((res (http-response/redirect "/new-location")))

97 (assert-equal (http-response-status res) 302)

98 (let ((loc (dict-ref (http-response-headers res) location: #f)))

99 (assert-true loc)

100 (assert-equal loc "/new-location"))))

101

102(test "http-response/redirect with custom status"

103 (let ((res (http-response/redirect "/permanent" 301)))

104 (assert-equal (http-response-status res) 301)

105 (let ((loc (dict-ref (http-response-headers res) location: #f)))

106 (assert-equal loc "/permanent"))))

107

108(test "http-response/error creates error response"

109 (let ((res (http-response/error 500 "Something went wrong")))

110 (assert-equal (http-response-status res) 500)

111 (assert-true (string-contains? (http-response-body res) "500"))

112 (assert-true (string-contains? (http-response-body res) "Something went wrong"))))

113

114;; ============================================================

115;;; Response Serialization Tests

116;; ============================================================

117

118(test "http-response->string formats simple response"

119 (let* ((res (http-response

120 status: 200

121 headers: #{ content-type: "text/plain" }

122 body: "Hello"))

123 (str (http-response->string res)))

124 ;; Check status line

125 (assert-true (string-starts-with? str "HTTP/1.1 200 OK\r\n"))

126 ;; Check headers present

127 (assert-true (string-contains? str "content-type: text/plain"))

128 ;; Check body

129 (assert-true (string-contains? str "\r\n\r\nHello"))))

130

131(test "http-response->string adds Content-Length"

132 (let* ((res (http-response

133 status: 200

134 body: "12345"))

135 (str (http-response->string res)))

136 (assert-true (string-contains? str "content-length: 5"))))

137

138(test "http-response->string handles no body"

139 (let* ((res (http-response status: 204))

140 (str (http-response->string res)))

141 (assert-true (string-starts-with? str "HTTP/1.1 204 No Content\r\n"))

142 (assert-true (string-contains? str "content-length: 0"))))

143

144;; ============================================================

145;;; Write Response Tests (with mock socket)

146;; ============================================================

147

148(test "write-http-response calls write function correctly"

149 (let ((written '()))

150 (define (mock-write sock data)

151 (set! written (cons data written))

152 (string-length data))

153 (let ((res (http-response/text 200 "Test body")))

154 (write-http-response res 'mock-socket mock-write)

155 ;; Should have written: status line, headers, blank line, body

156 (let ((output (apply string-append (reverse written))))

157 (assert-true (string-starts-with? output "HTTP/1.1 200 OK"))

158 (assert-true (string-contains? output "Test body"))))))

159

160(test "write-http-response handles streaming body"

161 (let ((written '()))

162 (define (mock-write sock data)

163 (set! written (cons data written))

164 (string-length data))

165 (let ((res (http-response

166 status: 200

167 headers: #{ content-type: "text/plain" }

168 body: (lambda (emit-chunk finish)

169 (emit-chunk "chunk1")

170 (emit-chunk "chunk2")

171 (finish)))))

172 (write-http-response res 'mock-socket mock-write)

173 (let ((output (apply string-append (reverse written))))

174 (assert-true (string-contains? output "chunk1"))

175 (assert-true (string-contains? output "chunk2"))))))

176

177;; T3: HEAD returns identical status + headers but zero body bytes.

178(test "write-http-response head?: suppresses the body but keeps headers"

179 (let ((written '()))

180 (define (mock-write sock data)

181 (set! written (cons data written))

182 (string-length data))

183 (let ((res (http-response/text 200 "Test body")))

184 (write-http-response res 'mock-socket mock-write head?: #t)

185 (let ((output (apply string-append (reverse written))))

186 ;; Status line + headers present, incl. the GET Content-Length...

187 (assert-true (string-starts-with? output "HTTP/1.1 200 OK"))

188 (assert-true (string-contains? output "content-length: 9"))

189 ;; ...but the body itself must NOT be on the wire.

190 (assert-false (string-contains? output "Test body"))

191 ;; And nothing follows the header terminator.

192 (assert-true (string-ends-with? output "\r\n\r\n"))))))

193

194;; T3: HEAD must not invoke a streaming producer at all.

195(test "write-http-response head?: does not run a streaming body"

196 (let ((written '())

197 (produced #f))

198 (define (mock-write sock data)

199 (set! written (cons data written))

200 (string-length data))

201 (let ((res (http-response

202 status: 200

203 headers: #{ content-type: "text/plain" }

204 body: (lambda (emit-chunk finish)

205 (set! produced #t)

206 (emit-chunk "chunk1")

207 (finish)))))

208 (write-http-response res 'mock-socket mock-write head?: #t)

209 (let ((output (apply string-append (reverse written))))

210 (assert-false produced) ; producer never called

211 (assert-false (string-contains? output "chunk1"))

212 (assert-true (string-starts-with? output "HTTP/1.1 200 OK"))))))

213

214;; ============================================================

215;; T2: Range / 206 / 416 handling

216;; ============================================================

217

218(test-group "parse-range-header"

219

220 (test "absolute range bytes=0-499"

221 (assert-equal (parse-range-header "bytes=0-499") (cons 0 499)))

222

223 (test "open-ended range bytes=500-"

224 (assert-equal (parse-range-header "bytes=500-") (cons 500 #f)))

225

226 (test "suffix range bytes=-500 => (#f . 500)"

227 (assert-equal (parse-range-header "bytes=-500") (cons #f 500)))

228

229 (test "absent header => #f"

230 (assert-false (parse-range-header #f)))

231

232 (test "malformed (no '=') => #f"

233 (assert-false (parse-range-header "bytes 0-99")))

234

235 (test "malformed (bare dash) => #f"

236 (assert-false (parse-range-header "bytes=-"))))

237

238(test-group "resolve-range"

239

240 (test "absolute in-bounds"

241 (assert-equal (resolve-range (cons 0 99) 1000) (cons 0 99)))

242

243 (test "open-ended clamps to last byte"

244 (assert-equal (resolve-range (cons 500 #f) 1000) (cons 500 999)))

245

246 (test "end past EOF is clamped"

247 (assert-equal (resolve-range (cons 900 5000) 1000) (cons 900 999)))

248

249 (test "suffix returns the last N bytes"

250 (assert-equal (resolve-range (cons #f 500) 1000) (cons 500 999)))

251

252 (test "suffix larger than file yields whole file"

253 (assert-equal (resolve-range (cons #f 5000) 1000) (cons 0 999)))

254

255 (test "start at/after EOF is unsatisfiable"

256 (assert-equal (resolve-range (cons 1000 #f) 1000) 'unsatisfiable)

257 (assert-equal (resolve-range (cons 2000 3000) 1000) 'unsatisfiable))

258

259 (test "empty file: any range unsatisfiable"

260 (assert-equal (resolve-range (cons 0 0) 0) 'unsatisfiable)

261 (assert-equal (resolve-range (cons #f 10) 0) 'unsatisfiable)))

262

263;; http-response/file end-to-end range behavior against a real 1000-byte file.

264(define range-test-path "/tmp/sigil-http-range-test.bin")

265(define range-test-size 1000)

266

267(define range-test-bytes

268 (let ((bv (make-bytevector range-test-size 0)))

269 (let loop ((i 0))

270 (if (>= i range-test-size)

271 bv

272 (begin

273 (bytevector-u8-set! bv i (modulo i 256))

274 (loop (+ i 1)))))))

275

276(write-file-bytes range-test-path range-test-bytes)

277

278;; Drive a streaming file-response body to completion, returning its bytes.

279(define (collect-file-body res)

280 (let ((chunks '()))

281 ((http-response-body res)

282 (lambda (data)

283 (set! chunks (cons (if (string? data) (string->utf8 data) data) chunks))

284 #t)

285 (lambda () #t))

286 (if (null? chunks)

287 (make-bytevector 0)

288 (apply bytevector-append (reverse chunks)))))

289

290(define (res-header res key)

291 (dict-ref (http-response-headers res) key #f))

292

293(test-group "http-response/file range wiring"

294

295 (test "bytes=0-99 -> 206 + Content-Range + 100 bytes"

296 (let ((res (http-response/file range-test-path range: "bytes=0-99")))

297 (assert-equal (http-response-status res) 206)

298 (assert-equal (res-header res content-range:) "bytes 0-99/1000")

299 (assert-equal (res-header res content-length:) "100")

300 (assert-equal (res-header res accept-ranges:) "bytes")

301 (let ((body (collect-file-body res)))

302 (assert-equal (bytevector-length body) 100)

303 (assert-equal (bytevector-copy body 0 100)

304 (bytevector-copy range-test-bytes 0 100)))))

305

306 (test "open-ended bytes=500- -> 206, last 500 bytes"

307 (let ((res (http-response/file range-test-path range: "bytes=500-")))

308 (assert-equal (http-response-status res) 206)

309 (assert-equal (res-header res content-range:) "bytes 500-999/1000")

310 (assert-equal (res-header res content-length:) "500")

311 (let ((body (collect-file-body res)))

312 (assert-equal (bytevector-length body) 500)

313 (assert-equal body (bytevector-copy range-test-bytes 500 1000)))))

314

315 (test "suffix bytes=-500 -> 206, final 500 bytes"

316 (let ((res (http-response/file range-test-path range: "bytes=-500")))

317 (assert-equal (http-response-status res) 206)

318 (assert-equal (res-header res content-range:) "bytes 500-999/1000")

319 (assert-equal (res-header res content-length:) "500")

320 (let ((body (collect-file-body res)))

321 (assert-equal (bytevector-length body) 500)

322 (assert-equal body (bytevector-copy range-test-bytes 500 1000)))))

323

324 (test "unsatisfiable range -> 416 + Content-Range: bytes */total"

325 (let ((res (http-response/file range-test-path range: "bytes=2000-3000")))

326 (assert-equal (http-response-status res) 416)

327 (assert-equal (res-header res content-range:) "bytes */1000")))

328

329 (test "absent Range -> 200 full body"

330 (let ((res (http-response/file range-test-path)))

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

332 (assert-equal (res-header res content-length:) "1000")

333 (assert-equal (res-header res accept-ranges:) "bytes")

334 (assert-equal (bytevector-length (collect-file-body res)) 1000)))

335

336 (test "malformed Range -> 200 full body"

337 (let ((res (http-response/file range-test-path range: "not-a-range")))

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

339 (assert-equal (res-header res content-length:) "1000"))))

340

341;; ============================================================

342;; T4: Chunked transfer-encoding framing

343;; ============================================================

344

345;; Collect the full wire output of write-http-response into one string.

346(define (capture-response res . kw)

347 (let ((out '()))

348 (define (w sock data)

349 (set! out (cons (if (string? data) data (utf8->string data)) out))

350 (if (string? data) (string-length data) (bytevector-length data)))

351 (apply write-http-response res 'sock w kw)

352 (apply string-append (reverse out))))

353

354(test-group "chunked framing"

355

356 (test "streaming body without length -> Transfer-Encoding: chunked + terminator"

357 (let* ((res (http-response

358 status: 200

359 headers: #{ content-type: "text/plain" }

360 body: (lambda (emit finish)

361 (emit "hello")

362 (emit " world")

363 (finish))))

364 (out (capture-response res chunked: #t)))

365 ;; Header advertises chunked, and NO Content-Length is present.

366 (assert-true (string-contains? out "transfer-encoding: chunked"))

367 (assert-false (string-contains? out "content-length:"))

368 ;; Each write is framed <hexlen>\r\n<data>\r\n ...

369 (assert-true (string-contains? out "5\r\nhello\r\n"))

370 (assert-true (string-contains? out "6\r\n world\r\n"))

371 ;; ...and the stream ends with the zero-length terminator.

372 (assert-true (string-ends-with? out "0\r\n\r\n"))))

373

374 (test "chunked skips empty writes (no premature terminator)"

375 (let* ((res (http-response

376 status: 200

377 headers: #{ content-type: "text/plain" }

378 body: (lambda (emit finish)

379 (emit "") ; must be skipped, not framed as 0

380 (emit "data")

381 (finish))))

382 (out (capture-response res chunked: #t)))

383 (assert-true (string-contains? out "4\r\ndata\r\n"))

384 ;; Only ONE terminator, at the very end.

385 (assert-true (string-ends-with? out "0\r\n\r\n"))))

386

387 (test "keep-alive: sets Connection: keep-alive"

388 (let* ((res (http-response/text 200 "hi"))

389 (out (capture-response res keep-alive: #t)))

390 (assert-true (string-contains? out "connection: keep-alive"))

391 (assert-true (string-contains? out "content-length: 2"))))

392

393 (test "default (no keep-alive) still Connection: close"

394 (let* ((res (http-response/text 200 "hi"))

395 (out (capture-response res)))

396 (assert-true (string-contains? out "connection: close")))))

397

398;; ============================================================

399;; SSE Heartbeat Tests

400;; ============================================================

401

402(test "sse-heartbeat-message is a valid SSE comment"

403 (assert-true (string-starts-with? sse-heartbeat-message ":"))

404 (assert-true (string-ends-with? sse-heartbeat-message "\n\n")))

405

406(test "start-sse-heartbeat! fires marker on single broadcast"

407 (let ((received #f))

408 (with-async

409 (let* ((bc (make-broadcast))

410 (sub (broadcast-subscribe bc))

411 (stop (start-sse-heartbeat! bc 0.02)))

412 (set! received (channel-receive sub))

413 (stop)))

414 (assert-equal received sse-heartbeat-marker)))

415

416(test "start-sse-heartbeat! fires marker on list of broadcasts"

417 (let ((m1 #f) (m2 #f))

418 (with-async

419 (let* ((bc1 (make-broadcast))

420 (bc2 (make-broadcast))

421 (sub1 (broadcast-subscribe bc1))

422 (sub2 (broadcast-subscribe bc2))

423 (stop (start-sse-heartbeat! (list bc1 bc2) 0.02)))

424 (set! m1 (channel-receive sub1))

425 (set! m2 (channel-receive sub2))

426 (stop)))

427 (assert-equal m1 sse-heartbeat-marker)

428 (assert-equal m2 sse-heartbeat-marker)))

429

430(test "start-sse-heartbeat! stop thunk halts the loop"

431 ;; After stop, no further markers should arrive. Verify by checking

432 ;; that channel-try-receive returns nothing after the stop window.

433 (let ((extra-received #f))

434 (with-async

435 (let* ((bc (make-broadcast))

436 (sub (broadcast-subscribe bc))

437 (stop (start-sse-heartbeat! bc 0.02)))

438 (channel-receive sub) ; drain one heartbeat

439 (stop)

440 (sleep 0.1) ; wait long enough for several intervals

441 ;; Any pending marker would have landed by now

442 (set! extra-received (channel-try-receive sub))))

443 ;; channel-try-receive returns a falsy sentinel when no message is buffered

444 (assert-true (or (not extra-received)

445 (eq? extra-received 'empty)))))

446

447(test "http-response/sse-broadcast writes comment for heartbeat marker"

448 (let ((writes '()))

449 (with-async

450 (let* ((bc (make-broadcast))

451 (res (http-response/sse-broadcast bc

452 (lambda (msg) (sse-data msg))))

453 (body (http-response-body res))

454 ;; First heartbeat succeeds; second triggers unsubscribe

455 ;; so the goroutine can exit.

456 (call-count 0)

457 (write-chunk (lambda (s)

458 (set! writes (cons s writes))

459 (set! call-count (+ call-count 1))

460 (if (= call-count 1) #t #f)))

461 (close (lambda () #t)))

462 (go (body write-chunk close))

463 (sleep 0.01)

464 (broadcast-send bc sse-heartbeat-marker)

465 (sleep 0.01)

466 (broadcast-send bc sse-heartbeat-marker)

467 (sleep 0.02)))

468 (assert-true (member sse-heartbeat-message writes))))

469

470(test "http-response/sse-broadcast still delivers normal events"

471 (let ((writes '()))

472 (with-async

473 (let* ((bc (make-broadcast))

474 (res (http-response/sse-broadcast bc

475 (lambda (msg) (sse-data msg))))

476 (body (http-response-body res))

477 (call-count 0)

478 ;; Succeed for first write, fail second so loop exits.

479 (write-chunk (lambda (s)

480 (set! writes (cons s writes))

481 (set! call-count (+ call-count 1))

482 (if (= call-count 1) #t #f)))

483 (close (lambda () #t)))

484 (go (body write-chunk close))

485 (sleep 0.01)

486 (broadcast-send bc "hello")

487 (sleep 0.01)

488 (broadcast-send bc "world")

489 (sleep 0.02)))

490 (assert-true (member "data: hello\n\n" writes))))

491

492(run-tests)