Commitf4c8765bRecorded3 Sep 2026Repositorysigil-mcp

feat(http): add stateless dual-era Streamable HTTP transport

Message

Adds mcp-server-run-http beside the existing stdio loop. The transport targets protocol revision 2026-07-28 -- per-request _meta, no sessions, no Mcp-Session-Id -- while still answering a legacy initialize handshake so clients that have not migrated keep working.

Dispatch was already factored out of the read loop, so both transports share mcp-server-handle-message and cannot drift apart.

  • Origin is validated against the whole host, not a substring, and an absent Origin is allowed (non-browser clients send none).
  • MCP-Protocol-Version, Mcp-Method and Mcp-Name must agree with the body. The headers exist so a proxy can route without parsing JSON, which only holds while the two agree.
  • An unimplemented METHOD answers 404; an unknown TOOL answers 200 with an error. Both reach the transport as -32601, so the method name is checked against an explicit list before dispatch rather than inferred from the response.
  • Results carry resultType and _meta.serverInfo; listings also carry ttlMs/cacheScope. Tool output is deliberately not cacheable.

Two fixes fall out of this and apply to stdio as well:

  • initialize now answers with the version the client asked for when it is supported, instead of a hardcoded one. A client pinned to an older revision was being handed a version string it did not know.
  • server/discover is implemented, and reports supported versions, capabilities and identity.

The sigil: floor moves from the grandfathered caret ^0.19 to a bare "0.21", matching the estate convention that the field is a floor rather than a range.

sigil-http reaches native code through sigil-tls, so sigil test now requires an explicit test harness; sigil-test and sigil-test-runner are added as dev-dependencies.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com> Claude-Session: https://claude.ai/code/session_01HgY55w6F7XJf643tYHhwLn

Changed
 package.sgl                |  14 +++++-
 sigil.lock                 |  44 +++++++++++++++++--
 src/sigil/mcp/http.sgl     | 391 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/sigil/mcp/protocol.sgl |  65 ++++++++++++++++++++++++++++
 src/sigil/mcp/server.sgl   |  40 +++++++++++++++--
 test/test-http.sgl         | 364 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 6 files changed, 909 insertions(+), 9 deletions(-)
Diff
package.sglmodified
@@ -8,7 +8,7 @@
8
(package
9
name: "sigil-mcp"
10
version: "0.17.5"
−11
sigil: "^0.19"
+11
sigil: "0.21"
12
description: "Library for building MCP clients and servers in Sigil"
13
url: "https://codeberg.org/sigil/sigil-mcp"
14
license: "BSD-3-Clause"
@@ -17,4 +17,14 @@
17
dependencies: (list
18
(from-git url: "codeberg:sigil/sigil-json" version: "^0.16")
19
(from-git url: "codeberg:sigil/sigil-log" version: "^0.16")
−20
(from-git url: "codeberg:sigil/sigil-nrepl" version: "^0.17.1")))
+20
(from-git url: "codeberg:sigil/sigil-http" version: "^0.18.5")
+21
(from-git url: "codeberg:sigil/sigil-nrepl" version: "^0.17.1"))
+22
+23
;; sigil-http reaches native code through sigil-tls, and `sigil test`
+24
;; requires an explicit test harness for any package whose graph contains
+25
;; native code. These are test-only and do not reach consumers.
+26
dev-dependencies: (list
+27
(from-git url: "codeberg:sigil/sigil"
+28
package: "sigil-test" version: ">=0.21")
+29
(from-git url: "codeberg:sigil/sigil"
+30
package: "sigil-test-runner" version: ">=0.21")))
sigil.lockmodified
@@ -2,10 +2,22 @@
2
(lock
3
(package name: "sigil-stdlib"
4
url: "codeberg:sigil/sigil"
−5
ref: "^0.19"
−6
sha: "b99b8f2dd82e7ff7465c3d49a1f81250f2d00007"
+5
ref: ">=0.21, <1.0"
+6
sha: "8643e9abf19038c5f4961d41748427dbd623cb15"
7
package-selector: "sigil-stdlib"
−8
version: "0.19.0")
+8
version: "0.21.0")
+9
(package name: "sigil-test"
+10
url: "codeberg:sigil/sigil"
+11
ref: ">=0.21"
+12
sha: "8643e9abf19038c5f4961d41748427dbd623cb15"
+13
package-selector: "sigil-test"
+14
version: "0.21.0")
+15
(package name: "sigil-test-runner"
+16
url: "codeberg:sigil/sigil"
+17
ref: ">=0.21"
+18
sha: "8643e9abf19038c5f4961d41748427dbd623cb15"
+19
package-selector: "sigil-test-runner"
+20
version: "0.21.0")
21
(package name: "sigil-json"
22
url: "codeberg:sigil/sigil-json"
23
ref: "^0.16"
@@ -16,15 +28,41 @@
28
ref: "^0.16"
29
sha: "56e4fc5a52dc370c037ef14502bb8d6d2876dc53"
30
version: "0.16.0")
+31
(package name: "sigil-http"
+32
url: "codeberg:sigil/sigil-http"
+33
ref: "^0.18.5"
+34
sha: "0b4617ac000d6f3ed9f3d0906e6b746ad995ea03"
+35
version: "0.18.5")
36
(package name: "sigil-nrepl"
37
url: "codeberg:sigil/sigil-nrepl"
38
ref: "^0.17.1"
39
sha: "3d741f14b046ed7a3e39017a3a6d7229be4537a8"
40
version: "0.17.1")
+41
(package name: "sigil-crypto"
+42
url: "codeberg:sigil/sigil-crypto"
+43
ref: "^0.16.0"
+44
sha: "debba4462b7ff4de143db9e0792b8606fdc455bc"
+45
version: "0.16.5")
+46
(package name: "sigil-sqlite"
+47
url: "codeberg:sigil/sigil-sqlite"
+48
ref: "^0.16.0"
+49
sha: "569ef1063dda8f5989968644af31fc09c64b4bfe"
+50
version: "0.16.3")
+51
(package name: "sigil-tls"
+52
url: "codeberg:sigil/sigil-tls"
+53
ref: "^0.16.5"
+54
sha: "4cde885f8bbb15b1457b0293a5b9fa7d292cfc46"
+55
version: "0.16.6")
56
(package name: "sigil-repl"
57
url: "codeberg:sigil/sigil"
58
ref: "^0.19"
59
sha: "b99b8f2dd82e7ff7465c3d49a1f81250f2d00007"
60
package-selector: "sigil-repl"
61
version: "0.19.0")
+62
(package name: "sigil-lib"
+63
url: "codeberg:sigil/sigil"
+64
ref: "^0.19"
+65
sha: "8643e9abf19038c5f4961d41748427dbd623cb15"
+66
package-selector: "sigil-lib"
+67
version: "0.21.0")
68
)
src/sigil/mcp/http.sgladded
@@ -0,0 +1,391 @@
+1
;;; (sigil mcp http) - Streamable HTTP transport for MCP servers.
+2
;;;
+3
;;; Serves an MCP server over a single POST endpoint, stateless and
+4
;;; dual-era. It targets protocol revision 2026-07-28 — per-request `_meta`,
+5
;;; no sessions, no `Mcp-Session-Id` — while still answering the legacy
+6
;;; `initialize` handshake for clients that have not migrated.
+7
;;;
+8
;;; Stateless refers to MCP sessions only. The hosting application stays as
+9
;;; stateful as it likes; what this transport promises is that no request
+10
;;; depends on a previous one having arrived on the same connection.
+11
;;;
+12
;;; ```scheme
+13
;;; (import (sigil mcp) (sigil mcp http))
+14
;;;
+15
;;; (define server (mcp-server name: "example" version: "1.0.0"))
+16
;;; (mcp-server-register-tool! server "ping" "Reply with pong"
+17
;;; '((type . "object") (properties . ()))
+18
;;; (lambda (args) "pong"))
+19
;;; (mcp-server-run-http server port: 8765)
+20
;;; ```
+21
+22
(define-library (sigil mcp http)
+23
(import (sigil mcp protocol)
+24
(sigil mcp server)
+25
(sigil http request)
+26
(sigil http response)
+27
(sigil http server)
+28
(sigil json)
+29
(sigil dict)
+30
(sigil string)
+31
(sigil error)
+32
(sigil log))
+33
(export mcp-server-run-http
+34
mcp-http-handler
+35
mcp-http-origin-allowed?
+36
mcp-http-cacheable-method?)
+37
(begin
+38
+39
;; ============================================================
+40
;; Cacheability
+41
;; ============================================================
+42
+43
;; Results of these methods must carry `ttlMs` and `cacheScope`.
+44
;; Everything a tool returns is excluded: tool output is a computation,
+45
;; not a listing, and caching it would change behaviour.
+46
(define cacheable-methods
+47
(list "tools/list"
+48
"prompts/list"
+49
"resources/list"
+50
"resources/read"
+51
"resources/templates/list"
+52
"server/discover"))
+53
+54
;; Conservative default: one minute, and never cacheable by a shared
+55
;; intermediary. A server whose tool list is genuinely public can widen
+56
;; this, but guessing "public" on behalf of an application that exposes
+57
;; per-user tools would leak one client's surface to another.
+58
(define default-cache-ttl-ms 60000)
+59
(define default-cache-scope "private")
+60
+61
;;; Does a result for `method` have to carry cache metadata?
+62
(define (mcp-http-cacheable-method? method)
+63
(and (string? method)
+64
(if (member method cacheable-methods) #t #f)))
+65
+66
;; ============================================================
+67
;; Origin Validation
+68
;; ============================================================
+69
+70
;; Hosts a browser page may legitimately be served from when it is
+71
;; talking to a loopback MCP server. Anything else is treated as a
+72
;; DNS-rebinding attempt.
+73
(define loopback-hosts
+74
(list "127.0.0.1" "localhost" "[::1]" "::1"))
+75
+76
;; Reduce an Origin header to its host, dropping scheme and port.
+77
;; "http://127.0.0.1:8765" -> "127.0.0.1"
+78
(define (origin-host origin)
+79
(let* ((after-scheme (let ((parts (string-split origin "://")))
+80
(if (> (length parts) 1)
+81
(cadr parts)
+82
(car parts))))
+83
;; An IPv6 literal keeps its brackets, so only split on a
+84
;; colon that follows them.
+85
(host (if (string-starts-with? after-scheme "[")
+86
(let ((parts (string-split after-scheme "]")))
+87
(if (> (length parts) 1)
+88
(string-append (car parts) "]")
+89
after-scheme))
+90
(car (string-split after-scheme ":")))))
+91
(string-downcase host)))
+92
+93
;;; Is this `Origin` header value acceptable?
+94
;;;
+95
;;; An absent Origin (`#f`) is allowed: non-browser clients do not send
+96
;;; one, and the spec only requires rejecting an Origin that is present
+97
;;; and invalid. A present Origin must name a loopback host.
+98
(define (mcp-http-origin-allowed? origin)
+99
(cond
+100
((not origin) #t)
+101
((not (string? origin)) #f)
+102
((equal? origin "null") #f)
+103
(else (if (member (origin-host origin) loopback-hosts) #t #f))))
+104
+105
;; ============================================================
+106
;; Response Helpers
+107
;; ============================================================
+108
+109
;; `dict-ref` raises on a non-dict, and both `params` and a missing
+110
;; `_meta` degrade to '() or #f, so every optional lookup goes here.
+111
(define (safe-ref d key default)
+112
(if (dict? d) (dict-ref d key default) default))
+113
+114
(define (json-error-body id code message data)
+115
(error-response->json
+116
(if data
+117
(make-error-response id code message data)
+118
(make-error-response id code message))))
+119
+120
;; An error carried by an HTTP status other than 200. The body is a
+121
;; JSON-RPC error so a client that reads it learns which rule it broke;
+122
;; the status is what a client that does not read bodies acts on.
+123
(define (error-response status id code message . data)
+124
(http-response
+125
status: status
+126
headers: #{ content-type: "application/json" }
+127
body: (json-error-body id code message
+128
(if (null? data) #f (car data)))))
+129
+130
(define (server-info-meta server)
+131
(list (cons (string->symbol meta-server-info-key)
+132
`((name . ,(mcp-server-name server))
+133
(version . ,(mcp-server-version server))))))
+134
+135
;; Stamp a successful result with the envelope every modern result owes:
+136
;; `resultType`, `_meta.serverInfo`, and cache metadata for the methods
+137
;; that require it. Error responses pass through untouched — the spec
+138
;; puts none of this on an error.
+139
(define (augment-result server resp method)
+140
(if (jsonrpc-response? resp)
+141
(let* ((base (let ((r (jsonrpc-response-result resp)))
+142
(if (list? r) r '())))
+143
(cached (if (mcp-http-cacheable-method? method)
+144
(append `((ttlMs . ,default-cache-ttl-ms)
+145
(cacheScope . ,default-cache-scope))
+146
base)
+147
base)))
+148
(jsonrpc-response
+149
id: (jsonrpc-response-id resp)
+150
result: (append
+151
`((resultType . "complete")
+152
(_meta . ,(server-info-meta server)))
+153
cached)))
+154
resp))
+155
+156
;; ============================================================
+157
;; Request Validation
+158
;; ============================================================
+159
+160
;; Which era is this request in? A body naming `initialize` is legacy by
+161
;; definition — that method does not exist in the modern revision. Every
+162
;; other request is modern and must carry the `_meta` envelope.
+163
(define (legacy-initialize? method)
+164
(equal? method "initialize"))
+165
+166
;; Validate the header/body agreement the modern era requires. Returns #f
+167
;; when the request is well-formed, or an http-response describing the
+168
;; violation.
+169
;;
+170
;; The headers duplicate values already in the body so that proxies and
+171
;; gateways can route and authorise without parsing JSON. That only holds
+172
;; if the two actually agree, which is why a mismatch is an error rather
+173
;; than a preference for one source.
+174
(define (validate-headers req method id name-required)
+175
(let ((hdr-method (http-request-header req "Mcp-Method"))
+176
(hdr-name (http-request-header req "Mcp-Name")))
+177
(cond
+178
((not hdr-method)
+179
(error-response HTTP-BAD-REQUEST id error-header-mismatch
+180
"Missing required header: Mcp-Method"))
+181
((not (equal? hdr-method method))
+182
(error-response HTTP-BAD-REQUEST id error-header-mismatch
+183
(format "Mcp-Method header ~s does not match request method ~s"
+184
hdr-method method)))
+185
((and name-required (not hdr-name))
+186
(error-response HTTP-BAD-REQUEST id error-header-mismatch
+187
(format "Missing required header: Mcp-Name (required for ~a)"
+188
method)))
+189
((and name-required (not (equal? hdr-name name-required)))
+190
(error-response HTTP-BAD-REQUEST id error-header-mismatch
+191
(format "Mcp-Name header ~s does not match request target ~s"
+192
hdr-name name-required)))
+193
(else #f))))
+194
+195
;; The name a request's `Mcp-Name` header must carry, or #f when the
+196
;; method does not use one.
+197
(define (request-target-name method params)
+198
(cond
+199
((equal? method "tools/call") (safe-ref params name: #f))
+200
((equal? method "prompts/get") (safe-ref params name: #f))
+201
((equal? method "resources/read") (safe-ref params uri: #f))
+202
(else #f)))
+203
+204
;; Validate the modern `_meta` envelope and the protocol version, in both
+205
;; the body and the header. Returns #f when well-formed, else a response.
+206
(define (validate-modern-envelope req params id)
+207
(let* ((meta (safe-ref params '_meta: #f))
+208
(body-version (safe-ref meta
+209
(string->keyword meta-protocol-version-key)
+210
#f))
+211
(caps (safe-ref meta
+212
(string->keyword meta-client-capabilities-key)
+213
#f))
+214
(hdr-version (http-request-header req "MCP-Protocol-Version")))
+215
(cond
+216
((not body-version)
+217
(error-response HTTP-BAD-REQUEST id error-invalid-params
+218
(format "Missing required _meta field: ~a"
+219
meta-protocol-version-key)))
+220
((not caps)
+221
(error-response HTTP-BAD-REQUEST id error-invalid-params
+222
(format "Missing required _meta field: ~a"
+223
meta-client-capabilities-key)))
+224
((not (member body-version mcp-supported-versions))
+225
(error-response HTTP-BAD-REQUEST id error-unsupported-version
+226
"Unsupported protocol version"
+227
`((supported . ,mcp-supported-versions)
+228
(requested . ,body-version))))
+229
((not hdr-version)
+230
(error-response HTTP-BAD-REQUEST id error-header-mismatch
+231
"Missing required header: MCP-Protocol-Version"))
+232
((not (equal? hdr-version body-version))
+233
(error-response HTTP-BAD-REQUEST id error-header-mismatch
+234
(format "MCP-Protocol-Version header ~s does not match _meta ~s"
+235
hdr-version body-version)))
+236
(else #f))))
+237
+238
;; ============================================================
+239
;; Dispatch
+240
;; ============================================================
+241
+242
;; Methods this server does not implement answer 404, not 200-with-error:
+243
;; the spec makes "no such method" an HTTP-level fact so a client can tell
+244
;; it apart from a method that ran and failed.
+245
(define (method-not-found-response id method)
+246
(error-response HTTP-NOT-FOUND id error-method-not-found
+247
(format "Unknown method: ~a" method)))
+248
+249
;; The methods this server implements. An unknown METHOD is an HTTP-level
+250
;; 404; an unknown TOOL is a 200 carrying an error from a method that ran.
+251
;; Both arrive from the core dispatcher as -32601, so they cannot be told
+252
;; apart by inspecting the response — the method name has to be checked
+253
;; against this list BEFORE dispatching.
+254
(define implemented-methods
+255
(list "initialize"
+256
"server/discover"
+257
"tools/list"
+258
"tools/call"
+259
"resources/list"
+260
"resources/read"
+261
"resources/templates/list"
+262
"prompts/list"
+263
"prompts/get"
+264
;; Removed in 2026-07-28, retained for legacy clients.
+265
"ping"))
+266
+267
(define (implemented-method? method)
+268
(and (string? method)
+269
(if (member method implemented-methods) #t #f)))
+270
+271
(define (dispatch-message server msg method)
+272
(let ((resp (mcp-server-handle-message server msg)))
+273
(cond
+274
;; Notifications produce no response at all.
+275
((not resp)
+276
(http-response status: HTTP-ACCEPTED
+277
headers: #{ content-type: "application/json" }
+278
body: ""))
+279
((jsonrpc-error-response? resp)
+280
(http-response status: HTTP-OK
+281
headers: #{ content-type: "application/json" }
+282
body: (error-response->json resp)))
+283
(else
+284
(http-response
+285
status: HTTP-OK
+286
headers: #{ content-type: "application/json" }
+287
body: (response->json (augment-result server resp method)))))))
+288
+289
;; The method name of a request, or #f for anything else. Used to tell a
+290
;; dispatcher-level "unknown method" apart from an unknown TOOL, which is
+291
;; also reported as -32601 but is a 200 with an error, not a 404.
+292
(define (jsonrpc-request-method-safe msg)
+293
(if (jsonrpc-request? msg) (jsonrpc-request-method msg) #f))
+294
+295
;; ============================================================
+296
;; The Handler
+297
;; ============================================================
+298
+299
(define (handle-post server req)
+300
(let* ((body (http-request-body req))
+301
(msg (guard (e (else #f))
+302
(parse-message-string (if (string? body) body "")))))
+303
(if (not msg)
+304
(error-response HTTP-BAD-REQUEST #f error-parse "Parse error")
+305
(let* ((method (jsonrpc-request-method-safe msg))
+306
(id (if (jsonrpc-request? msg)
+307
(jsonrpc-request-id msg)
+308
#f))
+309
(params (if (jsonrpc-request? msg)
+310
(jsonrpc-request-params msg)
+311
#f)))
+312
(cond
+313
;; Legacy era: an `initialize` request opts this exchange out
+314
;; of the modern envelope entirely. Header and `_meta` rules
+315
;; do not apply, because the client predates them.
+316
((legacy-initialize? method)
+317
(let ((resp (mcp-server-handle-message server msg)))
+318
(http-response
+319
status: HTTP-OK
+320
headers: #{ content-type: "application/json" }
+321
body: (if (jsonrpc-error-response? resp)
+322
(error-response->json resp)
+323
(response->json resp)))))
+324
;; A legacy notification (`notifications/initialized`) carries
+325
;; no envelope either, and wants no response.
+326
((jsonrpc-notification? msg)
+327
(dispatch-message server msg method))
+328
;; Checked before the envelope: a client asking for a method
+329
;; we do not have gets the same 404 whether or not its headers
+330
;; were in order, and learns the endpoint exists.
+331
((not (implemented-method? method))
+332
(method-not-found-response id method))
+333
(else
+334
(or (validate-modern-envelope req params id)
+335
(validate-headers req method id
+336
(request-target-name method params))
+337
(dispatch-message server msg method))))))))
+338
+339
;;; Build the HTTP handler for an MCP server.
+340
;;;
+341
;;; Returns a procedure suitable for `http-serve`. Exposed separately from
+342
;;; `mcp-server-run-http` so it can be tested against constructed requests
+343
;;; without opening a socket.
+344
(define (mcp-http-handler server (keys: (path "/mcp")))
+345
(lambda (req)
+346
(guard (e (else
+347
(guard (le (else #f))
+348
(log-error "MCP HTTP handler failed"
+349
error: (guard (fe (else "unknown error"))
+350
(format-exception e))))
+351
(error-response HTTP-INTERNAL-SERVER-ERROR #f
+352
error-internal "Internal error")))
+353
(let ((method (http-request-method req))
+354
(origin (http-request-header req "Origin")))
+355
(cond
+356
;; Origin is checked before anything else, including the path:
+357
;; a rebinding attempt should not learn which paths exist.
+358
((not (mcp-http-origin-allowed? origin))
+359
(error-response HTTP-FORBIDDEN #f error-invalid-request
+360
"Origin not permitted"))
+361
((not (equal? (http-request-path req) path))
+362
(error-response HTTP-NOT-FOUND #f error-method-not-found
+363
"Not found"))
+364
;; There is no GET stream in this revision: resumability and
+365
;; the server-opened SSE channel are both gone.
+366
((or (equal? method "GET") (equal? method "DELETE"))
+367
(error-response HTTP-METHOD-NOT-ALLOWED #f error-invalid-request
+368
"Method not allowed; POST a JSON-RPC message to this endpoint"))
+369
((not (equal? method "POST"))
+370
(error-response HTTP-METHOD-NOT-ALLOWED #f error-invalid-request
+371
"Method not allowed"))
+372
(else (handle-post server req)))))))
+373
+374
;;; Run an MCP server over Streamable HTTP.
+375
;;;
+376
;;; Binds loopback by default. The transport is stateless: it never issues
+377
;;; or honours a session id, so any number of clients may attach and each
+378
;;; may restart without disturbing the others or the hosting application.
+379
;;;
+380
;;; Blocks until the server stops, exactly as `mcp-server-run` does.
+381
(define (mcp-server-run-http server (keys: (port 8765)
+382
(host "127.0.0.1")
+383
(path "/mcp")))
+384
(log-info "MCP HTTP server ready"
+385
name: (mcp-server-name server)
+386
host: host
+387
port: port
+388
path: path)
+389
(http-serve (mcp-http-handler server path: path)
+390
port: port
+391
host: host))))
src/sigil/mcp/protocol.sglmodified
@@ -46,6 +46,21 @@
46
error-method-not-found
47
error-invalid-params
48
error-internal
+49
error-header-mismatch
+50
error-missing-capability
+51
error-unsupported-version
+52
+53
;; Protocol revisions
+54
mcp-current-version
+55
mcp-legacy-versions
+56
mcp-supported-versions
+57
mcp-negotiate-legacy-version
+58
+59
;; Reserved `_meta` keys
+60
meta-protocol-version-key
+61
meta-client-capabilities-key
+62
meta-client-info-key
+63
meta-server-info-key
64
65
;; Helpers
66
make-error-response
@@ -86,6 +101,56 @@
101
(define error-invalid-params -32602)
102
(define error-internal -32603)
103
+104
;; MCP spec-defined codes. The -32020..-32099 band is reserved for the
+105
;; specification's own codes; -32000..-32019 stays implementation-defined,
+106
;; so nothing new may be allocated there.
+107
(define error-header-mismatch -32020)
+108
(define error-missing-capability -32021)
+109
(define error-unsupported-version -32022)
+110
+111
;; ============================================================
+112
;; Protocol Revisions
+113
;; ============================================================
+114
+115
;;; The current (stateless) protocol revision. Requests in this era carry
+116
;;; their version in `_meta` on every message and never call `initialize`.
+117
(define mcp-current-version "2026-07-28")
+118
+119
;;; Revisions reachable only through the legacy `initialize` handshake,
+120
;;; newest first. The head is the fallback offered to a legacy client
+121
;;; whose requested version we do not recognise.
+122
(define mcp-legacy-versions
+123
(list "2025-11-25" "2025-06-18" "2025-03-26" "2024-11-05"))
+124
+125
;;; Everything this implementation can speak, newest first.
+126
(define mcp-supported-versions
+127
(cons mcp-current-version mcp-legacy-versions))
+128
+129
;;; Choose the version to answer a legacy `initialize` with.
+130
;;;
+131
;;; Echoes the client's request when we support it, otherwise offers our
+132
;;; newest legacy revision. NEVER answers with `mcp-current-version`: that
+133
;;; revision has no `initialize` handshake at all, so a legacy client
+134
;;; handed it would be looking at a version it cannot speak. A client that
+135
;;; asked for a version we do not know is expected to disconnect if it
+136
;;; cannot accept the counter-offer.
+137
(define (mcp-negotiate-legacy-version requested)
+138
(if (and (string? requested) (member requested mcp-legacy-versions))
+139
requested
+140
(car mcp-legacy-versions)))
+141
+142
;; ============================================================
+143
;; Reserved `_meta` Keys
+144
;; ============================================================
+145
+146
;; The `io.modelcontextprotocol/` prefix is reserved by the spec for the
+147
;; protocol's own fields; these are the four this implementation reads or
+148
;; writes.
+149
(define meta-protocol-version-key "io.modelcontextprotocol/protocolVersion")
+150
(define meta-client-capabilities-key "io.modelcontextprotocol/clientCapabilities")
+151
(define meta-client-info-key "io.modelcontextprotocol/clientInfo")
+152
(define meta-server-info-key "io.modelcontextprotocol/serverInfo")
+153
154
;; ============================================================
155
;; Message Parsing
156
;; ============================================================
src/sigil/mcp/server.sglmodified
@@ -15,6 +15,8 @@
15
(sigil log))
16
(export mcp-server
17
mcp-server?
+18
mcp-server-name
+19
mcp-server-version
20
mcp-server-initialized
21
mcp-server-register-tool!
22
mcp-server-register-resource!
@@ -190,17 +192,45 @@
192
(else (cons (car rest) (keep (cdr rest)))))))
193
defaults))
194
+195
;; `dict-ref` raises on a non-dict, and `params` degrades to '() for a
+196
;; request that carried none, so every optional lookup goes through this.
+197
(define (params-ref params key default)
+198
(if (dict? params) (dict-ref params key default) default))
+199
+200
(define (server-info server)
+201
`((name . ,(mcp-server-name server))
+202
(version . ,(mcp-server-version server))))
+203
204
(define (handle-initialize server params id)
205
(set-mcp-server-initialized! server #t)
+206
;; Answer with the version the client asked for when we support it.
+207
;; Replying with a fixed version regardless of the request breaks
+208
;; clients pinned to an older revision: they receive a version string
+209
;; they do not know and disconnect.
210
(let ((caps (merge-capabilities (default-capabilities server)
211
(mcp-server-capabilities server)))
−197
(info `((name . ,(mcp-server-name server))
−198
(version . ,(mcp-server-version server)))))
+212
(negotiated (mcp-negotiate-legacy-version
+213
(params-ref params protocolVersion: #f))))
214
(make-response id
215
(append
−201
`((protocolVersion . "2025-11-25")
+216
`((protocolVersion . ,negotiated)
217
(capabilities . ,caps)
−203
(serverInfo . ,info))
+218
(serverInfo . ,(server-info server)))
+219
(if (mcp-server-instructions server)
+220
`((instructions . ,(mcp-server-instructions server)))
+221
'())))))
+222
+223
;;; Answer `server/discover`: the versions, capabilities and identity a
+224
;;; client reads before sending anything else. Required of every server
+225
;;; from revision 2026-07-28, and harmless on stdio, so it is answered
+226
;;; here rather than in a single transport.
+227
(define (handle-server-discover server params id)
+228
(let ((caps (merge-capabilities (default-capabilities server)
+229
(mcp-server-capabilities server))))
+230
(make-response id
+231
(append
+232
`((supportedVersions . ,mcp-supported-versions)
+233
(capabilities . ,caps))
234
(if (mcp-server-instructions server)
235
`((instructions . ,(mcp-server-instructions server)))
236
'())))))
@@ -384,6 +414,8 @@
414
(cond
415
((equal? method "initialize")
416
(handle-initialize server params id))
+417
((equal? method "server/discover")
+418
(handle-server-discover server params id))
419
((equal? method "tools/list")
420
(handle-tools-list server params id))
421
((equal? method "tools/call")
test/test-http.sgladded
@@ -0,0 +1,364 @@
+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))
+10
+11
;; ============================================================
+12
;; Fixtures
+13
;; ============================================================
+14
+15
(define current-version "2026-07-28")
+16
+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))
+27
+28
(define (handler) (mcp-http-handler (make-server)))
+29
+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
'())))))))))
+44
+45
(define (post headers body)
+46
(http-request method: "POST" path: "/mcp" headers: headers body: body))
+47
+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))))
+56
+57
(define (respond req) ((handler) req))
+58
+59
(define (body-json resp) (json-decode (http-response-body resp)))
+60
+61
(define (error-code resp)
+62
(let ((err (dict-ref (body-json resp) 'error: #f)))
+63
(and err (dict-ref err 'code: #f))))
+64
+65
(define (result-of resp) (dict-ref (body-json resp) 'result: #f))
+66
+67
;; ============================================================
+68
;; Origin validation
+69
;; ============================================================
+70
+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)))
+76
+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")))
+82
+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")))
+87
+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")))
+93
+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)))))
+99
+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 "unknown path is 404"
+116
(let ((resp (respond (http-request method: "POST" path: "/nope"
+117
headers: (dict) body: ""))))
+118
(assert-equal 404 (http-response-status resp)))))
+119
+120
;; ============================================================
+121
;; Body parsing
+122
;; ============================================================
+123
+124
(test-group "body parsing"
+125
(test "unparseable body is 400 with -32700"
+126
(let ((resp (respond (post (dict) "{not json"))))
+127
(assert-equal 400 (http-response-status resp))
+128
(assert-equal -32700 (error-code resp)))))
+129
+130
;; ============================================================
+131
;; Modern envelope validation
+132
;; ============================================================
+133
+134
(test-group "modern envelope"
+135
(test "missing _meta protocolVersion is -32602"
+136
(let* ((body (json-encode
+137
`((jsonrpc . "2.0") (id . 1) (method . "tools/list")
+138
(params . ((_meta . ,(list (cons (string->symbol
+139
meta-client-capabilities-key)
+140
'()))))))))
+141
(resp (respond (post (modern-headers "tools/list") body))))
+142
(assert-equal 400 (http-response-status resp))
+143
(assert-equal -32602 (error-code resp))))
+144
+145
(test "missing _meta clientCapabilities is -32602"
+146
(let* ((body (json-encode
+147
`((jsonrpc . "2.0") (id . 1) (method . "tools/list")
+148
(params . ((_meta . ,(list (cons (string->symbol
+149
meta-protocol-version-key)
+150
current-version))))))))
+151
(resp (respond (post (modern-headers "tools/list") body))))
+152
(assert-equal 400 (http-response-status resp))
+153
(assert-equal -32602 (error-code resp))))
+154
+155
(test "unsupported version is -32022 and lists what we support"
+156
(let* ((body (json-encode
+157
`((jsonrpc . "2.0") (id . 1) (method . "tools/list")
+158
(params . ((_meta . ,(list
+159
(cons (string->symbol
+160
meta-protocol-version-key)
+161
"1900-01-01")
+162
(cons (string->symbol
+163
meta-client-capabilities-key)
+164
'()))))))))
+165
(resp (respond (post (dict 'mcp-protocol-version: "1900-01-01"
+166
'mcp-method: "tools/list")
+167
body)))
+168
(err (dict-ref (body-json resp) 'error: #f))
+169
(data (dict-ref err 'data: #f)))
+170
(assert-equal 400 (http-response-status resp))
+171
(assert-equal -32022 (error-code resp))
+172
(assert-equal "1900-01-01" (dict-ref data 'requested: #f))
+173
;; The client cannot fall forward on its own; the supported list is
+174
;; how it learns what to retry with.
+175
(assert-true (> (array-length (dict-ref data 'supported: #[])) 0)))))
+176
+177
;; ============================================================
+178
;; Header agreement
+179
;; ============================================================
+180
+181
(test-group "header agreement"
+182
(test "missing MCP-Protocol-Version header is -32020"
+183
(let ((resp (respond (post (dict 'mcp-method: "tools/list")
+184
(modern-body 1 "tools/list" '())))))
+185
(assert-equal 400 (http-response-status resp))
+186
(assert-equal -32020 (error-code resp))))
+187
+188
(test "header version disagreeing with _meta is -32020"
+189
;; The headers exist so a proxy can route without parsing JSON. That is
+190
;; only sound while the two agree, so disagreement is an error rather
+191
;; than a preference for one source.
+192
(let ((resp (respond (post (dict 'mcp-protocol-version: "2025-11-25"
+193
'mcp-method: "tools/list")
+194
(modern-body 1 "tools/list" '())))))
+195
(assert-equal 400 (http-response-status resp))
+196
(assert-equal -32020 (error-code resp))))
+197
+198
(test "missing Mcp-Method header is -32020"
+199
(let ((resp (respond (post (dict 'mcp-protocol-version: current-version)
+200
(modern-body 1 "tools/list" '())))))
+201
(assert-equal 400 (http-response-status resp))
+202
(assert-equal -32020 (error-code resp))))
+203
+204
(test "Mcp-Method disagreeing with the body method is -32020"
+205
(let ((resp (respond (post (modern-headers "prompts/list")
+206
(modern-body 1 "tools/list" '())))))
+207
(assert-equal 400 (http-response-status resp))
+208
(assert-equal -32020 (error-code resp))))
+209
+210
(test "tools/call without Mcp-Name is -32020"
+211
(let ((resp (respond (post (modern-headers "tools/call")
+212
(modern-body 1 "tools/call"
+213
'((name . "echo")
+214
(arguments . ((text . "hi")))))))))
+215
(assert-equal 400 (http-response-status resp))
+216
(assert-equal -32020 (error-code resp))))
+217
+218
(test "tools/call with a mismatched Mcp-Name is -32020"
+219
(let ((resp (respond (post (modern-headers "tools/call" "other")
+220
(modern-body 1 "tools/call"
+221
'((name . "echo")
+222
(arguments . ((text . "hi")))))))))
+223
(assert-equal 400 (http-response-status resp))
+224
(assert-equal -32020 (error-code resp))))
+225
+226
(test "resources/read takes its Mcp-Name from the uri"
+227
(let ((resp (respond (post (modern-headers "resources/read" "test://doc")
+228
(modern-body 1 "resources/read"
+229
'((uri . "test://doc")))))))
+230
(assert-equal 200 (http-response-status resp)))))
+231
+232
;; ============================================================
+233
;; Successful dispatch and the result envelope
+234
;; ============================================================
+235
+236
(test-group "result envelope"
+237
(test "tools/list succeeds and carries the full envelope"
+238
(let* ((resp (respond (post (modern-headers "tools/list")
+239
(modern-body 1 "tools/list" '()))))
+240
(result (result-of resp)))
+241
(assert-equal 200 (http-response-status resp))
+242
(assert-equal "complete" (dict-ref result 'resultType: #f))
+243
(let* ((meta (dict-ref result '_meta: #f))
+244
(info (dict-ref meta (string->keyword meta-server-info-key) #f)))
+245
(assert-equal "test-http" (dict-ref info 'name: #f))
+246
(assert-equal "9.9.9" (dict-ref info 'version: #f)))
+247
;; Cacheable listings must say for how long and to whom.
+248
(assert-equal 60000 (dict-ref result 'ttlMs: #f))
+249
(assert-equal "private" (dict-ref result 'cacheScope: #f))))
+250
+251
(test "tools/call succeeds and is NOT marked cacheable"
+252
;; Tool output is a computation, not a listing. Marking it cacheable
+253
;; would let an intermediary serve a stale answer for a fresh call.
+254
(let* ((resp (respond (post (modern-headers "tools/call" "echo")
+255
(modern-body 1 "tools/call"
+256
'((name . "echo")
+257
(arguments . ((text . "hi"))))))))
+258
(result (result-of resp)))
+259
(assert-equal 200 (http-response-status resp))
+260
(assert-equal "complete" (dict-ref result 'resultType: #f))
+261
(assert-false (dict-ref result 'ttlMs: #f))
+262
(assert-false (dict-ref result 'cacheScope: #f))))
+263
+264
(test "cacheable-method? agrees with what the envelope stamps"
+265
(assert-true (mcp-http-cacheable-method? "tools/list"))
+266
(assert-true (mcp-http-cacheable-method? "resources/read"))
+267
(assert-true (mcp-http-cacheable-method? "server/discover"))
+268
(assert-false (mcp-http-cacheable-method? "tools/call"))
+269
(assert-false (mcp-http-cacheable-method? "initialize"))))
+270
+271
;; ============================================================
+272
;; Method resolution
+273
;; ============================================================
+274
+275
(test-group "method resolution"
+276
(test "an unimplemented METHOD is 404"
+277
(let ((resp (respond (post (modern-headers "nope/nope")
+278
(modern-body 1 "nope/nope" '())))))
+279
(assert-equal 404 (http-response-status resp))
+280
(assert-equal -32601 (error-code resp))))
+281
+282
(test "an unknown TOOL is 200 with an error, not 404"
+283
;; The distinction is load-bearing: "this server has no such method" is
+284
;; an HTTP-level fact a client caches, while "this server has no such
+285
;; tool" is an answer from a method that ran.
+286
(let ((resp (respond (post (modern-headers "tools/call" "ghost")
+287
(modern-body 1 "tools/call"
+288
'((name . "ghost")
+289
(arguments . ())))))))
+290
(assert-equal 200 (http-response-status resp))
+291
(assert-equal -32601 (error-code resp)))))
+292
+293
;; ============================================================
+294
;; server/discover
+295
;; ============================================================
+296
+297
(test-group "server/discover"
+298
(test "discover reports supported versions and identity"
+299
(let* ((resp (respond (post (modern-headers "server/discover")
+300
(modern-body 1 "server/discover" '()))))
+301
(result (result-of resp))
+302
(versions (dict-ref result 'supportedVersions: #[])))
+303
(assert-equal 200 (http-response-status resp))
+304
(assert-true (> (array-length versions) 1))
+305
;; The modern revision must be offered first.
+306
(assert-equal current-version (array-ref versions 0))
+307
(assert-true (dict-ref result 'capabilities: #f)))))
+308
+309
;; ============================================================
+310
;; Legacy era
+311
;; ============================================================
+312
+313
(test-group "legacy initialize"
+314
(test "initialize echoes a supported legacy version back"
+315
;; A client pinned to 2025-06-18 must hear 2025-06-18. Answering with a
+316
;; different version is what makes an older client hang up.
+317
(let* ((body (json-encode
+318
`((jsonrpc . "2.0") (id . 1) (method . "initialize")
+319
(params . ((protocolVersion . "2025-06-18"))))))
+320
(resp (respond (post (dict) body)))
+321
(result (result-of resp)))
+322
(assert-equal 200 (http-response-status resp))
+323
(assert-equal "2025-06-18" (dict-ref result 'protocolVersion: #f))))
+324
+325
(test "initialize needs no modern headers or _meta at all"
+326
;; The whole point of dual-era: a legacy client cannot be expected to
+327
;; send an envelope defined after it shipped.
+328
(let* ((body (json-encode
+329
`((jsonrpc . "2.0") (id . 1) (method . "initialize")
+330
(params . ((protocolVersion . "2025-11-25"))))))
+331
(resp (respond (post (dict) body))))
+332
(assert-equal 200 (http-response-status resp))))
+333
+334
(test "an unknown requested version gets our newest LEGACY version"
+335
;; Never the modern one: 2026-07-28 has no initialize handshake, so a
+336
;; client that just sent one could not speak it.
+337
(let* ((body (json-encode
+338
`((jsonrpc . "2.0") (id . 1) (method . "initialize")
+339
(params . ((protocolVersion . "1999-01-01"))))))
+340
(resp (respond (post (dict) body)))
+341
(answered (dict-ref (result-of resp) 'protocolVersion: #f)))
+342
(assert-equal "2025-11-25" answered)
+343
(assert-false (equal? current-version answered))))
+344
+345
(test "negotiation never answers with the modern version"
+346
(assert-false (equal? mcp-current-version
+347
(mcp-negotiate-legacy-version "2026-07-28")))
+348
(assert-false (equal? mcp-current-version
+349
(mcp-negotiate-legacy-version #f)))
+350
(assert-equal "2025-06-18" (mcp-negotiate-legacy-version "2025-06-18"))))
+351
+352
;; ============================================================
+353
;; Notifications
+354
;; ============================================================
+355
+356
(test-group "notifications"
+357
(test "a notification is accepted with 202 and an empty body"
+358
(let* ((body (json-encode
+359
`((jsonrpc . "2.0") (method . "notifications/initialized"))))
+360
(resp (respond (post (dict) body))))
+361
(assert-equal 202 (http-response-status resp))
+362
(assert-equal "" (http-response-body resp)))))
+363
+364
(run-tests)