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_template: string;
192 description: string option;
193 mime_type: string option;
194 handler: handler;
195 }
196
197 let create ~uri_template ?description ?mime_type ~handler () =
198 { uri_template; description; mime_type; handler }
199
200 let to_json resource =
201 let assoc = [
202 ("uriTemplate", `String resource.uri_template);
203 ] in
204 let assoc = match resource.description with
205 | Some desc -> ("description", `String desc) :: assoc
206 | None -> assoc
207 in
208 let assoc = match resource.mime_type with
209 | Some mime -> ("mimeType", `String mime) :: assoc
210 | None -> assoc
211 in
212 `Assoc assoc
213
214 (* Convert to Mcp_rpc.ResourcesList.Resource.t *)
215 let to_rpc_resource_list_resource (resource:t) =
216 Mcp_rpc.ResourcesList.Resource.{
217 uri = resource.uri_template;
218 name = resource.uri_template; (* Use uri as name by default *)
219 description = resource.description;
220 mime_type = resource.mime_type;
221 size = None; (* 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 = {
238 role: Role.t;
239 content: content;
240 }
241
242 type handler = Context.t -> (string * string) list -> (message list, string) result
243
244 type t = {
245 name: string;
246 description: string option;
247 arguments: argument list;
248 handler: handler;
249 }
250
251 let create ~name ?description ?(arguments=[]) ~handler () =
252 { name; description; arguments; handler }
253
254 let create_argument ~name ?description ?(required=false) () =
255 { name; description; required }
256
257 let to_json prompt =
258 let assoc = [
259 ("name", `String prompt.name);
260 ] in
261 let assoc = match prompt.description with
262 | Some desc -> ("description", `String desc) :: assoc
263 | None -> assoc
264 in
265 let assoc = if prompt.arguments <> [] then
266 let args = List.map (fun (arg: argument) ->
267 let arg_assoc = [
268 ("name", `String arg.name);
269 ] in
270 let arg_assoc = match arg.description with
271 | Some desc -> ("description", `String desc) :: arg_assoc
272 | None -> arg_assoc
273 in
274 let arg_assoc =
275 if arg.required then
276 ("required", `Bool true) :: arg_assoc
277 else
278 arg_assoc
279 in
280 `Assoc arg_assoc
281 ) prompt.arguments in
282 ("arguments", `List args) :: assoc
283 else
284 assoc
285 in
286 `Assoc assoc
287
288 (* Convert argument to Mcp_rpc.PromptsList.PromptArgument.t *)
289 let argument_to_rpc_prompt_argument (arg:argument) =
290 Mcp_rpc.PromptsList.PromptArgument.{
291 name = arg.name;
292 description = arg.description;
293 required = arg.required;
294 }
295
296 (* Convert to Mcp_rpc.PromptsList.Prompt.t *)
297 let to_rpc_prompt_list_prompt (prompt:t) =
298 Mcp_rpc.PromptsList.Prompt.{
299 name = prompt.name;
300 description = prompt.description;
301 arguments = List.map argument_to_rpc_prompt_argument prompt.arguments;
302 }
303
304 (* Convert a list of Prompt.t to the format needed for prompts/list response *)
305 let to_rpc_prompts_list prompts =
306 List.map to_rpc_prompt_list_prompt prompts
307
308 (* Convert message to Mcp_rpc.PromptMessage.t *)
309 let message_to_rpc_prompt_message msg =
310 {
311 PromptMessage.role = msg.role;
312 PromptMessage.content = msg.content;
313 }
314
315 (* Convert a list of messages to the format needed for prompts/get response *)
316 let messages_to_rpc_prompt_messages messages =
317 List.map message_to_rpc_prompt_message messages
318end
319
320let make_tool_schema properties required =
321 let props = List.map (fun (name, schema_type, description) ->
322 (name, `Assoc [
323 ("type", `String schema_type);
324 ("description", `String description)
325 ])
326 ) properties in
327 let required_json = `List (List.map (fun name -> `String name) required) in
328 `Assoc [
329 ("type", `String "object");
330 ("properties", `Assoc props);
331 ("required", required_json)
332 ]
333
334(* Main server type *)
335type server = {
336 name: string;
337 version: string;
338 protocol_version: string;
339 lifespan_context: (string * Json.t) list;
340 mutable capabilities: Json.t;
341 mutable tools: Tool.t list;
342 mutable resources: Resource.t list;
343 mutable prompts: Prompt.t list;
344}
345
346let name { name; _ } = name
347let version { version; _ } = version
348let capabilities { capabilities; _ } = capabilities
349let lifespan_context { lifespan_context; _ } = lifespan_context
350let protocol_version { protocol_version; _ } = protocol_version
351let tools { tools; _ } = tools
352let resources { resources; _ } = resources
353let prompts { prompts; _ } = prompts
354
355(* Create a new server *)
356let create_server ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") () =
357 {
358 name;
359 version;
360 protocol_version;
361 capabilities = `Assoc [];
362 tools = [];
363 resources = [];
364 prompts = [];
365 lifespan_context = [];
366 }
367
368(* Default capabilities for the server *)
369let default_capabilities ?(with_tools=true) ?(with_resources=false) ?(with_prompts=false) () =
370 let caps = [] in
371 let caps =
372 if with_tools then
373 ("tools", `Assoc [
374 ("listChanged", `Bool true)
375 ]) :: caps
376 else
377 caps
378 in
379 let caps =
380 if with_resources then
381 ("resources", `Assoc [
382 ("listChanged", `Bool true);
383 ("subscribe", `Bool false)
384 ]) :: caps
385 else if not with_resources then
386 ("resources", `Assoc [
387 ("listChanged", `Bool false);
388 ("subscribe", `Bool false)
389 ]) :: caps
390 else
391 caps
392 in
393 let caps =
394 if with_prompts then
395 ("prompts", `Assoc [
396 ("listChanged", `Bool true)
397 ]) :: caps
398 else if not with_prompts then
399 ("prompts", `Assoc [
400 ("listChanged", `Bool false)
401 ]) :: caps
402 else
403 caps
404 in
405 `Assoc caps
406
407(* Register a tool *)
408let register_tool server tool =
409 server.tools <- tool :: server.tools;
410 tool
411
412(* Create and register a tool in one step *)
413let add_tool server ~name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =
414 let input_schema = make_tool_schema schema_properties schema_required in
415 let handler' ctx args =
416 try
417 Ok (handler args)
418 with exn ->
419 Error (Printexc.to_string exn)
420 in
421 let tool = Tool.create
422 ~name
423 ?description
424 ~input_schema
425 ~handler:handler'
426 ()
427 in
428 register_tool server tool
429
430(* Register a resource *)
431let register_resource server resource =
432 server.resources <- resource :: server.resources;
433 resource
434
435(* Create and register a resource in one step *)
436let add_resource server ~uri_template ?description ?mime_type handler =
437 let handler' _ctx params =
438 try
439 Ok (handler params)
440 with exn ->
441 Error (Printexc.to_string exn)
442 in
443 let resource = Resource.create
444 ~uri_template
445 ?description
446 ?mime_type
447 ~handler:handler'
448 ()
449 in
450 register_resource server resource
451
452(* Register a prompt *)
453let register_prompt server prompt =
454 server.prompts <- prompt :: server.prompts;
455 prompt
456
457(* Create and register a prompt in one step *)
458let add_prompt server ~name ?description ?(arguments=[]) handler =
459 let prompt_args = List.map (fun (name, desc, required) ->
460 Prompt.create_argument ~name ?description:desc ~required ()
461 ) arguments in
462 let handler' _ctx args =
463 try
464 Ok (handler args)
465 with exn ->
466 Error (Printexc.to_string exn)
467 in
468 let prompt = Prompt.create
469 ~name
470 ?description
471 ~arguments:prompt_args
472 ~handler:handler'
473 ()
474 in
475 register_prompt server prompt
476
477(* Set server capabilities *)
478let set_capabilities server capabilities =
479 server.capabilities <- capabilities
480
481(* Configure server with default capabilities based on registered components *)
482let configure_server server ?with_tools ?with_resources ?with_prompts () =
483 let with_tools = match with_tools with
484 | Some b -> b
485 | None -> server.tools <> []
486 in
487 let with_resources = match with_resources with
488 | Some b -> b
489 | None -> server.resources <> []
490 in
491 let with_prompts = match with_prompts with
492 | Some b -> b
493 | None -> server.prompts <> []
494 in
495 let capabilities = default_capabilities ~with_tools ~with_resources ~with_prompts () in
496 set_capabilities server capabilities;
497 server