Commitb87d241fRecorded31 Aug 2026Repositorysigil-mcp
sigil-mcp: add transport-independent client
Changed
README.md | 3 ++-
package.sgl | 4 ++--
src/sigil/mcp.sgl | 22 ++++++++++++++++++++++
src/sigil/mcp/client.sgl | 168 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/sigil/mcp/protocol.sgl | 35 ++++++++++++++++++++++++++---------
test/test-client.sgl | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
test/test-protocol.sgl | 17 ++++++++++++++++-
7 files changed, 327 insertions(+), 13 deletions(-)Diff
README.mdmodified
@@ -1,6 +1,6 @@
1
# sigil-mcp 2
−3
Library for building Model Context Protocol servers in+3
Library for building Model Context Protocol clients and servers in 4
[Sigil](https://codeberg.org/sigil/sigil). Provides the server loop, 5
JSON-RPC 2.0 framing, and channel-based message routing primitives so 6
any Sigil project can expose tools and resources to MCP clients.@@ -16,6 +16,7 @@ work idiomatically against a live Sigil project.
16
|------------------------|--------------------------------------------------------| 17
| `(sigil mcp)` | Top-level re-exports plus package-tool discovery | 18
| `(sigil mcp server)` | Server loop, message routing, handler registration |+19
| `(sigil mcp client)` | Client lifecycle, correlation, cancellation, events | 20
| `(sigil mcp protocol)` | JSON-RPC 2.0 framing and MCP message shapes | 21
| `(sigil mcp channel)` | Helpers for channel-based server transports | 22
package.sglmodified
@@ -7,9 +7,9 @@
7
8
(package 9
name: "sigil-mcp"−10
version: "0.17.1"+10
version: "0.17.2" 11
sigil: "^0.19"−12
description: "Library for building MCP servers in Sigil"+12
description: "Library for building MCP clients and servers in Sigil" 13
url: "https://codeberg.org/sigil/sigil-mcp" 14
license: "BSD-3-Clause" 15
authors: (list "David Wilson <david@daviwil.com>")src/sigil/mcp.sglmodified
@@ -16,6 +16,7 @@
16
(sigil path) 17
(sigil io) 18
(sigil mcp protocol)+19
(sigil mcp client) 20
(sigil mcp server) 21
(sigil mcp channel) 22
(sigil package)@@ -31,6 +32,27 @@
32
mcp-server-register-prompt! 33
mcp-server-notify! 34
+35
;; Transport-independent client core+36
mcp-client+37
mcp-client?+38
mcp-client-state+39
mcp-client-protocol-version+40
mcp-client-server-info+41
mcp-client-server-capabilities+42
mcp-client-pending-count+43
mcp-client-request!+44
mcp-client-notify!+45
mcp-client-cancel!+46
mcp-client-initialize!+47
mcp-client-list-tools!+48
mcp-client-call-tool!+49
mcp-client-list-resources!+50
mcp-client-list-resource-templates!+51
mcp-client-read-resource!+52
mcp-client-list-prompts!+53
mcp-client-handle-message!+54
mcp-client-handle-line!+55
56
;; Channel server helpers 57
mcp-channel-server 58
channel-notify!src/sigil/mcp/client.sgladded
@@ -0,0 +1,168 @@
+1
;;; (sigil mcp client) - transport-independent MCP client core.+2
+3
(define-library (sigil mcp client)+4
(import (sigil core)+5
(sigil struct)+6
(sigil mcp protocol))+7
(export mcp-client+8
mcp-client?+9
mcp-client-state+10
mcp-client-protocol-version+11
mcp-client-server-info+12
mcp-client-server-capabilities+13
mcp-client-pending-count+14
mcp-client-request!+15
mcp-client-notify!+16
mcp-client-cancel!+17
mcp-client-initialize!+18
mcp-client-list-tools!+19
mcp-client-call-tool!+20
mcp-client-list-resources!+21
mcp-client-list-resource-templates!+22
mcp-client-read-resource!+23
mcp-client-list-prompts!+24
mcp-client-handle-message!+25
mcp-client-handle-line!)+26
(begin+27
;; SEND receives one complete JSON line. EVENT receives typed public+28
;; lifecycle/protocol records. Slate supplies both and therefore retains+29
;; ownership of processes, scheduling, logging, and policy.+30
(define-struct mcp-client+31
(send)+32
(event default: (lambda (_) #t))+33
(now default: (lambda () 0))+34
(max-frame-bytes default: 1048576)+35
(next-id default: 1 mutable: #t)+36
(pending default: '() mutable: #t)+37
(state default: 'new mutable: #t)+38
(protocol-version default: #f mutable: #t)+39
(server-info default: #f mutable: #t)+40
(server-capabilities default: #f mutable: #t))+41
+42
(define (emit! client value)+43
((mcp-client-event client) value))+44
+45
(define (mcp-client-pending-count client)+46
(length (mcp-client-pending client)))+47
+48
;; JSON decoders may represent a wire id as an inexact number even when+49
;; the locally allocated id is exact. JSON-RPC defines numeric ids by+50
;; value, so correlate numbers numerically and other id types structurally.+51
(define (same-id? left right)+52
(if (and (number? left) (number? right))+53
(= left right)+54
(equal? left right)))+55
+56
(define (take-pending! client id)+57
(let loop ((rest (mcp-client-pending client)) (kept '()))+58
(cond+59
((null? rest) #f)+60
((same-id? id (caar rest))+61
(set-mcp-client-pending! client (append (reverse kept) (cdr rest)))+62
(cdar rest))+63
(else (loop (cdr rest) (cons (car rest) kept))))))+64
+65
(define (mcp-client-request! client method params callback)+66
(let ((id (mcp-client-next-id client)))+67
(set-mcp-client-next-id! client (+ id 1))+68
(set-mcp-client-pending!+69
client+70
(cons (cons id `((method . ,method)+71
(started-at . ,((mcp-client-now client)))+72
(callback . ,callback)))+73
(mcp-client-pending client)))+74
((mcp-client-send client)+75
(request->json (jsonrpc-request id: id method: method params: params)))+76
id))+77
+78
(define (mcp-client-notify! client method . params)+79
((mcp-client-send client)+80
(notification->json+81
(jsonrpc-notification method: method+82
params: (if (null? params) #f (car params))))))+83
+84
(define (mcp-client-cancel! client id)+85
(mcp-client-notify! client "notifications/cancelled"+86
`((requestId . ,id))))+87
+88
(define (mcp-client-initialize! client protocol-version client-info capabilities callback)+89
(set-mcp-client-state! client 'initializing)+90
(mcp-client-request!+91
client "initialize"+92
`((protocolVersion . ,protocol-version)+93
(capabilities . ,capabilities)+94
(clientInfo . ,client-info))+95
(lambda (outcome)+96
(if (jsonrpc-response? outcome)+97
(let ((result (jsonrpc-response-result outcome)))+98
(set-mcp-client-protocol-version!+99
client (and (list? result) (assoc-ref 'protocolVersion result)))+100
(set-mcp-client-server-info!+101
client (and (list? result) (assoc-ref 'serverInfo result)))+102
(set-mcp-client-server-capabilities!+103
client (and (list? result) (assoc-ref 'capabilities result)))+104
(set-mcp-client-state! client 'ready)+105
(mcp-client-notify! client "notifications/initialized")+106
(emit! client `((type . initialized)+107
(protocol-version . ,(mcp-client-protocol-version client)))))+108
(set-mcp-client-state! client 'failed))+109
(callback outcome))))+110
+111
;; These wrappers deliberately preserve MCP wire values. Product-specific+112
;; schema conversion, allowlists, and context policy belong to the caller.+113
(define (cursor-params cursor)+114
(if cursor `((cursor . ,cursor)) '()))+115
+116
(define (mcp-client-list-tools! client cursor callback)+117
(mcp-client-request! client "tools/list" (cursor-params cursor) callback))+118
+119
(define (mcp-client-call-tool! client name arguments callback)+120
(mcp-client-request! client "tools/call"+121
`((name . ,name) (arguments . ,arguments)) callback))+122
+123
(define (mcp-client-list-resources! client cursor callback)+124
(mcp-client-request! client "resources/list" (cursor-params cursor) callback))+125
+126
(define (mcp-client-list-resource-templates! client cursor callback)+127
(mcp-client-request! client "resources/templates/list"+128
(cursor-params cursor) callback))+129
+130
(define (mcp-client-read-resource! client uri callback)+131
(mcp-client-request! client "resources/read" `((uri . ,uri)) callback))+132
+133
(define (mcp-client-list-prompts! client cursor callback)+134
(mcp-client-request! client "prompts/list" (cursor-params cursor) callback))+135
+136
(define (mcp-client-handle-message! client message)+137
(cond+138
((or (jsonrpc-response? message) (jsonrpc-error-response? message))+139
(let* ((id (if (jsonrpc-response? message)+140
(jsonrpc-response-id message)+141
(jsonrpc-error-response-id message)))+142
(entry (take-pending! client id)))+143
(if entry+144
((assoc-ref 'callback entry) message)+145
(emit! client `((type . orphan-response) (id . ,id))))))+146
((jsonrpc-notification? message)+147
(emit! client `((type . notification)+148
(method . ,(jsonrpc-notification-method message))+149
(params . ,(jsonrpc-notification-params message)))))+150
((jsonrpc-request? message)+151
;; Server-to-client requests require a product policy decision. The+152
;; core reports them but never grants or executes anything itself.+153
(emit! client `((type . server-request)+154
(id . ,(jsonrpc-request-id message))+155
(method . ,(jsonrpc-request-method message))+156
(params . ,(jsonrpc-request-params message)))))+157
(else (emit! client '((type . invalid-message))))))+158
+159
(define (mcp-client-handle-line! client line)+160
(if (> (string-length line) (mcp-client-max-frame-bytes client))+161
(begin+162
(emit! client `((type . frame-refused)+163
(bytes . ,(string-length line))))+164
#f)+165
(let ((message (guard (_ (#t #f)) (parse-message-string line))))+166
(if message+167
(begin (mcp-client-handle-message! client message) #t)+168
(begin (emit! client '((type . invalid-frame))) #f)))))))src/sigil/mcp/protocol.sglmodified
@@ -102,20 +102,37 @@
102
103
;;; Parse a JSON-RPC message from a parsed JSON value (dict). 104
;;;−105
;;; Returns a jsonrpc-request, jsonrpc-notification, or #f if invalid.+105
;;; Returns a JSON-RPC request, notification, response, error response,+106
;;; or #f if invalid. Keeping both directions in this module prevents+107
;;; clients and servers from growing subtly different wire parsers. 108
(define (parse-message json) 109
(and (dict? json) 110
(equal? (dict-ref json jsonrpc: #f) "2.0") 111
(let ((method (dict-ref json method: #f))−110
(id (dict-ref json id: #f))+112
(has-id? (dict-contains? json id:))+113
(has-result? (dict-contains? json result:))+114
(has-error? (dict-contains? json error:)) 115
(params (dict-ref json params: #f)))−112
(and (string? method)−113
(if id−114
(jsonrpc-request id: id−115
method: method−116
params: params)−117
(jsonrpc-notification method: method−118
params: params))))))+116
(cond+117
((string? method)+118
(if has-id?+119
(jsonrpc-request id: (dict-ref json id:)+120
method: method+121
params: params)+122
(jsonrpc-notification method: method params: params)))+123
((and has-id? has-result? (not has-error?))+124
(jsonrpc-response id: (dict-ref json id:)+125
result: (dict-ref json result:)))+126
((and has-id? has-error? (dict? (dict-ref json error:)))+127
(let ((error (dict-ref json error:)))+128
(and (number? (dict-ref error code: #f))+129
(string? (dict-ref error message: #f))+130
(jsonrpc-error-response+131
id: (dict-ref json id:)+132
code: (dict-ref error code:)+133
message: (dict-ref error message:)+134
data: (dict-ref error data: #f)))))+135
(else #f))))) 136
137
;; ============================================================ 138
;; Message Serializationtest/test-client.sgladded
@@ -0,0 +1,91 @@
+1
(import (sigil test)+2
(sigil mcp client)+3
(sigil mcp protocol)+4
(sigil json))+5
+6
(define sent '())+7
(define events '())+8
(define now-value 100)+9
(define client+10
(mcp-client send: (lambda (line) (set! sent (append sent (list line))))+11
event: (lambda (event) (set! events (append events (list event))))+12
now: (lambda () now-value)+13
max-frame-bytes: 256))+14
+15
(test-group "request correlation"+16
(test "out-of-order responses resolve by id"+17
(let* ((settled '())+18
(a (mcp-client-request! client "one" '()+19
(lambda (r) (set! settled (append settled+20
(list (jsonrpc-response-result r)))))))+21
(b (mcp-client-request! client "two" '()+22
(lambda (r) (set! settled (append settled+23
(list (jsonrpc-response-result r))))))))+24
(assert-equal 2 (mcp-client-pending-count client))+25
(mcp-client-handle-message! client (make-response b "second"))+26
(mcp-client-handle-message! client (make-response a "first"))+27
(assert-equal '("second" "first") settled)+28
(assert-equal 0 (mcp-client-pending-count client))))+29
+30
(test "unknown response is observable"+31
(mcp-client-handle-message! client (make-response 999 '()))+32
(assert-equal 'orphan-response (assoc-ref 'type (car (reverse events))))))+33
+34
(test-group "lifecycle"+35
(test "initialize records negotiation and sends initialized"+36
(let* ((outcome #f)+37
(id (mcp-client-initialize!+38
client "2025-06-18"+39
'((name . "test") (version . "1"))+40
'()+41
(lambda (r) (set! outcome r)))))+42
(assert-equal 'initializing (mcp-client-state client))+43
(mcp-client-handle-message!+44
client+45
(make-response id+46
'((protocolVersion . "2025-06-18")+47
(capabilities . ((tools . ())))+48
(serverInfo . ((name . "fixture") (version . "1"))))))+49
(assert-true (jsonrpc-response? outcome))+50
(assert-equal 'ready (mcp-client-state client))+51
(assert-equal "2025-06-18" (mcp-client-protocol-version client))+52
(assert-equal "notifications/initialized"+53
(dict-ref (json-decode (car (reverse sent))) method:))))+54
+55
(test "server notification is typed and observable"+56
(mcp-client-handle-message!+57
client (make-notification "notifications/claude/channel" '((content . "hi"))))+58
(let ((event (car (reverse events))))+59
(assert-equal 'notification (assoc-ref 'type event))+60
(assert-equal "notifications/claude/channel" (assoc-ref 'method event)))))+61
+62
(test-group "bounds and cancellation"+63
(test "oversize line is refused before parsing"+64
(assert-false (mcp-client-handle-line! client (make-string 257 #\x)))+65
(assert-equal 'frame-refused (assoc-ref 'type (car (reverse events)))))+66
+67
(test "cancellation names the request id"+68
(mcp-client-cancel! client 44)+69
(let* ((wire (json-decode (car (reverse sent))))+70
(params (dict-ref wire params:)))+71
(assert-equal "notifications/cancelled" (dict-ref wire method:))+72
(assert-equal 44 (dict-ref params requestId:)))))+73
+74
(test-group "MCP methods"+75
(test "tool and resource wrappers retain protocol values"+76
(mcp-client-list-tools! client "next-tools" (lambda (_) #t))+77
(let ((wire (json-decode (car (reverse sent)))))+78
(assert-equal "tools/list" (dict-ref wire method:))+79
(assert-equal "next-tools" (dict-ref (dict-ref wire params:) cursor:)))+80
(mcp-client-call-tool! client "folio.read" '((name . "note")) (lambda (_) #t))+81
(let ((wire (json-decode (car (reverse sent)))))+82
(assert-equal "tools/call" (dict-ref wire method:))+83
(assert-equal "folio.read" (dict-ref (dict-ref wire params:) name:)))+84
(mcp-client-list-resource-templates! client #f (lambda (_) #t))+85
(assert-equal "resources/templates/list"+86
(dict-ref (json-decode (car (reverse sent))) method:))+87
(mcp-client-read-resource! client "sigil://index" (lambda (_) #t))+88
(assert-equal "sigil://index"+89
(dict-ref (dict-ref (json-decode (car (reverse sent))) params:) uri:))))+90
+91
(run-tests)test/test-protocol.sglmodified
@@ -36,7 +36,22 @@
36
(assert-false msg))) 37
38
(test "non-dict returns #f"−39
(assert-false (parse-message "not a dict"))))+39
(assert-false (parse-message "not a dict")))+40
+41
(test "successful response"+42
(let ((msg (parse-message-string+43
"{\"jsonrpc\":\"2.0\",\"id\":0,\"result\":{\"ok\":true}}")))+44
(assert-true (jsonrpc-response? msg))+45
(assert-equal 0 (jsonrpc-response-id msg))+46
(assert-true (dict-ref (jsonrpc-response-result msg) ok:))))+47
+48
(test "error response"+49
(let ((msg (parse-message-string+50
"{\"jsonrpc\":\"2.0\",\"id\":7,\"error\":{\"code\":-32001,\"message\":\"refused\",\"data\":{\"kind\":\"policy\"}}}")))+51
(assert-true (jsonrpc-error-response? msg))+52
(assert-equal 7 (jsonrpc-error-response-id msg))+53
(assert-equal -32001 (jsonrpc-error-response-code msg))+54
(assert-equal "refused" (jsonrpc-error-response-message msg))))) 55
56
;; ============================================================ 57
;; parse-message-string