test/test-server.sgl

1(import (sigil test)

2 (sigil mcp server)

3 (sigil mcp protocol)

4 (sigil json)

5 (sigil string)

6 (sigil io)

7 (sigil log)

8 (sigil async))

10;; ============================================================

11;; Server creation

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

14(test-group "server creation"

15 (test "mcp-server creates a server"

16 (let ((s (mcp-server)))

17 (assert-true (mcp-server? s))))

19 (test "mcp-server with custom name and version"

20 (let ((s (mcp-server name: "test-server" version: "1.0.0")))

21 (assert-true (mcp-server? s))))

23 (test "mcp-server? returns false for non-server"

24 (assert-false (mcp-server? 42))

25 (assert-false (mcp-server? "hello"))))

27;; ============================================================

28;; Tool registration

29;; ============================================================

31(test-group "tool registration"

32 (test "register-tool adds tool to server"

33 (let ((s (mcp-server)))

34 (mcp-server-register-tool! s "test-tool" "A test tool"

35 '((type . "object")) (lambda (args) "ok"))

36 (let* ((msg (jsonrpc-request id: 1 method: "tools/list" params: (dict)))

37 (resp (mcp-server-handle-message s msg))

38 (result (jsonrpc-response-result resp))

39 (tools (assoc-ref 'tools result)))

40 (assert-equal 1 (length tools))

41 (assert-equal "test-tool" (assoc-ref 'name (car tools))))))

43 (test "multiple tools accumulate"

44 (let ((s (mcp-server)))

45 (mcp-server-register-tool! s "tool-a" "First" '() (lambda (a) "a"))

46 (mcp-server-register-tool! s "tool-b" "Second" '() (lambda (a) "b"))

47 (let* ((msg (jsonrpc-request id: 1 method: "tools/list" params: (dict)))

48 (resp (mcp-server-handle-message s msg))

49 (result (jsonrpc-response-result resp))

50 (tools (assoc-ref 'tools result)))

51 (assert-equal 2 (length tools))))))

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

54;; Resource registration

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

57(test-group "resource registration"

58 (test "register-resource adds resource"

59 (let ((s (mcp-server)))

60 (mcp-server-register-resource! s "test://doc" "Test Doc"

61 "A test document" (lambda (uri) "content"))

62 (let* ((msg (jsonrpc-request id: 1 method: "resources/list" params: (dict)))

63 (resp (mcp-server-handle-message s msg))

64 (result (jsonrpc-response-result resp))

65 (resources (assoc-ref 'resources result)))

66 (assert-equal 1 (length resources))

67 (assert-equal "test://doc" (assoc-ref 'uri (car resources)))))))

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

70;; Prompt registration

71;; ============================================================

73(test-group "prompt registration"

74 (test "register-prompt adds prompt"

75 (let ((s (mcp-server)))

76 (mcp-server-register-prompt! s "test-prompt" "A test prompt"

77 '() (lambda (args) '()))

78 (let* ((msg (jsonrpc-request id: 1 method: "prompts/list" params: (dict)))

79 (resp (mcp-server-handle-message s msg))

80 (result (jsonrpc-response-result resp))

81 (prompts (assoc-ref 'prompts result)))

82 (assert-equal 1 (length prompts))

83 (assert-equal "test-prompt" (assoc-ref 'name (car prompts)))))))

85;; ============================================================

86;; Initialize

87;; ============================================================

89(test-group "initialize"

90 (test "initialize returns capabilities"

91 (let* ((s (mcp-server name: "test" version: "1.0"))

92 (msg (jsonrpc-request id: 1 method: "initialize" params: (dict)))

93 (resp (mcp-server-handle-message s msg))

94 (result (jsonrpc-response-result resp)))

95 (assert-true (jsonrpc-response? resp))

96 (assert-equal 1 (jsonrpc-response-id resp))

97 ;; A client that names no version gets our newest legacy revision.

98 (assert-equal "2025-11-25" (assoc-ref 'protocolVersion result))

99 (let ((info (assoc-ref 'serverInfo result)))

100 (assert-equal "test" (assoc-ref 'name info))

101 (assert-equal "1.0" (assoc-ref 'version info)))))

102

103 ;; These cover the STDIO path specifically. Existing consumers -- courier,

104 ;; folio, apiary -- all speak stdio with a legacy handshake, so a

105 ;; regression here breaks them silently at connect time rather than

106 ;; anywhere a test would obviously look.

107

108 (test "a legacy client's requested version is echoed back"

109 ;; Answering with a fixed version regardless of the request is what

110 ;; makes a pinned client disconnect: it receives a version string it

111 ;; does not know and hangs up.

112 (let* ((s (mcp-server name: "test" version: "1.0"))

113 (msg (jsonrpc-request id: 1 method: "initialize"

114 params: (dict protocolVersion: "2025-06-18")))

115 (result (jsonrpc-response-result (mcp-server-handle-message s msg))))

116 (assert-equal "2025-06-18" (assoc-ref 'protocolVersion result))))

117

118 (test "each supported legacy revision is echoed, not normalised"

119 (let ((s (mcp-server name: "test" version: "1.0")))

120 (for-each

121 (lambda (v)

122 (let* ((msg (jsonrpc-request id: 1 method: "initialize"

123 params: (dict protocolVersion: v)))

124 (result (jsonrpc-response-result

125 (mcp-server-handle-message s msg))))

126 (assert-equal v (assoc-ref 'protocolVersion result))))

127 (list "2025-11-25" "2025-06-18" "2025-03-26" "2024-11-05"))))

128

129 (test "an unknown requested version gets a LEGACY counter-offer"

130 ;; Never the modern revision: it has no initialize handshake at all, so

131 ;; a client that just sent one could not speak it.

132 (let* ((s (mcp-server name: "test" version: "1.0"))

133 (msg (jsonrpc-request id: 1 method: "initialize"

134 params: (dict protocolVersion: "1999-01-01")))

135 (result (jsonrpc-response-result (mcp-server-handle-message s msg)))

136 (answered (assoc-ref 'protocolVersion result)))

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

138 (assert-false (equal? mcp-current-version answered))))

139

140 (test "the full stdio loop answers a legacy handshake"

141 ;; Drives mcp-server-run over a real string port pair, the way a stdio

142 ;; consumer does, rather than calling the dispatcher directly.

143 (let* ((s (mcp-server name: "test" version: "1.0"))

144 (input (open-input-string

145 (string-append

146 (json-encode

147 (dict jsonrpc: "2.0" id: 1 method: "initialize"

148 params: (dict protocolVersion: "2025-06-18")))

149 "\n")))

150 (output (open-output-string)))

151 (parameterize ((current-input-port input)

152 (current-output-port output))

153 (mcp-server-run s load-env?: #f))

154 (let* ((line (car (filter (lambda (l) (not (string-empty? l)))

155 (string-split (get-output-string output) "\n"))))

156 (resp (json-decode line))

157 (result (dict-ref resp result:)))

158 (assert-equal "2025-06-18" (dict-ref result protocolVersion:))

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

160

161;; ============================================================

162;; Ping

163;; ============================================================

164

165(test-group "ping"

166 (test "ping returns empty response"

167 (let* ((s (mcp-server))

168 (msg (jsonrpc-request id: 42 method: "ping" params: (dict)))

169 (resp (mcp-server-handle-message s msg)))

170 (assert-true (jsonrpc-response? resp))

171 (assert-equal 42 (jsonrpc-response-id resp)))))

172

173;; ============================================================

174;; tools/call

175;; ============================================================

176

177(test-group "tools/call"

178 (test "call valid tool returns result"

179 (let ((s (mcp-server)))

180 (mcp-server-register-tool! s "echo" "Echo tool"

181 '((type . "object"))

182 (lambda (args) (dict-ref args message:)))

183 (let* ((msg (jsonrpc-request id: 1 method: "tools/call"

184 params: (dict name: "echo"

185 arguments: (dict message: "hello"))))

186 (resp (mcp-server-handle-message s msg))

187 (result (jsonrpc-response-result resp))

188 (content (assoc-ref 'content result)))

189 (assert-true (jsonrpc-response? resp))

190 (assert-equal "hello" (assoc-ref 'text (car content))))))

191

192 (test "call unknown tool returns error"

193 (let* ((s (mcp-server))

194 (msg (jsonrpc-request id: 1 method: "tools/call"

195 params: (dict name: "nonexistent")))

196 (resp (mcp-server-handle-message s msg)))

197 (assert-true (jsonrpc-error-response? resp))

198 (assert-equal error-method-not-found (jsonrpc-error-response-code resp))))

199

200 (test "tool handler exception returns error response"

201 (let ((s (mcp-server)))

202 (mcp-server-register-tool! s "fail" "Failing tool" '()

203 (lambda (args) (error "intentional failure")))

204 (let* ((msg (jsonrpc-request id: 1 method: "tools/call"

205 params: (dict name: "fail")))

206 (resp (mcp-server-handle-message s msg)))

207 (assert-true (jsonrpc-error-response? resp))

208 (assert-equal error-internal (jsonrpc-error-response-code resp)))))

209

210 ;; Required-args validation: handler must NOT be called when a required

211 ;; field from inputSchema.required is absent. Without this validation,

212 ;; handlers using `(dict-ref args X:)` (no default) raise "dict-ref: key

213 ;; not found", which escapes as an opaque multi-frame stack trace. The

214 ;; validation surfaces a structured error-invalid-params instead.

215 (test "missing required arg returns invalid-params (not handler call)"

216 (let ((s (mcp-server))

217 (handler-called #f))

218 (mcp-server-register-tool! s "needs-org" "Tool requiring org"

219 '((type . "object")

220 (properties . ((org . ((type . "string")))))

221 (required . ("org")))

222 (lambda (args)

223 (set! handler-called #t)

224 (dict-ref args org:)))

225 (let* ((msg (jsonrpc-request id: 1 method: "tools/call"

226 params: (dict name: "needs-org" arguments: (dict))))

227 (resp (mcp-server-handle-message s msg)))

228 (assert-true (jsonrpc-error-response? resp))

229 (assert-equal error-invalid-params (jsonrpc-error-response-code resp))

230 (assert-false handler-called))))

231

232 (test "multiple missing required args listed in error"

233 (let ((s (mcp-server)))

234 (mcp-server-register-tool! s "needs-two" "Tool requiring owner + repo"

235 '((type . "object")

236 (properties . ((owner . ((type . "string")))

237 (repo . ((type . "string")))))

238 (required . ("owner" "repo")))

239 (lambda (args) "should not reach"))

240 (let* ((msg (jsonrpc-request id: 1 method: "tools/call"

241 params: (dict name: "needs-two" arguments: (dict))))

242 (resp (mcp-server-handle-message s msg))

243 (err-msg (jsonrpc-error-response-message resp)))

244 (assert-true (jsonrpc-error-response? resp))

245 (assert-equal error-invalid-params (jsonrpc-error-response-code resp))

246 (assert-true (string-contains? err-msg "owner"))

247 (assert-true (string-contains? err-msg "repo")))))

248

249 (test "required args all present dispatches normally"

250 (let ((s (mcp-server)))

251 (mcp-server-register-tool! s "needs-org" "Tool requiring org"

252 '((type . "object")

253 (properties . ((org . ((type . "string")))))

254 (required . ("org")))

255 (lambda (args)

256 (string-append "org=" (dict-ref args org:))))

257 (let* ((msg (jsonrpc-request id: 1 method: "tools/call"

258 params: (dict name: "needs-org"

259 arguments: (dict org: "sigil"))))

260 (resp (mcp-server-handle-message s msg))

261 (result (jsonrpc-response-result resp))

262 (content (assoc-ref 'content result)))

263 (assert-true (jsonrpc-response? resp))

264 (assert-equal "org=sigil" (assoc-ref 'text (car content))))))

265

266 (test "schema with no required field skips validation"

267 (let ((s (mcp-server)))

268 (mcp-server-register-tool! s "anything-goes" "Tool with no required args"

269 '((type . "object")

270 (properties . ((opt . ((type . "string"))))))

271 (lambda (args) "ok"))

272 (let* ((msg (jsonrpc-request id: 1 method: "tools/call"

273 params: (dict name: "anything-goes" arguments: (dict))))

274 (resp (mcp-server-handle-message s msg))

275 (result (jsonrpc-response-result resp))

276 (content (assoc-ref 'content result)))

277 (assert-true (jsonrpc-response? resp))

278 (assert-equal "ok" (assoc-ref 'text (car content)))))))

279

280;; ============================================================

281;; tool-handler error isolation — dispatch loop must survive a raise

282;; ============================================================

283;;

284;; Regression for the "MCP dispatch continuation wedge": a tool handler

285;; that raises must return a clean JSON-RPC error AND leave the server

286;; loop alive to serve the NEXT request. The earlier workaround used a

287;; call/cc escape from inside a with-exception-handler to dodge a Sigil

288;; VM bug (exception propagation through map's CPS frames corrupting

289;; call-with-prompt's return context). On the buggy VM that escape jumped

290;; past the dispatch loop's continuation, so the loop never resumed and

291;; the next request got "Connection closed". The VM bug was fixed in

292;; sigil v0.16.0 (the guard-raise-escape / abort-propagation fix), so

293;; handle-tools-call now uses a plain `guard` like every other handler.

294;;

295;; These tests drive the full mcp-server-run loop: a raising tools/call

296;; followed by a second request, asserting BOTH get well-formed responses.

297;; The async variant runs inside with-async/go with logging enabled,

298;; reproducing the production context (scheduler prompt + async logging

299;; path live on the stack) where the wedge originally manifested.

300

301(define (drive-loop server input-string)

302 ;; Run mcp-server-run over a string input, returning the non-empty

303 ;; response lines written to stdout.

304 (let ((input (open-input-string input-string))

305 (output (open-output-string)))

306 (parameterize ((current-input-port input)

307 (current-output-port output))

308 (mcp-server-run server load-env?: #f))

309 (filter (lambda (l) (not (string-empty? l)))

310 (string-split (get-output-string output) "\n"))))

311

312(define (raise+follow-up-input)

313 (string-append

314 (json-encode (dict jsonrpc: "2.0" id: 1 method: "tools/call"

315 params: (dict name: "boom" arguments: (dict))))

316 "\n"

317 (json-encode (dict jsonrpc: "2.0" id: 2 method: "ping" params: (dict)))

318 "\n"))

319

320(test-group "tool-handler error isolation"

321 (test "raising tool/call returns error AND loop serves next request"

322 (let ((s (mcp-server name: "test" version: "1.0")))

323 (mcp-server-register-tool! s "boom" "Always fails" '()

324 (lambda (args) (error "intentional boom")))

325 (let ((lines (drive-loop s (raise+follow-up-input))))

326 ;; Both requests answered: loop survived the raise.

327 (assert-equal 2 (length lines))

328 (let ((resp1 (json-decode (car lines)))

329 (resp2 (json-decode (cadr lines))))

330 ;; First: well-formed JSON-RPC error for the raising call.

331 (assert-equal 1 (dict-ref resp1 id:))

332 (assert-true (dict-ref resp1 error: #f))

333 (assert-equal error-internal

334 (dict-ref (dict-ref resp1 error:) code:))

335 ;; Second: the follow-up ping succeeded (no "Connection closed").

336 (assert-equal 2 (dict-ref resp2 id:))

337 (assert-false (dict-ref resp2 error: #f))))))

338

339 (test "loop survives a raising tool/call inside with-async/go"

340 ;; Faithful to production: mcp-server-run runs in a goroutine and

341 ;; logging routes through the async await-port-writable path. Logs

342 ;; go to a sink port so they don't pollute test output.

343 (let ((s (mcp-server name: "test" version: "1.0"))

344 (log-sink (open-output-string))

345 (input (open-input-string (raise+follow-up-input)))

346 (output (open-output-string)))

347 (mcp-server-register-tool! s "boom" "Always fails" '()

348 (lambda (args) (error "intentional boom")))

349 (log-configure! level: 'debug target: log-sink)

350 (parameterize ((current-input-port input)

351 (current-output-port output))

352 (with-async

353 (go (mcp-server-run s load-env?: #f))))

354 (log-configure! level: 'warn target: 'console)

355 (let ((lines (filter (lambda (l) (not (string-empty? l)))

356 (string-split (get-output-string output) "\n"))))

357 (assert-equal 2 (length lines))

358 (let ((resp1 (json-decode (car lines)))

359 (resp2 (json-decode (cadr lines))))

360 (assert-true (dict-ref resp1 error: #f))

361 (assert-equal 2 (dict-ref resp2 id:))

362 (assert-false (dict-ref resp2 error: #f)))))))

363

364;; ============================================================

365;; resources/read

366;; ============================================================

367

368(test-group "resources/read"

369 (test "read valid resource returns content"

370 (let ((s (mcp-server)))

371 (mcp-server-register-resource! s "test://hello" "Hello"

372 "Hello resource" (lambda (uri) "Hello, world!"))

373 (let* ((msg (jsonrpc-request id: 1 method: "resources/read"

374 params: (dict uri: "test://hello")))

375 (resp (mcp-server-handle-message s msg))

376 (result (jsonrpc-response-result resp))

377 (contents (assoc-ref 'contents result)))

378 (assert-true (jsonrpc-response? resp))

379 (assert-equal "Hello, world!" (assoc-ref 'text (car contents)))

380 (assert-equal "test://hello" (assoc-ref 'uri (car contents))))))

381

382 (test "read with wildcard match"

383 (let ((s (mcp-server)))

384 (mcp-server-register-resource! s "docs://pages/*" "Pages"

385 "Doc pages" (lambda (uri) (string-append "Page: " uri)))

386 (let* ((msg (jsonrpc-request id: 1 method: "resources/read"

387 params: (dict uri: "docs://pages/intro")))

388 (resp (mcp-server-handle-message s msg))

389 (result (jsonrpc-response-result resp))

390 (contents (assoc-ref 'contents result)))

391 (assert-true (jsonrpc-response? resp))

392 (assert-equal "Page: docs://pages/intro"

393 (assoc-ref 'text (car contents))))))

394

395 (test "read unknown resource returns error"

396 (let* ((s (mcp-server))

397 (msg (jsonrpc-request id: 1 method: "resources/read"

398 params: (dict uri: "test://missing")))

399 (resp (mcp-server-handle-message s msg)))

400 (assert-true (jsonrpc-error-response? resp))

401 (assert-equal error-invalid-params (jsonrpc-error-response-code resp))))

402

403 (test "resource handler exception returns error"

404 (let ((s (mcp-server)))

405 (mcp-server-register-resource! s "test://boom" "Boom"

406 "Failing resource" (lambda (uri) (error "resource failed")))

407 (let* ((msg (jsonrpc-request id: 1 method: "resources/read"

408 params: (dict uri: "test://boom")))

409 (resp (mcp-server-handle-message s msg)))

410 (assert-true (jsonrpc-error-response? resp))

411 (assert-equal error-internal (jsonrpc-error-response-code resp))))))

412

413;; ============================================================

414;; prompts/get

415;; ============================================================

416

417(test-group "prompts/get"

418 (test "get valid prompt calls handler"

419 (let ((s (mcp-server)))

420 (mcp-server-register-prompt! s "greet" "Greeting prompt"

421 '(((name . "name") (description . "Name to greet") (required . #t)))

422 (lambda (args)

423 `(((role . "user")

424 (content . ((text . ,(string-append "Hello, "

425 (dict-ref args name: "world")))))))))

426 (let* ((msg (jsonrpc-request id: 1 method: "prompts/get"

427 params: (dict name: "greet"

428 arguments: (dict name: "Alice"))))

429 (resp (mcp-server-handle-message s msg))

430 (result (jsonrpc-response-result resp))

431 (messages (assoc-ref 'messages result)))

432 (assert-true (jsonrpc-response? resp))

433 (assert-equal 1 (length messages)))))

434

435 (test "get unknown prompt returns error"

436 (let* ((s (mcp-server))

437 (msg (jsonrpc-request id: 1 method: "prompts/get"

438 params: (dict name: "nonexistent")))

439 (resp (mcp-server-handle-message s msg)))

440 (assert-true (jsonrpc-error-response? resp))

441 (assert-equal error-method-not-found (jsonrpc-error-response-code resp))))

442

443 (test "prompt handler exception returns error"

444 (let ((s (mcp-server)))

445 (mcp-server-register-prompt! s "fail" "Failing prompt" '()

446 (lambda (args) (error "prompt error")))

447 (let* ((msg (jsonrpc-request id: 1 method: "prompts/get"

448 params: (dict name: "fail")))

449 (resp (mcp-server-handle-message s msg)))

450 (assert-true (jsonrpc-error-response? resp))

451 (assert-equal error-internal (jsonrpc-error-response-code resp))))))

452

453;; ============================================================

454;; Unknown method

455;; ============================================================

456

457(test-group "unknown method"

458 (test "unknown method returns error-method-not-found"

459 (let* ((s (mcp-server))

460 (msg (jsonrpc-request id: 1 method: "nonexistent/method" params: (dict)))

461 (resp (mcp-server-handle-message s msg)))

462 (assert-true (jsonrpc-error-response? resp))

463 (assert-equal error-method-not-found (jsonrpc-error-response-code resp)))))

464

465;; ============================================================

466;; Notifications

467;; ============================================================

468

469(test-group "notifications"

470 (test "initialized notification returns #f"

471 (let* ((s (mcp-server))

472 (msg (jsonrpc-notification method: "initialized" params: (dict)))

473 (resp (mcp-server-handle-message s msg)))

474 (assert-false resp)))

475

476 (test "cancelled notification returns #f"

477 (let* ((s (mcp-server))

478 (msg (jsonrpc-notification method: "notifications/cancelled" params: (dict)))

479 (resp (mcp-server-handle-message s msg)))

480 (assert-false resp))))

481

482;; ============================================================

483;; Invalid messages

484;; ============================================================

485

486(test-group "invalid messages"

487 (test "non-request non-notification returns error"

488 (let* ((s (mcp-server))

489 (resp (mcp-server-handle-message s "not a message")))

490 (assert-true (jsonrpc-error-response? resp))

491 (assert-equal error-invalid-request (jsonrpc-error-response-code resp)))))

492

493;; ============================================================

494;; Custom capabilities

495;; ============================================================

496

497(test-group "custom capabilities"

498 (test "initialize includes custom capabilities merged with defaults"

499 (let* ((s (mcp-server name: "test" version: "1.0"

500 capabilities: '((experimental . ((claude/channel . ()))))))

501 (msg (jsonrpc-request id: 1 method: "initialize" params: (dict)))

502 (resp (mcp-server-handle-message s msg))

503 (result (jsonrpc-response-result resp))

504 (caps (assoc-ref 'capabilities result)))

505 ;; Custom capability present

506 (assert-true (assoc 'experimental caps))

507 ;; Default capabilities still present

508 (assert-true (assoc 'tools caps))

509 ;; resources and prompts omitted when none registered

510 (assert-false (assoc 'resources caps))

511 (assert-false (assoc 'prompts caps))))

512

513 (test "custom capabilities override defaults"

514 (let* ((s (mcp-server name: "test" version: "1.0"

515 capabilities: '((tools . ((listChanged . #t))))))

516 (msg (jsonrpc-request id: 1 method: "initialize" params: (dict)))

517 (resp (mcp-server-handle-message s msg))

518 (result (jsonrpc-response-result resp))

519 (caps (assoc-ref 'capabilities result))

520 (tools (assoc-ref 'tools caps)))

521 ;; Custom value used instead of default

522 (assert-equal #t (assoc-ref 'listChanged tools))))

523

524 (test "no custom capabilities uses defaults"

525 (let* ((s (mcp-server name: "test" version: "1.0"))

526 (msg (jsonrpc-request id: 1 method: "initialize" params: (dict)))

527 (resp (mcp-server-handle-message s msg))

528 (result (jsonrpc-response-result resp))

529 (caps (assoc-ref 'capabilities result)))

530 (assert-true (assoc 'tools caps))

531 ;; resources and prompts omitted when none registered

532 (assert-false (assoc 'resources caps))

533 (assert-false (assoc 'prompts caps))

534 (assert-false (assoc 'experimental caps))))

535

536 (test "resources capability advertised when resources registered"

537 (let* ((s (mcp-server name: "test" version: "1.0")))

538 (mcp-server-register-resource! s "test://doc" "doc" "A test resource"

539 (lambda (uri) "content"))

540 (let* ((msg (jsonrpc-request id: 1 method: "initialize" params: (dict)))

541 (resp (mcp-server-handle-message s msg))

542 (result (jsonrpc-response-result resp))

543 (caps (assoc-ref 'capabilities result)))

544 (assert-true (assoc 'resources caps))

545 (assert-false (assoc 'prompts caps)))))

546

547 (test "prompts capability advertised when prompts registered"

548 (let* ((s (mcp-server name: "test" version: "1.0")))

549 (mcp-server-register-prompt! s "greet" "A greeting prompt" '()

550 (lambda (args) "Hello!"))

551 (let* ((msg (jsonrpc-request id: 1 method: "initialize" params: (dict)))

552 (resp (mcp-server-handle-message s msg))

553 (result (jsonrpc-response-result resp))

554 (caps (assoc-ref 'capabilities result)))

555 (assert-false (assoc 'resources caps))

556 (assert-true (assoc 'prompts caps))))))

557

558;; ============================================================

559;; Instructions

560;; ============================================================

561

562(test-group "instructions"

563 (test "initialize includes instructions when set"

564 (let* ((s (mcp-server name: "test" version: "1.0"

565 instructions: "Reply with the reply tool."))

566 (msg (jsonrpc-request id: 1 method: "initialize" params: (dict)))

567 (resp (mcp-server-handle-message s msg))

568 (result (jsonrpc-response-result resp)))

569 (assert-equal "Reply with the reply tool."

570 (assoc-ref 'instructions result))))

571

572 (test "initialize omits instructions when not set"

573 (let* ((s (mcp-server name: "test" version: "1.0"))

574 (msg (jsonrpc-request id: 1 method: "initialize" params: (dict)))

575 (resp (mcp-server-handle-message s msg))

576 (result (jsonrpc-response-result resp)))

577 (assert-false (assoc-ref 'instructions result #f)))))

578

579;; ============================================================

580;; Server-initiated notifications

581;; ============================================================

582

583(test-group "server notify"

584 (test "mcp-server-notify! writes JSON-RPC notification to output"

585 (let* ((s (mcp-server name: "test" version: "1.0"))

586 (port (open-output-string)))

587 (parameterize ((current-output-port port))

588 (mcp-server-notify! s "notifications/claude/channel"

589 params: '((content . "hello from telegram")

590 (meta . ((sender . "david"))))))

591 (let* ((output (get-output-string port))

592 (parsed (json-decode output)))

593 (assert-equal "2.0" (dict-ref parsed jsonrpc:))

594 (assert-equal "notifications/claude/channel" (dict-ref parsed method:))

595 (let ((params (dict-ref parsed params:)))

596 (assert-equal "hello from telegram" (dict-ref params content:))

597 (assert-equal "david" (dict-ref (dict-ref params meta:) sender:))))))

598

599 (test "mcp-server-notify! without params"

600 (let* ((s (mcp-server name: "test" version: "1.0"))

601 (port (open-output-string)))

602 (parameterize ((current-output-port port))

603 (mcp-server-notify! s "notifications/test"))

604 (let* ((output (get-output-string port))

605 (parsed (json-decode output)))

606 (assert-equal "2.0" (dict-ref parsed jsonrpc:))

607 (assert-equal "notifications/test" (dict-ref parsed method:))

608 (assert-false (dict-ref parsed params: #f))))))

609

610;; ============================================================

611;; Server loop (mcp-server-run)

612;; ============================================================

613

614(test-group "server loop"

615 (test "processes messages from input port"

616 (let* ((init-msg (string-append

617 (json-encode (dict jsonrpc: "2.0" id: 1

618 method: "initialize" params: (dict)))

619 "\n"))

620 (ping-msg (string-append

621 (json-encode (dict jsonrpc: "2.0" id: 2

622 method: "ping" params: (dict)))

623 "\n"))

624 (input (open-input-string (string-append init-msg ping-msg)))

625 (output (open-output-string))

626 (s (mcp-server name: "test" version: "1.0")))

627 (parameterize ((current-input-port input)

628 (current-output-port output))

629 (mcp-server-run s load-env?: #f))

630 (let* ((lines (filter (lambda (l) (not (string-empty? l)))

631 (string-split (get-output-string output) "\n")))

632 (resp1 (json-decode (car lines)))

633 (resp2 (json-decode (cadr lines))))

634 (assert-equal 1 (dict-ref resp1 id:))

635 (assert-equal 2 (dict-ref resp2 id:)))))

636

637 (test "exits cleanly on EOF"

638 (let* ((input (open-input-string ""))

639 (output (open-output-string))

640 (s (mcp-server name: "test" version: "1.0")))

641 (parameterize ((current-input-port input)

642 (current-output-port output))

643 (mcp-server-run s load-env?: #f))

644 ;; Should reach here without error

645 (assert-true #t)))

646

647 (test "survives bad JSON input"

648 (let* ((bad-msg "not valid json\n")

649 (ping-msg (string-append

650 (json-encode (dict jsonrpc: "2.0" id: 1

651 method: "ping" params: (dict)))

652 "\n"))

653 (input (open-input-string (string-append bad-msg ping-msg)))

654 (output (open-output-string))

655 (s (mcp-server name: "test" version: "1.0")))

656 (parameterize ((current-input-port input)

657 (current-output-port output))

658 (mcp-server-run s load-env?: #f))

659 (let* ((lines (filter (lambda (l) (not (string-empty? l)))

660 (string-split (get-output-string output) "\n")))

661 ;; First response should be a parse error

662 (resp1 (json-decode (car lines)))

663 ;; Second response should be the ping reply

664 (resp2 (json-decode (cadr lines))))

665 (assert-true (dict-ref resp1 error: #f))

666 (assert-equal 1 (dict-ref resp2 id:)))))

667

668 (test "skips empty lines"

669 (let* ((ping-msg (string-append

670 (json-encode (dict jsonrpc: "2.0" id: 1

671 method: "ping" params: (dict)))

672 "\n"))

673 (input (open-input-string (string-append "\n\n" ping-msg "\n")))

674 (output (open-output-string))

675 (s (mcp-server name: "test" version: "1.0")))

676 (parameterize ((current-input-port input)

677 (current-output-port output))

678 (mcp-server-run s load-env?: #f))

679 (let* ((lines (filter (lambda (l) (not (string-empty? l)))

680 (string-split (get-output-string output) "\n"))))

681 (assert-equal 1 (length lines))

682 (assert-equal 1 (dict-ref (json-decode (car lines)) id:))))))

683

684(run-tests)