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