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