test/test-response.sgl

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

3(import (sigil test)

4 (sigil io)

5 (sigil string)

6 (sigil async)

7 (sigil channels)

8 (sigil time)

9 (sigil fs)

10 (sigil http response))

12;; ============================================================

13;;; Status Code Tests

14;; ============================================================

16(test "status code constants"

17 (assert-equal HTTP-OK 200)

18 (assert-equal HTTP-CREATED 201)

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

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

21 (assert-equal HTTP-FOUND 302)

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

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

24 (assert-equal HTTP-UNAUTHORIZED 401)

25 (assert-equal HTTP-FORBIDDEN 403)

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

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

29(test "status message lookup"

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

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

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

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

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

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

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

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

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

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

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

42;; ============================================================

43;;; Response Record Tests

44;; ============================================================

46(test "create response with all fields"

47 (let ((res (http-response

48 status: 200

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

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

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

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

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

55(test "response defaults"

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

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

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

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

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

62;; ============================================================

63;;; Convenience Constructor Tests

64;; ============================================================

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

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

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

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

70 ;; Check Content-Type header

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

72 (assert-true ct)

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

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

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

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

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

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

80 (assert-true ct)

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

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

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

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

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

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

88 (assert-true ct)

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

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

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

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

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

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

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

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

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

100 (assert-true loc)

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

102

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

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

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

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

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

108

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

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

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

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

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

114

115;; ============================================================

116;;; Response Serialization Tests

117;; ============================================================

118

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

120 (let* ((res (http-response

121 status: 200

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

123 body: "Hello"))

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

125 ;; Check status line

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

127 ;; Check headers present

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

129 ;; Check body

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

131

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

133 (let* ((res (http-response

134 status: 200

135 body: "12345"))

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

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

138

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

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

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

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

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

144

145;; ============================================================

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

147;; ============================================================

148

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

150 (let ((written '()))

151 (define (mock-write sock data)

152 (set! written (cons data written))

153 (string-length data))

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

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

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

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

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

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

160

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

162 (let ((written '()))

163 (define (mock-write sock data)

164 (set! written (cons data written))

165 (string-length data))

166 (let ((res (http-response

167 status: 200

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

169 body: (lambda (emit-chunk finish)

170 (emit-chunk "chunk1")

171 (emit-chunk "chunk2")

172 (finish)))))

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

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

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

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

177

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

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

180 (let ((written '()))

181 (define (mock-write sock data)

182 (set! written (cons data written))

183 (string-length data))

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

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

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

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

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

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

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

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

192 ;; And nothing follows the header terminator.

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

194

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

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

197 (let ((written '())

198 (produced #f))

199 (define (mock-write sock data)

200 (set! written (cons data written))

201 (string-length data))

202 (let ((res (http-response

203 status: 200

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

205 body: (lambda (emit-chunk finish)

206 (set! produced #t)

207 (emit-chunk "chunk1")

208 (finish)))))

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

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

211 (assert-false produced) ; producer never called

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

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

214

215;; ============================================================

216;; T2: Range / 206 / 416 handling

217;; ============================================================

218

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

220

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

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

223

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

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

226

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

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

229

230 (test "absent header => #f"

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

232

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

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

235

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

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

238

239(test-group "resolve-range"

240

241 (test "absolute in-bounds"

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

243

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

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

246

247 (test "end past EOF is clamped"

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

249

250 (test "suffix returns the last N bytes"

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

252

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

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

255

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

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

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

259

260 (test "empty file: any range unsatisfiable"

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

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

263

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

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

266(define range-test-size 1000)

267

268(define range-test-bytes

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

270 (let loop ((i 0))

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

272 bv

273 (begin

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

275 (loop (+ i 1)))))))

276

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

278

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

280(define (collect-file-body res)

281 (let ((chunks '()))

282 ((http-response-body res)

283 (lambda (data)

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

285 #t)

286 (lambda () #t))

287 (if (null? chunks)

288 (make-bytevector 0)

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

290

291(define (res-header res key)

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

293

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

295

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

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

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

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

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

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

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

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

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

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

306

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

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

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

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

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

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

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

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

315

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

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

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

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

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

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

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

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

324

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

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

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

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

329

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

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

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

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

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

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

336

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

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

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

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

341

342;; ============================================================

343;; T4: Chunked transfer-encoding framing

344;; ============================================================

345

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

347(define (capture-response res . kw)

348 (let ((out '()))

349 (define (w sock data)

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

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

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

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

354

355(test-group "chunked framing"

356

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

358 (let* ((res (http-response

359 status: 200

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

361 body: (lambda (emit finish)

362 (emit "hello")

363 (emit " world")

364 (finish))))

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

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

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

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

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

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

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

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

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

374

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

376 (let* ((res (http-response

377 status: 200

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

379 body: (lambda (emit finish)

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

381 (emit "data")

382 (finish))))

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

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

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

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

387

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

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

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

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

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

393

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

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

396 (out (capture-response res)))

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

398

399;; ============================================================

400;; SSE Heartbeat Tests

401;; ============================================================

402

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

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

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

406

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

408 (let ((received #f))

409 (with-async

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

411 (sub (broadcast-subscribe bc))

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

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

414 (stop)))

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

416

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

418 (let ((m1 #f) (m2 #f))

419 (with-async

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

421 (bc2 (make-broadcast))

422 (sub1 (broadcast-subscribe bc1))

423 (sub2 (broadcast-subscribe bc2))

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

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

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

427 (stop)))

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

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

430

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

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

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

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

435 (with-async

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

437 (sub (broadcast-subscribe bc))

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

439 (channel-receive sub) ; drain one heartbeat

440 (stop)

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

442 ;; Any pending marker would have landed by now

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

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

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

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

447

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

449 (let ((writes '()))

450 (with-async

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

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

453 (lambda (msg) (sse-data msg))))

454 (body (http-response-body res))

455 ;; First heartbeat succeeds; second triggers unsubscribe

456 ;; so the goroutine can exit.

457 (call-count 0)

458 (write-chunk (lambda (s)

459 (set! writes (cons s writes))

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

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

462 (close (lambda () #t)))

463 (go (body write-chunk close))

464 (sleep 0.01)

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

466 (sleep 0.01)

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

468 (sleep 0.02)))

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

470

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

472 (let ((writes '()))

473 (with-async

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

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

476 (lambda (msg) (sse-data msg))))

477 (body (http-response-body res))

478 (call-count 0)

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

480 (write-chunk (lambda (s)

481 (set! writes (cons s writes))

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

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

484 (close (lambda () #t)))

485 (go (body write-chunk close))

486 (sleep 0.01)

487 (broadcast-send bc "hello")

488 (sleep 0.01)

489 (broadcast-send bc "world")

490 (sleep 0.02)))

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

492

493(run-tests)