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 ~method_: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
77end
78
79(* Resources for the MCP server *)
80module Resource = struct
81 type handler = Context.t -> string list -> (string, string) result
82
83 type t = {
84 uri_template: string;
85 description: string option;
86 mime_type: string option;
87 handler: handler;
88 }
89
90 let create ~uri_template ?description ?mime_type ~handler () =
91 { uri_template; description; mime_type; handler }
92
93 let to_json resource =
94 let assoc = [
95 ("uriTemplate", `String resource.uri_template);
96 ] in
97 let assoc = match resource.description with
98 | Some desc -> ("description", `String desc) :: assoc
99 | None -> assoc
100 in
101 let assoc = match resource.mime_type with
102 | Some mime -> ("mimeType", `String mime) :: assoc
103 | None -> assoc
104 in
105 `Assoc assoc
106end
107
108(* Prompts for the MCP server *)
109module Prompt = struct
110 type argument = {
111 name: string;
112 description: string option;
113 required: bool;
114 }
115
116 type message = {
117 role: Role.t;
118 content: content;
119 }
120
121 type handler = Context.t -> (string * string) list -> (message list, string) result
122
123 type t = {
124 name: string;
125 description: string option;
126 arguments: argument list;
127 handler: handler;
128 }
129
130 let create ~name ?description ?(arguments=[]) ~handler () =
131 { name; description; arguments; handler }
132
133 let create_argument ~name ?description ?(required=false) () =
134 { name; description; required }
135
136 let to_json prompt =
137 let assoc = [
138 ("name", `String prompt.name);
139 ] in
140 let assoc = match prompt.description with
141 | Some desc -> ("description", `String desc) :: assoc
142 | None -> assoc
143 in
144 let assoc = if prompt.arguments <> [] then
145 let args = List.map (fun (arg: argument) ->
146 let arg_assoc = [
147 ("name", `String arg.name);
148 ] in
149 let arg_assoc = match arg.description with
150 | Some desc -> ("description", `String desc) :: arg_assoc
151 | None -> arg_assoc
152 in
153 let arg_assoc =
154 if arg.required then
155 ("required", `Bool true) :: arg_assoc
156 else
157 arg_assoc
158 in
159 `Assoc arg_assoc
160 ) prompt.arguments in
161 ("arguments", `List args) :: assoc
162 else
163 assoc
164 in
165 `Assoc assoc
166end
167
168(* Content type constructors have been moved to the Mcp module *)
169
170(* Tool result handling using Mcp_message.ToolsCall.ToolContent *)
171
172let create_tool_result contents ~is_error =
173 (* Use the original Mcp.content values as is *)
174 let content = List.map (fun content ->
175 match content with
176 | Text text_content ->
177 Mcp_message.ToolsCall.ToolContent.Text text_content
178 | Image image_content ->
179 Mcp_message.ToolsCall.ToolContent.Image image_content
180 | Audio audio_content ->
181 Mcp_message.ToolsCall.ToolContent.Audio audio_content
182 | Resource resource_content ->
183 Mcp_message.ToolsCall.ToolContent.Resource resource_content
184 ) contents in
185
186 (* Use the ToolsCall.Response module's JSON conversion *)
187 Mcp_message.ToolsCall.Response.yojson_of_t { content; is_error }
188
189(* Using error codes from Mcp.ErrorCode module *)
190
191let make_tool_schema properties required =
192 let props = List.map (fun (name, schema_type, description) ->
193 (name, `Assoc [
194 ("type", `String schema_type);
195 ("description", `String description)
196 ])
197 ) properties in
198 let required_json = `List (List.map (fun name -> `String name) required) in
199 `Assoc [
200 ("type", `String "object");
201 ("properties", `Assoc props);
202 ("required", required_json)
203 ]
204
205(* Main server type *)
206type server = {
207 name: string;
208 version: string;
209 protocol_version: string;
210 lifespan_context: (string * Json.t) list;
211 mutable capabilities: Json.t;
212 mutable tools: Tool.t list;
213 mutable resources: Resource.t list;
214 mutable prompts: Prompt.t list;
215}
216
217let name { name; _ } = name
218let version { version; _ } = version
219let capabilities { capabilities; _ } = capabilities
220let lifespan_context { lifespan_context; _ } = lifespan_context
221let protocol_version { protocol_version; _ } = protocol_version
222let tools { tools; _ } = tools
223let resources { resources; _ } = resources
224let prompts { prompts; _ } = prompts
225
226(* Create a new server *)
227let create_server ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") () =
228 {
229 name;
230 version;
231 protocol_version;
232 capabilities = `Assoc [];
233 tools = [];
234 resources = [];
235 prompts = [];
236 lifespan_context = [];
237 }
238
239(* Default capabilities for the server *)
240let default_capabilities ?(with_tools=true) ?(with_resources=false) ?(with_prompts=false) () =
241 let caps = [] in
242 let caps =
243 if with_tools then
244 ("tools", `Assoc [
245 ("listChanged", `Bool true)
246 ]) :: caps
247 else
248 caps
249 in
250 let caps =
251 if with_resources then
252 ("resources", `Assoc [
253 ("listChanged", `Bool true);
254 ("subscribe", `Bool false)
255 ]) :: caps
256 else if not with_resources then
257 ("resources", `Assoc [
258 ("listChanged", `Bool false);
259 ("subscribe", `Bool false)
260 ]) :: caps
261 else
262 caps
263 in
264 let caps =
265 if with_prompts then
266 ("prompts", `Assoc [
267 ("listChanged", `Bool true)
268 ]) :: caps
269 else if not with_prompts then
270 ("prompts", `Assoc [
271 ("listChanged", `Bool false)
272 ]) :: caps
273 else
274 caps
275 in
276 `Assoc caps
277
278(* Register a tool *)
279let register_tool server tool =
280 server.tools <- tool :: server.tools;
281 tool
282
283(* Create a rich tool result with multiple content types *)
284let create_rich_tool_result ?(text=None) ?(image=None) ?(audio=None) ?(resource=None) ~is_error () =
285 let contents = [] in
286
287 (* Add text content if provided *)
288 let contents = match text with
289 | Some text -> (Mcp.make_text_content text) :: contents
290 | None -> contents
291 in
292
293 (* Add image content if provided *)
294 let contents = match image with
295 | Some (data, mime_type) -> (Mcp.make_image_content data mime_type) :: contents
296 | None -> contents
297 in
298
299 (* Add audio content if provided *)
300 let contents = match audio with
301 | Some (data, mime_type) -> (Mcp.make_audio_content data mime_type) :: contents
302 | None -> contents
303 in
304
305 (* Add resource content if provided *)
306 let contents = match resource with
307 | Some (uri, data, is_blob, mime_type) ->
308 (if is_blob then
309 Mcp.make_resource_blob_content uri data mime_type
310 else
311 Mcp.make_resource_text_content uri data mime_type) :: contents
312 | None -> contents
313 in
314
315 (* Create the final tool result *)
316 create_tool_result (List.rev contents) ~is_error
317
318(* Create and register a tool in one step *)
319let add_tool server ~name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =
320 let input_schema = make_tool_schema schema_properties schema_required in
321 let handler' ctx args =
322 try
323 Ok (handler args)
324 with exn ->
325 Error (Printexc.to_string exn)
326 in
327 let tool = Tool.create
328 ~name
329 ?description
330 ~input_schema
331 ~handler:handler'
332 ()
333 in
334 register_tool server tool
335
336(* Register a resource *)
337let register_resource server resource =
338 server.resources <- resource :: server.resources;
339 resource
340
341(* Create and register a resource in one step *)
342let add_resource server ~uri_template ?description ?mime_type handler =
343 let handler' _ctx params =
344 try
345 Ok (handler params)
346 with exn ->
347 Error (Printexc.to_string exn)
348 in
349 let resource = Resource.create
350 ~uri_template
351 ?description
352 ?mime_type
353 ~handler:handler'
354 ()
355 in
356 register_resource server resource
357
358(* Register a prompt *)
359let register_prompt server prompt =
360 server.prompts <- prompt :: server.prompts;
361 prompt
362
363(* Create and register a prompt in one step *)
364let add_prompt server ~name ?description ?(arguments=[]) handler =
365 let prompt_args = List.map (fun (name, desc, required) ->
366 Prompt.create_argument ~name ?description:desc ~required ()
367 ) arguments in
368 let handler' _ctx args =
369 try
370 Ok (handler args)
371 with exn ->
372 Error (Printexc.to_string exn)
373 in
374 let prompt = Prompt.create
375 ~name
376 ?description
377 ~arguments:prompt_args
378 ~handler:handler'
379 ()
380 in
381 register_prompt server prompt
382
383(* Set server capabilities *)
384let set_capabilities server capabilities =
385 server.capabilities <- capabilities
386
387(* Configure server with default capabilities based on registered components *)
388let configure_server server ?with_tools ?with_resources ?with_prompts () =
389 let with_tools = match with_tools with
390 | Some b -> b
391 | None -> server.tools <> []
392 in
393 let with_resources = match with_resources with
394 | Some b -> b
395 | None -> server.resources <> []
396 in
397 let with_prompts = match with_prompts with
398 | Some b -> b
399 | None -> server.prompts <> []
400 in
401 let capabilities = default_capabilities ~with_tools ~with_resources ~with_prompts () in
402 set_capabilities server capabilities;
403 server
404
405(* The MCP message helpers have been moved to Mcp_message module.
406 This module now reexports them through open statements. *)