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 mutable progress_token: ProgressToken.t option;
33 }
34
35 let create ?request_id ?(lifespan_context=[]) () =
36 { request_id; lifespan_context; progress_token = None }
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_:"notifications/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(* Helper functions for creating common objects *)
169(* Content type constructors *)
170let make_text_content text =
171 Text (TextContent.{ text; annotations = None })
172
173let make_image_content data mime_type =
174 Image (ImageContent.{ data; mime_type; annotations = None })
175
176(* Create audio content using the AudioContent module *)
177let make_audio_content data mime_type =
178 Audio (AudioContent.{ data; mime_type; annotations = None })
179
180let make_resource_text_content uri text mime_type =
181 Resource (EmbeddedResource.{
182 resource = `Text TextResourceContents.{ uri; text; mime_type };
183 annotations = None;
184 })
185
186let make_resource_blob_content uri blob mime_type =
187 Resource (EmbeddedResource.{
188 resource = `Blob BlobResourceContents.{ uri; blob; mime_type };
189 annotations = None;
190 })
191
192(* Tool result handling *)
193type tool_content =
194 | TextContent of string
195 | ImageContent of { data: string; mime_type: string }
196 | AudioContent of { data: string; mime_type: string }
197 | ResourceContent of { uri: string; data: string; is_blob: bool; mime_type: string option }
198
199let create_tool_result contents ~is_error =
200 let content_json = List.map (function
201 | TextContent text ->
202 `Assoc [
203 ("type", `String "text");
204 ("text", `String text)
205 ]
206 | ImageContent { data; mime_type } ->
207 `Assoc [
208 ("type", `String "image");
209 ("data", `String data);
210 ("mimeType", `String mime_type)
211 ]
212 | AudioContent { data; mime_type } ->
213 `Assoc [
214 ("type", `String "audio");
215 ("data", `String data);
216 ("mimeType", `String mime_type)
217 ]
218 | ResourceContent { uri; data; is_blob; mime_type } ->
219 let resource_data = if is_blob then
220 `Assoc (
221 [("uri", `String uri);
222 ("blob", `String data)] @
223 (match mime_type with
224 | Some mime -> [("mimeType", `String mime)]
225 | None -> [])
226 )
227 else
228 `Assoc (
229 [("uri", `String uri);
230 ("text", `String data)] @
231 (match mime_type with
232 | Some mime -> [("mimeType", `String mime)]
233 | None -> [])
234 )
235 in
236 `Assoc [
237 ("type", `String "resource");
238 ("resource", resource_data)
239 ]
240 ) contents in
241
242 `Assoc [
243 ("content", `List content_json);
244 ("isError", `Bool is_error)
245 ]
246
247(* Error types with standard JSON-RPC error codes *)
248type error_code =
249 | ParseError (* -32700 *)
250 | InvalidRequest (* -32600 *)
251 | MethodNotFound (* -32601 *)
252 | InvalidParams (* -32602 *)
253 | InternalError (* -32603 *)
254 | ResourceNotFound (* -32002 Custom code for MCP *)
255 | AuthenticationRequired (* -32001 Custom code for MCP *)
256 | CustomError of int
257
258let error_code_to_int = function
259 | ParseError -> -32700
260 | InvalidRequest -> -32600
261 | MethodNotFound -> -32601
262 | InvalidParams -> -32602
263 | InternalError -> -32603
264 | ResourceNotFound -> -32002
265 | AuthenticationRequired -> -32001
266 | CustomError code -> code
267
268let make_tool_schema properties required =
269 let props = List.map (fun (name, schema_type, description) ->
270 (name, `Assoc [
271 ("type", `String schema_type);
272 ("description", `String description)
273 ])
274 ) properties in
275 let required_json = `List (List.map (fun name -> `String name) required) in
276 `Assoc [
277 ("type", `String "object");
278 ("properties", `Assoc props);
279 ("required", required_json)
280 ]
281
282(* Main server type *)
283type server = {
284 name: string;
285 version: string;
286 protocol_version: string;
287 lifespan_context: (string * Json.t) list;
288 mutable capabilities: Json.t;
289 mutable tools: Tool.t list;
290 mutable resources: Resource.t list;
291 mutable prompts: Prompt.t list;
292}
293
294let name { name; _ } = name
295let version { version; _ } = version
296let capabilities { capabilities; _ } = capabilities
297let lifespan_context { lifespan_context; _ } = lifespan_context
298let protocol_version { protocol_version; _ } = protocol_version
299let tools { tools; _ } = tools
300let resources { resources; _ } = resources
301let prompts { prompts; _ } = prompts
302
303(* Create a new server *)
304let create_server ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") () =
305 {
306 name;
307 version;
308 protocol_version;
309 capabilities = `Assoc [];
310 tools = [];
311 resources = [];
312 prompts = [];
313 lifespan_context = [];
314 }
315
316(* Default capabilities for the server *)
317let default_capabilities ?(with_tools=true) ?(with_resources=false) ?(with_prompts=false) () =
318 let caps = [] in
319 let caps =
320 if with_tools then
321 ("tools", `Assoc [
322 ("listChanged", `Bool true)
323 ]) :: caps
324 else
325 caps
326 in
327 let caps =
328 if with_resources then
329 ("resources", `Assoc [
330 ("listChanged", `Bool true);
331 ("subscribe", `Bool false)
332 ]) :: caps
333 else if not with_resources then
334 ("resources", `Assoc [
335 ("listChanged", `Bool false);
336 ("subscribe", `Bool false)
337 ]) :: caps
338 else
339 caps
340 in
341 let caps =
342 if with_prompts then
343 ("prompts", `Assoc [
344 ("listChanged", `Bool true)
345 ]) :: caps
346 else if not with_prompts then
347 ("prompts", `Assoc [
348 ("listChanged", `Bool false)
349 ]) :: caps
350 else
351 caps
352 in
353 `Assoc caps
354
355(* Register a tool *)
356let register_tool server tool =
357 server.tools <- tool :: server.tools;
358 tool
359
360(* Create a rich tool result with multiple content types *)
361let create_rich_tool_result ?(text=None) ?(image=None) ?(audio=None) ?(resource=None) ~is_error () =
362 let contents = [] in
363
364 (* Add text content if provided *)
365 let contents = match text with
366 | Some text -> (TextContent text) :: contents
367 | None -> contents
368 in
369
370 (* Add image content if provided *)
371 let contents = match image with
372 | Some (data, mime_type) -> (ImageContent { data; mime_type }) :: contents
373 | None -> contents
374 in
375
376 (* Add audio content if provided *)
377 let contents = match audio with
378 | Some (data, mime_type) -> (AudioContent { data; mime_type }) :: contents
379 | None -> contents
380 in
381
382 (* Add resource content if provided *)
383 let contents = match resource with
384 | Some (uri, data, is_blob, mime_type) ->
385 (ResourceContent { uri; data; is_blob; mime_type }) :: contents
386 | None -> contents
387 in
388
389 (* Create the final tool result *)
390 create_tool_result (List.rev contents) ~is_error
391
392(* Create and register a tool in one step *)
393let add_tool server ~name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =
394 let input_schema = make_tool_schema schema_properties schema_required in
395 let handler' ctx args =
396 try
397 Ok (handler args)
398 with exn ->
399 Error (Printexc.to_string exn)
400 in
401 let tool = Tool.create
402 ~name
403 ?description
404 ~input_schema
405 ~handler:handler'
406 ()
407 in
408 register_tool server tool
409
410(* Register a resource *)
411let register_resource server resource =
412 server.resources <- resource :: server.resources;
413 resource
414
415(* Create and register a resource in one step *)
416let add_resource server ~uri_template ?description ?mime_type handler =
417 let handler' _ctx params =
418 try
419 Ok (handler params)
420 with exn ->
421 Error (Printexc.to_string exn)
422 in
423 let resource = Resource.create
424 ~uri_template
425 ?description
426 ?mime_type
427 ~handler:handler'
428 ()
429 in
430 register_resource server resource
431
432(* Register a prompt *)
433let register_prompt server prompt =
434 server.prompts <- prompt :: server.prompts;
435 prompt
436
437(* Create and register a prompt in one step *)
438let add_prompt server ~name ?description ?(arguments=[]) handler =
439 let prompt_args = List.map (fun (name, desc, required) ->
440 Prompt.create_argument ~name ?description:desc ~required ()
441 ) arguments in
442 let handler' _ctx args =
443 try
444 Ok (handler args)
445 with exn ->
446 Error (Printexc.to_string exn)
447 in
448 let prompt = Prompt.create
449 ~name
450 ?description
451 ~arguments:prompt_args
452 ~handler:handler'
453 ()
454 in
455 register_prompt server prompt
456
457(* Set server capabilities *)
458let set_capabilities server capabilities =
459 server.capabilities <- capabilities
460
461(* Configure server with default capabilities based on registered components *)
462let configure_server server ?with_tools ?with_resources ?with_prompts () =
463 let with_tools = match with_tools with
464 | Some b -> b
465 | None -> server.tools <> []
466 in
467 let with_resources = match with_resources with
468 | Some b -> b
469 | None -> server.resources <> []
470 in
471 let with_prompts = match with_prompts with
472 | Some b -> b
473 | None -> server.prompts <> []
474 in
475 let capabilities = default_capabilities ~with_tools ~with_resources ~with_prompts () in
476 set_capabilities server capabilities;
477 server