test/test-http.sgl — sigil-mcp

1(import (sigil test)

2 (sigil mcp http)

3 (sigil mcp server)

4 (sigil mcp protocol)

5 (sigil http request)

6 (sigil http response)

7 (sigil json)

8 (sigil dict)

9 (sigil string))

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

12;; Fixtures

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

15(define current-version "2026-07-28")

17(define (make-server)

18 (let ((s (mcp-server name: "test-http" version: "9.9.9")))

19 (mcp-server-register-tool! s "echo" "Echo the input"

20 '((type . "object")

21 (properties . ((text . ((type . "string")))))

22 (required . ("text")))

23 (lambda (args) (dict-ref args text: "")))

24 (mcp-server-register-resource! s "test://doc" "Doc" "A doc" "text/plain"

25 (lambda (uri) "contents"))

26 s))

28(define (handler) (mcp-http-handler (make-server)))

30;; A well-formed modern request body: `_meta` carrying the protocol version

31;; and the client's capabilities, both of which are required on every request.

32(define (modern-body id method params)

33 (json-encode

34 `((jsonrpc . "2.0")

35 (id . ,id)

36 (method . ,method)

37 (params . ,(append

38 params

39 `((_meta . ,(list

40 (cons (string->symbol meta-protocol-version-key)

41 current-version)

42 (cons (string->symbol meta-client-capabilities-key)

43 '())))))))))

45(define (post headers body)

46 (http-request method: 'POST path: "/mcp" headers: headers body: body))

48;; The header set a compliant modern client sends alongside `modern-body`.

49(define (modern-headers method . name)

50 (if (null? name)

51 (dict 'mcp-protocol-version: current-version

52 'mcp-method: method)

53 (dict 'mcp-protocol-version: current-version

54 'mcp-method: method

55 'mcp-name: (car name))))

57(define (respond req) ((handler) req))

59(define (body-json resp) (json-decode (http-response-body resp)))

61(define (error-code resp)

62 (let ((err (dict-ref (body-json resp) 'error: #f)))

63 (and err (dict-ref err 'code: #f))))

65(define (result-of resp) (dict-ref (body-json resp) 'result: #f))

67;; ============================================================

68;; Origin validation

69;; ============================================================

71(test-group "origin validation"

72 (test "absent Origin is allowed"

73 ;; Non-browser clients send no Origin at all; only a PRESENT and invalid

74 ;; one is a rebinding signal.

75 (assert-true (mcp-http-origin-allowed? #f)))

77 (test "loopback origins are allowed"

78 (assert-true (mcp-http-origin-allowed? "http://127.0.0.1:8765"))

79 (assert-true (mcp-http-origin-allowed? "http://localhost:3000"))

80 (assert-true (mcp-http-origin-allowed? "https://127.0.0.1"))

81 (assert-true (mcp-http-origin-allowed? "http://[::1]:9000")))

83 (test "foreign origins are rejected"

84 (assert-false (mcp-http-origin-allowed? "http://evil.com"))

85 (assert-false (mcp-http-origin-allowed? "https://example.org:443"))

86 (assert-false (mcp-http-origin-allowed? "null")))

88 (test "a host merely CONTAINING localhost is rejected"

89 ;; The check must compare the whole host, not look for a substring:

90 ;; localhost.evil.com resolves wherever the attacker points it.

91 (assert-false (mcp-http-origin-allowed? "http://localhost.evil.com"))

92 (assert-false (mcp-http-origin-allowed? "http://127.0.0.1.evil.com")))

94 (test "invalid Origin yields 403 before anything else is considered"

95 (let ((resp (respond (http-request method: 'POST path: "/mcp"

96 headers: (dict 'origin: "http://evil.com")

97 body: ""))))

98 (assert-equal 403 (http-response-status resp)))))

100;; ============================================================

101;; HTTP method and path

102;; ============================================================

103

104(test-group "http method and path"

105 (test "GET is 405 — this revision has no server-opened stream"

106 (let ((resp (respond (http-request method: 'GET path: "/mcp"

107 headers: (dict) body: ""))))

108 (assert-equal 405 (http-response-status resp))))

109

110 (test "DELETE is 405 — there is no session to delete"

111 (let ((resp (respond (http-request method: 'DELETE path: "/mcp"

112 headers: (dict) body: ""))))

113 (assert-equal 405 (http-response-status resp))))

114

115 (test "the verb is read as a symbol AND as a string"

116 ;; The wire parser produces 'POST; a hand-built request may carry "POST".

117 ;; Accepting only one of the two is invisible to a test suite that builds

118 ;; its own requests the same wrong way — every real POST answered 405

119 ;; while the suite stayed green.

120 (let ((sym (respond (http-request method: 'POST path: "/mcp"

121 headers: (dict) body: "{bad")))

122 (str (respond (http-request method: "POST" path: "/mcp"

123 headers: (dict) body: "{bad"))))

124 (assert-equal 400 (http-response-status sym))

125 (assert-equal 400 (http-response-status str)))

126 (let ((sym (respond (http-request method: 'GET path: "/mcp"

127 headers: (dict) body: "")))

128 (str (respond (http-request method: "GET" path: "/mcp"

129 headers: (dict) body: ""))))

130 (assert-equal 405 (http-response-status sym))

131 (assert-equal 405 (http-response-status str))))

132

133 (test "unknown path is 404"

134 (let ((resp (respond (http-request method: 'POST path: "/nope"

135 headers: (dict) body: ""))))

136 (assert-equal 404 (http-response-status resp)))))

137

138;; ============================================================

139;; Body parsing

140;; ============================================================

141

142(test-group "body parsing"

143 (test "unparseable body is 400 with -32700"

144 (let ((resp (respond (post (dict) "{not json"))))

145 (assert-equal 400 (http-response-status resp))

146 (assert-equal -32700 (error-code resp)))))

147

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

149;; Modern envelope validation

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

151

152(test-group "modern envelope"

153 (test "missing _meta protocolVersion is -32602"

154 (let* ((body (json-encode

155 `((jsonrpc . "2.0") (id . 1) (method . "tools/list")

156 (params . ((_meta . ,(list (cons (string->symbol

157 meta-client-capabilities-key)

158 '()))))))))

159 (resp (respond (post (modern-headers "tools/list") body))))

160 (assert-equal 400 (http-response-status resp))

161 (assert-equal -32602 (error-code resp))))

162

163 (test "missing _meta clientCapabilities is -32602"

164 (let* ((body (json-encode

165 `((jsonrpc . "2.0") (id . 1) (method . "tools/list")

166 (params . ((_meta . ,(list (cons (string->symbol

167 meta-protocol-version-key)

168 current-version))))))))

169 (resp (respond (post (modern-headers "tools/list") body))))

170 (assert-equal 400 (http-response-status resp))

171 (assert-equal -32602 (error-code resp))))

172

173 (test "unsupported version is -32022 and lists what we support"

174 (let* ((body (json-encode

175 `((jsonrpc . "2.0") (id . 1) (method . "tools/list")

176 (params . ((_meta . ,(list

177 (cons (string->symbol

178 meta-protocol-version-key)

179 "1900-01-01")

180 (cons (string->symbol

181 meta-client-capabilities-key)

182 '()))))))))

183 (resp (respond (post (dict 'mcp-protocol-version: "1900-01-01"

184 'mcp-method: "tools/list")

185 body)))

186 (err (dict-ref (body-json resp) 'error: #f))

187 (data (dict-ref err 'data: #f)))

188 (assert-equal 400 (http-response-status resp))

189 (assert-equal -32022 (error-code resp))

190 (assert-equal "1900-01-01" (dict-ref data 'requested: #f))

191 ;; The client cannot fall forward on its own; the supported list is

192 ;; how it learns what to retry with.

193 (assert-true (> (array-length (dict-ref data 'supported: #[])) 0)))))

194

195;; ============================================================

196;; Header agreement

197;; ============================================================

198

199(test-group "header agreement"

200 (test "missing MCP-Protocol-Version header is -32020"

201 (let ((resp (respond (post (dict 'mcp-method: "tools/list")

202 (modern-body 1 "tools/list" '())))))

203 (assert-equal 400 (http-response-status resp))

204 (assert-equal -32020 (error-code resp))))

205

206 (test "header version disagreeing with _meta is -32020"

207 ;; The headers exist so a proxy can route without parsing JSON. That is

208 ;; only sound while the two agree, so disagreement is an error rather

209 ;; than a preference for one source.

210 (let ((resp (respond (post (dict 'mcp-protocol-version: "2025-11-25"

211 'mcp-method: "tools/list")

212 (modern-body 1 "tools/list" '())))))

213 (assert-equal 400 (http-response-status resp))

214 (assert-equal -32020 (error-code resp))))

215

216 (test "missing Mcp-Method header is -32020"

217 (let ((resp (respond (post (dict 'mcp-protocol-version: current-version)

218 (modern-body 1 "tools/list" '())))))

219 (assert-equal 400 (http-response-status resp))

220 (assert-equal -32020 (error-code resp))))

221

222 (test "Mcp-Method disagreeing with the body method is -32020"

223 (let ((resp (respond (post (modern-headers "prompts/list")

224 (modern-body 1 "tools/list" '())))))

225 (assert-equal 400 (http-response-status resp))

226 (assert-equal -32020 (error-code resp))))

227

228 (test "tools/call without Mcp-Name is -32020"

229 (let ((resp (respond (post (modern-headers "tools/call")

230 (modern-body 1 "tools/call"

231 '((name . "echo")

232 (arguments . ((text . "hi")))))))))

233 (assert-equal 400 (http-response-status resp))

234 (assert-equal -32020 (error-code resp))))

235

236 (test "tools/call with a mismatched Mcp-Name is -32020"

237 (let ((resp (respond (post (modern-headers "tools/call" "other")

238 (modern-body 1 "tools/call"

239 '((name . "echo")

240 (arguments . ((text . "hi")))))))))

241 (assert-equal 400 (http-response-status resp))

242 (assert-equal -32020 (error-code resp))))

243

244 (test "resources/read takes its Mcp-Name from the uri"

245 (let ((resp (respond (post (modern-headers "resources/read" "test://doc")

246 (modern-body 1 "resources/read"

247 '((uri . "test://doc")))))))

248 (assert-equal 200 (http-response-status resp)))))

249

250;; ============================================================

251;; Successful dispatch and the result envelope

252;; ============================================================

253

254(test-group "result envelope"

255 (test "tools/list succeeds and carries the full envelope"

256 (let* ((resp (respond (post (modern-headers "tools/list")

257 (modern-body 1 "tools/list" '()))))

258 (result (result-of resp)))

259 (assert-equal 200 (http-response-status resp))

260 (assert-equal "complete" (dict-ref result 'resultType: #f))

261 (let* ((meta (dict-ref result '_meta: #f))

262 (info (dict-ref meta (string->keyword meta-server-info-key) #f)))

263 (assert-equal "test-http" (dict-ref info 'name: #f))

264 (assert-equal "9.9.9" (dict-ref info 'version: #f)))

265 ;; Cacheable listings must say for how long and to whom.

266 (assert-equal 60000 (dict-ref result 'ttlMs: #f))

267 (assert-equal "private" (dict-ref result 'cacheScope: #f))))

268

269 (test "tools/call succeeds and is NOT marked cacheable"

270 ;; Tool output is a computation, not a listing. Marking it cacheable

271 ;; would let an intermediary serve a stale answer for a fresh call.

272 (let* ((resp (respond (post (modern-headers "tools/call" "echo")

273 (modern-body 1 "tools/call"

274 '((name . "echo")

275 (arguments . ((text . "hi"))))))))

276 (result (result-of resp)))

277 (assert-equal 200 (http-response-status resp))

278 (assert-equal "complete" (dict-ref result 'resultType: #f))

279 (assert-false (dict-ref result 'ttlMs: #f))

280 (assert-false (dict-ref result 'cacheScope: #f))))

281

282 (test "cacheable-method? agrees with what the envelope stamps"

283 (assert-true (mcp-http-cacheable-method? "tools/list"))

284 (assert-true (mcp-http-cacheable-method? "resources/read"))

285 (assert-true (mcp-http-cacheable-method? "server/discover"))

286 (assert-false (mcp-http-cacheable-method? "tools/call"))

287 (assert-false (mcp-http-cacheable-method? "initialize"))))

288

289;; ============================================================

290;; Method resolution

291;; ============================================================

292

293(test-group "method resolution"

294 (test "an unimplemented METHOD is 404"

295 (let ((resp (respond (post (modern-headers "nope/nope")

296 (modern-body 1 "nope/nope" '())))))

297 (assert-equal 404 (http-response-status resp))

298 (assert-equal -32601 (error-code resp))))

299

300 (test "an unknown TOOL is 200 with an error, not 404"

301 ;; The distinction is load-bearing: "this server has no such method" is

302 ;; an HTTP-level fact a client caches, while "this server has no such

303 ;; tool" is an answer from a method that ran.

304 (let ((resp (respond (post (modern-headers "tools/call" "ghost")

305 (modern-body 1 "tools/call"

306 '((name . "ghost")

307 (arguments . ())))))))

308 (assert-equal 200 (http-response-status resp))

309 (assert-equal -32601 (error-code resp)))))

310

311;; ============================================================

312;; server/discover

313;; ============================================================

314

315(test-group "server/discover"

316 (test "discover reports supported versions and identity"

317 (let* ((resp (respond (post (modern-headers "server/discover")

318 (modern-body 1 "server/discover" '()))))

319 (result (result-of resp))

320 (versions (dict-ref result 'supportedVersions: #[])))

321 (assert-equal 200 (http-response-status resp))

322 (assert-true (> (array-length versions) 1))

323 ;; The modern revision must be offered first.

324 (assert-equal current-version (array-ref versions 0))

325 (assert-true (dict-ref result 'capabilities: #f)))))

326

327;; ============================================================

328;; Legacy era

329;; ============================================================

330

331(test-group "legacy initialize"

332 (test "initialize echoes a supported legacy version back"

333 ;; A client pinned to 2025-06-18 must hear 2025-06-18. Answering with a

334 ;; different version is what makes an older client hang up.

335 (let* ((body (json-encode

336 `((jsonrpc . "2.0") (id . 1) (method . "initialize")

337 (params . ((protocolVersion . "2025-06-18"))))))

338 (resp (respond (post (dict) body)))

339 (result (result-of resp)))

340 (assert-equal 200 (http-response-status resp))

341 (assert-equal "2025-06-18" (dict-ref result 'protocolVersion: #f))))

342

343 (test "initialize needs no modern headers or _meta at all"

344 ;; The whole point of dual-era: a legacy client cannot be expected to

345 ;; send an envelope defined after it shipped.

346 (let* ((body (json-encode

347 `((jsonrpc . "2.0") (id . 1) (method . "initialize")

348 (params . ((protocolVersion . "2025-11-25"))))))

349 (resp (respond (post (dict) body))))

350 (assert-equal 200 (http-response-status resp))))

351

352 (test "an unknown requested version gets our newest LEGACY version"

353 ;; Never the modern one: 2026-07-28 has no initialize handshake, so a

354 ;; client that just sent one could not speak it.

355 (let* ((body (json-encode

356 `((jsonrpc . "2.0") (id . 1) (method . "initialize")

357 (params . ((protocolVersion . "1999-01-01"))))))

358 (resp (respond (post (dict) body)))

359 (answered (dict-ref (result-of resp) 'protocolVersion: #f)))

360 (assert-equal "2025-11-25" answered)

361 (assert-false (equal? current-version answered))))

362

363 (test "negotiation never answers with the modern version"

364 (assert-false (equal? mcp-current-version

365 (mcp-negotiate-legacy-version "2026-07-28")))

366 (assert-false (equal? mcp-current-version

367 (mcp-negotiate-legacy-version #f)))

368 (assert-equal "2025-06-18" (mcp-negotiate-legacy-version "2025-06-18"))))

369

370;; ============================================================

371;; Notifications

372;; ============================================================

373

374(test-group "notifications"

375 (test "a notification is accepted with 202 and an empty body"

376 (let* ((body (json-encode

377 `((jsonrpc . "2.0") (method . "notifications/initialized"))))

378 (resp (respond (post (dict) body))))

379 (assert-equal 202 (http-response-status resp))

380 (assert-equal "" (http-response-body resp)))))

381

382(run-tests)