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 *)
169let make_text_content text =
170 Text (TextContent.{ text; annotations = None })
171
172let make_tool_schema properties required =
173 let props = List.map (fun (name, schema_type, description) ->
174 (name, `Assoc [
175 ("type", `String schema_type);
176 ("description", `String description)
177 ])
178 ) properties in
179 let required_json = `List (List.map (fun name -> `String name) required) in
180 `Assoc [
181 ("type", `String "object");
182 ("properties", `Assoc props);
183 ("required", required_json)
184 ]
185
186(* Main server type *)
187type server = {
188 name: string;
189 version: string;
190 protocol_version: string;
191 lifespan_context: (string * Json.t) list;
192 mutable capabilities: Json.t;
193 mutable tools: Tool.t list;
194 mutable resources: Resource.t list;
195 mutable prompts: Prompt.t list;
196}
197
198let name { name; _ } = name
199let version { version; _ } = version
200let capabilities { capabilities; _ } = capabilities
201let lifespan_context { lifespan_context; _ } = lifespan_context
202let protocol_version { protocol_version; _ } = protocol_version
203let tools { tools; _ } = tools
204let resources { resources; _ } = resources
205let prompts { prompts; _ } = prompts
206
207(* Create a new server *)
208let create_server ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") () =
209 {
210 name;
211 version;
212 protocol_version;
213 capabilities = `Assoc [];
214 tools = [];
215 resources = [];
216 prompts = [];
217 lifespan_context = [];
218 }
219
220(* Default capabilities for the server *)
221let default_capabilities ?(with_tools=true) ?(with_resources=false) ?(with_prompts=false) () =
222 let caps = [] in
223 let caps =
224 if with_tools then
225 ("tools", `Assoc [
226 ("listChanged", `Bool true)
227 ]) :: caps
228 else
229 caps
230 in
231 let caps =
232 if with_resources then
233 ("resources", `Assoc [
234 ("listChanged", `Bool true);
235 ("subscribe", `Bool false)
236 ]) :: caps
237 else if not with_resources then
238 ("resources", `Assoc [
239 ("listChanged", `Bool false);
240 ("subscribe", `Bool false)
241 ]) :: caps
242 else
243 caps
244 in
245 let caps =
246 if with_prompts then
247 ("prompts", `Assoc [
248 ("listChanged", `Bool true)
249 ]) :: caps
250 else if not with_prompts then
251 ("prompts", `Assoc [
252 ("listChanged", `Bool false)
253 ]) :: caps
254 else
255 caps
256 in
257 `Assoc caps
258
259(* Register a tool *)
260let register_tool server tool =
261 server.tools <- tool :: server.tools;
262 tool
263
264(* Create and register a tool in one step *)
265let add_tool server ~name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =
266 let input_schema = make_tool_schema schema_properties schema_required in
267 let handler' ctx args =
268 try
269 Ok (handler args)
270 with exn ->
271 Error (Printexc.to_string exn)
272 in
273 let tool = Tool.create
274 ~name
275 ?description
276 ~input_schema
277 ~handler:handler'
278 ()
279 in
280 register_tool server tool
281
282(* Register a resource *)
283let register_resource server resource =
284 server.resources <- resource :: server.resources;
285 resource
286
287(* Create and register a resource in one step *)
288let add_resource server ~uri_template ?description ?mime_type handler =
289 let handler' _ctx params =
290 try
291 Ok (handler params)
292 with exn ->
293 Error (Printexc.to_string exn)
294 in
295 let resource = Resource.create
296 ~uri_template
297 ?description
298 ?mime_type
299 ~handler:handler'
300 ()
301 in
302 register_resource server resource
303
304(* Register a prompt *)
305let register_prompt server prompt =
306 server.prompts <- prompt :: server.prompts;
307 prompt
308
309(* Create and register a prompt in one step *)
310let add_prompt server ~name ?description ?(arguments=[]) handler =
311 let prompt_args = List.map (fun (name, desc, required) ->
312 Prompt.create_argument ~name ?description:desc ~required ()
313 ) arguments in
314 let handler' _ctx args =
315 try
316 Ok (handler args)
317 with exn ->
318 Error (Printexc.to_string exn)
319 in
320 let prompt = Prompt.create
321 ~name
322 ?description
323 ~arguments:prompt_args
324 ~handler:handler'
325 ()
326 in
327 register_prompt server prompt
328
329(* Set server capabilities *)
330let set_capabilities server capabilities =
331 server.capabilities <- capabilities
332
333(* Configure server with default capabilities based on registered components *)
334let configure_server server ?with_tools ?with_resources ?with_prompts () =
335 let with_tools = match with_tools with
336 | Some b -> b
337 | None -> server.tools <> []
338 in
339 let with_resources = match with_resources with
340 | Some b -> b
341 | None -> server.resources <> []
342 in
343 let with_prompts = match with_prompts with
344 | Some b -> b
345 | None -> server.prompts <> []
346 in
347 let capabilities = default_capabilities ~with_tools ~with_resources ~with_prompts () in
348 set_capabilities server capabilities;
349 server