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