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