Model Context Protocol in OCaml
anil.recoil.org
1open Mcp
2open Jsonrpc
3
4(* SDK version *)
5let version = "0.1.0"
6let src = Logs.Src.create "mcp.sdk" ~doc:"mcp.sdk logging"
7
8module Log = (val Logs.src_log src : Logs.LOG)
9
10(* Context for tools and resources *)
11module Context = struct
12 type t = {
13 request_id : RequestId.t option;
14 lifespan_context : (string * Json.t) list;
15 progress_token : ProgressToken.t option;
16 }
17
18 let create ?request_id ?progress_token ?(lifespan_context = []) () =
19 { request_id; lifespan_context; progress_token }
20
21 let get_context_value ctx key = List.assoc_opt key ctx.lifespan_context
22
23 let report_progress ctx value total =
24 match (ctx.progress_token, ctx.request_id) with
25 | Some token, Some _id ->
26 let params =
27 `Assoc
28 [
29 ("progress", `Float value);
30 ("total", `Float total);
31 ("progressToken", ProgressToken.yojson_of_t token);
32 ]
33 in
34 Some
35 (create_notification ~meth:Method.Progress ~params:(Some params) ())
36 | _ -> None
37end
38
39(* Tools for the MCP server *)
40module Tool = struct
41 type handler = Context.t -> Json.t -> (Json.t, string) result
42
43 type t = {
44 name : string;
45 description : string option;
46 input_schema : Json.t; (* JSON Schema *)
47 handler : handler;
48 }
49
50 let create ~name ?description ~input_schema ~handler () =
51 { name; description; input_schema; handler }
52
53 let to_json tool =
54 let assoc =
55 [ ("name", `String tool.name); ("inputSchema", tool.input_schema) ]
56 in
57 let assoc =
58 match tool.description with
59 | Some desc -> ("description", `String desc) :: assoc
60 | None -> assoc
61 in
62 `Assoc assoc
63
64 (* Convert to Mcp_rpc.ToolsList.Tool.t *)
65 let to_rpc_tool_list_tool (tool : t) =
66 Mcp_rpc.ToolsList.Tool.
67 {
68 name = tool.name;
69 description = tool.description;
70 input_schema = tool.input_schema;
71 annotations = None;
72 (* Could be extended to support annotations *)
73 }
74
75 (* Convert a list of Tool.t to the format needed for tools/list response *)
76 let to_rpc_tools_list tools = List.map to_rpc_tool_list_tool tools
77
78 (* Convert Mcp_rpc.ToolsCall response content to Mcp.content list *)
79 let rpc_content_to_mcp_content content =
80 List.map
81 (function
82 | Mcp_rpc.ToolsCall.ToolContent.Text t ->
83 Mcp.Text { TextContent.text = t.text; annotations = None }
84 | Mcp_rpc.ToolsCall.ToolContent.Image i ->
85 Mcp.Image
86 {
87 ImageContent.mime_type = i.mime_type;
88 data = i.data;
89 annotations = None;
90 }
91 | Mcp_rpc.ToolsCall.ToolContent.Audio a ->
92 Mcp.Audio
93 {
94 AudioContent.mime_type = a.mime_type;
95 data = a.data;
96 annotations = None;
97 }
98 | Mcp_rpc.ToolsCall.ToolContent.Resource r ->
99 (* Create a simple text resource from the embedded resource *)
100 let uri =
101 match r with
102 | { EmbeddedResource.resource = `Text tr; _ } -> tr.uri
103 | { EmbeddedResource.resource = `Blob br; _ } -> br.uri
104 in
105 let text_content =
106 match r with
107 | { EmbeddedResource.resource = `Text tr; _ } -> tr.text
108 | { EmbeddedResource.resource = `Blob br; _ } -> "Binary content"
109 in
110 let mime_type =
111 match r with
112 | { EmbeddedResource.resource = `Text tr; _ } -> tr.mime_type
113 | { EmbeddedResource.resource = `Blob br; _ } -> br.mime_type
114 in
115 let text_resource =
116 { TextResourceContents.uri; text = text_content; mime_type }
117 in
118 Mcp.Resource
119 {
120 EmbeddedResource.resource = `Text text_resource;
121 annotations = None;
122 })
123 content
124
125 (* Convert Mcp.content list to Mcp_rpc.ToolsCall.ToolContent.t list *)
126 let mcp_content_to_rpc_content content =
127 List.map
128 (function
129 | Mcp.Text t -> Mcp_rpc.ToolsCall.ToolContent.Text t
130 | Mcp.Image img -> Mcp_rpc.ToolsCall.ToolContent.Image img
131 | Mcp.Audio aud -> Mcp_rpc.ToolsCall.ToolContent.Audio aud
132 | Mcp.Resource res ->
133 let resource_data =
134 match res.resource with
135 | `Text txt -> `Text txt
136 | `Blob blob -> `Blob blob
137 in
138 let resource =
139 {
140 EmbeddedResource.resource = resource_data;
141 annotations = res.annotations;
142 }
143 in
144 Mcp_rpc.ToolsCall.ToolContent.Resource resource)
145 content
146
147 (* Create a tool result with content *)
148 let create_tool_result content ~is_error =
149 `Assoc
150 [
151 ("content", `List (List.map Mcp.yojson_of_content content));
152 ("isError", `Bool is_error);
153 ]
154
155 (* Create a tool error result with structured content *)
156 let create_error_result error =
157 Logs.err (fun m -> m "Error result: %s" error);
158 create_tool_result [ Mcp.make_text_content error ] ~is_error:true
159
160 (* Handle tool execution errors *)
161 let handle_execution_error err =
162 create_error_result (Printf.sprintf "Error executing tool: %s" err)
163
164 (* Handle unknown tool error *)
165 let handle_unknown_tool_error name =
166 create_error_result (Printf.sprintf "Unknown tool: %s" name)
167
168 (* Handle general tool execution exception *)
169 let handle_execution_exception exn =
170 create_error_result
171 (Printf.sprintf "Internal error: %s" (Printexc.to_string exn))
172end
173
174(* Resources for the MCP server *)
175module Resource = struct
176 type handler = Context.t -> string list -> (string, string) result
177
178 type t = {
179 uri : string; (* For resources, this is the exact URI (no variables) *)
180 name : string;
181 description : string option;
182 mime_type : string option;
183 handler : handler;
184 }
185
186 let create ~uri ~name ?description ?mime_type ~handler () =
187 (* Validate that the URI doesn't contain template variables *)
188 if String.contains uri '{' || String.contains uri '}' then
189 Logs.warn (fun m ->
190 m
191 "Resource '%s' contains template variables. Consider using \
192 add_resource_template instead."
193 uri);
194 { uri; name; description; mime_type; handler }
195
196 let to_json resource =
197 let assoc =
198 [ ("uri", `String resource.uri); ("name", `String resource.name) ]
199 in
200 let assoc =
201 match resource.description with
202 | Some desc -> ("description", `String desc) :: assoc
203 | None -> assoc
204 in
205 let assoc =
206 match resource.mime_type with
207 | Some mime -> ("mimeType", `String mime) :: assoc
208 | None -> assoc
209 in
210 `Assoc assoc
211
212 (* Convert to Mcp_rpc.ResourcesList.Resource.t *)
213 let to_rpc_resource_list_resource (resource : t) =
214 Mcp_rpc.ResourcesList.Resource.
215 {
216 uri = resource.uri;
217 name = resource.name;
218 description = resource.description;
219 mime_type = resource.mime_type;
220 size = None;
221 (* Size can be added when we have actual resource content *)
222 }
223
224 (* Convert a list of Resource.t to the format needed for resources/list response *)
225 let to_rpc_resources_list resources =
226 List.map to_rpc_resource_list_resource resources
227end
228
229(* Prompts for the MCP server *)
230module Prompt = struct
231 type argument = {
232 name : string;
233 description : string option;
234 required : bool;
235 }
236
237 type message = { role : Role.t; content : content }
238
239 type handler =
240 Context.t -> (string * string) list -> (message list, string) result
241
242 type t = {
243 name : string;
244 description : string option;
245 arguments : argument list;
246 handler : handler;
247 }
248
249 let create ~name ?description ?(arguments = []) ~handler () =
250 { name; description; arguments; handler }
251
252 let create_argument ~name ?description ?(required = false) () =
253 { name; description; required }
254
255 let to_json prompt =
256 let assoc = [ ("name", `String prompt.name) ] in
257 let assoc =
258 match prompt.description with
259 | Some desc -> ("description", `String desc) :: assoc
260 | None -> assoc
261 in
262 let assoc =
263 if prompt.arguments <> [] then
264 let args =
265 List.map
266 (fun (arg : argument) ->
267 let arg_assoc = [ ("name", `String arg.name) ] in
268 let arg_assoc =
269 match arg.description with
270 | Some desc -> ("description", `String desc) :: arg_assoc
271 | None -> arg_assoc
272 in
273 let arg_assoc =
274 if arg.required then ("required", `Bool true) :: arg_assoc
275 else arg_assoc
276 in
277 `Assoc arg_assoc)
278 prompt.arguments
279 in
280 ("arguments", `List args) :: assoc
281 else assoc
282 in
283 `Assoc assoc
284
285 (* Convert argument to Mcp_rpc.PromptsList.PromptArgument.t *)
286 let argument_to_rpc_prompt_argument (arg : argument) =
287 Mcp_rpc.PromptsList.PromptArgument.
288 {
289 name = arg.name;
290 description = arg.description;
291 required = arg.required;
292 }
293
294 (* Convert to Mcp_rpc.PromptsList.Prompt.t *)
295 let to_rpc_prompt_list_prompt (prompt : t) =
296 Mcp_rpc.PromptsList.Prompt.
297 {
298 name = prompt.name;
299 description = prompt.description;
300 arguments = List.map argument_to_rpc_prompt_argument prompt.arguments;
301 }
302
303 (* Convert a list of Prompt.t to the format needed for prompts/list response *)
304 let to_rpc_prompts_list prompts = List.map to_rpc_prompt_list_prompt prompts
305
306 (* Convert message to Mcp_rpc.PromptMessage.t *)
307 let message_to_rpc_prompt_message msg =
308 { PromptMessage.role = msg.role; PromptMessage.content = msg.content }
309
310 (* Convert a list of messages to the format needed for prompts/get response *)
311 let messages_to_rpc_prompt_messages messages =
312 List.map message_to_rpc_prompt_message messages
313end
314
315let make_tool_schema properties required =
316 let props =
317 List.map
318 (fun (name, schema_type, description) ->
319 ( name,
320 `Assoc
321 [
322 ("type", `String schema_type); ("description", `String description);
323 ] ))
324 properties
325 in
326 let required_json = `List (List.map (fun name -> `String name) required) in
327 `Assoc
328 [
329 ("type", `String "object");
330 ("properties", `Assoc props);
331 ("required", required_json);
332 ]
333
334(* Resource Templates for the MCP server *)
335module ResourceTemplate = struct
336 type handler = Context.t -> string list -> (string, string) result
337
338 type t = {
339 uri_template : string;
340 name : string;
341 description : string option;
342 mime_type : string option;
343 handler : handler;
344 }
345
346 let create ~uri_template ~name ?description ?mime_type ~handler () =
347 { uri_template; name; description; mime_type; handler }
348
349 let to_json resource_template =
350 let assoc =
351 [
352 ("uriTemplate", `String resource_template.uri_template);
353 ("name", `String resource_template.name);
354 ]
355 in
356 let assoc =
357 match resource_template.description with
358 | Some desc -> ("description", `String desc) :: assoc
359 | None -> assoc
360 in
361 let assoc =
362 match resource_template.mime_type with
363 | Some mime -> ("mimeType", `String mime) :: assoc
364 | None -> assoc
365 in
366 `Assoc assoc
367
368 (* Convert to Mcp_rpc.ResourceTemplatesList.ResourceTemplate.t *)
369 let to_rpc_resource_template (template : t) =
370 Mcp_rpc.ListResourceTemplatesResult.ResourceTemplate.
371 {
372 uri_template = template.uri_template;
373 name = template.name;
374 description = template.description;
375 mime_type = template.mime_type;
376 }
377
378 (* Convert a list of ResourceTemplate.t to the format needed for resources/templates/list response *)
379 let to_rpc_resource_templates_list templates =
380 List.map to_rpc_resource_template templates
381end
382
383(* Main server type *)
384type server = {
385 name : string;
386 version : string;
387 protocol_version : string;
388 lifespan_context : (string * Json.t) list;
389 mutable capabilities : Json.t;
390 mutable tools : Tool.t list;
391 mutable resources : Resource.t list;
392 mutable resource_templates : ResourceTemplate.t list;
393 mutable prompts : Prompt.t list;
394}
395
396let name { name; _ } = name
397let version { version; _ } = version
398let capabilities { capabilities; _ } = capabilities
399let lifespan_context { lifespan_context; _ } = lifespan_context
400let protocol_version { protocol_version; _ } = protocol_version
401let tools { tools; _ } = tools
402let resources { resources; _ } = resources
403let resource_templates { resource_templates; _ } = resource_templates
404let prompts { prompts; _ } = prompts
405
406(* Create a new server *)
407let create_server ~name ?(version = "0.1.0") ?(protocol_version = "2024-11-05")
408 () =
409 {
410 name;
411 version;
412 protocol_version;
413 capabilities = `Assoc [];
414 tools = [];
415 resources = [];
416 resource_templates = [];
417 prompts = [];
418 lifespan_context = [];
419 }
420
421(* Default capabilities for the server *)
422let default_capabilities ?(with_tools = true) ?(with_resources = false)
423 ?(with_resource_templates = false) ?(with_prompts = false) () =
424 let caps = [] in
425 let caps =
426 if with_tools then ("tools", `Assoc [ ("listChanged", `Bool true) ]) :: caps
427 else caps
428 in
429 let caps =
430 if with_resources then
431 ( "resources",
432 `Assoc [ ("listChanged", `Bool true); ("subscribe", `Bool false) ] )
433 :: caps
434 else if not with_resources then
435 ( "resources",
436 `Assoc [ ("listChanged", `Bool false); ("subscribe", `Bool false) ] )
437 :: caps
438 else caps
439 in
440 let caps =
441 if with_resource_templates then
442 ("resourceTemplates", `Assoc [ ("listChanged", `Bool true) ]) :: caps
443 else if not with_resource_templates then
444 ("resourceTemplates", `Assoc [ ("listChanged", `Bool false) ]) :: caps
445 else caps
446 in
447 let caps =
448 if with_prompts then
449 ("prompts", `Assoc [ ("listChanged", `Bool true) ]) :: caps
450 else if not with_prompts then
451 ("prompts", `Assoc [ ("listChanged", `Bool false) ]) :: caps
452 else caps
453 in
454 `Assoc caps
455
456(* Register a tool *)
457let register_tool server tool =
458 server.tools <- tool :: server.tools;
459 tool
460
461(* Create and register a tool in one step *)
462let add_tool server ~name ?description ?(schema_properties = [])
463 ?(schema_required = []) handler =
464 let input_schema = make_tool_schema schema_properties schema_required in
465 let handler' ctx args =
466 try Ok (handler args) with exn -> Error (Printexc.to_string exn)
467 in
468 let tool =
469 Tool.create ~name ?description ~input_schema ~handler:handler' ()
470 in
471 register_tool server tool
472
473(* Register a resource *)
474let register_resource server resource =
475 server.resources <- resource :: server.resources;
476 resource
477
478(* Create and register a resource in one step *)
479let add_resource server ~uri ~name ?description ?mime_type handler =
480 let handler' _ctx params =
481 try Ok (handler params) with exn -> Error (Printexc.to_string exn)
482 in
483 let resource =
484 Resource.create ~uri ~name ?description ?mime_type ~handler:handler' ()
485 in
486 register_resource server resource
487
488(* Register a resource template *)
489let register_resource_template server template =
490 server.resource_templates <- template :: server.resource_templates;
491 template
492
493(* Create and register a resource template in one step *)
494let add_resource_template server ~uri_template ~name ?description ?mime_type
495 handler =
496 let handler' _ctx params =
497 try Ok (handler params) with exn -> Error (Printexc.to_string exn)
498 in
499 let template =
500 ResourceTemplate.create ~uri_template ~name ?description ?mime_type
501 ~handler:handler' ()
502 in
503 register_resource_template server template
504
505(* Register a prompt *)
506let register_prompt server prompt =
507 server.prompts <- prompt :: server.prompts;
508 prompt
509
510(* Create and register a prompt in one step *)
511let add_prompt server ~name ?description ?(arguments = []) handler =
512 let prompt_args =
513 List.map
514 (fun (name, desc, required) ->
515 Prompt.create_argument ~name ?description:desc ~required ())
516 arguments
517 in
518 let handler' _ctx args =
519 try Ok (handler args) with exn -> Error (Printexc.to_string exn)
520 in
521 let prompt =
522 Prompt.create ~name ?description ~arguments:prompt_args ~handler:handler' ()
523 in
524 register_prompt server prompt
525
526(* Set server capabilities *)
527let set_capabilities server capabilities = server.capabilities <- capabilities
528
529(* Configure server with default capabilities based on registered components *)
530let configure_server server ?with_tools ?with_resources ?with_resource_templates
531 ?with_prompts () =
532 let with_tools =
533 match with_tools with Some b -> b | None -> server.tools <> []
534 in
535 let with_resources =
536 match with_resources with Some b -> b | None -> server.resources <> []
537 in
538 let with_resource_templates =
539 match with_resource_templates with
540 | Some b -> b
541 | None -> server.resource_templates <> []
542 in
543 let with_prompts =
544 match with_prompts with Some b -> b | None -> server.prompts <> []
545 in
546 let capabilities =
547 default_capabilities ~with_tools ~with_resources ~with_resource_templates
548 ~with_prompts ()
549 in
550 set_capabilities server capabilities;
551 server