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 (* Create a tool result with content *)
86 let create_tool_result content ~is_error =
87 `Assoc [
88 ("content", `List (List.map Mcp.yojson_of_content content));
89 ("isError", `Bool is_error);
90 ]
91
92 (* Create a tool error result with structured content *)
93 let create_error_result error =
94 Log.errorf "Error result: %s" error;
95 create_tool_result [Mcp.make_text_content error] ~is_error:true
96
97 (* Handle tool execution errors *)
98 let handle_execution_error err =
99 create_error_result (Printf.sprintf "Error executing tool: %s" err)
100
101 (* Handle unknown tool error *)
102 let handle_unknown_tool_error name =
103 create_error_result (Printf.sprintf "Unknown tool: %s" name)
104
105 (* Handle general tool execution exception *)
106 let handle_execution_exception exn =
107 create_error_result (Printf.sprintf "Internal error: %s" (Printexc.to_string exn))
108end
109
110(* Resources for the MCP server *)
111module Resource = struct
112 type handler = Context.t -> string list -> (string, string) result
113
114 type t = {
115 uri_template: string;
116 description: string option;
117 mime_type: string option;
118 handler: handler;
119 }
120
121 let create ~uri_template ?description ?mime_type ~handler () =
122 { uri_template; description; mime_type; handler }
123
124 let to_json resource =
125 let assoc = [
126 ("uriTemplate", `String resource.uri_template);
127 ] in
128 let assoc = match resource.description with
129 | Some desc -> ("description", `String desc) :: assoc
130 | None -> assoc
131 in
132 let assoc = match resource.mime_type with
133 | Some mime -> ("mimeType", `String mime) :: assoc
134 | None -> assoc
135 in
136 `Assoc assoc
137end
138
139(* Prompts for the MCP server *)
140module Prompt = struct
141 type argument = {
142 name: string;
143 description: string option;
144 required: bool;
145 }
146
147 type message = {
148 role: Role.t;
149 content: content;
150 }
151
152 type handler = Context.t -> (string * string) list -> (message list, string) result
153
154 type t = {
155 name: string;
156 description: string option;
157 arguments: argument list;
158 handler: handler;
159 }
160
161 let create ~name ?description ?(arguments=[]) ~handler () =
162 { name; description; arguments; handler }
163
164 let create_argument ~name ?description ?(required=false) () =
165 { name; description; required }
166
167 let to_json prompt =
168 let assoc = [
169 ("name", `String prompt.name);
170 ] in
171 let assoc = match prompt.description with
172 | Some desc -> ("description", `String desc) :: assoc
173 | None -> assoc
174 in
175 let assoc = if prompt.arguments <> [] then
176 let args = List.map (fun (arg: argument) ->
177 let arg_assoc = [
178 ("name", `String arg.name);
179 ] in
180 let arg_assoc = match arg.description with
181 | Some desc -> ("description", `String desc) :: arg_assoc
182 | None -> arg_assoc
183 in
184 let arg_assoc =
185 if arg.required then
186 ("required", `Bool true) :: arg_assoc
187 else
188 arg_assoc
189 in
190 `Assoc arg_assoc
191 ) prompt.arguments in
192 ("arguments", `List args) :: assoc
193 else
194 assoc
195 in
196 `Assoc assoc
197end
198
199let make_tool_schema properties required =
200 let props = List.map (fun (name, schema_type, description) ->
201 (name, `Assoc [
202 ("type", `String schema_type);
203 ("description", `String description)
204 ])
205 ) properties in
206 let required_json = `List (List.map (fun name -> `String name) required) in
207 `Assoc [
208 ("type", `String "object");
209 ("properties", `Assoc props);
210 ("required", required_json)
211 ]
212
213(* Main server type *)
214type server = {
215 name: string;
216 version: string;
217 protocol_version: string;
218 lifespan_context: (string * Json.t) list;
219 mutable capabilities: Json.t;
220 mutable tools: Tool.t list;
221 mutable resources: Resource.t list;
222 mutable prompts: Prompt.t list;
223}
224
225let name { name; _ } = name
226let version { version; _ } = version
227let capabilities { capabilities; _ } = capabilities
228let lifespan_context { lifespan_context; _ } = lifespan_context
229let protocol_version { protocol_version; _ } = protocol_version
230let tools { tools; _ } = tools
231let resources { resources; _ } = resources
232let prompts { prompts; _ } = prompts
233
234(* Create a new server *)
235let create_server ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") () =
236 {
237 name;
238 version;
239 protocol_version;
240 capabilities = `Assoc [];
241 tools = [];
242 resources = [];
243 prompts = [];
244 lifespan_context = [];
245 }
246
247(* Default capabilities for the server *)
248let default_capabilities ?(with_tools=true) ?(with_resources=false) ?(with_prompts=false) () =
249 let caps = [] in
250 let caps =
251 if with_tools then
252 ("tools", `Assoc [
253 ("listChanged", `Bool true)
254 ]) :: caps
255 else
256 caps
257 in
258 let caps =
259 if with_resources then
260 ("resources", `Assoc [
261 ("listChanged", `Bool true);
262 ("subscribe", `Bool false)
263 ]) :: caps
264 else if not with_resources then
265 ("resources", `Assoc [
266 ("listChanged", `Bool false);
267 ("subscribe", `Bool false)
268 ]) :: caps
269 else
270 caps
271 in
272 let caps =
273 if with_prompts then
274 ("prompts", `Assoc [
275 ("listChanged", `Bool true)
276 ]) :: caps
277 else if not with_prompts then
278 ("prompts", `Assoc [
279 ("listChanged", `Bool false)
280 ]) :: caps
281 else
282 caps
283 in
284 `Assoc caps
285
286(* Register a tool *)
287let register_tool server tool =
288 server.tools <- tool :: server.tools;
289 tool
290
291(* Create and register a tool in one step *)
292let add_tool server ~name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =
293 let input_schema = make_tool_schema schema_properties schema_required in
294 let handler' ctx args =
295 try
296 Ok (handler args)
297 with exn ->
298 Error (Printexc.to_string exn)
299 in
300 let tool = Tool.create
301 ~name
302 ?description
303 ~input_schema
304 ~handler:handler'
305 ()
306 in
307 register_tool server tool
308
309(* Register a resource *)
310let register_resource server resource =
311 server.resources <- resource :: server.resources;
312 resource
313
314(* Create and register a resource in one step *)
315let add_resource server ~uri_template ?description ?mime_type handler =
316 let handler' _ctx params =
317 try
318 Ok (handler params)
319 with exn ->
320 Error (Printexc.to_string exn)
321 in
322 let resource = Resource.create
323 ~uri_template
324 ?description
325 ?mime_type
326 ~handler:handler'
327 ()
328 in
329 register_resource server resource
330
331(* Register a prompt *)
332let register_prompt server prompt =
333 server.prompts <- prompt :: server.prompts;
334 prompt
335
336(* Create and register a prompt in one step *)
337let add_prompt server ~name ?description ?(arguments=[]) handler =
338 let prompt_args = List.map (fun (name, desc, required) ->
339 Prompt.create_argument ~name ?description:desc ~required ()
340 ) arguments in
341 let handler' _ctx args =
342 try
343 Ok (handler args)
344 with exn ->
345 Error (Printexc.to_string exn)
346 in
347 let prompt = Prompt.create
348 ~name
349 ?description
350 ~arguments:prompt_args
351 ~handler:handler'
352 ()
353 in
354 register_prompt server prompt
355
356(* Set server capabilities *)
357let set_capabilities server capabilities =
358 server.capabilities <- capabilities
359
360(* Configure server with default capabilities based on registered components *)
361let configure_server server ?with_tools ?with_resources ?with_prompts () =
362 let with_tools = match with_tools with
363 | Some b -> b
364 | None -> server.tools <> []
365 in
366 let with_resources = match with_resources with
367 | Some b -> b
368 | None -> server.resources <> []
369 in
370 let with_prompts = match with_prompts with
371 | Some b -> b
372 | None -> server.prompts <> []
373 in
374 let capabilities = default_capabilities ~with_tools ~with_resources ~with_prompts () in
375 set_capabilities server capabilities;
376 server