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