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(run-tests)