this repo has no description
more
+5038
+288
claudeio/lib_mcp/SERVER_SESSION_README.md
+288
claudeio/lib_mcp/SERVER_SESSION_README.md
···
1
+
# MCP Server Session API
2
+
3
+
The `Server_session` module provides a high-level, easy-to-use API for creating MCP (Model Context Protocol) servers in OCaml using Eio.
4
+
5
+
## Overview
6
+
7
+
This module handles:
8
+
- **Initialization handshake**: Automatically handles the MCP initialization protocol
9
+
- **Request routing**: Routes incoming requests to your handler functions
10
+
- **Response encoding**: Automatically encodes responses using the correct MCP message types
11
+
- **Notification sending**: Provides convenient functions for sending notifications to clients
12
+
- **Error handling**: Returns proper JSON-RPC error responses for missing handlers
13
+
14
+
## Quick Start
15
+
16
+
```ocaml
17
+
open Mcp
18
+
19
+
(* Define your handlers *)
20
+
let list_tools ~cursor:_ =
21
+
let tool = Messages.Tools.make_tool
22
+
~name:"my_tool"
23
+
~description:"An example tool"
24
+
~input_schema:(Jsont.Object ([], Jsont.Meta.none))
25
+
()
26
+
in
27
+
Messages.Tools.make_list_result ~tools:[tool] ()
28
+
29
+
let call_tool ~name ~arguments =
30
+
match name with
31
+
| "my_tool" ->
32
+
Messages.Tools.make_call_result
33
+
~content:[Content.text "Tool result"]
34
+
()
35
+
| _ ->
36
+
Messages.Tools.make_call_result
37
+
~content:[Content.text "Unknown tool"]
38
+
~is_error:true
39
+
()
40
+
41
+
(* Configure your server *)
42
+
let config = {
43
+
Server_session.server_info = Capabilities.Implementation.make
44
+
~name:"my-server"
45
+
~version:"1.0.0";
46
+
server_capabilities = Capabilities.Server.make
47
+
~tools:(Capabilities.Tools.make ())
48
+
();
49
+
instructions = Some "My MCP server";
50
+
}
51
+
52
+
let handlers = {
53
+
Server_session.list_tools = Some list_tools;
54
+
call_tool = Some call_tool;
55
+
list_resources = None;
56
+
list_resource_templates = None;
57
+
read_resource = None;
58
+
subscribe_resource = None;
59
+
unsubscribe_resource = None;
60
+
list_prompts = None;
61
+
get_prompt = None;
62
+
complete = None;
63
+
ping = None;
64
+
}
65
+
66
+
(* Start the server *)
67
+
let () =
68
+
Eio_main.run @@ fun env ->
69
+
Eio.Switch.run @@ fun sw ->
70
+
let transport = (* create your transport *) in
71
+
let server = Server_session.create
72
+
~sw
73
+
~transport
74
+
config
75
+
handlers
76
+
in
77
+
(* Server is now running *)
78
+
```
79
+
80
+
## Architecture
81
+
82
+
### Initialization Flow
83
+
84
+
1. **Client sends Initialize request** → Server stores client capabilities and info
85
+
2. **Server responds with capabilities** → Returns server capabilities and info
86
+
3. **Client sends Initialized notification** → Server marks initialization complete
87
+
4. **Server is ready** → Now accepts requests and can send notifications
88
+
89
+
### Request Handling
90
+
91
+
When a request arrives:
92
+
93
+
1. The method name is matched against handler types
94
+
2. If a handler exists, it's called with the decoded parameters
95
+
3. The result is encoded and sent back
96
+
4. If no handler exists, a METHOD_NOT_FOUND error is returned
97
+
98
+
### Error Handling
99
+
100
+
The module automatically handles:
101
+
- Missing handlers → METHOD_NOT_FOUND error
102
+
- Invalid params → INVALID_PARAMS error
103
+
- Handler exceptions → INTERNAL_ERROR with exception message
104
+
- Pre-initialization requests → Rejected with error
105
+
106
+
## Supported Capabilities
107
+
108
+
The server can implement any combination of these capabilities:
109
+
110
+
### Resources
111
+
- `list_resources`: List available resources with optional pagination
112
+
- `list_resource_templates`: List resource templates
113
+
- `read_resource`: Read resource contents by URI
114
+
- `subscribe_resource`: Subscribe to resource updates
115
+
- `unsubscribe_resource`: Unsubscribe from updates
116
+
117
+
Notifications you can send:
118
+
- `send_resource_updated`: Notify about a specific resource update
119
+
- `send_resource_list_changed`: Notify that the resource list changed
120
+
121
+
### Tools
122
+
- `list_tools`: List available tools with optional pagination
123
+
- `call_tool`: Execute a tool by name with arguments
124
+
125
+
Notifications you can send:
126
+
- `send_tool_list_changed`: Notify that the tool list changed
127
+
128
+
### Prompts
129
+
- `list_prompts`: List available prompts with optional pagination
130
+
- `get_prompt`: Get a prompt by name with arguments
131
+
132
+
Notifications you can send:
133
+
- `send_prompt_list_changed`: Notify that the prompt list changed
134
+
135
+
### Other
136
+
- `complete`: Auto-completion suggestions
137
+
- `ping`: Keepalive handler
138
+
139
+
### Logging
140
+
- `send_log_message`: Send log messages to the client
141
+
142
+
### Progress
143
+
- `send_progress`: Send progress updates for long-running operations
144
+
145
+
## Handler Signatures
146
+
147
+
All handlers return strongly-typed message results:
148
+
149
+
```ocaml
150
+
type handlers = {
151
+
list_resources : (cursor:string option -> Messages.Resources.list_result) option;
152
+
read_resource : (uri:string -> Messages.Resources.read_result) option;
153
+
list_tools : (cursor:string option -> Messages.Tools.list_result) option;
154
+
call_tool : (name:string -> arguments:Jsont.json option -> Messages.Tools.call_result) option;
155
+
list_prompts : (cursor:string option -> Messages.Prompts.list_result) option;
156
+
get_prompt : (name:string -> arguments:(string * string) list option -> Messages.Prompts.get_result) option;
157
+
complete : (ref_:Messages.Completions.completion_ref -> argument:string -> Messages.Completions.result) option;
158
+
ping : (unit -> unit) option;
159
+
(* ... *)
160
+
}
161
+
```
162
+
163
+
Set a handler to `None` if you don't support that operation.
164
+
165
+
## Accessing Client Information
166
+
167
+
After initialization, you can query client capabilities:
168
+
169
+
```ocaml
170
+
let server = Server_session.create ~sw ~transport config handlers in
171
+
172
+
(* Get client capabilities *)
173
+
let client_caps = Server_session.client_capabilities server in
174
+
match client_caps.roots with
175
+
| Some _ -> (* Client supports roots *)
176
+
| None -> (* Client doesn't support roots *)
177
+
178
+
(* Get client info *)
179
+
let client_info = Server_session.client_info server in
180
+
Printf.printf "Connected to: %s v%s\n"
181
+
client_info.name
182
+
client_info.version;
183
+
184
+
(* Get protocol version *)
185
+
let version = Server_session.protocol_version server in
186
+
```
187
+
188
+
## Sending Notifications
189
+
190
+
Send notifications to inform clients of changes:
191
+
192
+
```ocaml
193
+
(* Resource was updated *)
194
+
Server_session.send_resource_updated server ~uri:"file:///example.txt";
195
+
196
+
(* Resource list changed *)
197
+
Server_session.send_resource_list_changed server;
198
+
199
+
(* Tool list changed *)
200
+
Server_session.send_tool_list_changed server;
201
+
202
+
(* Log a message *)
203
+
let log_data = Jsont.String ("Something happened", Jsont.Meta.none) in
204
+
Server_session.send_log_message server
205
+
~level:Messages.Logging.Info
206
+
~data:log_data
207
+
();
208
+
209
+
(* Report progress *)
210
+
Server_session.send_progress server
211
+
~progress_token:"operation-123"
212
+
~progress:0.5
213
+
~total:100.0
214
+
();
215
+
```
216
+
217
+
## Requesting from Client
218
+
219
+
Some servers may need to request information from clients:
220
+
221
+
```ocaml
222
+
(* Request the list of roots (if client supports it) *)
223
+
match Server_session.request_roots_list server with
224
+
| Some result ->
225
+
List.iter (fun root ->
226
+
Printf.printf "Root: %s\n" root.Messages.Roots.uri
227
+
) result.roots
228
+
| None ->
229
+
(* Client doesn't support roots capability *)
230
+
()
231
+
```
232
+
233
+
## Example: Simple Tool Server
234
+
235
+
See `examples/mcp_server_example.ml` for a complete example that demonstrates:
236
+
- Tool implementation (add, echo)
237
+
- Resource serving (example://greeting)
238
+
- Proper capability declaration
239
+
- Handler implementation
240
+
241
+
## Implementation Notes
242
+
243
+
### Thread Safety
244
+
The module uses Eio structured concurrency. All operations are safe within the same Eio domain. The Session module handles concurrent requests using Eio fibers.
245
+
246
+
### Timeout Support
247
+
You can configure request timeouts:
248
+
249
+
```ocaml
250
+
let server = Server_session.create
251
+
~sw
252
+
~transport
253
+
~timeout:30.0 (* 30 second timeout *)
254
+
~clock:(Session.C (Eio.Stdenv.clock env))
255
+
config
256
+
handlers
257
+
```
258
+
259
+
### Error Propagation
260
+
- Handler exceptions are caught and converted to INTERNAL_ERROR responses
261
+
- The server continues running after handler errors
262
+
- Use proper error handling in your handlers for better error messages
263
+
264
+
### Shutdown
265
+
The server runs as long as the Eio switch is active:
266
+
267
+
```ocaml
268
+
(* Explicit close *)
269
+
Server_session.close server;
270
+
271
+
(* Or let the switch handle cleanup *)
272
+
Eio.Switch.run @@ fun sw ->
273
+
let server = Server_session.create ~sw ~transport config handlers in
274
+
(* server auto-closes when switch exits *)
275
+
```
276
+
277
+
## Related Modules
278
+
279
+
- `Session`: Low-level bidirectional JSON-RPC session
280
+
- `Messages`: MCP protocol message types
281
+
- `Capabilities`: Capability negotiation types
282
+
- `Transport`: Transport layer abstraction
283
+
- `Content`: Content block types (text, image, etc.)
284
+
285
+
## References
286
+
287
+
- [MCP Specification](https://spec.modelcontextprotocol.io/)
288
+
- [JSON-RPC 2.0 Specification](https://www.jsonrpc.org/)
+284
claudeio/lib_mcp/capabilities.ml
+284
claudeio/lib_mcp/capabilities.ml
···
1
+
(** MCP Capability negotiation types *)
2
+
3
+
(* Implementation Info *)
4
+
5
+
module Implementation = struct
6
+
type t = {
7
+
name : string;
8
+
version : string;
9
+
unknown : Jsont.json;
10
+
}
11
+
12
+
let make ~name ~version =
13
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
14
+
{ name; version; unknown }
15
+
16
+
let jsont : t Jsont.t =
17
+
let make name version unknown = { name; version; unknown } in
18
+
Jsont.Object.map ~kind:"Implementation" make
19
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun i -> i.name)
20
+
|> Jsont.Object.mem "version" Jsont.string ~enc:(fun i -> i.version)
21
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun i -> i.unknown)
22
+
|> Jsont.Object.finish
23
+
24
+
let pp fmt i =
25
+
Format.fprintf fmt "%s/%s" i.name i.version
26
+
end
27
+
28
+
(* Client Capabilities *)
29
+
30
+
module Sampling = struct
31
+
type t = {
32
+
context : bool option;
33
+
tools : bool option;
34
+
unknown : Jsont.json;
35
+
}
36
+
37
+
let empty =
38
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
39
+
{ context = None; tools = None; unknown }
40
+
41
+
let make ?context ?tools () =
42
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
43
+
{ context; tools; unknown }
44
+
45
+
let jsont : t Jsont.t =
46
+
let make context tools unknown = { context; tools; unknown } in
47
+
Jsont.Object.map ~kind:"Sampling" make
48
+
|> Jsont.Object.opt_mem "context" Jsont.bool ~enc:(fun s -> s.context)
49
+
|> Jsont.Object.opt_mem "tools" Jsont.bool ~enc:(fun s -> s.tools)
50
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun s -> s.unknown)
51
+
|> Jsont.Object.finish
52
+
end
53
+
54
+
module Elicitation = struct
55
+
type t = {
56
+
unknown : Jsont.json;
57
+
}
58
+
59
+
let empty =
60
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
61
+
{ unknown }
62
+
63
+
let jsont : t Jsont.t =
64
+
let make unknown = { unknown } in
65
+
Jsont.Object.map ~kind:"Elicitation" make
66
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun e -> e.unknown)
67
+
|> Jsont.Object.finish
68
+
end
69
+
70
+
module Roots = struct
71
+
type t = {
72
+
list_changed : bool option;
73
+
unknown : Jsont.json;
74
+
}
75
+
76
+
let empty =
77
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
78
+
{ list_changed = None; unknown }
79
+
80
+
let make ?list_changed () =
81
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
82
+
{ list_changed; unknown }
83
+
84
+
let jsont : t Jsont.t =
85
+
let make list_changed unknown = { list_changed; unknown } in
86
+
Jsont.Object.map ~kind:"Roots" make
87
+
|> Jsont.Object.opt_mem "listChanged" Jsont.bool ~enc:(fun r -> r.list_changed)
88
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
89
+
|> Jsont.Object.finish
90
+
end
91
+
92
+
module Client = struct
93
+
type t = {
94
+
sampling : Sampling.t option;
95
+
elicitation : Elicitation.t option;
96
+
roots : Roots.t option;
97
+
experimental : Jsont.json option;
98
+
unknown : Jsont.json;
99
+
}
100
+
101
+
let empty =
102
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
103
+
{ sampling = None; elicitation = None; roots = None; experimental = None; unknown }
104
+
105
+
let make ?sampling ?elicitation ?roots ?experimental () =
106
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
107
+
{ sampling; elicitation; roots; experimental; unknown }
108
+
109
+
let jsont : t Jsont.t =
110
+
let make sampling elicitation roots experimental unknown =
111
+
{ sampling; elicitation; roots; experimental; unknown }
112
+
in
113
+
Jsont.Object.map ~kind:"ClientCapabilities" make
114
+
|> Jsont.Object.opt_mem "sampling" Sampling.jsont ~enc:(fun c -> c.sampling)
115
+
|> Jsont.Object.opt_mem "elicitation" Elicitation.jsont ~enc:(fun c -> c.elicitation)
116
+
|> Jsont.Object.opt_mem "roots" Roots.jsont ~enc:(fun c -> c.roots)
117
+
|> Jsont.Object.opt_mem "experimental" Jsont.json ~enc:(fun c -> c.experimental)
118
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun c -> c.unknown)
119
+
|> Jsont.Object.finish
120
+
121
+
let pp fmt c =
122
+
let caps = [
123
+
(match c.sampling with Some _ -> Some "sampling" | None -> None);
124
+
(match c.elicitation with Some _ -> Some "elicitation" | None -> None);
125
+
(match c.roots with Some _ -> Some "roots" | None -> None);
126
+
] |> List.filter_map Fun.id in
127
+
Format.fprintf fmt "[%s]" (String.concat ", " caps)
128
+
end
129
+
130
+
(* Server Capabilities *)
131
+
132
+
module Logging = struct
133
+
type t = {
134
+
unknown : Jsont.json;
135
+
}
136
+
137
+
let empty =
138
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
139
+
{ unknown }
140
+
141
+
let jsont : t Jsont.t =
142
+
let make unknown = { unknown } in
143
+
Jsont.Object.map ~kind:"Logging" make
144
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun l -> l.unknown)
145
+
|> Jsont.Object.finish
146
+
end
147
+
148
+
module Prompts = struct
149
+
type t = {
150
+
list_changed : bool option;
151
+
unknown : Jsont.json;
152
+
}
153
+
154
+
let empty =
155
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
156
+
{ list_changed = None; unknown }
157
+
158
+
let make ?list_changed () =
159
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
160
+
{ list_changed; unknown }
161
+
162
+
let jsont : t Jsont.t =
163
+
let make list_changed unknown = { list_changed; unknown } in
164
+
Jsont.Object.map ~kind:"Prompts" make
165
+
|> Jsont.Object.opt_mem "listChanged" Jsont.bool ~enc:(fun p -> p.list_changed)
166
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun p -> p.unknown)
167
+
|> Jsont.Object.finish
168
+
end
169
+
170
+
module Resources = struct
171
+
type t = {
172
+
subscribe : bool option;
173
+
list_changed : bool option;
174
+
unknown : Jsont.json;
175
+
}
176
+
177
+
let empty =
178
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
179
+
{ subscribe = None; list_changed = None; unknown }
180
+
181
+
let make ?subscribe ?list_changed () =
182
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
183
+
{ subscribe; list_changed; unknown }
184
+
185
+
let jsont : t Jsont.t =
186
+
let make subscribe list_changed unknown =
187
+
{ subscribe; list_changed; unknown }
188
+
in
189
+
Jsont.Object.map ~kind:"Resources" make
190
+
|> Jsont.Object.opt_mem "subscribe" Jsont.bool ~enc:(fun r -> r.subscribe)
191
+
|> Jsont.Object.opt_mem "listChanged" Jsont.bool ~enc:(fun r -> r.list_changed)
192
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
193
+
|> Jsont.Object.finish
194
+
end
195
+
196
+
module Tools = struct
197
+
type t = {
198
+
list_changed : bool option;
199
+
unknown : Jsont.json;
200
+
}
201
+
202
+
let empty =
203
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
204
+
{ list_changed = None; unknown }
205
+
206
+
let make ?list_changed () =
207
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
208
+
{ list_changed; unknown }
209
+
210
+
let jsont : t Jsont.t =
211
+
let make list_changed unknown = { list_changed; unknown } in
212
+
Jsont.Object.map ~kind:"Tools" make
213
+
|> Jsont.Object.opt_mem "listChanged" Jsont.bool ~enc:(fun t -> t.list_changed)
214
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun t -> t.unknown)
215
+
|> Jsont.Object.finish
216
+
end
217
+
218
+
module Completions = struct
219
+
type t = {
220
+
unknown : Jsont.json;
221
+
}
222
+
223
+
let empty =
224
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
225
+
{ unknown }
226
+
227
+
let jsont : t Jsont.t =
228
+
let make unknown = { unknown } in
229
+
Jsont.Object.map ~kind:"Completions" make
230
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun c -> c.unknown)
231
+
|> Jsont.Object.finish
232
+
end
233
+
234
+
module Server = struct
235
+
type t = {
236
+
logging : Logging.t option;
237
+
prompts : Prompts.t option;
238
+
resources : Resources.t option;
239
+
tools : Tools.t option;
240
+
completions : Completions.t option;
241
+
experimental : Jsont.json option;
242
+
unknown : Jsont.json;
243
+
}
244
+
245
+
let empty =
246
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
247
+
{
248
+
logging = None;
249
+
prompts = None;
250
+
resources = None;
251
+
tools = None;
252
+
completions = None;
253
+
experimental = None;
254
+
unknown;
255
+
}
256
+
257
+
let make ?logging ?prompts ?resources ?tools ?completions ?experimental () =
258
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
259
+
{ logging; prompts; resources; tools; completions; experimental; unknown }
260
+
261
+
let jsont : t Jsont.t =
262
+
let make logging prompts resources tools completions experimental unknown =
263
+
{ logging; prompts; resources; tools; completions; experimental; unknown }
264
+
in
265
+
Jsont.Object.map ~kind:"ServerCapabilities" make
266
+
|> Jsont.Object.opt_mem "logging" Logging.jsont ~enc:(fun s -> s.logging)
267
+
|> Jsont.Object.opt_mem "prompts" Prompts.jsont ~enc:(fun s -> s.prompts)
268
+
|> Jsont.Object.opt_mem "resources" Resources.jsont ~enc:(fun s -> s.resources)
269
+
|> Jsont.Object.opt_mem "tools" Tools.jsont ~enc:(fun s -> s.tools)
270
+
|> Jsont.Object.opt_mem "completions" Completions.jsont ~enc:(fun s -> s.completions)
271
+
|> Jsont.Object.opt_mem "experimental" Jsont.json ~enc:(fun s -> s.experimental)
272
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun s -> s.unknown)
273
+
|> Jsont.Object.finish
274
+
275
+
let pp fmt s =
276
+
let caps = [
277
+
(match s.logging with Some _ -> Some "logging" | None -> None);
278
+
(match s.prompts with Some _ -> Some "prompts" | None -> None);
279
+
(match s.resources with Some _ -> Some "resources" | None -> None);
280
+
(match s.tools with Some _ -> Some "tools" | None -> None);
281
+
(match s.completions with Some _ -> Some "completions" | None -> None);
282
+
] |> List.filter_map Fun.id in
283
+
Format.fprintf fmt "[%s]" (String.concat ", " caps)
284
+
end
+161
claudeio/lib_mcp/capabilities.mli
+161
claudeio/lib_mcp/capabilities.mli
···
1
+
(** MCP Capability negotiation types.
2
+
3
+
Capabilities are exchanged during initialization to determine what features
4
+
the client and server support. *)
5
+
6
+
(** {1 Implementation Info} *)
7
+
8
+
module Implementation : sig
9
+
type t = {
10
+
name : string;
11
+
version : string;
12
+
unknown : Jsont.json;
13
+
}
14
+
(** Information about client or server implementation *)
15
+
16
+
val make : name:string -> version:string -> t
17
+
val jsont : t Jsont.t
18
+
val pp : Format.formatter -> t -> unit
19
+
end
20
+
21
+
(** {1 Client Capabilities} *)
22
+
23
+
module Sampling : sig
24
+
type t = {
25
+
context : bool option;
26
+
tools : bool option;
27
+
unknown : Jsont.json;
28
+
}
29
+
(** Sampling capability (for servers to request LLM sampling from clients) *)
30
+
31
+
val empty : t
32
+
val make : ?context:bool -> ?tools:bool -> unit -> t
33
+
val jsont : t Jsont.t
34
+
end
35
+
36
+
module Elicitation : sig
37
+
type t = {
38
+
unknown : Jsont.json;
39
+
}
40
+
(** Elicitation capability (for servers to request user input) *)
41
+
42
+
val empty : t
43
+
val jsont : t Jsont.t
44
+
end
45
+
46
+
module Roots : sig
47
+
type t = {
48
+
list_changed : bool option;
49
+
unknown : Jsont.json;
50
+
}
51
+
(** Roots capability (for servers to query filesystem roots) *)
52
+
53
+
val empty : t
54
+
val make : ?list_changed:bool -> unit -> t
55
+
val jsont : t Jsont.t
56
+
end
57
+
58
+
module Client : sig
59
+
type t = {
60
+
sampling : Sampling.t option;
61
+
elicitation : Elicitation.t option;
62
+
roots : Roots.t option;
63
+
experimental : Jsont.json option;
64
+
unknown : Jsont.json;
65
+
}
66
+
(** Client capabilities advertised during initialization *)
67
+
68
+
val empty : t
69
+
val make :
70
+
?sampling:Sampling.t ->
71
+
?elicitation:Elicitation.t ->
72
+
?roots:Roots.t ->
73
+
?experimental:Jsont.json ->
74
+
unit -> t
75
+
val jsont : t Jsont.t
76
+
val pp : Format.formatter -> t -> unit
77
+
end
78
+
79
+
(** {1 Server Capabilities} *)
80
+
81
+
module Logging : sig
82
+
type t = {
83
+
unknown : Jsont.json;
84
+
}
85
+
(** Logging capability *)
86
+
87
+
val empty : t
88
+
val jsont : t Jsont.t
89
+
end
90
+
91
+
module Prompts : sig
92
+
type t = {
93
+
list_changed : bool option;
94
+
unknown : Jsont.json;
95
+
}
96
+
(** Prompts capability *)
97
+
98
+
val empty : t
99
+
val make : ?list_changed:bool -> unit -> t
100
+
val jsont : t Jsont.t
101
+
end
102
+
103
+
module Resources : sig
104
+
type t = {
105
+
subscribe : bool option;
106
+
list_changed : bool option;
107
+
unknown : Jsont.json;
108
+
}
109
+
(** Resources capability *)
110
+
111
+
val empty : t
112
+
val make : ?subscribe:bool -> ?list_changed:bool -> unit -> t
113
+
val jsont : t Jsont.t
114
+
end
115
+
116
+
module Tools : sig
117
+
type t = {
118
+
list_changed : bool option;
119
+
unknown : Jsont.json;
120
+
}
121
+
(** Tools capability *)
122
+
123
+
val empty : t
124
+
val make : ?list_changed:bool -> unit -> t
125
+
val jsont : t Jsont.t
126
+
end
127
+
128
+
module Completions : sig
129
+
type t = {
130
+
unknown : Jsont.json;
131
+
}
132
+
(** Completions capability (for auto-complete) *)
133
+
134
+
val empty : t
135
+
val jsont : t Jsont.t
136
+
end
137
+
138
+
module Server : sig
139
+
type t = {
140
+
logging : Logging.t option;
141
+
prompts : Prompts.t option;
142
+
resources : Resources.t option;
143
+
tools : Tools.t option;
144
+
completions : Completions.t option;
145
+
experimental : Jsont.json option;
146
+
unknown : Jsont.json;
147
+
}
148
+
(** Server capabilities advertised during initialization *)
149
+
150
+
val empty : t
151
+
val make :
152
+
?logging:Logging.t ->
153
+
?prompts:Prompts.t ->
154
+
?resources:Resources.t ->
155
+
?tools:Tools.t ->
156
+
?completions:Completions.t ->
157
+
?experimental:Jsont.json ->
158
+
unit -> t
159
+
val jsont : t Jsont.t
160
+
val pp : Format.formatter -> t -> unit
161
+
end
+356
claudeio/lib_mcp/client_session.ml
+356
claudeio/lib_mcp/client_session.ml
···
1
+
(** High-level MCP client session implementation *)
2
+
3
+
(** {1 Configuration} *)
4
+
5
+
type config = {
6
+
client_info : Capabilities.Implementation.t;
7
+
client_capabilities : Capabilities.Client.t;
8
+
}
9
+
10
+
(** {1 Internal State} *)
11
+
12
+
exception Initialization_error of string
13
+
14
+
type notification_handlers = {
15
+
mutable on_resource_updated : (uri:string -> unit) option;
16
+
mutable on_resource_list_changed : (unit -> unit) option;
17
+
mutable on_tool_list_changed : (unit -> unit) option;
18
+
mutable on_prompt_list_changed : (unit -> unit) option;
19
+
mutable on_log_message : (level:Messages.Logging.level -> logger:string option -> data:Jsont.json -> unit) option;
20
+
}
21
+
22
+
type t = {
23
+
session : Session.t;
24
+
server_capabilities : Capabilities.Server.t;
25
+
server_info : Capabilities.Implementation.t;
26
+
server_instructions : string option;
27
+
handlers : notification_handlers;
28
+
}
29
+
30
+
(** {1 Helper Functions} *)
31
+
32
+
(* Encode a value to JSON using jsont codec *)
33
+
let encode codec value =
34
+
match Jsont.Json.encode codec value with
35
+
| Ok json -> json
36
+
| Error msg -> failwith ("Failed to encode: " ^ msg)
37
+
38
+
(* Decode a JSON value using jsont codec *)
39
+
let decode codec json =
40
+
match Jsont.Json.decode codec json with
41
+
| Ok value -> value
42
+
| Error msg -> failwith ("Failed to decode: " ^ msg)
43
+
44
+
(* Parse notification parameters - returns None if params is None or null *)
45
+
let parse_notification_params codec params_opt =
46
+
match params_opt with
47
+
| None -> None
48
+
| Some (Jsont.Null _) -> None
49
+
| Some json -> Some (decode codec json)
50
+
51
+
(** {1 Notification Routing} *)
52
+
53
+
let create_notification_handler handlers : Session.notification_handler =
54
+
fun ~method_ ~params ->
55
+
match method_ with
56
+
| "notifications/resources/updated" ->
57
+
(match handlers.on_resource_updated with
58
+
| None -> ()
59
+
| Some handler ->
60
+
let notif = parse_notification_params
61
+
Messages.Resources.updated_notification_jsont params in
62
+
(match notif with
63
+
| None -> ()
64
+
| Some n -> handler ~uri:n.Messages.Resources.uri))
65
+
66
+
| "notifications/resources/list_changed" ->
67
+
(match handlers.on_resource_list_changed with
68
+
| None -> ()
69
+
| Some handler -> handler ())
70
+
71
+
| "notifications/tools/list_changed" ->
72
+
(match handlers.on_tool_list_changed with
73
+
| None -> ()
74
+
| Some handler -> handler ())
75
+
76
+
| "notifications/prompts/list_changed" ->
77
+
(match handlers.on_prompt_list_changed with
78
+
| None -> ()
79
+
| Some handler -> handler ())
80
+
81
+
| "notifications/message" ->
82
+
(match handlers.on_log_message with
83
+
| None -> ()
84
+
| Some handler ->
85
+
let notif = parse_notification_params
86
+
Messages.Logging.notification_jsont params in
87
+
(match notif with
88
+
| None -> ()
89
+
| Some n ->
90
+
let data = match n.Messages.Logging.data with
91
+
| None -> Jsont.Null ((), Jsont.Meta.none)
92
+
| Some d -> d
93
+
in
94
+
handler
95
+
~level:n.Messages.Logging.level
96
+
~logger:n.Messages.Logging.logger
97
+
~data))
98
+
99
+
| _ ->
100
+
(* Unknown notification - ignore *)
101
+
()
102
+
103
+
(** {1 Request Handler} *)
104
+
105
+
(* Client doesn't expect to receive requests from server in most cases *)
106
+
let create_request_handler () : Session.request_handler =
107
+
fun ~method_ ~params:_ ->
108
+
(* Default: return method not found error *)
109
+
let error = Jsonrpc.Error_data.make
110
+
~code:Method_not_found
111
+
~message:(Printf.sprintf "Client does not handle method: %s" method_)
112
+
()
113
+
in
114
+
raise (Session.Remote_error error)
115
+
116
+
(** {1 Initialization} *)
117
+
118
+
let perform_initialization session config =
119
+
(* Send Initialize request *)
120
+
let init_params = Messages.Initialize.make_request_params
121
+
~protocol_version:"2024-11-05"
122
+
~capabilities:config.client_capabilities
123
+
~client_info:config.client_info
124
+
()
125
+
in
126
+
let params_json = encode Messages.Initialize.request_params_jsont init_params in
127
+
128
+
let response_json = Session.send_request session
129
+
~method_:Messages.Initialize.method_
130
+
~params:params_json
131
+
()
132
+
in
133
+
134
+
(* Decode Initialize result *)
135
+
let init_result = decode Messages.Initialize.result_jsont response_json in
136
+
137
+
(* Send Initialized notification *)
138
+
let initialized_notif = Messages.Initialized.make_notification () in
139
+
let notif_json = encode Messages.Initialized.notification_jsont initialized_notif in
140
+
Session.send_notification session
141
+
~method_:Messages.Initialized.method_
142
+
~params:notif_json
143
+
();
144
+
145
+
(* Return server info *)
146
+
(init_result.Messages.Initialize.capabilities,
147
+
init_result.Messages.Initialize.server_info,
148
+
init_result.Messages.Initialize.instructions)
149
+
150
+
(** {1 Public API} *)
151
+
152
+
let create ~sw ~transport ?timeout ?clock config =
153
+
(* Create notification handlers *)
154
+
let handlers = {
155
+
on_resource_updated = None;
156
+
on_resource_list_changed = None;
157
+
on_tool_list_changed = None;
158
+
on_prompt_list_changed = None;
159
+
on_log_message = None;
160
+
} in
161
+
162
+
(* Create session config *)
163
+
let session_config : Session.config = {
164
+
transport;
165
+
request_handler = create_request_handler ();
166
+
notification_handler = create_notification_handler handlers;
167
+
timeout;
168
+
clock;
169
+
} in
170
+
171
+
(* Create underlying session *)
172
+
let session = Session.create ~sw session_config in
173
+
174
+
try
175
+
(* Perform initialization handshake *)
176
+
let (server_capabilities, server_info, server_instructions) =
177
+
perform_initialization session config
178
+
in
179
+
180
+
(* Return client session *)
181
+
{
182
+
session;
183
+
server_capabilities;
184
+
server_info;
185
+
server_instructions;
186
+
handlers;
187
+
}
188
+
with
189
+
| Session.Remote_error err ->
190
+
Session.close session;
191
+
raise (Initialization_error
192
+
(Printf.sprintf "Server returned error: %s" err.Jsonrpc.Error_data.message))
193
+
| Session.Timeout msg ->
194
+
Session.close session;
195
+
raise (Initialization_error ("Initialization timeout: " ^ msg))
196
+
| exn ->
197
+
Session.close session;
198
+
raise (Initialization_error
199
+
(Printf.sprintf "Initialization failed: %s" (Printexc.to_string exn)))
200
+
201
+
(** {1 Server Information} *)
202
+
203
+
let server_capabilities t = t.server_capabilities
204
+
let server_info t = t.server_info
205
+
let server_instructions t = t.server_instructions
206
+
207
+
(** {1 Basic Operations} *)
208
+
209
+
let ping t =
210
+
let params = Messages.Ping.make_params () in
211
+
let params_json = encode Messages.Ping.params_jsont params in
212
+
let response_json = Session.send_request t.session
213
+
~method_:Messages.Ping.method_
214
+
~params:params_json
215
+
()
216
+
in
217
+
let _result = decode Messages.Ping.result_jsont response_json in
218
+
()
219
+
220
+
(** {1 Resources} *)
221
+
222
+
let list_resources t ?cursor () =
223
+
let request = Messages.Resources.make_list_request ?cursor () in
224
+
let params_json = encode Messages.Resources.list_request_jsont request in
225
+
let response_json = Session.send_request t.session
226
+
~method_:Messages.Resources.list_method
227
+
~params:params_json
228
+
()
229
+
in
230
+
decode Messages.Resources.list_result_jsont response_json
231
+
232
+
let read_resource t ~uri =
233
+
let request = Messages.Resources.make_read_request ~uri in
234
+
let params_json = encode Messages.Resources.read_request_jsont request in
235
+
let response_json = Session.send_request t.session
236
+
~method_:Messages.Resources.read_method
237
+
~params:params_json
238
+
()
239
+
in
240
+
decode Messages.Resources.read_result_jsont response_json
241
+
242
+
let subscribe_resource t ~uri =
243
+
let request = Messages.Resources.make_subscribe_request ~uri in
244
+
let params_json = encode Messages.Resources.subscribe_request_jsont request in
245
+
let _response_json = Session.send_request t.session
246
+
~method_:Messages.Resources.subscribe_method
247
+
~params:params_json
248
+
()
249
+
in
250
+
()
251
+
252
+
let unsubscribe_resource t ~uri =
253
+
let request = Messages.Resources.make_unsubscribe_request ~uri in
254
+
let params_json = encode Messages.Resources.unsubscribe_request_jsont request in
255
+
let _response_json = Session.send_request t.session
256
+
~method_:Messages.Resources.unsubscribe_method
257
+
~params:params_json
258
+
()
259
+
in
260
+
()
261
+
262
+
(** {1 Tools} *)
263
+
264
+
let list_tools t ?cursor () =
265
+
let request = Messages.Tools.make_list_request ?cursor () in
266
+
let params_json = encode Messages.Tools.list_request_jsont request in
267
+
let response_json = Session.send_request t.session
268
+
~method_:Messages.Tools.list_method
269
+
~params:params_json
270
+
()
271
+
in
272
+
decode Messages.Tools.list_result_jsont response_json
273
+
274
+
let call_tool t ~name ?arguments () =
275
+
let request = Messages.Tools.make_call_request ~name ?arguments () in
276
+
let params_json = encode Messages.Tools.call_request_jsont request in
277
+
let response_json = Session.send_request t.session
278
+
~method_:Messages.Tools.call_method
279
+
~params:params_json
280
+
()
281
+
in
282
+
decode Messages.Tools.call_result_jsont response_json
283
+
284
+
(** {1 Prompts} *)
285
+
286
+
let list_prompts t ?cursor () =
287
+
let request = Messages.Prompts.make_list_request ?cursor () in
288
+
let params_json = encode Messages.Prompts.list_request_jsont request in
289
+
let response_json = Session.send_request t.session
290
+
~method_:Messages.Prompts.list_method
291
+
~params:params_json
292
+
()
293
+
in
294
+
decode Messages.Prompts.list_result_jsont response_json
295
+
296
+
let get_prompt t ~name ?arguments () =
297
+
let request = Messages.Prompts.make_get_request ~name ?arguments () in
298
+
let params_json = encode Messages.Prompts.get_request_jsont request in
299
+
let response_json = Session.send_request t.session
300
+
~method_:Messages.Prompts.get_method
301
+
~params:params_json
302
+
()
303
+
in
304
+
decode Messages.Prompts.get_result_jsont response_json
305
+
306
+
(** {1 Completions} *)
307
+
308
+
let complete t ~ref ~argument =
309
+
let request = Messages.Completions.make_request ~ref_:ref ~argument () in
310
+
let params_json = encode Messages.Completions.request_jsont request in
311
+
let response_json = Session.send_request t.session
312
+
~method_:Messages.Completions.method_
313
+
~params:params_json
314
+
()
315
+
in
316
+
decode Messages.Completions.result_jsont response_json
317
+
318
+
(** {1 Logging} *)
319
+
320
+
let set_log_level t level =
321
+
(* Create a simple request with level parameter *)
322
+
let level_json = encode Messages.Logging.level_jsont level in
323
+
let params = Jsont.Object ([
324
+
(("level", Jsont.Meta.none), level_json)
325
+
], Jsont.Meta.none) in
326
+
let _response_json = Session.send_request t.session
327
+
~method_:"logging/setLevel"
328
+
~params
329
+
()
330
+
in
331
+
()
332
+
333
+
(** {1 Notification Handlers} *)
334
+
335
+
let on_resource_updated t handler =
336
+
t.handlers.on_resource_updated <- Some handler
337
+
338
+
let on_resource_list_changed t handler =
339
+
t.handlers.on_resource_list_changed <- Some handler
340
+
341
+
let on_tool_list_changed t handler =
342
+
t.handlers.on_tool_list_changed <- Some handler
343
+
344
+
let on_prompt_list_changed t handler =
345
+
t.handlers.on_prompt_list_changed <- Some handler
346
+
347
+
let on_log_message t handler =
348
+
t.handlers.on_log_message <- Some handler
349
+
350
+
(** {1 Session Control} *)
351
+
352
+
let close t =
353
+
Session.close t.session
354
+
355
+
let is_closed t =
356
+
Session.is_closed t.session
+217
claudeio/lib_mcp/client_session.mli
+217
claudeio/lib_mcp/client_session.mli
···
1
+
(** High-level MCP client session API.
2
+
3
+
This module provides a high-level client API for connecting to MCP servers.
4
+
It handles the initialization handshake, capability negotiation, and provides
5
+
typed methods for all MCP protocol operations.
6
+
7
+
{1 Example Usage}
8
+
9
+
{[
10
+
Eio_main.run @@ fun env ->
11
+
Eio.Switch.run @@ fun sw ->
12
+
let transport = Transport_stdio.create ~sw (module Eio.Stdenv : Eio.Stdenv.S with type t = _) env in
13
+
14
+
let config = {
15
+
client_info = Capabilities.Implementation.make
16
+
~name:"my-client"
17
+
~version:"1.0.0";
18
+
client_capabilities = Capabilities.Client.make
19
+
~roots:(Capabilities.Roots.make ~list_changed:true ())
20
+
();
21
+
} in
22
+
23
+
let client = Client_session.create ~sw ~transport config in
24
+
25
+
(* List available tools *)
26
+
let tools_result = Client_session.list_tools client () in
27
+
List.iter (fun tool ->
28
+
Printf.printf "Tool: %s\n" tool.Messages.Tools.name
29
+
) tools_result.Messages.Tools.tools;
30
+
31
+
(* Call a tool *)
32
+
let args = `Object [("query", `String "hello")] in
33
+
let result = Client_session.call_tool client
34
+
~name:"search"
35
+
~arguments:args
36
+
()
37
+
in
38
+
39
+
Client_session.close client
40
+
]} *)
41
+
42
+
(** {1 Configuration} *)
43
+
44
+
type config = {
45
+
client_info : Capabilities.Implementation.t;
46
+
(** Client implementation information (name and version) *)
47
+
client_capabilities : Capabilities.Client.t;
48
+
(** Client capabilities to advertise to server *)
49
+
}
50
+
(** Client session configuration *)
51
+
52
+
(** {1 Session Management} *)
53
+
54
+
type t
55
+
(** Client session handle *)
56
+
57
+
exception Initialization_error of string
58
+
(** Raised when initialization handshake fails *)
59
+
60
+
val create :
61
+
sw:Eio.Switch.t ->
62
+
transport:Transport.t ->
63
+
?timeout:float ->
64
+
?clock:Session.clock ->
65
+
config ->
66
+
t
67
+
(** Create a client session and perform the initialization handshake.
68
+
69
+
This sends an Initialize request to the server, stores the server's
70
+
capabilities and info, then sends an Initialized notification.
71
+
72
+
@param sw Switch for background fibers
73
+
@param transport Transport layer for communication
74
+
@param timeout Optional request timeout in seconds
75
+
@param clock Clock for timeout handling (required if timeout is set)
76
+
@param config Client configuration
77
+
@raise Initialization_error if the handshake fails
78
+
@raise Session.Remote_error if the server returns an error
79
+
@raise Session.Timeout if the initialize request times out *)
80
+
81
+
(** {1 Server Information} *)
82
+
83
+
val server_capabilities : t -> Capabilities.Server.t
84
+
(** Get the server's advertised capabilities from initialization *)
85
+
86
+
val server_info : t -> Capabilities.Implementation.t
87
+
(** Get the server's implementation info (name and version) *)
88
+
89
+
val server_instructions : t -> string option
90
+
(** Get optional server instructions from initialization *)
91
+
92
+
(** {1 Basic Operations} *)
93
+
94
+
val ping : t -> unit
95
+
(** Send a ping request to the server (keepalive).
96
+
@raise Session.Remote_error if the server returns an error
97
+
@raise Session.Timeout if the request times out
98
+
@raise Session.Session_closed if the session is closed *)
99
+
100
+
(** {1 Resources} *)
101
+
102
+
val list_resources : t -> ?cursor:string -> unit -> Messages.Resources.list_result
103
+
(** List available resources.
104
+
@param cursor Optional pagination cursor
105
+
@raise Session.Remote_error if the server returns an error
106
+
@raise Session.Timeout if the request times out
107
+
@raise Session.Session_closed if the session is closed *)
108
+
109
+
val read_resource : t -> uri:string -> Messages.Resources.read_result
110
+
(** Read resource contents by URI.
111
+
@param uri Resource URI to read
112
+
@raise Session.Remote_error if the server returns an error
113
+
@raise Session.Timeout if the request times out
114
+
@raise Session.Session_closed if the session is closed *)
115
+
116
+
val subscribe_resource : t -> uri:string -> unit
117
+
(** Subscribe to resource update notifications.
118
+
@param uri Resource URI to subscribe to
119
+
@raise Session.Remote_error if the server returns an error
120
+
@raise Session.Timeout if the request times out
121
+
@raise Session.Session_closed if the session is closed *)
122
+
123
+
val unsubscribe_resource : t -> uri:string -> unit
124
+
(** Unsubscribe from resource update notifications.
125
+
@param uri Resource URI to unsubscribe from
126
+
@raise Session.Remote_error if the server returns an error
127
+
@raise Session.Timeout if the request times out
128
+
@raise Session.Session_closed if the session is closed *)
129
+
130
+
(** {1 Tools} *)
131
+
132
+
val list_tools : t -> ?cursor:string -> unit -> Messages.Tools.list_result
133
+
(** List available tools.
134
+
@param cursor Optional pagination cursor
135
+
@raise Session.Remote_error if the server returns an error
136
+
@raise Session.Timeout if the request times out
137
+
@raise Session.Session_closed if the session is closed *)
138
+
139
+
val call_tool : t -> name:string -> ?arguments:Jsont.json -> unit -> Messages.Tools.call_result
140
+
(** Call a tool by name.
141
+
@param name Tool name
142
+
@param arguments Optional tool arguments (JSON object)
143
+
@raise Session.Remote_error if the server returns an error
144
+
@raise Session.Timeout if the request times out
145
+
@raise Session.Session_closed if the session is closed *)
146
+
147
+
(** {1 Prompts} *)
148
+
149
+
val list_prompts : t -> ?cursor:string -> unit -> Messages.Prompts.list_result
150
+
(** List available prompts.
151
+
@param cursor Optional pagination cursor
152
+
@raise Session.Remote_error if the server returns an error
153
+
@raise Session.Timeout if the request times out
154
+
@raise Session.Session_closed if the session is closed *)
155
+
156
+
val get_prompt : t -> name:string -> ?arguments:(string * string) list -> unit -> Messages.Prompts.get_result
157
+
(** Get a prompt by name with optional arguments.
158
+
@param name Prompt name
159
+
@param arguments Optional key-value pairs for prompt arguments
160
+
@raise Session.Remote_error if the server returns an error
161
+
@raise Session.Timeout if the request times out
162
+
@raise Session.Session_closed if the session is closed *)
163
+
164
+
(** {1 Completions} *)
165
+
166
+
val complete : t -> ref:Messages.Completions.completion_ref -> argument:string -> Messages.Completions.result
167
+
(** Request auto-completion suggestions.
168
+
@param ref Completion reference (prompt or resource)
169
+
@param argument Argument value to complete
170
+
@raise Session.Remote_error if the server returns an error
171
+
@raise Session.Timeout if the request times out
172
+
@raise Session.Session_closed if the session is closed *)
173
+
174
+
(** {1 Logging} *)
175
+
176
+
val set_log_level : t -> Messages.Logging.level -> unit
177
+
(** Set the server's logging level.
178
+
Note: This sends a "logging/setLevel" request.
179
+
@param level Desired log level
180
+
@raise Session.Remote_error if the server returns an error
181
+
@raise Session.Timeout if the request times out
182
+
@raise Session.Session_closed if the session is closed *)
183
+
184
+
(** {1 Notification Handlers} *)
185
+
186
+
val on_resource_updated : t -> (uri:string -> unit) -> unit
187
+
(** Register a handler for resource update notifications.
188
+
The handler is called when a subscribed resource is updated.
189
+
Only one handler can be registered at a time (replaces previous handler). *)
190
+
191
+
val on_resource_list_changed : t -> (unit -> unit) -> unit
192
+
(** Register a handler for resource list change notifications.
193
+
The handler is called when the list of available resources changes.
194
+
Only one handler can be registered at a time (replaces previous handler). *)
195
+
196
+
val on_tool_list_changed : t -> (unit -> unit) -> unit
197
+
(** Register a handler for tool list change notifications.
198
+
The handler is called when the list of available tools changes.
199
+
Only one handler can be registered at a time (replaces previous handler). *)
200
+
201
+
val on_prompt_list_changed : t -> (unit -> unit) -> unit
202
+
(** Register a handler for prompt list change notifications.
203
+
The handler is called when the list of available prompts changes.
204
+
Only one handler can be registered at a time (replaces previous handler). *)
205
+
206
+
val on_log_message : t -> (level:Messages.Logging.level -> logger:string option -> data:Jsont.json -> unit) -> unit
207
+
(** Register a handler for log message notifications from the server.
208
+
Only one handler can be registered at a time (replaces previous handler). *)
209
+
210
+
(** {1 Session Control} *)
211
+
212
+
val close : t -> unit
213
+
(** Close the client session and underlying transport.
214
+
This is idempotent - safe to call multiple times. *)
215
+
216
+
val is_closed : t -> bool
217
+
(** Check if the session is closed. *)
+246
claudeio/lib_mcp/content.ml
+246
claudeio/lib_mcp/content.ml
···
1
+
(** MCP Content Block types *)
2
+
3
+
(* Annotations *)
4
+
5
+
module Audience = struct
6
+
type t = User | Assistant
7
+
8
+
let jsont : t Jsont.t =
9
+
Jsont.enum [
10
+
"user", User;
11
+
"assistant", Assistant;
12
+
]
13
+
14
+
let pp fmt = function
15
+
| User -> Format.fprintf fmt "user"
16
+
| Assistant -> Format.fprintf fmt "assistant"
17
+
end
18
+
19
+
module Annotations = struct
20
+
type t = {
21
+
audience : Audience.t list option;
22
+
priority : float option;
23
+
unknown : Jsont.json;
24
+
}
25
+
26
+
let empty =
27
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
28
+
{ audience = None; priority = None; unknown }
29
+
30
+
let jsont : t Jsont.t =
31
+
let make audience priority unknown = { audience; priority; unknown } in
32
+
Jsont.Object.map ~kind:"Annotations" make
33
+
|> Jsont.Object.opt_mem "audience" (Jsont.list Audience.jsont)
34
+
~enc:(fun a -> a.audience)
35
+
|> Jsont.Object.opt_mem "priority" Jsont.number
36
+
~enc:(fun a -> a.priority)
37
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun a -> a.unknown)
38
+
|> Jsont.Object.finish
39
+
40
+
let pp fmt _ann =
41
+
Format.fprintf fmt "{annotations}"
42
+
end
43
+
44
+
(* Text Content *)
45
+
46
+
module Text = struct
47
+
type t = {
48
+
text : string;
49
+
annotations : Annotations.t option;
50
+
unknown : Jsont.json;
51
+
}
52
+
53
+
let make text =
54
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
55
+
{ text; annotations = None; unknown }
56
+
57
+
let jsont : t Jsont.t =
58
+
let make text annotations unknown = { text; annotations; unknown } in
59
+
Jsont.Object.map ~kind:"TextContent" make
60
+
|> Jsont.Object.mem "text" Jsont.string ~enc:(fun t -> t.text)
61
+
|> Jsont.Object.opt_mem "annotations" Annotations.jsont
62
+
~enc:(fun t -> t.annotations)
63
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun t -> t.unknown)
64
+
|> Jsont.Object.finish
65
+
66
+
let pp fmt t =
67
+
Format.fprintf fmt "%S" t.text
68
+
end
69
+
70
+
(* Image Content *)
71
+
72
+
module Image = struct
73
+
type t = {
74
+
data : string;
75
+
mime_type : string;
76
+
annotations : Annotations.t option;
77
+
unknown : Jsont.json;
78
+
}
79
+
80
+
let make ~data ~mime_type =
81
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
82
+
{ data; mime_type; annotations = None; unknown }
83
+
84
+
let jsont : t Jsont.t =
85
+
let make data mime_type annotations unknown =
86
+
{ data; mime_type; annotations; unknown }
87
+
in
88
+
Jsont.Object.map ~kind:"ImageContent" make
89
+
|> Jsont.Object.mem "data" Jsont.string ~enc:(fun i -> i.data)
90
+
|> Jsont.Object.mem "mimeType" Jsont.string ~enc:(fun i -> i.mime_type)
91
+
|> Jsont.Object.opt_mem "annotations" Annotations.jsont
92
+
~enc:(fun i -> i.annotations)
93
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun i -> i.unknown)
94
+
|> Jsont.Object.finish
95
+
96
+
let pp fmt i =
97
+
Format.fprintf fmt "Image(%s, %d bytes)" i.mime_type (String.length i.data)
98
+
end
99
+
100
+
(* Audio Content *)
101
+
102
+
module Audio = struct
103
+
type t = {
104
+
data : string;
105
+
mime_type : string;
106
+
annotations : Annotations.t option;
107
+
unknown : Jsont.json;
108
+
}
109
+
110
+
let make ~data ~mime_type =
111
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
112
+
{ data; mime_type; annotations = None; unknown }
113
+
114
+
let jsont : t Jsont.t =
115
+
let make data mime_type annotations unknown =
116
+
{ data; mime_type; annotations; unknown }
117
+
in
118
+
Jsont.Object.map ~kind:"AudioContent" make
119
+
|> Jsont.Object.mem "data" Jsont.string ~enc:(fun a -> a.data)
120
+
|> Jsont.Object.mem "mimeType" Jsont.string ~enc:(fun a -> a.mime_type)
121
+
|> Jsont.Object.opt_mem "annotations" Annotations.jsont
122
+
~enc:(fun a -> a.annotations)
123
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun a -> a.unknown)
124
+
|> Jsont.Object.finish
125
+
126
+
let pp fmt a =
127
+
Format.fprintf fmt "Audio(%s, %d bytes)" a.mime_type (String.length a.data)
128
+
end
129
+
130
+
(* Embedded Resource *)
131
+
132
+
module Embedded_resource = struct
133
+
type resource = {
134
+
uri : string;
135
+
mime_type : string option;
136
+
text : string option;
137
+
blob : string option;
138
+
unknown : Jsont.json;
139
+
}
140
+
141
+
let resource_jsont : resource Jsont.t =
142
+
let make uri mime_type text blob unknown =
143
+
{ uri; mime_type; text; blob; unknown }
144
+
in
145
+
Jsont.Object.map ~kind:"Resource" make
146
+
|> Jsont.Object.mem "uri" Jsont.string ~enc:(fun r -> r.uri)
147
+
|> Jsont.Object.opt_mem "mimeType" Jsont.string ~enc:(fun r -> r.mime_type)
148
+
|> Jsont.Object.opt_mem "text" Jsont.string ~enc:(fun r -> r.text)
149
+
|> Jsont.Object.opt_mem "blob" Jsont.string ~enc:(fun r -> r.blob)
150
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
151
+
|> Jsont.Object.finish
152
+
153
+
type t = {
154
+
resource : resource;
155
+
annotations : Annotations.t option;
156
+
unknown : Jsont.json;
157
+
}
158
+
159
+
let make_text ~uri ~text ?mime_type () =
160
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
161
+
let resource = {
162
+
uri;
163
+
mime_type;
164
+
text = Some text;
165
+
blob = None;
166
+
unknown;
167
+
} in
168
+
{ resource; annotations = None; unknown }
169
+
170
+
let make_blob ~uri ~blob ~mime_type =
171
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
172
+
let resource = {
173
+
uri;
174
+
mime_type = Some mime_type;
175
+
text = None;
176
+
blob = Some blob;
177
+
unknown;
178
+
} in
179
+
{ resource; annotations = None; unknown }
180
+
181
+
let jsont : t Jsont.t =
182
+
let make resource annotations unknown =
183
+
{ resource; annotations; unknown }
184
+
in
185
+
Jsont.Object.map ~kind:"EmbeddedResource" make
186
+
|> Jsont.Object.mem "resource" resource_jsont ~enc:(fun e -> e.resource)
187
+
|> Jsont.Object.opt_mem "annotations" Annotations.jsont
188
+
~enc:(fun e -> e.annotations)
189
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun e -> e.unknown)
190
+
|> Jsont.Object.finish
191
+
192
+
let pp fmt e =
193
+
Format.fprintf fmt "Resource(%s)" e.resource.uri
194
+
end
195
+
196
+
(* Content Block *)
197
+
198
+
type block =
199
+
| Text of Text.t
200
+
| Image of Image.t
201
+
| Audio of Audio.t
202
+
| Embedded_resource of Embedded_resource.t
203
+
204
+
let block_jsont : block Jsont.t =
205
+
(* Content blocks use "type" discriminator *)
206
+
let case_map kind obj dec = Jsont.Object.Case.map kind obj ~dec in
207
+
208
+
let case_text = case_map "text" Text.jsont (fun v -> Text v) in
209
+
let case_image = case_map "image" Image.jsont (fun v -> Image v) in
210
+
let case_audio = case_map "audio" Audio.jsont (fun v -> Audio v) in
211
+
let case_resource = case_map "resource" Embedded_resource.jsont
212
+
(fun v -> Embedded_resource v)
213
+
in
214
+
215
+
let enc_case = function
216
+
| Text v -> Jsont.Object.Case.value case_text v
217
+
| Image v -> Jsont.Object.Case.value case_image v
218
+
| Audio v -> Jsont.Object.Case.value case_audio v
219
+
| Embedded_resource v -> Jsont.Object.Case.value case_resource v
220
+
in
221
+
222
+
let cases = Jsont.Object.Case.[
223
+
make case_text;
224
+
make case_image;
225
+
make case_audio;
226
+
make case_resource;
227
+
] in
228
+
229
+
Jsont.Object.map ~kind:"ContentBlock" Fun.id
230
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
231
+
~tag_to_string:Fun.id ~tag_compare:String.compare
232
+
|> Jsont.Object.finish
233
+
234
+
let pp_block fmt = function
235
+
| Text t -> Text.pp fmt t
236
+
| Image i -> Image.pp fmt i
237
+
| Audio a -> Audio.pp fmt a
238
+
| Embedded_resource e -> Embedded_resource.pp fmt e
239
+
240
+
(* Convenience constructors *)
241
+
242
+
let text s = Text (Text.make s)
243
+
244
+
let image ~data ~mime_type = Image (Image.make ~data ~mime_type)
245
+
246
+
let audio ~data ~mime_type = Audio (Audio.make ~data ~mime_type)
+125
claudeio/lib_mcp/content.mli
+125
claudeio/lib_mcp/content.mli
···
1
+
(** MCP Content Block types.
2
+
3
+
Content blocks are the building blocks for tool results, prompts, and resource contents.
4
+
They support text, images, audio, embedded resources, and tool use/results. *)
5
+
6
+
(** {1 Annotations} *)
7
+
8
+
module Audience : sig
9
+
type t = User | Assistant
10
+
(** Who should see this content *)
11
+
12
+
val jsont : t Jsont.t
13
+
val pp : Format.formatter -> t -> unit
14
+
end
15
+
16
+
module Annotations : sig
17
+
type t = {
18
+
audience : Audience.t list option;
19
+
priority : float option;
20
+
unknown : Jsont.json;
21
+
}
22
+
(** Hints about content visibility and importance *)
23
+
24
+
val empty : t
25
+
val jsont : t Jsont.t
26
+
val pp : Format.formatter -> t -> unit
27
+
end
28
+
29
+
(** {1 Text Content} *)
30
+
31
+
module Text : sig
32
+
type t = {
33
+
text : string;
34
+
annotations : Annotations.t option;
35
+
unknown : Jsont.json;
36
+
}
37
+
(** Plain text content *)
38
+
39
+
val make : string -> t
40
+
val jsont : t Jsont.t
41
+
val pp : Format.formatter -> t -> unit
42
+
end
43
+
44
+
(** {1 Image Content} *)
45
+
46
+
module Image : sig
47
+
type t = {
48
+
data : string; (** Base64-encoded image data *)
49
+
mime_type : string; (** e.g. "image/png" *)
50
+
annotations : Annotations.t option;
51
+
unknown : Jsont.json;
52
+
}
53
+
(** Image content (base64-encoded) *)
54
+
55
+
val make : data:string -> mime_type:string -> t
56
+
val jsont : t Jsont.t
57
+
val pp : Format.formatter -> t -> unit
58
+
end
59
+
60
+
(** {1 Audio Content} *)
61
+
62
+
module Audio : sig
63
+
type t = {
64
+
data : string; (** Base64-encoded audio data *)
65
+
mime_type : string; (** e.g. "audio/mp3" *)
66
+
annotations : Annotations.t option;
67
+
unknown : Jsont.json;
68
+
}
69
+
(** Audio content (base64-encoded) *)
70
+
71
+
val make : data:string -> mime_type:string -> t
72
+
val jsont : t Jsont.t
73
+
val pp : Format.formatter -> t -> unit
74
+
end
75
+
76
+
(** {1 Embedded Resource} *)
77
+
78
+
module Embedded_resource : sig
79
+
type resource = {
80
+
uri : string;
81
+
mime_type : string option;
82
+
text : string option;
83
+
blob : string option; (** Base64-encoded binary data *)
84
+
unknown : Jsont.json;
85
+
}
86
+
(** Resource contents *)
87
+
88
+
type t = {
89
+
resource : resource;
90
+
annotations : Annotations.t option;
91
+
unknown : Jsont.json;
92
+
}
93
+
(** Embedded resource content *)
94
+
95
+
val make_text : uri:string -> text:string -> ?mime_type:string -> unit -> t
96
+
val make_blob : uri:string -> blob:string -> mime_type:string -> t
97
+
val jsont : t Jsont.t
98
+
val pp : Format.formatter -> t -> unit
99
+
end
100
+
101
+
(** {1 Content Block} *)
102
+
103
+
type block =
104
+
| Text of Text.t
105
+
| Image of Image.t
106
+
| Audio of Audio.t
107
+
| Embedded_resource of Embedded_resource.t
108
+
(** Content block variants *)
109
+
110
+
val block_jsont : block Jsont.t
111
+
(** Codec for content blocks (discriminated by "type" field) *)
112
+
113
+
val pp_block : Format.formatter -> block -> unit
114
+
(** Pretty-print a content block *)
115
+
116
+
(** {1 Convenience Constructors} *)
117
+
118
+
val text : string -> block
119
+
(** Create a text content block *)
120
+
121
+
val image : data:string -> mime_type:string -> block
122
+
(** Create an image content block *)
123
+
124
+
val audio : data:string -> mime_type:string -> block
125
+
(** Create an audio content block *)
+4
claudeio/lib_mcp/dune
+4
claudeio/lib_mcp/dune
+279
claudeio/lib_mcp/jsonrpc.ml
+279
claudeio/lib_mcp/jsonrpc.ml
···
1
+
(** JSON-RPC 2.0 protocol implementation *)
2
+
3
+
(* Protocol Version *)
4
+
5
+
type jsonrpc = [ `V2 ]
6
+
7
+
let jsonrpc_jsont = Jsont.enum ["2.0", `V2]
8
+
9
+
(* Request/Response Identifiers *)
10
+
11
+
module Id = struct
12
+
type t = [ `String of string | `Number of float | `Null ]
13
+
14
+
let jsont : t Jsont.t =
15
+
let null = Jsont.null `Null in
16
+
let string =
17
+
let dec s = `String s in
18
+
let enc = function `String s -> s | _ -> assert false in
19
+
Jsont.map ~dec ~enc Jsont.string
20
+
in
21
+
let number =
22
+
let dec n = `Number n in
23
+
let enc = function `Number n -> n | _ -> assert false in
24
+
Jsont.map ~dec ~enc Jsont.number
25
+
in
26
+
let enc = function
27
+
| `Null -> null | `String _ -> string | `Number _ -> number
28
+
in
29
+
Jsont.any ~dec_null:null ~dec_string:string ~dec_number:number ~enc ()
30
+
31
+
let to_string = function
32
+
| `String s -> s
33
+
| `Number n -> string_of_float n
34
+
| `Null -> "null"
35
+
36
+
let compare a b = match a, b with
37
+
| `Null, `Null -> 0
38
+
| `Null, _ -> -1
39
+
| _, `Null -> 1
40
+
| `String s1, `String s2 -> String.compare s1 s2
41
+
| `String _, _ -> -1
42
+
| _, `String _ -> 1
43
+
| `Number n1, `Number n2 -> Float.compare n1 n2
44
+
45
+
let pp fmt = function
46
+
| `String s -> Format.fprintf fmt "%S" s
47
+
| `Number n -> Format.fprintf fmt "%g" n
48
+
| `Null -> Format.fprintf fmt "null"
49
+
end
50
+
51
+
(* Error Codes *)
52
+
53
+
module Error_code = struct
54
+
type t =
55
+
| Parse_error
56
+
| Invalid_request
57
+
| Method_not_found
58
+
| Invalid_params
59
+
| Internal_error
60
+
| Connection_closed
61
+
| Server_error of int
62
+
| Other of int
63
+
64
+
let to_int = function
65
+
| Parse_error -> -32700
66
+
| Invalid_request -> -32600
67
+
| Method_not_found -> -32601
68
+
| Invalid_params -> -32602
69
+
| Internal_error -> -32603
70
+
| Connection_closed -> -32000
71
+
| Server_error n -> n
72
+
| Other n -> n
73
+
74
+
let of_int = function
75
+
| -32700 -> Parse_error
76
+
| -32600 -> Invalid_request
77
+
| -32601 -> Method_not_found
78
+
| -32602 -> Invalid_params
79
+
| -32603 -> Internal_error
80
+
| -32000 -> Connection_closed
81
+
| n when n >= -32099 && n <= -32001 -> Server_error n
82
+
| n -> Other n
83
+
84
+
let jsont : t Jsont.t =
85
+
let dec n = of_int n in
86
+
let enc code = to_int code in
87
+
Jsont.map ~dec ~enc Jsont.int
88
+
89
+
let pp fmt code =
90
+
Format.fprintf fmt "%d" (to_int code)
91
+
end
92
+
93
+
(* Error Data *)
94
+
95
+
module Error_data = struct
96
+
type t = {
97
+
code : Error_code.t;
98
+
message : string;
99
+
data : Jsont.json option;
100
+
unknown : Jsont.json;
101
+
}
102
+
103
+
let make ~code ~message ?data () =
104
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
105
+
{ code; message; data; unknown }
106
+
107
+
let jsont : t Jsont.t =
108
+
let make code message data unknown = { code; message; data; unknown } in
109
+
Jsont.Object.map ~kind:"ErrorData" make
110
+
|> Jsont.Object.mem "code" Error_code.jsont ~enc:(fun e -> e.code)
111
+
|> Jsont.Object.mem "message" Jsont.string ~enc:(fun e -> e.message)
112
+
|> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun e -> e.data)
113
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun e -> e.unknown)
114
+
|> Jsont.Object.finish
115
+
116
+
let pp fmt err =
117
+
Format.fprintf fmt "{code=%a, message=%S}" Error_code.pp err.code err.message
118
+
end
119
+
120
+
(* Params *)
121
+
122
+
type params = Jsont.json
123
+
124
+
let params_jsont =
125
+
let enc = function
126
+
| Jsont.Object _ | Jsont.Array _ -> Jsont.json
127
+
| j ->
128
+
let meta = Jsont.Meta.none in
129
+
let fnd = Jsont.Sort.to_string (Jsont.Json.sort j) in
130
+
Jsont.Error.expected meta "object or array" ~fnd
131
+
in
132
+
let kind = "JSON-RPC params" in
133
+
Jsont.any ~kind ~dec_array:Jsont.json ~dec_object:Jsont.json ~enc ()
134
+
135
+
(* Request Message *)
136
+
137
+
module Request = struct
138
+
type t = {
139
+
jsonrpc : jsonrpc;
140
+
method_ : string;
141
+
params : params option;
142
+
id : Id.t option;
143
+
unknown : Jsont.json;
144
+
}
145
+
146
+
let make ~method_ ?params ?id () =
147
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
148
+
{ jsonrpc = `V2; method_; params; id; unknown }
149
+
150
+
let jsont : t Jsont.t =
151
+
let make jsonrpc method_ params id unknown =
152
+
{ jsonrpc; method_; params; id; unknown }
153
+
in
154
+
Jsont.Object.map ~kind:"JSONRPCRequest" make
155
+
|> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
156
+
|> Jsont.Object.mem "method" Jsont.string ~enc:(fun r -> r.method_)
157
+
|> Jsont.Object.opt_mem "params" params_jsont ~enc:(fun r -> r.params)
158
+
|> Jsont.Object.opt_mem "id" Id.jsont ~enc:(fun r -> r.id)
159
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
160
+
|> Jsont.Object.finish
161
+
162
+
let pp fmt req =
163
+
let id_str = match req.id with
164
+
| Some id -> Id.to_string id
165
+
| None -> "none"
166
+
in
167
+
Format.fprintf fmt "{method=%S, id=%s}" req.method_ id_str
168
+
end
169
+
170
+
(* Response Message *)
171
+
172
+
module Response = struct
173
+
type t = {
174
+
jsonrpc : jsonrpc;
175
+
value : (Jsont.json, Error_data.t) result;
176
+
id : Id.t;
177
+
unknown : Jsont.json;
178
+
}
179
+
180
+
let make_result ~id ~result =
181
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
182
+
{ jsonrpc = `V2; value = Ok result; id; unknown }
183
+
184
+
let make_error ~id ~error =
185
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
186
+
{ jsonrpc = `V2; value = Error error; id; unknown }
187
+
188
+
let response_result r = match r.value with Ok v -> Some v | Error _ -> None
189
+
let response_error r = match r.value with Ok _ -> None | Error e -> Some e
190
+
191
+
let response jsonrpc result error id : t =
192
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
193
+
let err_both () =
194
+
Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined"
195
+
Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error"
196
+
in
197
+
let err_none () =
198
+
Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member"
199
+
Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error"
200
+
in
201
+
match result, error with
202
+
| Some result, None -> { jsonrpc; value = Ok result; id; unknown }
203
+
| None, Some error -> { jsonrpc; value = Error error; id; unknown }
204
+
| Some _ , Some _ -> err_both ()
205
+
| None, None -> err_none ()
206
+
207
+
let jsont : t Jsont.t =
208
+
let make jsonrpc result error id unknown =
209
+
let resp = response jsonrpc result error id in
210
+
{ resp with unknown }
211
+
in
212
+
Jsont.Object.map ~kind:"JSONRPCResponse" make
213
+
|> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
214
+
|> Jsont.Object.opt_mem "result" Jsont.json ~enc:response_result
215
+
|> Jsont.Object.opt_mem "error" Error_data.jsont ~enc:response_error
216
+
|> Jsont.Object.mem "id" Id.jsont ~enc:(fun r -> r.id)
217
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
218
+
|> Jsont.Object.finish
219
+
220
+
let pp fmt resp =
221
+
let result_str = match resp.value with
222
+
| Ok _ -> "Ok(...)"
223
+
| Error err -> Format.asprintf "Error(%a)" Error_data.pp err
224
+
in
225
+
Format.fprintf fmt "{id=%a, %s}" Id.pp resp.id result_str
226
+
end
227
+
228
+
(* Message Union *)
229
+
230
+
module Message = struct
231
+
type t =
232
+
| Request of Request.t
233
+
| Response of Response.t
234
+
235
+
let classify json =
236
+
(* Detect message type by presence of fields:
237
+
- "method" -> Request
238
+
- "result" or "error" -> Response *)
239
+
match json with
240
+
| Jsont.Object (members, _) ->
241
+
let has_method = List.exists (fun ((name, _), _) -> name = "method") members in
242
+
let has_result_or_error =
243
+
List.exists (fun ((name, _), _) ->
244
+
name = "result" || name = "error"
245
+
) members
246
+
in
247
+
if has_method then
248
+
match Jsont.Json.decode Request.jsont json with
249
+
| Ok req -> Request req
250
+
| Error msg -> failwith ("Failed to decode request: " ^ msg)
251
+
else if has_result_or_error then
252
+
match Jsont.Json.decode Response.jsont json with
253
+
| Ok resp -> Response resp
254
+
| Error msg -> failwith ("Failed to decode response: " ^ msg)
255
+
else
256
+
failwith "Invalid JSON-RPC message: missing method or result/error"
257
+
| _ ->
258
+
failwith "Invalid JSON-RPC message: not an object"
259
+
260
+
let jsont : t Jsont.t =
261
+
let enc = function
262
+
| Request req ->
263
+
(match Jsont.Json.encode Request.jsont req with
264
+
| Ok json -> json
265
+
| Error msg -> failwith ("Failed to encode request: " ^ msg))
266
+
| Response resp ->
267
+
(match Jsont.Json.encode Response.jsont resp with
268
+
| Ok json -> json
269
+
| Error msg -> failwith ("Failed to encode response: " ^ msg))
270
+
in
271
+
let dec json =
272
+
classify json
273
+
in
274
+
Jsont.map ~kind:"JSONRPCMessage" ~dec ~enc Jsont.json
275
+
276
+
let pp fmt = function
277
+
| Request req -> Format.fprintf fmt "Request(%a)" Request.pp req
278
+
| Response resp -> Format.fprintf fmt "Response(%a)" Response.pp resp
279
+
end
+161
claudeio/lib_mcp/jsonrpc.mli
+161
claudeio/lib_mcp/jsonrpc.mli
···
1
+
(** JSON-RPC 2.0 protocol implementation using jsont.
2
+
3
+
Based on the JSON-RPC 2.0 specification: https://www.jsonrpc.org/
4
+
5
+
This module provides type-safe encoding/decoding of JSON-RPC messages
6
+
with forward-compatible unknown field preservation. *)
7
+
8
+
(** {1 Protocol Version} *)
9
+
10
+
type jsonrpc = [ `V2 ]
11
+
(** JSON-RPC protocol version *)
12
+
13
+
val jsonrpc_jsont : jsonrpc Jsont.t
14
+
(** Codec for protocol version *)
15
+
16
+
(** {1 Request/Response Identifiers} *)
17
+
18
+
module Id : sig
19
+
type t = [ `String of string | `Number of float | `Null ]
20
+
(** Request/response correlation ID.
21
+
Can be a string, number, or null. *)
22
+
23
+
val jsont : t Jsont.t
24
+
(** Codec for IDs *)
25
+
26
+
val to_string : t -> string
27
+
(** Convert ID to string representation *)
28
+
29
+
val compare : t -> t -> int
30
+
(** Compare IDs for ordering *)
31
+
32
+
val pp : Format.formatter -> t -> unit
33
+
(** Pretty-print an ID *)
34
+
end
35
+
36
+
(** {1 Error Codes} *)
37
+
38
+
module Error_code : sig
39
+
type t =
40
+
| Parse_error (** -32700: Invalid JSON *)
41
+
| Invalid_request (** -32600: Invalid Request object *)
42
+
| Method_not_found (** -32601: Method does not exist *)
43
+
| Invalid_params (** -32602: Invalid method parameters *)
44
+
| Internal_error (** -32603: Internal JSON-RPC error *)
45
+
| Connection_closed (** -32000: MCP-specific: connection closed *)
46
+
| Server_error of int (** -32099 to -32000: Server error *)
47
+
| Other of int (** Implementation-defined error *)
48
+
49
+
val jsont : t Jsont.t
50
+
(** Codec for error codes *)
51
+
52
+
val to_int : t -> int
53
+
(** Convert error code to integer *)
54
+
55
+
val of_int : int -> t
56
+
(** Convert integer to error code *)
57
+
58
+
val pp : Format.formatter -> t -> unit
59
+
(** Pretty-print an error code *)
60
+
end
61
+
62
+
(** {1 Error Data} *)
63
+
64
+
module Error_data : sig
65
+
type t = {
66
+
code : Error_code.t;
67
+
message : string;
68
+
data : Jsont.json option;
69
+
unknown : Jsont.json;
70
+
}
71
+
(** Error information *)
72
+
73
+
val make : code:Error_code.t -> message:string -> ?data:Jsont.json -> unit -> t
74
+
(** Create error data *)
75
+
76
+
val jsont : t Jsont.t
77
+
(** Codec for error data *)
78
+
79
+
val pp : Format.formatter -> t -> unit
80
+
(** Pretty-print error data *)
81
+
end
82
+
83
+
(** {1 Params} *)
84
+
85
+
type params = Jsont.json
86
+
(** Parameters for requests (must be Array or Object) *)
87
+
88
+
val params_jsont : params Jsont.t
89
+
(** Codec for params (validates array or object) *)
90
+
91
+
(** {1 Request Message} *)
92
+
93
+
module Request : sig
94
+
type t = {
95
+
jsonrpc : jsonrpc;
96
+
method_ : string;
97
+
params : params option;
98
+
id : Id.t option;
99
+
unknown : Jsont.json;
100
+
}
101
+
(** JSON-RPC request.
102
+
- If [id] is [Some _], expects a response
103
+
- If [id] is [None], it's a notification (no response) *)
104
+
105
+
val make :
106
+
method_:string ->
107
+
?params:params ->
108
+
?id:Id.t ->
109
+
unit ->
110
+
t
111
+
(** Create a request *)
112
+
113
+
val jsont : t Jsont.t
114
+
(** Codec for requests *)
115
+
116
+
val pp : Format.formatter -> t -> unit
117
+
(** Pretty-print a request *)
118
+
end
119
+
120
+
(** {1 Response Message} *)
121
+
122
+
module Response : sig
123
+
type t = {
124
+
jsonrpc : jsonrpc;
125
+
value : (Jsont.json, Error_data.t) result;
126
+
id : Id.t;
127
+
unknown : Jsont.json;
128
+
}
129
+
(** JSON-RPC response.
130
+
Either contains [Ok result] or [Error error]. *)
131
+
132
+
val make_result : id:Id.t -> result:Jsont.json -> t
133
+
(** Create a successful response *)
134
+
135
+
val make_error : id:Id.t -> error:Error_data.t -> t
136
+
(** Create an error response *)
137
+
138
+
val jsont : t Jsont.t
139
+
(** Codec for responses *)
140
+
141
+
val pp : Format.formatter -> t -> unit
142
+
(** Pretty-print a response *)
143
+
end
144
+
145
+
(** {1 Message Union} *)
146
+
147
+
module Message : sig
148
+
type t =
149
+
| Request of Request.t
150
+
| Response of Response.t
151
+
(** Union of all JSON-RPC message types *)
152
+
153
+
val jsont : t Jsont.t
154
+
(** Codec for messages *)
155
+
156
+
val classify : Jsont.json -> t
157
+
(** Classify a JSON value as a specific message type *)
158
+
159
+
val pp : Format.formatter -> t -> unit
160
+
(** Pretty-print a message *)
161
+
end
+11
claudeio/lib_mcp/mcp.ml
+11
claudeio/lib_mcp/mcp.ml
···
1
+
(** Model Context Protocol (MCP) OCaml Implementation *)
2
+
3
+
module Jsonrpc = Jsonrpc
4
+
module Content = Content
5
+
module Capabilities = Capabilities
6
+
module Messages = Messages
7
+
module Session = Session
8
+
module Transport = Transport
9
+
module Transport_stdio = Transport_stdio
10
+
module Server_session = Server_session
11
+
module Client_session = Client_session
+63
claudeio/lib_mcp/mcp.mli
+63
claudeio/lib_mcp/mcp.mli
···
1
+
(** Model Context Protocol (MCP) OCaml Implementation.
2
+
3
+
This library provides a type-safe, Eio-based implementation of the Model Context Protocol,
4
+
using jsont for JSON serialization with forward-compatible unknown field preservation.
5
+
6
+
{1 Quick Start}
7
+
8
+
The MCP library is organized into several modules:
9
+
10
+
- {!Jsonrpc}: JSON-RPC 2.0 protocol layer
11
+
- {!Content}: Content block types (text, image, audio, resources)
12
+
- {!Capabilities}: Client and server capability negotiation
13
+
14
+
{1 Example}
15
+
16
+
{[
17
+
open Mcp
18
+
19
+
(* Create client capabilities *)
20
+
let client_caps = Capabilities.Client.make
21
+
~sampling:(Capabilities.Sampling.make ~tools:true ())
22
+
()
23
+
24
+
(* Create content blocks *)
25
+
let text_block = Content.text "Hello, MCP!"
26
+
let image_block = Content.image ~data:"..." ~mime_type:"image/png"
27
+
]}
28
+
29
+
{1 Design Principles}
30
+
31
+
- {b Type Safety}: All protocol types use jsont codecs for bidirectional JSON serialization
32
+
- {b Forward Compatibility}: Unknown fields are preserved in all types
33
+
- {b Eio Integration}: Uses Eio for structured concurrency
34
+
- {b Protocol Compliance}: Follows MCP specification exactly
35
+
36
+
{1 Modules} *)
37
+
38
+
(** JSON-RPC 2.0 protocol implementation *)
39
+
module Jsonrpc : module type of Jsonrpc
40
+
41
+
(** MCP content block types *)
42
+
module Content : module type of Content
43
+
44
+
(** Client and server capability negotiation *)
45
+
module Capabilities : module type of Capabilities
46
+
47
+
(** MCP protocol messages (initialize, resources, tools, prompts, logging, etc.) *)
48
+
module Messages : module type of Messages
49
+
50
+
(** Bidirectional JSON-RPC session management *)
51
+
module Session : module type of Session
52
+
53
+
(** Transport layer for JSON-RPC communication *)
54
+
module Transport : module type of Transport
55
+
56
+
(** Stdio transport implementation *)
57
+
module Transport_stdio : module type of Transport_stdio
58
+
59
+
(** High-level MCP server session API *)
60
+
module Server_session : module type of Server_session
61
+
62
+
(** High-level MCP client session API *)
63
+
module Client_session : module type of Client_session
+900
claudeio/lib_mcp/messages.ml
+900
claudeio/lib_mcp/messages.ml
···
1
+
(** MCP Protocol Messages *)
2
+
3
+
(* Protocol Version *)
4
+
5
+
type protocol_version = string
6
+
7
+
let protocol_version_jsont = Jsont.string
8
+
9
+
(* Initialize Protocol *)
10
+
11
+
module Initialize = struct
12
+
type request_params = {
13
+
protocol_version : protocol_version;
14
+
capabilities : Capabilities.Client.t;
15
+
client_info : Capabilities.Implementation.t;
16
+
unknown : Jsont.json;
17
+
}
18
+
19
+
let make_request_params ~protocol_version ~capabilities ~client_info () =
20
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
21
+
{ protocol_version; capabilities; client_info; unknown }
22
+
23
+
let request_params_jsont : request_params Jsont.t =
24
+
let make protocol_version capabilities client_info unknown =
25
+
{ protocol_version; capabilities; client_info; unknown }
26
+
in
27
+
Jsont.Object.map ~kind:"InitializeRequestParams" make
28
+
|> Jsont.Object.mem "protocolVersion" protocol_version_jsont
29
+
~enc:(fun p -> p.protocol_version)
30
+
|> Jsont.Object.mem "capabilities" Capabilities.Client.jsont
31
+
~enc:(fun p -> p.capabilities)
32
+
|> Jsont.Object.mem "clientInfo" Capabilities.Implementation.jsont
33
+
~enc:(fun p -> p.client_info)
34
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun p -> p.unknown)
35
+
|> Jsont.Object.finish
36
+
37
+
type result = {
38
+
protocol_version : protocol_version;
39
+
capabilities : Capabilities.Server.t;
40
+
server_info : Capabilities.Implementation.t;
41
+
instructions : string option;
42
+
unknown : Jsont.json;
43
+
}
44
+
45
+
let make_result ~protocol_version ~capabilities ~server_info ?instructions () =
46
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
47
+
{ protocol_version; capabilities; server_info; instructions; unknown }
48
+
49
+
let result_jsont : result Jsont.t =
50
+
let make protocol_version capabilities server_info instructions unknown =
51
+
{ protocol_version; capabilities; server_info; instructions; unknown }
52
+
in
53
+
Jsont.Object.map ~kind:"InitializeResult" make
54
+
|> Jsont.Object.mem "protocolVersion" protocol_version_jsont
55
+
~enc:(fun r -> r.protocol_version)
56
+
|> Jsont.Object.mem "capabilities" Capabilities.Server.jsont
57
+
~enc:(fun r -> r.capabilities)
58
+
|> Jsont.Object.mem "serverInfo" Capabilities.Implementation.jsont
59
+
~enc:(fun r -> r.server_info)
60
+
|> Jsont.Object.opt_mem "instructions" Jsont.string
61
+
~enc:(fun r -> r.instructions)
62
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
63
+
|> Jsont.Object.finish
64
+
65
+
let method_ = "initialize"
66
+
end
67
+
68
+
module Initialized = struct
69
+
type notification = {
70
+
unknown : Jsont.json;
71
+
}
72
+
73
+
let make_notification () =
74
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
75
+
{ unknown }
76
+
77
+
let notification_jsont : notification Jsont.t =
78
+
let make unknown = { unknown } in
79
+
Jsont.Object.map ~kind:"InitializedNotification" make
80
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun n -> n.unknown)
81
+
|> Jsont.Object.finish
82
+
83
+
let method_ = "notifications/initialized"
84
+
end
85
+
86
+
module Ping = struct
87
+
type params = {
88
+
unknown : Jsont.json;
89
+
}
90
+
91
+
let make_params () =
92
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
93
+
{ unknown }
94
+
95
+
let params_jsont : params Jsont.t =
96
+
let make unknown = { unknown } in
97
+
Jsont.Object.map ~kind:"PingParams" make
98
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun p -> p.unknown)
99
+
|> Jsont.Object.finish
100
+
101
+
type result = {
102
+
unknown : Jsont.json;
103
+
}
104
+
105
+
let make_result () =
106
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
107
+
{ unknown }
108
+
109
+
let result_jsont : result Jsont.t =
110
+
let make unknown = { unknown } in
111
+
Jsont.Object.map ~kind:"PingResult" make
112
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
113
+
|> Jsont.Object.finish
114
+
115
+
let method_ = "ping"
116
+
end
117
+
118
+
(* Resources *)
119
+
120
+
module Resources = struct
121
+
type resource = {
122
+
uri : string;
123
+
name : string;
124
+
description : string option;
125
+
mime_type : string option;
126
+
unknown : Jsont.json;
127
+
}
128
+
129
+
let make_resource ~uri ~name ?description ?mime_type () =
130
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
131
+
{ uri; name; description; mime_type; unknown }
132
+
133
+
let resource_jsont : resource Jsont.t =
134
+
let make uri name description mime_type unknown =
135
+
{ uri; name; description; mime_type; unknown }
136
+
in
137
+
Jsont.Object.map ~kind:"Resource" make
138
+
|> Jsont.Object.mem "uri" Jsont.string ~enc:(fun r -> r.uri)
139
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun r -> r.name)
140
+
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:(fun r -> r.description)
141
+
|> Jsont.Object.opt_mem "mimeType" Jsont.string ~enc:(fun r -> r.mime_type)
142
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
143
+
|> Jsont.Object.finish
144
+
145
+
type resource_template = {
146
+
uri_template : string;
147
+
name : string;
148
+
description : string option;
149
+
mime_type : string option;
150
+
unknown : Jsont.json;
151
+
}
152
+
153
+
let make_resource_template ~uri_template ~name ?description ?mime_type () =
154
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
155
+
{ uri_template; name; description; mime_type; unknown }
156
+
157
+
let resource_template_jsont : resource_template Jsont.t =
158
+
let make uri_template name description mime_type unknown =
159
+
{ uri_template; name; description; mime_type; unknown }
160
+
in
161
+
Jsont.Object.map ~kind:"ResourceTemplate" make
162
+
|> Jsont.Object.mem "uriTemplate" Jsont.string ~enc:(fun t -> t.uri_template)
163
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun t -> t.name)
164
+
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:(fun t -> t.description)
165
+
|> Jsont.Object.opt_mem "mimeType" Jsont.string ~enc:(fun t -> t.mime_type)
166
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun t -> t.unknown)
167
+
|> Jsont.Object.finish
168
+
169
+
type resource_contents = {
170
+
uri : string;
171
+
mime_type : string option;
172
+
text : string option;
173
+
blob : string option;
174
+
unknown : Jsont.json;
175
+
}
176
+
177
+
let make_text_contents ~uri ~text ?mime_type () =
178
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
179
+
{ uri; mime_type; text = Some text; blob = None; unknown }
180
+
181
+
let make_blob_contents ~uri ~blob ~mime_type =
182
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
183
+
{ uri; mime_type = Some mime_type; text = None; blob = Some blob; unknown }
184
+
185
+
let resource_contents_jsont : resource_contents Jsont.t =
186
+
let make uri mime_type text blob unknown =
187
+
{ uri; mime_type; text; blob; unknown }
188
+
in
189
+
Jsont.Object.map ~kind:"ResourceContents" make
190
+
|> Jsont.Object.mem "uri" Jsont.string ~enc:(fun c -> c.uri)
191
+
|> Jsont.Object.opt_mem "mimeType" Jsont.string ~enc:(fun c -> c.mime_type)
192
+
|> Jsont.Object.opt_mem "text" Jsont.string ~enc:(fun c -> c.text)
193
+
|> Jsont.Object.opt_mem "blob" Jsont.string ~enc:(fun c -> c.blob)
194
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun c -> c.unknown)
195
+
|> Jsont.Object.finish
196
+
197
+
type list_request = {
198
+
cursor : string option;
199
+
unknown : Jsont.json;
200
+
}
201
+
202
+
let make_list_request ?cursor () =
203
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
204
+
{ cursor; unknown }
205
+
206
+
let list_request_jsont : list_request Jsont.t =
207
+
let make cursor unknown = { cursor; unknown } in
208
+
Jsont.Object.map ~kind:"ResourcesListRequest" make
209
+
|> Jsont.Object.opt_mem "cursor" Jsont.string ~enc:(fun r -> r.cursor)
210
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
211
+
|> Jsont.Object.finish
212
+
213
+
type list_result = {
214
+
resources : resource list;
215
+
next_cursor : string option;
216
+
unknown : Jsont.json;
217
+
}
218
+
219
+
let make_list_result ~resources ?next_cursor () =
220
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
221
+
{ resources; next_cursor; unknown }
222
+
223
+
let list_result_jsont : list_result Jsont.t =
224
+
let make resources next_cursor unknown =
225
+
{ resources; next_cursor; unknown }
226
+
in
227
+
Jsont.Object.map ~kind:"ResourcesListResult" make
228
+
|> Jsont.Object.mem "resources" (Jsont.list resource_jsont)
229
+
~enc:(fun r -> r.resources)
230
+
|> Jsont.Object.opt_mem "nextCursor" Jsont.string
231
+
~enc:(fun r -> r.next_cursor)
232
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
233
+
|> Jsont.Object.finish
234
+
235
+
type read_request = {
236
+
uri : string;
237
+
unknown : Jsont.json;
238
+
}
239
+
240
+
let make_read_request ~uri =
241
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
242
+
{ uri; unknown }
243
+
244
+
let read_request_jsont : read_request Jsont.t =
245
+
let make uri unknown = { uri; unknown } in
246
+
Jsont.Object.map ~kind:"ResourcesReadRequest" make
247
+
|> Jsont.Object.mem "uri" Jsont.string ~enc:(fun r -> r.uri)
248
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
249
+
|> Jsont.Object.finish
250
+
251
+
type read_result = {
252
+
contents : resource_contents list;
253
+
unknown : Jsont.json;
254
+
}
255
+
256
+
let make_read_result ~contents =
257
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
258
+
{ contents; unknown }
259
+
260
+
let read_result_jsont : read_result Jsont.t =
261
+
let make contents unknown = { contents; unknown } in
262
+
Jsont.Object.map ~kind:"ResourcesReadResult" make
263
+
|> Jsont.Object.mem "contents" (Jsont.list resource_contents_jsont)
264
+
~enc:(fun r -> r.contents)
265
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
266
+
|> Jsont.Object.finish
267
+
268
+
type subscribe_request = {
269
+
uri : string;
270
+
unknown : Jsont.json;
271
+
}
272
+
273
+
let make_subscribe_request ~uri =
274
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
275
+
{ uri; unknown }
276
+
277
+
let subscribe_request_jsont : subscribe_request Jsont.t =
278
+
let make uri unknown = { uri; unknown } in
279
+
Jsont.Object.map ~kind:"ResourcesSubscribeRequest" make
280
+
|> Jsont.Object.mem "uri" Jsont.string ~enc:(fun r -> r.uri)
281
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
282
+
|> Jsont.Object.finish
283
+
284
+
type unsubscribe_request = {
285
+
uri : string;
286
+
unknown : Jsont.json;
287
+
}
288
+
289
+
let make_unsubscribe_request ~uri =
290
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
291
+
{ uri; unknown }
292
+
293
+
let unsubscribe_request_jsont : unsubscribe_request Jsont.t =
294
+
let make uri unknown = { uri; unknown } in
295
+
Jsont.Object.map ~kind:"ResourcesUnsubscribeRequest" make
296
+
|> Jsont.Object.mem "uri" Jsont.string ~enc:(fun r -> r.uri)
297
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
298
+
|> Jsont.Object.finish
299
+
300
+
type updated_notification = {
301
+
uri : string;
302
+
unknown : Jsont.json;
303
+
}
304
+
305
+
let make_updated_notification ~uri =
306
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
307
+
{ uri; unknown }
308
+
309
+
let updated_notification_jsont : updated_notification Jsont.t =
310
+
let make uri unknown = { uri; unknown } in
311
+
Jsont.Object.map ~kind:"ResourceUpdatedNotification" make
312
+
|> Jsont.Object.mem "uri" Jsont.string ~enc:(fun n -> n.uri)
313
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun n -> n.unknown)
314
+
|> Jsont.Object.finish
315
+
316
+
type list_changed_notification = {
317
+
unknown : Jsont.json;
318
+
}
319
+
320
+
let make_list_changed_notification () =
321
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
322
+
{ unknown }
323
+
324
+
let list_changed_notification_jsont : list_changed_notification Jsont.t =
325
+
let make unknown = { unknown } in
326
+
Jsont.Object.map ~kind:"ResourceListChangedNotification" make
327
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun n -> n.unknown)
328
+
|> Jsont.Object.finish
329
+
330
+
let list_method = "resources/list"
331
+
let read_method = "resources/read"
332
+
let subscribe_method = "resources/subscribe"
333
+
let unsubscribe_method = "resources/unsubscribe"
334
+
let updated_notification_method = "notifications/resources/updated"
335
+
let list_changed_notification_method = "notifications/resources/list_changed"
336
+
end
337
+
338
+
(* Tools *)
339
+
340
+
module Tools = struct
341
+
type tool = {
342
+
name : string;
343
+
description : string option;
344
+
input_schema : Jsont.json;
345
+
unknown : Jsont.json;
346
+
}
347
+
348
+
let make_tool ~name ?description ~input_schema () =
349
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
350
+
{ name; description; input_schema; unknown }
351
+
352
+
let tool_jsont : tool Jsont.t =
353
+
let make name description input_schema unknown =
354
+
{ name; description; input_schema; unknown }
355
+
in
356
+
Jsont.Object.map ~kind:"Tool" make
357
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun t -> t.name)
358
+
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:(fun t -> t.description)
359
+
|> Jsont.Object.mem "inputSchema" Jsont.json ~enc:(fun t -> t.input_schema)
360
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun t -> t.unknown)
361
+
|> Jsont.Object.finish
362
+
363
+
type list_request = {
364
+
cursor : string option;
365
+
unknown : Jsont.json;
366
+
}
367
+
368
+
let make_list_request ?cursor () =
369
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
370
+
{ cursor; unknown }
371
+
372
+
let list_request_jsont : list_request Jsont.t =
373
+
let make cursor unknown = { cursor; unknown } in
374
+
Jsont.Object.map ~kind:"ToolsListRequest" make
375
+
|> Jsont.Object.opt_mem "cursor" Jsont.string ~enc:(fun r -> r.cursor)
376
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
377
+
|> Jsont.Object.finish
378
+
379
+
type list_result = {
380
+
tools : tool list;
381
+
next_cursor : string option;
382
+
unknown : Jsont.json;
383
+
}
384
+
385
+
let make_list_result ~tools ?next_cursor () =
386
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
387
+
{ tools; next_cursor; unknown }
388
+
389
+
let list_result_jsont : list_result Jsont.t =
390
+
let make tools next_cursor unknown =
391
+
{ tools; next_cursor; unknown }
392
+
in
393
+
Jsont.Object.map ~kind:"ToolsListResult" make
394
+
|> Jsont.Object.mem "tools" (Jsont.list tool_jsont)
395
+
~enc:(fun r -> r.tools)
396
+
|> Jsont.Object.opt_mem "nextCursor" Jsont.string
397
+
~enc:(fun r -> r.next_cursor)
398
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
399
+
|> Jsont.Object.finish
400
+
401
+
type call_request = {
402
+
name : string;
403
+
arguments : Jsont.json option;
404
+
unknown : Jsont.json;
405
+
}
406
+
407
+
let make_call_request ~name ?arguments () =
408
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
409
+
{ name; arguments; unknown }
410
+
411
+
let call_request_jsont : call_request Jsont.t =
412
+
let make name arguments unknown = { name; arguments; unknown } in
413
+
Jsont.Object.map ~kind:"ToolsCallRequest" make
414
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun r -> r.name)
415
+
|> Jsont.Object.opt_mem "arguments" Jsont.json ~enc:(fun r -> r.arguments)
416
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
417
+
|> Jsont.Object.finish
418
+
419
+
type call_result = {
420
+
content : Content.block list;
421
+
is_error : bool option;
422
+
unknown : Jsont.json;
423
+
}
424
+
425
+
let make_call_result ~content ?is_error () =
426
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
427
+
{ content; is_error; unknown }
428
+
429
+
let call_result_jsont : call_result Jsont.t =
430
+
let make content is_error unknown =
431
+
{ content; is_error; unknown }
432
+
in
433
+
Jsont.Object.map ~kind:"ToolsCallResult" make
434
+
|> Jsont.Object.mem "content" (Jsont.list Content.block_jsont)
435
+
~enc:(fun r -> r.content)
436
+
|> Jsont.Object.opt_mem "isError" Jsont.bool ~enc:(fun r -> r.is_error)
437
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
438
+
|> Jsont.Object.finish
439
+
440
+
type list_changed_notification = {
441
+
unknown : Jsont.json;
442
+
}
443
+
444
+
let make_list_changed_notification () =
445
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
446
+
{ unknown }
447
+
448
+
let list_changed_notification_jsont : list_changed_notification Jsont.t =
449
+
let make unknown = { unknown } in
450
+
Jsont.Object.map ~kind:"ToolsListChangedNotification" make
451
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun n -> n.unknown)
452
+
|> Jsont.Object.finish
453
+
454
+
let list_method = "tools/list"
455
+
let call_method = "tools/call"
456
+
let list_changed_notification_method = "notifications/tools/list_changed"
457
+
end
458
+
459
+
(* Prompts *)
460
+
461
+
module Prompts = struct
462
+
type prompt_argument = {
463
+
name : string;
464
+
description : string option;
465
+
required : bool option;
466
+
unknown : Jsont.json;
467
+
}
468
+
469
+
let make_prompt_argument ~name ?description ?required () =
470
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
471
+
{ name; description; required; unknown }
472
+
473
+
let prompt_argument_jsont : prompt_argument Jsont.t =
474
+
let make name description required unknown =
475
+
{ name; description; required; unknown }
476
+
in
477
+
Jsont.Object.map ~kind:"PromptArgument" make
478
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun a -> a.name)
479
+
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:(fun a -> a.description)
480
+
|> Jsont.Object.opt_mem "required" Jsont.bool ~enc:(fun a -> a.required)
481
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun a -> a.unknown)
482
+
|> Jsont.Object.finish
483
+
484
+
type prompt = {
485
+
name : string;
486
+
description : string option;
487
+
arguments : prompt_argument list option;
488
+
unknown : Jsont.json;
489
+
}
490
+
491
+
let make_prompt ~name ?description ?arguments () =
492
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
493
+
{ name; description; arguments; unknown }
494
+
495
+
let prompt_jsont : prompt Jsont.t =
496
+
let make name description arguments unknown =
497
+
{ name; description; arguments; unknown }
498
+
in
499
+
Jsont.Object.map ~kind:"Prompt" make
500
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun p -> p.name)
501
+
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:(fun p -> p.description)
502
+
|> Jsont.Object.opt_mem "arguments" (Jsont.list prompt_argument_jsont)
503
+
~enc:(fun p -> p.arguments)
504
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun p -> p.unknown)
505
+
|> Jsont.Object.finish
506
+
507
+
type role = User | Assistant
508
+
509
+
let role_jsont : role Jsont.t =
510
+
Jsont.enum [
511
+
"user", User;
512
+
"assistant", Assistant;
513
+
]
514
+
515
+
type prompt_message = {
516
+
role : role;
517
+
content : Content.block list;
518
+
unknown : Jsont.json;
519
+
}
520
+
521
+
let make_prompt_message ~role ~content () =
522
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
523
+
{ role; content; unknown }
524
+
525
+
let prompt_message_jsont : prompt_message Jsont.t =
526
+
let make role content unknown = { role; content; unknown } in
527
+
Jsont.Object.map ~kind:"PromptMessage" make
528
+
|> Jsont.Object.mem "role" role_jsont ~enc:(fun m -> m.role)
529
+
|> Jsont.Object.mem "content" (Jsont.list Content.block_jsont)
530
+
~enc:(fun m -> m.content)
531
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun m -> m.unknown)
532
+
|> Jsont.Object.finish
533
+
534
+
type list_request = {
535
+
cursor : string option;
536
+
unknown : Jsont.json;
537
+
}
538
+
539
+
let make_list_request ?cursor () =
540
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
541
+
{ cursor; unknown }
542
+
543
+
let list_request_jsont : list_request Jsont.t =
544
+
let make cursor unknown = { cursor; unknown } in
545
+
Jsont.Object.map ~kind:"PromptsListRequest" make
546
+
|> Jsont.Object.opt_mem "cursor" Jsont.string ~enc:(fun r -> r.cursor)
547
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
548
+
|> Jsont.Object.finish
549
+
550
+
type list_result = {
551
+
prompts : prompt list;
552
+
next_cursor : string option;
553
+
unknown : Jsont.json;
554
+
}
555
+
556
+
let make_list_result ~prompts ?next_cursor () =
557
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
558
+
{ prompts; next_cursor; unknown }
559
+
560
+
let list_result_jsont : list_result Jsont.t =
561
+
let make prompts next_cursor unknown =
562
+
{ prompts; next_cursor; unknown }
563
+
in
564
+
Jsont.Object.map ~kind:"PromptsListResult" make
565
+
|> Jsont.Object.mem "prompts" (Jsont.list prompt_jsont)
566
+
~enc:(fun r -> r.prompts)
567
+
|> Jsont.Object.opt_mem "nextCursor" Jsont.string
568
+
~enc:(fun r -> r.next_cursor)
569
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
570
+
|> Jsont.Object.finish
571
+
572
+
(* Arguments as object with string keys *)
573
+
let arguments_jsont : (string * string) list Jsont.t =
574
+
let enc_obj args =
575
+
let pairs = List.map (fun (k, v) ->
576
+
((k, Jsont.Meta.none), Jsont.String (v, Jsont.Meta.none))
577
+
) args in
578
+
Jsont.Object (pairs, Jsont.Meta.none)
579
+
in
580
+
let dec_obj = function
581
+
| Jsont.Object (members, _) ->
582
+
List.map (fun ((k, _), v) ->
583
+
match v with
584
+
| Jsont.String (s, _) -> (k, s)
585
+
| _ -> Jsont.Error.msgf Jsont.Meta.none
586
+
"Argument values must be strings"
587
+
) members
588
+
| _ ->
589
+
Jsont.Error.msgf Jsont.Meta.none "Arguments must be an object"
590
+
in
591
+
Jsont.map ~kind:"PromptArguments" ~dec:dec_obj ~enc:enc_obj Jsont.json
592
+
593
+
type get_request = {
594
+
name : string;
595
+
arguments : (string * string) list option;
596
+
unknown : Jsont.json;
597
+
}
598
+
599
+
let make_get_request ~name ?arguments () =
600
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
601
+
{ name; arguments; unknown }
602
+
603
+
let get_request_jsont : get_request Jsont.t =
604
+
let make name arguments unknown = { name; arguments; unknown } in
605
+
Jsont.Object.map ~kind:"PromptsGetRequest" make
606
+
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun r -> r.name)
607
+
|> Jsont.Object.opt_mem "arguments" arguments_jsont ~enc:(fun r -> r.arguments)
608
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
609
+
|> Jsont.Object.finish
610
+
611
+
type get_result = {
612
+
description : string option;
613
+
messages : prompt_message list;
614
+
unknown : Jsont.json;
615
+
}
616
+
617
+
let make_get_result ?description ~messages () =
618
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
619
+
{ description; messages; unknown }
620
+
621
+
let get_result_jsont : get_result Jsont.t =
622
+
let make description messages unknown =
623
+
{ description; messages; unknown }
624
+
in
625
+
Jsont.Object.map ~kind:"PromptsGetResult" make
626
+
|> Jsont.Object.opt_mem "description" Jsont.string ~enc:(fun r -> r.description)
627
+
|> Jsont.Object.mem "messages" (Jsont.list prompt_message_jsont)
628
+
~enc:(fun r -> r.messages)
629
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
630
+
|> Jsont.Object.finish
631
+
632
+
type list_changed_notification = {
633
+
unknown : Jsont.json;
634
+
}
635
+
636
+
let make_list_changed_notification () =
637
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
638
+
{ unknown }
639
+
640
+
let list_changed_notification_jsont : list_changed_notification Jsont.t =
641
+
let make unknown = { unknown } in
642
+
Jsont.Object.map ~kind:"PromptsListChangedNotification" make
643
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun n -> n.unknown)
644
+
|> Jsont.Object.finish
645
+
646
+
let list_method = "prompts/list"
647
+
let get_method = "prompts/get"
648
+
let list_changed_notification_method = "notifications/prompts/list_changed"
649
+
end
650
+
651
+
(* Logging *)
652
+
653
+
module Logging = struct
654
+
type level =
655
+
| Debug
656
+
| Info
657
+
| Notice
658
+
| Warning
659
+
| Error
660
+
| Critical
661
+
| Alert
662
+
| Emergency
663
+
664
+
let level_jsont : level Jsont.t =
665
+
Jsont.enum [
666
+
"debug", Debug;
667
+
"info", Info;
668
+
"notice", Notice;
669
+
"warning", Warning;
670
+
"error", Error;
671
+
"critical", Critical;
672
+
"alert", Alert;
673
+
"emergency", Emergency;
674
+
]
675
+
676
+
let level_to_string = function
677
+
| Debug -> "debug"
678
+
| Info -> "info"
679
+
| Notice -> "notice"
680
+
| Warning -> "warning"
681
+
| Error -> "error"
682
+
| Critical -> "critical"
683
+
| Alert -> "alert"
684
+
| Emergency -> "emergency"
685
+
686
+
type notification = {
687
+
level : level;
688
+
logger : string option;
689
+
data : Jsont.json option;
690
+
unknown : Jsont.json;
691
+
}
692
+
693
+
let make_notification ~level ?logger ?data () =
694
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
695
+
{ level; logger; data; unknown }
696
+
697
+
let notification_jsont : notification Jsont.t =
698
+
let make level logger data unknown =
699
+
{ level; logger; data; unknown }
700
+
in
701
+
Jsont.Object.map ~kind:"LoggingNotification" make
702
+
|> Jsont.Object.mem "level" level_jsont ~enc:(fun n -> n.level)
703
+
|> Jsont.Object.opt_mem "logger" Jsont.string ~enc:(fun n -> n.logger)
704
+
|> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun n -> n.data)
705
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun n -> n.unknown)
706
+
|> Jsont.Object.finish
707
+
708
+
let method_ = "notifications/message"
709
+
end
710
+
711
+
(* Completions *)
712
+
713
+
module Completions = struct
714
+
type completion_ref = {
715
+
ref_type : string;
716
+
uri : string;
717
+
unknown : Jsont.json;
718
+
}
719
+
720
+
let make_completion_ref ~ref_type ~uri () =
721
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
722
+
{ ref_type; uri; unknown }
723
+
724
+
let completion_ref_jsont : completion_ref Jsont.t =
725
+
let make ref_type uri unknown = { ref_type; uri; unknown } in
726
+
Jsont.Object.map ~kind:"CompletionRef" make
727
+
|> Jsont.Object.mem "type" Jsont.string ~enc:(fun r -> r.ref_type)
728
+
|> Jsont.Object.mem "uri" Jsont.string ~enc:(fun r -> r.uri)
729
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
730
+
|> Jsont.Object.finish
731
+
732
+
type request = {
733
+
ref_ : completion_ref;
734
+
argument : string option;
735
+
unknown : Jsont.json;
736
+
}
737
+
738
+
let make_request ~ref_ ?argument () =
739
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
740
+
{ ref_; argument; unknown }
741
+
742
+
let request_jsont : request Jsont.t =
743
+
let make ref_ argument unknown = { ref_; argument; unknown } in
744
+
Jsont.Object.map ~kind:"CompletionRequest" make
745
+
|> Jsont.Object.mem "ref" completion_ref_jsont ~enc:(fun r -> r.ref_)
746
+
|> Jsont.Object.opt_mem "argument" Jsont.string ~enc:(fun r -> r.argument)
747
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
748
+
|> Jsont.Object.finish
749
+
750
+
type result = {
751
+
completion : string list;
752
+
total : int option;
753
+
has_more : bool option;
754
+
unknown : Jsont.json;
755
+
}
756
+
757
+
let make_result ~completion ?total ?has_more () =
758
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
759
+
{ completion; total; has_more; unknown }
760
+
761
+
let result_jsont : result Jsont.t =
762
+
let make completion total has_more unknown =
763
+
{ completion; total; has_more; unknown }
764
+
in
765
+
Jsont.Object.map ~kind:"CompletionResult" make
766
+
|> Jsont.Object.mem "completion" (Jsont.list Jsont.string)
767
+
~enc:(fun r -> r.completion)
768
+
|> Jsont.Object.opt_mem "total" Jsont.int ~enc:(fun r -> r.total)
769
+
|> Jsont.Object.opt_mem "hasMore" Jsont.bool ~enc:(fun r -> r.has_more)
770
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
771
+
|> Jsont.Object.finish
772
+
773
+
let method_ = "completion/complete"
774
+
end
775
+
776
+
(* Roots *)
777
+
778
+
module Roots = struct
779
+
type root = {
780
+
uri : string;
781
+
name : string option;
782
+
unknown : Jsont.json;
783
+
}
784
+
785
+
let make_root ~uri ?name () =
786
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
787
+
{ uri; name; unknown }
788
+
789
+
let root_jsont : root Jsont.t =
790
+
let make uri name unknown = { uri; name; unknown } in
791
+
Jsont.Object.map ~kind:"Root" make
792
+
|> Jsont.Object.mem "uri" Jsont.string ~enc:(fun r -> r.uri)
793
+
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:(fun r -> r.name)
794
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
795
+
|> Jsont.Object.finish
796
+
797
+
type list_request = {
798
+
unknown : Jsont.json;
799
+
}
800
+
801
+
let make_list_request () =
802
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
803
+
{ unknown }
804
+
805
+
let list_request_jsont : list_request Jsont.t =
806
+
let make unknown = { unknown } in
807
+
Jsont.Object.map ~kind:"RootsListRequest" make
808
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
809
+
|> Jsont.Object.finish
810
+
811
+
type list_result = {
812
+
roots : root list;
813
+
unknown : Jsont.json;
814
+
}
815
+
816
+
let make_list_result ~roots =
817
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
818
+
{ roots; unknown }
819
+
820
+
let list_result_jsont : list_result Jsont.t =
821
+
let make roots unknown = { roots; unknown } in
822
+
Jsont.Object.map ~kind:"RootsListResult" make
823
+
|> Jsont.Object.mem "roots" (Jsont.list root_jsont)
824
+
~enc:(fun r -> r.roots)
825
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
826
+
|> Jsont.Object.finish
827
+
828
+
type list_changed_notification = {
829
+
unknown : Jsont.json;
830
+
}
831
+
832
+
let make_list_changed_notification () =
833
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
834
+
{ unknown }
835
+
836
+
let list_changed_notification_jsont : list_changed_notification Jsont.t =
837
+
let make unknown = { unknown } in
838
+
Jsont.Object.map ~kind:"RootsListChangedNotification" make
839
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun n -> n.unknown)
840
+
|> Jsont.Object.finish
841
+
842
+
let list_method = "roots/list"
843
+
let list_changed_notification_method = "notifications/roots/list_changed"
844
+
end
845
+
846
+
(* Progress *)
847
+
848
+
module Progress = struct
849
+
type notification = {
850
+
progress_token : string;
851
+
progress : float;
852
+
total : float option;
853
+
unknown : Jsont.json;
854
+
}
855
+
856
+
let make_notification ~progress_token ~progress ?total () =
857
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
858
+
{ progress_token; progress; total; unknown }
859
+
860
+
let notification_jsont : notification Jsont.t =
861
+
let make progress_token progress total unknown =
862
+
{ progress_token; progress; total; unknown }
863
+
in
864
+
Jsont.Object.map ~kind:"ProgressNotification" make
865
+
|> Jsont.Object.mem "progressToken" Jsont.string
866
+
~enc:(fun n -> n.progress_token)
867
+
|> Jsont.Object.mem "progress" Jsont.number ~enc:(fun n -> n.progress)
868
+
|> Jsont.Object.opt_mem "total" Jsont.number ~enc:(fun n -> n.total)
869
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun n -> n.unknown)
870
+
|> Jsont.Object.finish
871
+
872
+
let method_ = "notifications/progress"
873
+
end
874
+
875
+
(* Cancellation *)
876
+
877
+
module Cancellation = struct
878
+
type notification = {
879
+
request_id : Jsonrpc.Id.t;
880
+
reason : string option;
881
+
unknown : Jsont.json;
882
+
}
883
+
884
+
let make_notification ~request_id ?reason () =
885
+
let unknown = Jsont.Object ([], Jsont.Meta.none) in
886
+
{ request_id; reason; unknown }
887
+
888
+
let notification_jsont : notification Jsont.t =
889
+
let make request_id reason unknown =
890
+
{ request_id; reason; unknown }
891
+
in
892
+
Jsont.Object.map ~kind:"CancellationNotification" make
893
+
|> Jsont.Object.mem "requestId" Jsonrpc.Id.jsont
894
+
~enc:(fun n -> n.request_id)
895
+
|> Jsont.Object.opt_mem "reason" Jsont.string ~enc:(fun n -> n.reason)
896
+
|> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun n -> n.unknown)
897
+
|> Jsont.Object.finish
898
+
899
+
let method_ = "notifications/cancelled"
900
+
end
+660
claudeio/lib_mcp/messages.mli
+660
claudeio/lib_mcp/messages.mli
···
1
+
(** MCP Protocol Messages.
2
+
3
+
This module provides all protocol message types for the Model Context Protocol (MCP).
4
+
It includes initialization, resources, tools, prompts, logging, and other protocol messages.
5
+
6
+
All types include unknown field preservation for forward compatibility. *)
7
+
8
+
(** {1 Protocol Version} *)
9
+
10
+
type protocol_version = string
11
+
(** MCP protocol version string (e.g., "2024-11-05") *)
12
+
13
+
val protocol_version_jsont : protocol_version Jsont.t
14
+
15
+
(** {1 Initialize Protocol} *)
16
+
17
+
module Initialize : sig
18
+
(** Initialize request parameters *)
19
+
type request_params = {
20
+
protocol_version : protocol_version;
21
+
capabilities : Capabilities.Client.t;
22
+
client_info : Capabilities.Implementation.t;
23
+
unknown : Jsont.json;
24
+
}
25
+
26
+
val make_request_params :
27
+
protocol_version:protocol_version ->
28
+
capabilities:Capabilities.Client.t ->
29
+
client_info:Capabilities.Implementation.t ->
30
+
unit ->
31
+
request_params
32
+
33
+
val request_params_jsont : request_params Jsont.t
34
+
35
+
(** Initialize result *)
36
+
type result = {
37
+
protocol_version : protocol_version;
38
+
capabilities : Capabilities.Server.t;
39
+
server_info : Capabilities.Implementation.t;
40
+
instructions : string option;
41
+
unknown : Jsont.json;
42
+
}
43
+
44
+
val make_result :
45
+
protocol_version:protocol_version ->
46
+
capabilities:Capabilities.Server.t ->
47
+
server_info:Capabilities.Implementation.t ->
48
+
?instructions:string ->
49
+
unit ->
50
+
result
51
+
52
+
val result_jsont : result Jsont.t
53
+
54
+
val method_ : string
55
+
(** Method name: "initialize" *)
56
+
end
57
+
58
+
module Initialized : sig
59
+
(** Initialized notification (sent after initialize completes) *)
60
+
type notification = {
61
+
unknown : Jsont.json;
62
+
}
63
+
64
+
val make_notification : unit -> notification
65
+
val notification_jsont : notification Jsont.t
66
+
67
+
val method_ : string
68
+
(** Method name: "notifications/initialized" *)
69
+
end
70
+
71
+
module Ping : sig
72
+
(** Ping request (keepalive) *)
73
+
type params = {
74
+
unknown : Jsont.json;
75
+
}
76
+
77
+
val make_params : unit -> params
78
+
val params_jsont : params Jsont.t
79
+
80
+
(** Ping result (empty object) *)
81
+
type result = {
82
+
unknown : Jsont.json;
83
+
}
84
+
85
+
val make_result : unit -> result
86
+
val result_jsont : result Jsont.t
87
+
88
+
val method_ : string
89
+
(** Method name: "ping" *)
90
+
end
91
+
92
+
(** {1 Resources} *)
93
+
94
+
module Resources : sig
95
+
(** Resource descriptor *)
96
+
type resource = {
97
+
uri : string;
98
+
name : string;
99
+
description : string option;
100
+
mime_type : string option;
101
+
unknown : Jsont.json;
102
+
}
103
+
104
+
val make_resource :
105
+
uri:string ->
106
+
name:string ->
107
+
?description:string ->
108
+
?mime_type:string ->
109
+
unit ->
110
+
resource
111
+
112
+
val resource_jsont : resource Jsont.t
113
+
114
+
(** Resource template (URI template with placeholders) *)
115
+
type resource_template = {
116
+
uri_template : string;
117
+
name : string;
118
+
description : string option;
119
+
mime_type : string option;
120
+
unknown : Jsont.json;
121
+
}
122
+
123
+
val make_resource_template :
124
+
uri_template:string ->
125
+
name:string ->
126
+
?description:string ->
127
+
?mime_type:string ->
128
+
unit ->
129
+
resource_template
130
+
131
+
val resource_template_jsont : resource_template Jsont.t
132
+
133
+
(** Resource contents (from read request) *)
134
+
type resource_contents = {
135
+
uri : string;
136
+
mime_type : string option;
137
+
text : string option;
138
+
blob : string option; (** Base64-encoded binary data *)
139
+
unknown : Jsont.json;
140
+
}
141
+
142
+
val make_text_contents :
143
+
uri:string ->
144
+
text:string ->
145
+
?mime_type:string ->
146
+
unit ->
147
+
resource_contents
148
+
149
+
val make_blob_contents :
150
+
uri:string ->
151
+
blob:string ->
152
+
mime_type:string ->
153
+
resource_contents
154
+
155
+
val resource_contents_jsont : resource_contents Jsont.t
156
+
157
+
(** List resources request *)
158
+
type list_request = {
159
+
cursor : string option;
160
+
unknown : Jsont.json;
161
+
}
162
+
163
+
val make_list_request : ?cursor:string -> unit -> list_request
164
+
val list_request_jsont : list_request Jsont.t
165
+
166
+
(** List resources result *)
167
+
type list_result = {
168
+
resources : resource list;
169
+
next_cursor : string option;
170
+
unknown : Jsont.json;
171
+
}
172
+
173
+
val make_list_result :
174
+
resources:resource list ->
175
+
?next_cursor:string ->
176
+
unit ->
177
+
list_result
178
+
179
+
val list_result_jsont : list_result Jsont.t
180
+
181
+
(** Read resource request *)
182
+
type read_request = {
183
+
uri : string;
184
+
unknown : Jsont.json;
185
+
}
186
+
187
+
val make_read_request : uri:string -> read_request
188
+
val read_request_jsont : read_request Jsont.t
189
+
190
+
(** Read resource result *)
191
+
type read_result = {
192
+
contents : resource_contents list;
193
+
unknown : Jsont.json;
194
+
}
195
+
196
+
val make_read_result : contents:resource_contents list -> read_result
197
+
val read_result_jsont : read_result Jsont.t
198
+
199
+
(** Subscribe to resource updates *)
200
+
type subscribe_request = {
201
+
uri : string;
202
+
unknown : Jsont.json;
203
+
}
204
+
205
+
val make_subscribe_request : uri:string -> subscribe_request
206
+
val subscribe_request_jsont : subscribe_request Jsont.t
207
+
208
+
(** Unsubscribe from resource updates *)
209
+
type unsubscribe_request = {
210
+
uri : string;
211
+
unknown : Jsont.json;
212
+
}
213
+
214
+
val make_unsubscribe_request : uri:string -> unsubscribe_request
215
+
val unsubscribe_request_jsont : unsubscribe_request Jsont.t
216
+
217
+
(** Resource updated notification *)
218
+
type updated_notification = {
219
+
uri : string;
220
+
unknown : Jsont.json;
221
+
}
222
+
223
+
val make_updated_notification : uri:string -> updated_notification
224
+
val updated_notification_jsont : updated_notification Jsont.t
225
+
226
+
(** Resource list changed notification *)
227
+
type list_changed_notification = {
228
+
unknown : Jsont.json;
229
+
}
230
+
231
+
val make_list_changed_notification : unit -> list_changed_notification
232
+
val list_changed_notification_jsont : list_changed_notification Jsont.t
233
+
234
+
val list_method : string
235
+
(** Method name: "resources/list" *)
236
+
237
+
val read_method : string
238
+
(** Method name: "resources/read" *)
239
+
240
+
val subscribe_method : string
241
+
(** Method name: "resources/subscribe" *)
242
+
243
+
val unsubscribe_method : string
244
+
(** Method name: "resources/unsubscribe" *)
245
+
246
+
val updated_notification_method : string
247
+
(** Method name: "notifications/resources/updated" *)
248
+
249
+
val list_changed_notification_method : string
250
+
(** Method name: "notifications/resources/list_changed" *)
251
+
end
252
+
253
+
(** {1 Tools} *)
254
+
255
+
module Tools : sig
256
+
(** Tool descriptor *)
257
+
type tool = {
258
+
name : string;
259
+
description : string option;
260
+
input_schema : Jsont.json; (** JSON Schema for tool inputs *)
261
+
unknown : Jsont.json;
262
+
}
263
+
264
+
val make_tool :
265
+
name:string ->
266
+
?description:string ->
267
+
input_schema:Jsont.json ->
268
+
unit ->
269
+
tool
270
+
271
+
val tool_jsont : tool Jsont.t
272
+
273
+
(** List tools request *)
274
+
type list_request = {
275
+
cursor : string option;
276
+
unknown : Jsont.json;
277
+
}
278
+
279
+
val make_list_request : ?cursor:string -> unit -> list_request
280
+
val list_request_jsont : list_request Jsont.t
281
+
282
+
(** List tools result *)
283
+
type list_result = {
284
+
tools : tool list;
285
+
next_cursor : string option;
286
+
unknown : Jsont.json;
287
+
}
288
+
289
+
val make_list_result :
290
+
tools:tool list ->
291
+
?next_cursor:string ->
292
+
unit ->
293
+
list_result
294
+
295
+
val list_result_jsont : list_result Jsont.t
296
+
297
+
(** Call tool request *)
298
+
type call_request = {
299
+
name : string;
300
+
arguments : Jsont.json option;
301
+
unknown : Jsont.json;
302
+
}
303
+
304
+
val make_call_request :
305
+
name:string ->
306
+
?arguments:Jsont.json ->
307
+
unit ->
308
+
call_request
309
+
310
+
val call_request_jsont : call_request Jsont.t
311
+
312
+
(** Call tool result *)
313
+
type call_result = {
314
+
content : Content.block list;
315
+
is_error : bool option;
316
+
unknown : Jsont.json;
317
+
}
318
+
319
+
val make_call_result :
320
+
content:Content.block list ->
321
+
?is_error:bool ->
322
+
unit ->
323
+
call_result
324
+
325
+
val call_result_jsont : call_result Jsont.t
326
+
327
+
(** Tool list changed notification *)
328
+
type list_changed_notification = {
329
+
unknown : Jsont.json;
330
+
}
331
+
332
+
val make_list_changed_notification : unit -> list_changed_notification
333
+
val list_changed_notification_jsont : list_changed_notification Jsont.t
334
+
335
+
val list_method : string
336
+
(** Method name: "tools/list" *)
337
+
338
+
val call_method : string
339
+
(** Method name: "tools/call" *)
340
+
341
+
val list_changed_notification_method : string
342
+
(** Method name: "notifications/tools/list_changed" *)
343
+
end
344
+
345
+
(** {1 Prompts} *)
346
+
347
+
module Prompts : sig
348
+
(** Prompt argument descriptor *)
349
+
type prompt_argument = {
350
+
name : string;
351
+
description : string option;
352
+
required : bool option;
353
+
unknown : Jsont.json;
354
+
}
355
+
356
+
val make_prompt_argument :
357
+
name:string ->
358
+
?description:string ->
359
+
?required:bool ->
360
+
unit ->
361
+
prompt_argument
362
+
363
+
val prompt_argument_jsont : prompt_argument Jsont.t
364
+
365
+
(** Prompt descriptor *)
366
+
type prompt = {
367
+
name : string;
368
+
description : string option;
369
+
arguments : prompt_argument list option;
370
+
unknown : Jsont.json;
371
+
}
372
+
373
+
val make_prompt :
374
+
name:string ->
375
+
?description:string ->
376
+
?arguments:prompt_argument list ->
377
+
unit ->
378
+
prompt
379
+
380
+
val prompt_jsont : prompt Jsont.t
381
+
382
+
(** Prompt message role *)
383
+
type role = User | Assistant
384
+
385
+
val role_jsont : role Jsont.t
386
+
387
+
(** Prompt message *)
388
+
type prompt_message = {
389
+
role : role;
390
+
content : Content.block list;
391
+
unknown : Jsont.json;
392
+
}
393
+
394
+
val make_prompt_message :
395
+
role:role ->
396
+
content:Content.block list ->
397
+
unit ->
398
+
prompt_message
399
+
400
+
val prompt_message_jsont : prompt_message Jsont.t
401
+
402
+
(** List prompts request *)
403
+
type list_request = {
404
+
cursor : string option;
405
+
unknown : Jsont.json;
406
+
}
407
+
408
+
val make_list_request : ?cursor:string -> unit -> list_request
409
+
val list_request_jsont : list_request Jsont.t
410
+
411
+
(** List prompts result *)
412
+
type list_result = {
413
+
prompts : prompt list;
414
+
next_cursor : string option;
415
+
unknown : Jsont.json;
416
+
}
417
+
418
+
val make_list_result :
419
+
prompts:prompt list ->
420
+
?next_cursor:string ->
421
+
unit ->
422
+
list_result
423
+
424
+
val list_result_jsont : list_result Jsont.t
425
+
426
+
(** Get prompt request *)
427
+
type get_request = {
428
+
name : string;
429
+
arguments : (string * string) list option; (** Key-value pairs *)
430
+
unknown : Jsont.json;
431
+
}
432
+
433
+
val make_get_request :
434
+
name:string ->
435
+
?arguments:(string * string) list ->
436
+
unit ->
437
+
get_request
438
+
439
+
val get_request_jsont : get_request Jsont.t
440
+
441
+
(** Get prompt result *)
442
+
type get_result = {
443
+
description : string option;
444
+
messages : prompt_message list;
445
+
unknown : Jsont.json;
446
+
}
447
+
448
+
val make_get_result :
449
+
?description:string ->
450
+
messages:prompt_message list ->
451
+
unit ->
452
+
get_result
453
+
454
+
val get_result_jsont : get_result Jsont.t
455
+
456
+
(** Prompt list changed notification *)
457
+
type list_changed_notification = {
458
+
unknown : Jsont.json;
459
+
}
460
+
461
+
val make_list_changed_notification : unit -> list_changed_notification
462
+
val list_changed_notification_jsont : list_changed_notification Jsont.t
463
+
464
+
val list_method : string
465
+
(** Method name: "prompts/list" *)
466
+
467
+
val get_method : string
468
+
(** Method name: "prompts/get" *)
469
+
470
+
val list_changed_notification_method : string
471
+
(** Method name: "notifications/prompts/list_changed" *)
472
+
end
473
+
474
+
(** {1 Logging} *)
475
+
476
+
module Logging : sig
477
+
(** Log level *)
478
+
type level =
479
+
| Debug
480
+
| Info
481
+
| Notice
482
+
| Warning
483
+
| Error
484
+
| Critical
485
+
| Alert
486
+
| Emergency
487
+
488
+
val level_jsont : level Jsont.t
489
+
val level_to_string : level -> string
490
+
491
+
(** Logging message notification *)
492
+
type notification = {
493
+
level : level;
494
+
logger : string option;
495
+
data : Jsont.json option;
496
+
unknown : Jsont.json;
497
+
}
498
+
499
+
val make_notification :
500
+
level:level ->
501
+
?logger:string ->
502
+
?data:Jsont.json ->
503
+
unit ->
504
+
notification
505
+
506
+
val notification_jsont : notification Jsont.t
507
+
508
+
val method_ : string
509
+
(** Method name: "notifications/message" *)
510
+
end
511
+
512
+
(** {1 Completions} *)
513
+
514
+
module Completions : sig
515
+
(** Completion reference (argument or resource URI) *)
516
+
type completion_ref = {
517
+
ref_type : string; (** "ref/prompt" or "ref/resource" *)
518
+
uri : string;
519
+
unknown : Jsont.json;
520
+
}
521
+
522
+
val make_completion_ref :
523
+
ref_type:string ->
524
+
uri:string ->
525
+
unit ->
526
+
completion_ref
527
+
528
+
val completion_ref_jsont : completion_ref Jsont.t
529
+
530
+
(** Completion request *)
531
+
type request = {
532
+
ref_ : completion_ref;
533
+
argument : string option;
534
+
unknown : Jsont.json;
535
+
}
536
+
537
+
val make_request :
538
+
ref_:completion_ref ->
539
+
?argument:string ->
540
+
unit ->
541
+
request
542
+
543
+
val request_jsont : request Jsont.t
544
+
545
+
(** Completion result *)
546
+
type result = {
547
+
completion : string list;
548
+
total : int option;
549
+
has_more : bool option;
550
+
unknown : Jsont.json;
551
+
}
552
+
553
+
val make_result :
554
+
completion:string list ->
555
+
?total:int ->
556
+
?has_more:bool ->
557
+
unit ->
558
+
result
559
+
560
+
val result_jsont : result Jsont.t
561
+
562
+
val method_ : string
563
+
(** Method name: "completion/complete" *)
564
+
end
565
+
566
+
(** {1 Roots} *)
567
+
568
+
module Roots : sig
569
+
(** Root descriptor *)
570
+
type root = {
571
+
uri : string;
572
+
name : string option;
573
+
unknown : Jsont.json;
574
+
}
575
+
576
+
val make_root :
577
+
uri:string ->
578
+
?name:string ->
579
+
unit ->
580
+
root
581
+
582
+
val root_jsont : root Jsont.t
583
+
584
+
(** List roots request *)
585
+
type list_request = {
586
+
unknown : Jsont.json;
587
+
}
588
+
589
+
val make_list_request : unit -> list_request
590
+
val list_request_jsont : list_request Jsont.t
591
+
592
+
(** List roots result *)
593
+
type list_result = {
594
+
roots : root list;
595
+
unknown : Jsont.json;
596
+
}
597
+
598
+
val make_list_result : roots:root list -> list_result
599
+
val list_result_jsont : list_result Jsont.t
600
+
601
+
(** Roots list changed notification *)
602
+
type list_changed_notification = {
603
+
unknown : Jsont.json;
604
+
}
605
+
606
+
val make_list_changed_notification : unit -> list_changed_notification
607
+
val list_changed_notification_jsont : list_changed_notification Jsont.t
608
+
609
+
val list_method : string
610
+
(** Method name: "roots/list" *)
611
+
612
+
val list_changed_notification_method : string
613
+
(** Method name: "notifications/roots/list_changed" *)
614
+
end
615
+
616
+
(** {1 Progress} *)
617
+
618
+
module Progress : sig
619
+
(** Progress notification *)
620
+
type notification = {
621
+
progress_token : string; (** Unique token identifying the operation *)
622
+
progress : float; (** Progress value (0.0 to 1.0) *)
623
+
total : float option; (** Optional total value *)
624
+
unknown : Jsont.json;
625
+
}
626
+
627
+
val make_notification :
628
+
progress_token:string ->
629
+
progress:float ->
630
+
?total:float ->
631
+
unit ->
632
+
notification
633
+
634
+
val notification_jsont : notification Jsont.t
635
+
636
+
val method_ : string
637
+
(** Method name: "notifications/progress" *)
638
+
end
639
+
640
+
(** {1 Cancellation} *)
641
+
642
+
module Cancellation : sig
643
+
(** Cancel request notification *)
644
+
type notification = {
645
+
request_id : Jsonrpc.Id.t;
646
+
reason : string option;
647
+
unknown : Jsont.json;
648
+
}
649
+
650
+
val make_notification :
651
+
request_id:Jsonrpc.Id.t ->
652
+
?reason:string ->
653
+
unit ->
654
+
notification
655
+
656
+
val notification_jsont : notification Jsont.t
657
+
658
+
val method_ : string
659
+
(** Method name: "notifications/cancelled" *)
660
+
end
+371
claudeio/lib_mcp/server_session.ml
+371
claudeio/lib_mcp/server_session.ml
···
1
+
(** High-level MCP server session API *)
2
+
3
+
(** {1 Types} *)
4
+
5
+
type config = {
6
+
server_info : Capabilities.Implementation.t;
7
+
server_capabilities : Capabilities.Server.t;
8
+
instructions : string option;
9
+
}
10
+
11
+
type handlers = {
12
+
list_resources : (cursor:string option -> Messages.Resources.list_result) option;
13
+
list_resource_templates : (cursor:string option -> Messages.Resources.list_result) option;
14
+
read_resource : (uri:string -> Messages.Resources.read_result) option;
15
+
subscribe_resource : (uri:string -> unit) option;
16
+
unsubscribe_resource : (uri:string -> unit) option;
17
+
list_tools : (cursor:string option -> Messages.Tools.list_result) option;
18
+
call_tool : (name:string -> arguments:Jsont.json option -> Messages.Tools.call_result) option;
19
+
list_prompts : (cursor:string option -> Messages.Prompts.list_result) option;
20
+
get_prompt : (name:string -> arguments:(string * string) list option -> Messages.Prompts.get_result) option;
21
+
complete : (ref_:Messages.Completions.completion_ref -> argument:string -> Messages.Completions.result) option;
22
+
ping : (unit -> unit) option;
23
+
}
24
+
25
+
type t = {
26
+
session : Session.t;
27
+
config : config;
28
+
handlers : handlers;
29
+
mutable client_capabilities : Capabilities.Client.t option;
30
+
mutable client_info : Capabilities.Implementation.t option;
31
+
mutable protocol_version : string option;
32
+
mutable initialized : bool;
33
+
}
34
+
35
+
(** {1 Helper Functions} *)
36
+
37
+
let encode_json jsont value =
38
+
match Jsont.Json.encode jsont value with
39
+
| Ok json -> json
40
+
| Error e -> failwith ("Failed to encode JSON: " ^ e)
41
+
42
+
let decode_json jsont json =
43
+
match Jsont.Json.decode jsont json with
44
+
| Ok value -> value
45
+
| Error e -> failwith ("Failed to decode JSON: " ^ e)
46
+
47
+
let method_not_found method_ =
48
+
let error = Jsonrpc.Error_data.make
49
+
~code:Method_not_found
50
+
~message:(Printf.sprintf "Method not found: %s" method_)
51
+
()
52
+
in
53
+
raise (Session.Remote_error error)
54
+
55
+
let invalid_params method_ msg =
56
+
let error = Jsonrpc.Error_data.make
57
+
~code:Invalid_params
58
+
~message:(Printf.sprintf "Invalid params for %s: %s" method_ msg)
59
+
()
60
+
in
61
+
raise (Session.Remote_error error)
62
+
63
+
(** {1 Request Handler} *)
64
+
65
+
let handle_request t ~method_ ~params =
66
+
(* Ensure initialization has completed for non-init requests *)
67
+
if method_ <> Messages.Initialize.method_ && not t.initialized then begin
68
+
let error = Jsonrpc.Error_data.make
69
+
~code:Internal_error
70
+
~message:"Server not initialized"
71
+
()
72
+
in
73
+
raise (Session.Remote_error error)
74
+
end;
75
+
76
+
(* Route to appropriate handler *)
77
+
match method_ with
78
+
| m when m = Messages.Initialize.method_ ->
79
+
(* Handle initialization *)
80
+
let req_params = match params with
81
+
| Some p -> decode_json Messages.Initialize.request_params_jsont p
82
+
| None -> invalid_params method_ "missing params"
83
+
in
84
+
85
+
(* Store client info *)
86
+
t.client_capabilities <- Some req_params.capabilities;
87
+
t.client_info <- Some req_params.client_info;
88
+
t.protocol_version <- Some req_params.protocol_version;
89
+
90
+
(* Build response *)
91
+
let result = Messages.Initialize.make_result
92
+
~protocol_version:req_params.protocol_version
93
+
~capabilities:t.config.server_capabilities
94
+
~server_info:t.config.server_info
95
+
?instructions:t.config.instructions
96
+
()
97
+
in
98
+
encode_json Messages.Initialize.result_jsont result
99
+
100
+
| m when m = Messages.Ping.method_ ->
101
+
let handler = t.handlers.ping in
102
+
(match handler with
103
+
| None -> method_not_found method_
104
+
| Some h ->
105
+
h ();
106
+
let result = Messages.Ping.make_result () in
107
+
encode_json Messages.Ping.result_jsont result)
108
+
109
+
| m when m = Messages.Resources.list_method ->
110
+
let handler = t.handlers.list_resources in
111
+
(match handler with
112
+
| None -> method_not_found method_
113
+
| Some h ->
114
+
let req = match params with
115
+
| Some p -> decode_json Messages.Resources.list_request_jsont p
116
+
| None -> Messages.Resources.make_list_request ()
117
+
in
118
+
let result = h ~cursor:req.cursor in
119
+
encode_json Messages.Resources.list_result_jsont result)
120
+
121
+
| m when m = Messages.Resources.read_method ->
122
+
let handler = t.handlers.read_resource in
123
+
(match handler with
124
+
| None -> method_not_found method_
125
+
| Some h ->
126
+
let req = match params with
127
+
| Some p -> decode_json Messages.Resources.read_request_jsont p
128
+
| None -> invalid_params method_ "missing params"
129
+
in
130
+
let result = h ~uri:req.uri in
131
+
encode_json Messages.Resources.read_result_jsont result)
132
+
133
+
| m when m = Messages.Resources.subscribe_method ->
134
+
let handler = t.handlers.subscribe_resource in
135
+
(match handler with
136
+
| None -> method_not_found method_
137
+
| Some h ->
138
+
let req = match params with
139
+
| Some p -> decode_json Messages.Resources.subscribe_request_jsont p
140
+
| None -> invalid_params method_ "missing params"
141
+
in
142
+
h ~uri:req.uri;
143
+
Jsont.Object ([], Jsont.Meta.none)) (* Empty response *)
144
+
145
+
| m when m = Messages.Resources.unsubscribe_method ->
146
+
let handler = t.handlers.unsubscribe_resource in
147
+
(match handler with
148
+
| None -> method_not_found method_
149
+
| Some h ->
150
+
let req = match params with
151
+
| Some p -> decode_json Messages.Resources.unsubscribe_request_jsont p
152
+
| None -> invalid_params method_ "missing params"
153
+
in
154
+
h ~uri:req.uri;
155
+
Jsont.Object ([], Jsont.Meta.none)) (* Empty response *)
156
+
157
+
| m when m = Messages.Tools.list_method ->
158
+
let handler = t.handlers.list_tools in
159
+
(match handler with
160
+
| None -> method_not_found method_
161
+
| Some h ->
162
+
let req = match params with
163
+
| Some p -> decode_json Messages.Tools.list_request_jsont p
164
+
| None -> Messages.Tools.make_list_request ()
165
+
in
166
+
let result = h ~cursor:req.cursor in
167
+
encode_json Messages.Tools.list_result_jsont result)
168
+
169
+
| m when m = Messages.Tools.call_method ->
170
+
let handler = t.handlers.call_tool in
171
+
(match handler with
172
+
| None -> method_not_found method_
173
+
| Some h ->
174
+
let req = match params with
175
+
| Some p -> decode_json Messages.Tools.call_request_jsont p
176
+
| None -> invalid_params method_ "missing params"
177
+
in
178
+
let result = h ~name:req.name ~arguments:req.arguments in
179
+
encode_json Messages.Tools.call_result_jsont result)
180
+
181
+
| m when m = Messages.Prompts.list_method ->
182
+
let handler = t.handlers.list_prompts in
183
+
(match handler with
184
+
| None -> method_not_found method_
185
+
| Some h ->
186
+
let req = match params with
187
+
| Some p -> decode_json Messages.Prompts.list_request_jsont p
188
+
| None -> Messages.Prompts.make_list_request ()
189
+
in
190
+
let result = h ~cursor:req.cursor in
191
+
encode_json Messages.Prompts.list_result_jsont result)
192
+
193
+
| m when m = Messages.Prompts.get_method ->
194
+
let handler = t.handlers.get_prompt in
195
+
(match handler with
196
+
| None -> method_not_found method_
197
+
| Some h ->
198
+
let req = match params with
199
+
| Some p -> decode_json Messages.Prompts.get_request_jsont p
200
+
| None -> invalid_params method_ "missing params"
201
+
in
202
+
let result = h ~name:req.name ~arguments:req.arguments in
203
+
encode_json Messages.Prompts.get_result_jsont result)
204
+
205
+
| m when m = Messages.Completions.method_ ->
206
+
let handler = t.handlers.complete in
207
+
(match handler with
208
+
| None -> method_not_found method_
209
+
| Some h ->
210
+
let req = match params with
211
+
| Some p -> decode_json Messages.Completions.request_jsont p
212
+
| None -> invalid_params method_ "missing params"
213
+
in
214
+
let argument = match req.argument with
215
+
| Some a -> a
216
+
| None -> ""
217
+
in
218
+
let result = h ~ref_:req.ref_ ~argument in
219
+
encode_json Messages.Completions.result_jsont result)
220
+
221
+
| _ ->
222
+
method_not_found method_
223
+
224
+
(** {1 Notification Handler} *)
225
+
226
+
let handle_notification t ~method_ ~params =
227
+
match method_ with
228
+
| m when m = Messages.Initialized.method_ ->
229
+
(* Client has confirmed initialization *)
230
+
let _notif = match params with
231
+
| Some p -> decode_json Messages.Initialized.notification_jsont p
232
+
| None -> Messages.Initialized.make_notification ()
233
+
in
234
+
t.initialized <- true
235
+
236
+
| _ ->
237
+
(* Ignore unknown notifications *)
238
+
()
239
+
240
+
(** {1 Public API} *)
241
+
242
+
let create ~sw ~transport ?timeout ?clock config handlers =
243
+
(* Create session with handlers *)
244
+
let t_ref = ref None in
245
+
246
+
let request_handler ~method_ ~params =
247
+
match !t_ref with
248
+
| None -> failwith "Server session not initialized"
249
+
| Some t -> handle_request t ~method_ ~params
250
+
in
251
+
252
+
let notification_handler ~method_ ~params =
253
+
match !t_ref with
254
+
| None -> ()
255
+
| Some t -> handle_notification t ~method_ ~params
256
+
in
257
+
258
+
let session_config = {
259
+
Session.transport;
260
+
request_handler;
261
+
notification_handler;
262
+
timeout;
263
+
clock;
264
+
} in
265
+
266
+
let session = Session.create ~sw session_config in
267
+
268
+
let t = {
269
+
session;
270
+
config;
271
+
handlers;
272
+
client_capabilities = None;
273
+
client_info = None;
274
+
protocol_version = None;
275
+
initialized = false;
276
+
} in
277
+
278
+
t_ref := Some t;
279
+
280
+
t
281
+
282
+
let client_capabilities t =
283
+
match t.client_capabilities with
284
+
| Some c -> c
285
+
| None -> invalid_arg "Server_session.client_capabilities: not initialized"
286
+
287
+
let client_info t =
288
+
match t.client_info with
289
+
| Some i -> i
290
+
| None -> invalid_arg "Server_session.client_info: not initialized"
291
+
292
+
let protocol_version t =
293
+
match t.protocol_version with
294
+
| Some v -> v
295
+
| None -> invalid_arg "Server_session.protocol_version: not initialized"
296
+
297
+
(** {1 Sending Notifications} *)
298
+
299
+
let send_notification t method_ params_jsont params =
300
+
let params_json = encode_json params_jsont params in
301
+
Session.send_notification t.session ~method_ ~params:params_json ()
302
+
303
+
let send_resource_updated t ~uri =
304
+
let notif = Messages.Resources.make_updated_notification ~uri in
305
+
send_notification t
306
+
Messages.Resources.updated_notification_method
307
+
Messages.Resources.updated_notification_jsont
308
+
notif
309
+
310
+
let send_resource_list_changed t =
311
+
let notif = Messages.Resources.make_list_changed_notification () in
312
+
send_notification t
313
+
Messages.Resources.list_changed_notification_method
314
+
Messages.Resources.list_changed_notification_jsont
315
+
notif
316
+
317
+
let send_tool_list_changed t =
318
+
let notif = Messages.Tools.make_list_changed_notification () in
319
+
send_notification t
320
+
Messages.Tools.list_changed_notification_method
321
+
Messages.Tools.list_changed_notification_jsont
322
+
notif
323
+
324
+
let send_prompt_list_changed t =
325
+
let notif = Messages.Prompts.make_list_changed_notification () in
326
+
send_notification t
327
+
Messages.Prompts.list_changed_notification_method
328
+
Messages.Prompts.list_changed_notification_jsont
329
+
notif
330
+
331
+
let send_roots_list_changed t =
332
+
let notif = Messages.Roots.make_list_changed_notification () in
333
+
send_notification t
334
+
Messages.Roots.list_changed_notification_method
335
+
Messages.Roots.list_changed_notification_jsont
336
+
notif
337
+
338
+
let send_log_message t ~level ?logger ~data () =
339
+
let notif = Messages.Logging.make_notification ~level ?logger ~data () in
340
+
send_notification t
341
+
Messages.Logging.method_
342
+
Messages.Logging.notification_jsont
343
+
notif
344
+
345
+
let send_progress t ~progress_token ~progress ?total () =
346
+
let notif = Messages.Progress.make_notification ~progress_token ~progress ?total () in
347
+
send_notification t
348
+
Messages.Progress.method_
349
+
Messages.Progress.notification_jsont
350
+
notif
351
+
352
+
(** {1 Requesting from Client} *)
353
+
354
+
let request_roots_list t =
355
+
match client_capabilities t with
356
+
| { roots = None; _ } -> None
357
+
| { roots = Some _; _ } ->
358
+
let req = Messages.Roots.make_list_request () in
359
+
let params = encode_json Messages.Roots.list_request_jsont req in
360
+
let result_json = Session.send_request t.session
361
+
~method_:Messages.Roots.list_method
362
+
~params
363
+
()
364
+
in
365
+
let result = decode_json Messages.Roots.list_result_jsont result_json in
366
+
Some result
367
+
368
+
(** {1 Session Management} *)
369
+
370
+
let close t =
371
+
Session.close t.session
+208
claudeio/lib_mcp/server_session.mli
+208
claudeio/lib_mcp/server_session.mli
···
1
+
(** High-level MCP server session API.
2
+
3
+
This module provides a convenient server-side API for hosting MCP servers.
4
+
It handles the initialization handshake, routes incoming requests to handlers,
5
+
and provides helpers for sending notifications to clients.
6
+
7
+
{1 Example Usage}
8
+
9
+
{[
10
+
let config = {
11
+
server_info = Capabilities.Implementation.make
12
+
~name:"my-server"
13
+
~version:"1.0.0";
14
+
server_capabilities = Capabilities.Server.make
15
+
~tools:(Some (Capabilities.Tools.make ()))
16
+
();
17
+
instructions = Some "This is my MCP server";
18
+
} in
19
+
20
+
let handlers = {
21
+
list_tools = Some (fun ~cursor ->
22
+
Messages.Tools.make_list_result
23
+
~tools:[
24
+
Messages.Tools.make_tool
25
+
~name:"example"
26
+
~description:"An example tool"
27
+
~input_schema:(`Object [])
28
+
();
29
+
]
30
+
()
31
+
);
32
+
call_tool = Some (fun ~name ~arguments ->
33
+
Messages.Tools.make_call_result
34
+
~content:[Content.text "Tool result"]
35
+
()
36
+
);
37
+
(* ... other handlers ... *)
38
+
list_resources = None;
39
+
list_resource_templates = None;
40
+
read_resource = None;
41
+
subscribe_resource = None;
42
+
unsubscribe_resource = None;
43
+
list_prompts = None;
44
+
get_prompt = None;
45
+
complete = None;
46
+
ping = None;
47
+
} in
48
+
49
+
Eio.Switch.run @@ fun sw ->
50
+
let server = Server_session.create
51
+
~sw
52
+
~transport
53
+
config
54
+
handlers
55
+
in
56
+
(* Server is now running and handling requests *)
57
+
(* Send notifications as needed *)
58
+
Server_session.send_tool_list_changed server
59
+
]} *)
60
+
61
+
(** {1 Types} *)
62
+
63
+
type t
64
+
(** Server session handle *)
65
+
66
+
(** {1 Configuration} *)
67
+
68
+
type config = {
69
+
server_info : Capabilities.Implementation.t;
70
+
(** Server implementation information (name, version) *)
71
+
server_capabilities : Capabilities.Server.t;
72
+
(** Server capabilities to advertise to client *)
73
+
instructions : string option;
74
+
(** Optional instructions for using the server *)
75
+
}
76
+
(** Server configuration *)
77
+
78
+
(** {1 Request Handlers} *)
79
+
80
+
type handlers = {
81
+
(* Resources *)
82
+
list_resources : (cursor:string option -> Messages.Resources.list_result) option;
83
+
(** Handler for resources/list requests *)
84
+
85
+
list_resource_templates : (cursor:string option -> Messages.Resources.list_result) option;
86
+
(** Handler for resources/templates/list requests *)
87
+
88
+
read_resource : (uri:string -> Messages.Resources.read_result) option;
89
+
(** Handler for resources/read requests *)
90
+
91
+
subscribe_resource : (uri:string -> unit) option;
92
+
(** Handler for resources/subscribe requests *)
93
+
94
+
unsubscribe_resource : (uri:string -> unit) option;
95
+
(** Handler for resources/unsubscribe requests *)
96
+
97
+
(* Tools *)
98
+
list_tools : (cursor:string option -> Messages.Tools.list_result) option;
99
+
(** Handler for tools/list requests *)
100
+
101
+
call_tool : (name:string -> arguments:Jsont.json option -> Messages.Tools.call_result) option;
102
+
(** Handler for tools/call requests *)
103
+
104
+
(* Prompts *)
105
+
list_prompts : (cursor:string option -> Messages.Prompts.list_result) option;
106
+
(** Handler for prompts/list requests *)
107
+
108
+
get_prompt : (name:string -> arguments:(string * string) list option -> Messages.Prompts.get_result) option;
109
+
(** Handler for prompts/get requests *)
110
+
111
+
(* Completions *)
112
+
complete : (ref_:Messages.Completions.completion_ref -> argument:string -> Messages.Completions.result) option;
113
+
(** Handler for completion/complete requests *)
114
+
115
+
(* Ping *)
116
+
ping : (unit -> unit) option;
117
+
(** Handler for ping requests *)
118
+
}
119
+
(** Request handler callbacks.
120
+
Set to [None] to indicate the method is not supported.
121
+
If a request is received for an unsupported method, a METHOD_NOT_FOUND error is returned. *)
122
+
123
+
(** {1 Server Creation} *)
124
+
125
+
val create :
126
+
sw:Eio.Switch.t ->
127
+
transport:Transport.t ->
128
+
?timeout:float ->
129
+
?clock:Session.clock ->
130
+
config ->
131
+
handlers ->
132
+
t
133
+
(** Create and initialize a server session.
134
+
135
+
This function:
136
+
1. Creates an underlying Session
137
+
2. Waits for the Initialize request from the client
138
+
3. Returns the Initialize response with server capabilities
139
+
4. Waits for the Initialized notification
140
+
5. Returns a ready-to-use server session
141
+
142
+
The server will then handle incoming requests by routing them to the provided handlers.
143
+
144
+
@param sw Switch for the session background fibers
145
+
@param transport Transport layer for communication
146
+
@param timeout Optional request timeout in seconds
147
+
@param clock Optional clock for timeout handling (required if timeout is set)
148
+
@raise Invalid_argument if initialization fails or times out *)
149
+
150
+
(** {1 Client Information} *)
151
+
152
+
val client_capabilities : t -> Capabilities.Client.t
153
+
(** Get the client's advertised capabilities *)
154
+
155
+
val client_info : t -> Capabilities.Implementation.t
156
+
(** Get the client's implementation information *)
157
+
158
+
val protocol_version : t -> string
159
+
(** Get the negotiated protocol version *)
160
+
161
+
(** {1 Sending Notifications} *)
162
+
163
+
val send_resource_updated : t -> uri:string -> unit
164
+
(** Send a notification that a resource has been updated.
165
+
Only works if client supports resource subscriptions.
166
+
@param uri The URI of the updated resource *)
167
+
168
+
val send_resource_list_changed : t -> unit
169
+
(** Send a notification that the resource list has changed.
170
+
Only works if client supports resource list_changed capability. *)
171
+
172
+
val send_tool_list_changed : t -> unit
173
+
(** Send a notification that the tool list has changed.
174
+
Only works if server advertised tools capability. *)
175
+
176
+
val send_prompt_list_changed : t -> unit
177
+
(** Send a notification that the prompt list has changed.
178
+
Only works if server advertised prompts capability. *)
179
+
180
+
val send_roots_list_changed : t -> unit
181
+
(** Send a notification that the roots list has changed.
182
+
Only works if client supports roots capability. *)
183
+
184
+
val send_log_message : t -> level:Messages.Logging.level -> ?logger:string -> data:Jsont.json -> unit -> unit
185
+
(** Send a log message notification.
186
+
Only works if server advertised logging capability.
187
+
@param level Log level
188
+
@param logger Optional logger name
189
+
@param data Log message data (any JSON value) *)
190
+
191
+
val send_progress : t -> progress_token:string -> progress:float -> ?total:float -> unit -> unit
192
+
(** Send a progress notification.
193
+
@param progress_token Unique token identifying the operation
194
+
@param progress Progress value (0.0 to 1.0)
195
+
@param total Optional total value *)
196
+
197
+
(** {1 Requesting from Client} *)
198
+
199
+
val request_roots_list : t -> Messages.Roots.list_result option
200
+
(** Request the list of roots from the client.
201
+
Returns [None] if the client doesn't support the roots capability.
202
+
@raise Session.Timeout if the request times out
203
+
@raise Session.Remote_error if the client returns an error *)
204
+
205
+
(** {1 Session Management} *)
206
+
207
+
val close : t -> unit
208
+
(** Close the server session and underlying transport *)
+254
claudeio/lib_mcp/session.ml
+254
claudeio/lib_mcp/session.ml
···
1
+
(** Bidirectional JSON-RPC session management with request/response correlation *)
2
+
3
+
(** {1 Handlers} *)
4
+
5
+
type request_handler =
6
+
method_:string ->
7
+
params:Jsont.json option ->
8
+
Jsont.json
9
+
10
+
type notification_handler =
11
+
method_:string ->
12
+
params:Jsont.json option ->
13
+
unit
14
+
15
+
(** {1 Configuration} *)
16
+
17
+
type clock = C : _ Eio.Time.clock -> clock
18
+
19
+
type config = {
20
+
transport : Transport.t;
21
+
request_handler : request_handler;
22
+
notification_handler : notification_handler;
23
+
timeout : float option;
24
+
clock : clock option;
25
+
(** Clock for timeout handling. Required if timeout is set. *)
26
+
}
27
+
28
+
(** {1 Exceptions} *)
29
+
30
+
exception Timeout of string
31
+
exception Session_closed
32
+
exception Unknown_response of Jsonrpc.Id.t
33
+
exception Remote_error of Jsonrpc.Error_data.t
34
+
35
+
(** {1 Internal Types} *)
36
+
37
+
type response_result =
38
+
| Success of Jsont.json
39
+
| Error of exn
40
+
41
+
type pending_request = {
42
+
id : Jsonrpc.Id.t;
43
+
resolver : response_result Eio.Promise.u;
44
+
mutable cancelled : bool; (* Flag to indicate request was completed *)
45
+
}
46
+
47
+
type t = {
48
+
transport : Transport.t;
49
+
mutable next_id : int;
50
+
pending : (Jsonrpc.Id.t, pending_request) Hashtbl.t;
51
+
request_handler : request_handler;
52
+
notification_handler : notification_handler;
53
+
timeout : float option;
54
+
clock : clock option;
55
+
sw : Eio.Switch.t;
56
+
mutable closed : bool;
57
+
}
58
+
59
+
(** {1 Helper Functions} *)
60
+
61
+
let encode_message msg =
62
+
match Jsont.Json.encode Jsonrpc.Message.jsont msg with
63
+
| Ok json -> json
64
+
| Error e -> failwith ("Failed to encode message: " ^ e)
65
+
66
+
let send_json t json =
67
+
if t.closed then raise Session_closed;
68
+
Transport.send t.transport json
69
+
70
+
(** Handle an incoming request by calling the user's handler and sending response *)
71
+
let handle_request t req =
72
+
let open Jsonrpc in
73
+
let id = match req.Request.id with
74
+
| Some id -> id
75
+
| None ->
76
+
(* This is a notification, not a request - no response needed *)
77
+
t.notification_handler
78
+
~method_:req.Request.method_
79
+
~params:req.Request.params;
80
+
raise Exit (* Exit this handler without sending response *)
81
+
in
82
+
83
+
try
84
+
(* Call user's request handler *)
85
+
let result = t.request_handler
86
+
~method_:req.Request.method_
87
+
~params:req.Request.params
88
+
in
89
+
(* Send success response *)
90
+
let response = Response.make_result ~id ~result in
91
+
let msg = Message.Response response in
92
+
let json = encode_message msg in
93
+
send_json t json
94
+
with
95
+
| Exit -> () (* Notification, no response *)
96
+
| exn ->
97
+
(* Convert exception to error response *)
98
+
let error = Error_data.make
99
+
~code:Internal_error
100
+
~message:(Printexc.to_string exn)
101
+
()
102
+
in
103
+
let response = Response.make_error ~id ~error in
104
+
let msg = Message.Response response in
105
+
let json = encode_message msg in
106
+
send_json t json
107
+
108
+
(** Resolve a pending request with a response *)
109
+
let resolve_response t resp =
110
+
let open Jsonrpc in
111
+
let id = resp.Response.id in
112
+
match Hashtbl.find_opt t.pending id with
113
+
| None ->
114
+
(* Received response for unknown request ID *)
115
+
raise (Unknown_response id)
116
+
| Some pending ->
117
+
Hashtbl.remove t.pending id;
118
+
(* Mark as cancelled so timeout doesn't fire *)
119
+
pending.cancelled <- true;
120
+
(* Resolve the promise with result or error *)
121
+
(match resp.Response.value with
122
+
| Ok result ->
123
+
Eio.Promise.resolve pending.resolver (Success result)
124
+
| Stdlib.Result.Error error ->
125
+
Eio.Promise.resolve pending.resolver (Error (Remote_error error)))
126
+
127
+
(** Background receive loop - reads messages and routes them *)
128
+
let rec receive_loop t =
129
+
if t.closed then () else
130
+
match Transport.receive t.transport with
131
+
| None ->
132
+
(* Transport closed *)
133
+
t.closed <- true;
134
+
(* Cancel all pending requests *)
135
+
Hashtbl.iter (fun _ pending ->
136
+
Eio.Promise.resolve pending.resolver (Error Session_closed)
137
+
) t.pending;
138
+
Hashtbl.clear t.pending
139
+
| Some json ->
140
+
(try
141
+
let msg = Jsonrpc.Message.classify json in
142
+
match msg with
143
+
| Request req ->
144
+
(* Handle request in new fibre so it doesn't block receive loop *)
145
+
Eio.Fiber.fork_promise ~sw:t.sw (fun () ->
146
+
handle_request t req
147
+
) |> ignore
148
+
| Response resp ->
149
+
(* Resolve pending promise *)
150
+
resolve_response t resp
151
+
with exn ->
152
+
(* Log error but continue receive loop *)
153
+
Printf.eprintf "Error in receive loop: %s\n%!" (Printexc.to_string exn)
154
+
);
155
+
receive_loop t
156
+
157
+
(** {1 Public API} *)
158
+
159
+
let create ~sw (config : config) : t =
160
+
(* Validate that clock is provided if timeout is set *)
161
+
(match config.timeout with
162
+
| Some _ when config.clock = None ->
163
+
invalid_arg "Session.create: clock must be provided when timeout is set"
164
+
| _ -> ());
165
+
166
+
let t = {
167
+
transport = config.transport;
168
+
next_id = 1;
169
+
pending = Hashtbl.create 16;
170
+
request_handler = config.request_handler;
171
+
notification_handler = config.notification_handler;
172
+
timeout = config.timeout;
173
+
clock = config.clock;
174
+
sw;
175
+
closed = false;
176
+
} in
177
+
178
+
(* Start background receive loop *)
179
+
Eio.Fiber.fork ~sw (fun () -> receive_loop t);
180
+
181
+
t
182
+
183
+
let send_request t ~method_ ?params () =
184
+
if t.closed then raise Session_closed;
185
+
186
+
(* Generate unique request ID *)
187
+
let id = `Number (float_of_int t.next_id) in
188
+
t.next_id <- t.next_id + 1;
189
+
190
+
(* Create promise for response *)
191
+
let promise, resolver = Eio.Promise.create () in
192
+
193
+
(* Register pending request *)
194
+
let pending = {
195
+
id;
196
+
resolver;
197
+
cancelled = false;
198
+
} in
199
+
Hashtbl.add t.pending id pending;
200
+
201
+
(* Setup timeout if configured *)
202
+
(match t.timeout, t.clock with
203
+
| None, _ | _, None -> ()
204
+
| Some timeout_sec, Some (C clock) ->
205
+
(* Start timeout fiber *)
206
+
Eio.Fiber.fork ~sw:t.sw (fun () ->
207
+
Eio.Time.sleep clock timeout_sec;
208
+
(* Timeout expired - check if request is still pending and not cancelled *)
209
+
if not pending.cancelled then begin
210
+
match Hashtbl.find_opt t.pending id with
211
+
| Some _ ->
212
+
Hashtbl.remove t.pending id;
213
+
let msg = Printf.sprintf "Request timeout after %.1fs: %s" timeout_sec method_ in
214
+
Eio.Promise.resolve pending.resolver (Error (Timeout msg))
215
+
| None ->
216
+
(* Request already completed, nothing to do *)
217
+
()
218
+
end
219
+
)
220
+
);
221
+
222
+
(* Send request *)
223
+
let req = Jsonrpc.Request.make ~method_ ?params ~id () in
224
+
let msg = Jsonrpc.Message.Request req in
225
+
let json = encode_message msg in
226
+
send_json t json;
227
+
228
+
(* Wait for response *)
229
+
match Eio.Promise.await promise with
230
+
| Success result -> result
231
+
| Error exn -> raise exn
232
+
233
+
let send_notification t ~method_ ?params () =
234
+
if t.closed then raise Session_closed;
235
+
236
+
(* Create notification (request with no ID) *)
237
+
let req = Jsonrpc.Request.make ~method_ ?params () in
238
+
let msg = Jsonrpc.Message.Request req in
239
+
let json = encode_message msg in
240
+
send_json t json
241
+
242
+
let close t =
243
+
if not t.closed then begin
244
+
t.closed <- true;
245
+
(* Cancel all pending requests *)
246
+
Hashtbl.iter (fun _ pending ->
247
+
Eio.Promise.resolve pending.resolver (Error Session_closed)
248
+
) t.pending;
249
+
Hashtbl.clear t.pending;
250
+
(* Close transport *)
251
+
Transport.close t.transport
252
+
end
253
+
254
+
let is_closed t = t.closed
+140
claudeio/lib_mcp/session.mli
+140
claudeio/lib_mcp/session.mli
···
1
+
(** Bidirectional JSON-RPC session management with request/response correlation.
2
+
3
+
This module provides a high-level session abstraction over a transport layer,
4
+
handling request ID generation, response correlation via promises, and
5
+
bidirectional message routing using Eio structured concurrency.
6
+
7
+
{1 Architecture}
8
+
9
+
Sessions run a background receive loop in an Eio fiber that continuously
10
+
reads from the transport and routes messages:
11
+
- Incoming requests → dispatched to request_handler in new fiber
12
+
- Incoming responses → resolve pending promises
13
+
- Incoming notifications → dispatched to notification_handler
14
+
15
+
Outgoing messages (requests and notifications) are sent directly on the
16
+
transport. Requests return promises that are resolved when the corresponding
17
+
response arrives.
18
+
19
+
{1 Example Usage}
20
+
21
+
{[
22
+
Eio_main.run @@ fun env ->
23
+
let config = {
24
+
transport;
25
+
request_handler = (fun ~method_ ~params ->
26
+
(* Handle incoming requests *)
27
+
match method_ with
28
+
| "ping" -> `String "pong"
29
+
| _ -> failwith "Unknown method"
30
+
);
31
+
notification_handler = (fun ~method_ ~params ->
32
+
(* Handle incoming notifications *)
33
+
Printf.printf "Notification: %s\n" method_
34
+
);
35
+
timeout = Some 30.0; (* 30 second timeout *)
36
+
clock = Some (C (Eio.Stdenv.clock env));
37
+
}
38
+
in
39
+
40
+
Eio.Switch.run @@ fun sw ->
41
+
let session = Session.create ~sw config in
42
+
43
+
(* Send a request and wait for response *)
44
+
let response = Session.send_request session
45
+
~method_:"initialize"
46
+
~params:(`Object [("version", `String "1.0")])
47
+
()
48
+
in
49
+
50
+
(* Send a notification (no response expected) *)
51
+
Session.send_notification session
52
+
~method_:"progress"
53
+
~params:(`Object [("percent", `Number 50.0)])
54
+
()
55
+
]} *)
56
+
57
+
(** {1 Handlers} *)
58
+
59
+
type request_handler =
60
+
method_:string ->
61
+
params:Jsont.json option ->
62
+
Jsont.json
63
+
(** Handler for incoming requests. Should return the result value.
64
+
May raise exceptions which will be converted to JSON-RPC errors. *)
65
+
66
+
type notification_handler =
67
+
method_:string ->
68
+
params:Jsont.json option ->
69
+
unit
70
+
(** Handler for incoming notifications. No response is expected. *)
71
+
72
+
(** {1 Configuration} *)
73
+
74
+
type clock = C : _ Eio.Time.clock -> clock
75
+
(** Wrapper for existential clock type *)
76
+
77
+
type config = {
78
+
transport : Transport.t;
79
+
(** Transport layer for sending/receiving JSON messages *)
80
+
request_handler : request_handler;
81
+
(** Handler for incoming requests *)
82
+
notification_handler : notification_handler;
83
+
(** Handler for incoming notifications *)
84
+
timeout : float option;
85
+
(** Request timeout in seconds. [None] means no timeout. *)
86
+
clock : clock option;
87
+
(** Clock for timeout handling. Required if [timeout] is set. *)
88
+
}
89
+
(** Session configuration *)
90
+
91
+
(** {1 Session Management} *)
92
+
93
+
type t
94
+
(** Session handle *)
95
+
96
+
exception Timeout of string
97
+
(** Raised when a request times out *)
98
+
99
+
exception Session_closed
100
+
(** Raised when attempting to use a closed session *)
101
+
102
+
exception Unknown_response of Jsonrpc.Id.t
103
+
(** Raised when receiving a response for an unknown request ID *)
104
+
105
+
exception Remote_error of Jsonrpc.Error_data.t
106
+
(** Raised when the remote side returns an error response *)
107
+
108
+
val create :
109
+
sw:Eio.Switch.t ->
110
+
config ->
111
+
t
112
+
(** Create and start a session with a background receive loop.
113
+
The receive loop runs in a background fiber attached to [sw]. *)
114
+
115
+
val send_request :
116
+
t ->
117
+
method_:string ->
118
+
?params:Jsont.json ->
119
+
unit ->
120
+
Jsont.json
121
+
(** Send a request and await the response.
122
+
Raises [Timeout] if the request times out.
123
+
Raises [Remote_error] if the server returns an error.
124
+
Raises [Session_closed] if the session is closed. *)
125
+
126
+
val send_notification :
127
+
t ->
128
+
method_:string ->
129
+
?params:Jsont.json ->
130
+
unit ->
131
+
unit
132
+
(** Send a notification (no response expected).
133
+
Raises [Session_closed] if the session is closed. *)
134
+
135
+
val close : t -> unit
136
+
(** Close the session and underlying transport.
137
+
This will cancel all pending requests. *)
138
+
139
+
val is_closed : t -> bool
140
+
(** Check if the session is closed *)
+29
claudeio/lib_mcp/transport.ml
+29
claudeio/lib_mcp/transport.ml
···
1
+
(** Abstract transport layer for MCP communication *)
2
+
3
+
exception Connection_error of string
4
+
5
+
(** Internal module type that transport implementations must satisfy *)
6
+
module type TRANSPORT = sig
7
+
type state
8
+
9
+
val send : state -> Jsont.json -> unit
10
+
val receive : state -> Jsont.json option
11
+
val close : state -> unit
12
+
val is_closed : state -> bool
13
+
end
14
+
15
+
(** The abstract transport type - hides the concrete implementation *)
16
+
type t = T : (module TRANSPORT with type state = 'a) * 'a -> t
17
+
[@@warning "-37"] (* Constructor T is used in transport implementations *)
18
+
19
+
let send (T ((module M), state)) json =
20
+
M.send state json
21
+
22
+
let receive (T ((module M), state)) =
23
+
M.receive state
24
+
25
+
let close (T ((module M), state)) =
26
+
M.close state
27
+
28
+
let is_closed (T ((module M), state)) =
29
+
M.is_closed state
+34
claudeio/lib_mcp/transport.mli
+34
claudeio/lib_mcp/transport.mli
···
1
+
(** Abstract transport layer for MCP communication *)
2
+
3
+
(** Module type that transport implementations must satisfy *)
4
+
module type TRANSPORT = sig
5
+
type state
6
+
7
+
val send : state -> Jsont.json -> unit
8
+
val receive : state -> Jsont.json option
9
+
val close : state -> unit
10
+
val is_closed : state -> bool
11
+
end
12
+
13
+
(** The abstract transport type for sending/receiving JSON messages *)
14
+
type t = T : (module TRANSPORT with type state = 'a) * 'a -> t
15
+
16
+
(** [send t json] sends a JSON message through the transport.
17
+
@raise Connection_error if the transport is closed or sending fails *)
18
+
val send : t -> Jsont.json -> unit
19
+
20
+
(** [receive t] receives a JSON message from the transport (blocking).
21
+
Returns [None] on EOF or when the transport is closed.
22
+
@raise Connection_error if receiving fails for reasons other than EOF *)
23
+
val receive : t -> Jsont.json option
24
+
25
+
(** [close t] closes the transport and releases all associated resources.
26
+
This is idempotent - calling close multiple times is safe. *)
27
+
val close : t -> unit
28
+
29
+
(** [is_closed t] checks if the transport is closed.
30
+
Returns [true] if the transport has been closed, [false] otherwise. *)
31
+
val is_closed : t -> bool
32
+
33
+
(** Exception raised when transport operations fail *)
34
+
exception Connection_error of string
+179
claudeio/lib_mcp/transport_stdio.ml
+179
claudeio/lib_mcp/transport_stdio.ml
···
1
+
(** Stdio transport implementation for MCP *)
2
+
3
+
let src = Logs.Src.create "mcp.transport.stdio" ~doc:"MCP stdio transport"
4
+
module Log = (val Logs.src_log src : Logs.LOG)
5
+
6
+
exception Process_spawn_error of string
7
+
8
+
(** Parameters for creating a stdio transport *)
9
+
type params = {
10
+
command : string;
11
+
args : string list;
12
+
env : (string * string) list option;
13
+
max_buffer_size : int option;
14
+
}
15
+
16
+
(** Wrapper for existential process type *)
17
+
type process = P : _ Eio.Process.t -> process
18
+
19
+
(** Internal state for stdio transport *)
20
+
type state = {
21
+
process : process;
22
+
stdin : Eio.Flow.sink_ty Eio.Resource.t;
23
+
stdin_close : [`Close | `Flow] Eio.Resource.t;
24
+
stdout : Eio.Buf_read.t;
25
+
mutable closed : bool;
26
+
sw : Eio.Switch.t;
27
+
}
28
+
29
+
(** Send a JSON message by encoding to a line-delimited string *)
30
+
let send state json =
31
+
if state.closed then
32
+
raise (Transport.Connection_error "Transport is closed");
33
+
34
+
let data = match Jsont_bytesrw.encode_string' Jsont.json json with
35
+
| Ok s -> s
36
+
| Error err ->
37
+
let msg = Jsont.Error.to_string err in
38
+
raise (Transport.Connection_error ("JSON encoding failed: " ^ msg))
39
+
in
40
+
41
+
Log.debug (fun m -> m "Sending: %s" data);
42
+
43
+
try
44
+
Eio.Flow.write state.stdin [Cstruct.of_string (data ^ "\n")]
45
+
with
46
+
| exn ->
47
+
Log.err (fun m -> m "Failed to send message: %s" (Printexc.to_string exn));
48
+
raise (Transport.Connection_error
49
+
(Printf.sprintf "Failed to send message: %s" (Printexc.to_string exn)))
50
+
51
+
(** Receive a JSON message by reading a line and decoding *)
52
+
let receive state =
53
+
if state.closed then
54
+
None
55
+
else
56
+
try
57
+
match Eio.Buf_read.line state.stdout with
58
+
| line ->
59
+
Log.debug (fun m -> m "Received: %s" line);
60
+
(match Jsont_bytesrw.decode_string' Jsont.json line with
61
+
| Ok json -> Some json
62
+
| Error err ->
63
+
let msg = Jsont.Error.to_string err in
64
+
Log.err (fun m -> m "JSON decoding failed: %s" msg);
65
+
raise (Transport.Connection_error ("JSON decoding failed: " ^ msg)))
66
+
| exception End_of_file ->
67
+
Log.debug (fun m -> m "Received EOF");
68
+
state.closed <- true;
69
+
None
70
+
with
71
+
| Transport.Connection_error _ as e -> raise e
72
+
| exn ->
73
+
Log.err (fun m -> m "Failed to receive message: %s" (Printexc.to_string exn));
74
+
raise (Transport.Connection_error
75
+
(Printf.sprintf "Failed to receive message: %s" (Printexc.to_string exn)))
76
+
77
+
(** Close the transport and cleanup resources *)
78
+
let close state =
79
+
if not state.closed then begin
80
+
state.closed <- true;
81
+
try
82
+
Eio.Flow.close state.stdin_close;
83
+
let (P process) = state.process in
84
+
Eio.Process.await_exn process
85
+
with _ -> ()
86
+
end
87
+
88
+
(** Check if transport is closed *)
89
+
let is_closed state =
90
+
state.closed
91
+
92
+
(** The transport module implementation *)
93
+
module Stdio_transport : Transport.TRANSPORT with type state = state = struct
94
+
type nonrec state = state
95
+
96
+
let send = send
97
+
let receive = receive
98
+
let close = close
99
+
let is_closed = is_closed
100
+
end
101
+
102
+
(** Create a new stdio transport *)
103
+
let create ~sw ~process_mgr params =
104
+
(* Build command arguments *)
105
+
let cmd = params.command :: params.args in
106
+
107
+
(* Build environment - preserve essential vars and add custom ones *)
108
+
let home = try Unix.getenv "HOME" with Not_found -> "/tmp" in
109
+
let path = try Unix.getenv "PATH" with Not_found -> "/usr/bin:/bin" in
110
+
111
+
(* Preserve other potentially important environment variables *)
112
+
let preserve_vars = [
113
+
"USER"; "LOGNAME"; "SHELL"; "TERM";
114
+
"XDG_CONFIG_HOME"; "XDG_DATA_HOME"; "XDG_CACHE_HOME";
115
+
] in
116
+
117
+
let preserved = List.filter_map (fun var ->
118
+
try Some (Printf.sprintf "%s=%s" var (Unix.getenv var))
119
+
with Not_found -> None
120
+
) preserve_vars in
121
+
122
+
let base_env = [
123
+
Printf.sprintf "HOME=%s" home;
124
+
Printf.sprintf "PATH=%s" path;
125
+
] @ preserved in
126
+
127
+
let custom_env = match params.env with
128
+
| None -> []
129
+
| Some vars -> List.map (fun (k, v) -> Printf.sprintf "%s=%s" k v) vars
130
+
in
131
+
132
+
let env = Array.of_list (base_env @ custom_env) in
133
+
134
+
Log.debug (fun m -> m "Environment: HOME=%s, PATH=%s" home path);
135
+
Log.info (fun m -> m "Spawning command: %s" (String.concat " " cmd));
136
+
137
+
(* Create pipes for stdin/stdout *)
138
+
let stdin_r, stdin_w = Eio.Process.pipe ~sw process_mgr in
139
+
let stdout_r, stdout_w = Eio.Process.pipe ~sw process_mgr in
140
+
141
+
(* Spawn the process *)
142
+
let process =
143
+
try
144
+
Eio.Process.spawn ~sw process_mgr
145
+
~env
146
+
~stdin:(stdin_r :> Eio.Flow.source_ty Eio.Resource.t)
147
+
~stdout:(stdout_w :> Eio.Flow.sink_ty Eio.Resource.t)
148
+
cmd
149
+
with
150
+
| exn ->
151
+
Log.err (fun m -> m "Failed to spawn process: %s" (Printexc.to_string exn));
152
+
raise (Process_spawn_error
153
+
(Printf.sprintf "Failed to spawn process: %s" (Printexc.to_string exn)))
154
+
in
155
+
156
+
(* Setup stdin for writing *)
157
+
let stdin = (stdin_w :> Eio.Flow.sink_ty Eio.Resource.t) in
158
+
let stdin_close = (stdin_w :> [`Close | `Flow] Eio.Resource.t) in
159
+
160
+
(* Setup stdout for reading with buffering *)
161
+
let max_size = match params.max_buffer_size with
162
+
| Some size -> size
163
+
| None -> 1_000_000 (* Default 1MB *)
164
+
in
165
+
let stdout = Eio.Buf_read.of_flow ~max_size
166
+
(stdout_r :> Eio.Flow.source_ty Eio.Resource.t) in
167
+
168
+
(* Create the state *)
169
+
let state = {
170
+
process = P process;
171
+
stdin;
172
+
stdin_close;
173
+
stdout;
174
+
closed = false;
175
+
sw;
176
+
} in
177
+
178
+
(* Wrap in abstract transport type *)
179
+
Transport.T ((module Stdio_transport), state)
+38
claudeio/lib_mcp/transport_stdio.mli
+38
claudeio/lib_mcp/transport_stdio.mli
···
1
+
(** Stdio transport implementation for MCP *)
2
+
3
+
(** Parameters for creating a stdio transport *)
4
+
type params = {
5
+
command : string;
6
+
(** The command to execute (executable path or name in PATH) *)
7
+
8
+
args : string list;
9
+
(** Command-line arguments to pass to the command *)
10
+
11
+
env : (string * string) list option;
12
+
(** Optional environment variables to set. If [None], inherits parent environment.
13
+
If [Some vars], these are ADDED to essential preserved variables (HOME, PATH, etc.) *)
14
+
15
+
max_buffer_size : int option;
16
+
(** Maximum buffer size for reading from stdout. Defaults to 1MB if [None] *)
17
+
}
18
+
19
+
(** [create ~sw ~process_mgr params] creates a new stdio transport by spawning
20
+
a subprocess with the given parameters.
21
+
22
+
The subprocess communicates via line-delimited JSON on stdin/stdout:
23
+
- Each message is a single JSON object on one line
24
+
- Lines are terminated with newline ('\n')
25
+
- The transport handles encoding/decoding automatically
26
+
27
+
@param sw The Eio switch that manages the subprocess lifetime
28
+
@param process_mgr The Eio process manager for spawning subprocesses
29
+
@param params Configuration parameters for the subprocess
30
+
@raise Transport.Connection_error if subprocess spawning fails *)
31
+
val create :
32
+
sw:Eio.Switch.t ->
33
+
process_mgr:_ Eio.Process.mgr ->
34
+
params ->
35
+
Transport.t
36
+
37
+
(** Exception raised when subprocess spawning fails *)
38
+
exception Process_spawn_error of string
+30
claudeio/mcp.opam
+30
claudeio/mcp.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Model Context Protocol (MCP) implementation in OCaml"
4
+
description:
5
+
"An Eio-based OCaml library implementing the Model Context Protocol for connecting AI assistants with tools and data sources"
6
+
depends: [
7
+
"ocaml"
8
+
"dune" {>= "3.0"}
9
+
"eio"
10
+
"fmt"
11
+
"logs"
12
+
"jsont" {>= "0.2.0"}
13
+
"jsont_bytesrw" {>= "0.2.0"}
14
+
"alcotest" {with-test}
15
+
"odoc" {with-doc}
16
+
]
17
+
build: [
18
+
["dune" "subst"] {dev}
19
+
[
20
+
"dune"
21
+
"build"
22
+
"-p"
23
+
name
24
+
"-j"
25
+
jobs
26
+
"@install"
27
+
"@runtest" {with-test}
28
+
"@doc" {with-doc}
29
+
]
30
+
]