Model Context Protocol in OCaml
anil.recoil.org
1open Mcp
2open Jsonrpc
3open Mcp_sdk
4
5let src = Logs.Src.create "mcp.sdk" ~doc:"mcp.sdk logging"
6
7module Log = (val Logs.src_log src : Logs.LOG)
8
9(* Create a proper JSONRPC error with code and data *)
10let create_jsonrpc_error id code message ?data () =
11 let error_code = ErrorCode.to_int code in
12 let error_data = match data with Some d -> d | None -> `Null in
13 create_error ~id ~code:error_code ~message ~data:(Some error_data) ()
14
15(* Process initialize request *)
16let handle_initialize server req =
17 Log.debug (fun m -> m "Processing initialize request");
18 let result =
19 match req.JSONRPCMessage.params with
20 | Some params ->
21 let req_data = Initialize.Request.t_of_yojson params in
22 Logs.debug (fun m ->
23 m "Client info: %s v%s" req_data.client_info.name
24 req_data.client_info.version);
25 Log.debug (fun m ->
26 m "Client protocol version: %s" req_data.protocol_version);
27
28 (* Create initialize response *)
29 let result =
30 Initialize.Result.create ~capabilities:(capabilities server)
31 ~server_info:
32 Implementation.{ name = name server; version = version server }
33 ~protocol_version:(protocol_version server)
34 ~instructions:
35 (Printf.sprintf "This server provides tools for %s." (name server))
36 ()
37 in
38 Initialize.Result.yojson_of_t result
39 | None ->
40 Log.err (fun m -> m "Missing params for initialize request");
41 `Assoc [ ("error", `String "Missing params for initialize request") ]
42 in
43 Some (create_response ~id:req.id ~result)
44
45(* Process tools/list request *)
46let handle_tools_list server (req : JSONRPCMessage.request) =
47 Log.debug (fun m -> m "Processing tools/list request");
48 let tools_list = Tool.to_rpc_tools_list (tools server) in
49 let response =
50 Mcp_rpc.ToolsList.create_response ~id:req.id ~tools:tools_list ()
51 in
52 Some response
53
54(* Process prompts/list request *)
55let handle_prompts_list server (req : JSONRPCMessage.request) =
56 Log.debug (fun m -> m "Processing prompts/list request");
57 let prompts_list = Prompt.to_rpc_prompts_list (prompts server) in
58 let response =
59 Mcp_rpc.PromptsList.create_response ~id:req.id ~prompts:prompts_list ()
60 in
61 Some response
62
63(* Process resources/list request *)
64let handle_resources_list server (req : JSONRPCMessage.request) =
65 Log.debug (fun m -> m "Processing resources/list request");
66 let resources_list = Resource.to_rpc_resources_list (resources server) in
67 let response =
68 Mcp_rpc.ResourcesList.create_response ~id:req.id ~resources:resources_list
69 ()
70 in
71 Some response
72
73(* Process resources/templates/list request *)
74let handle_resource_templates_list server (req : JSONRPCMessage.request) =
75 Log.debug (fun m -> m "Processing resources/templates/list request");
76 let templates_list =
77 ResourceTemplate.to_rpc_resource_templates_list (resource_templates server)
78 in
79 let response =
80 Mcp_rpc.ListResourceTemplatesResult.create_response ~id:req.id
81 ~resource_templates:templates_list ()
82 in
83 Some response
84
85(* Utility module for resource template matching *)
86module Resource_matcher = struct
87 (* Define variants for resource handling result *)
88 type resource_match =
89 | DirectResource of Resource.t * string list
90 | TemplateResource of ResourceTemplate.t * string list
91 | NoMatch
92
93 (* Extract parameters from a template URI *)
94 let extract_template_vars template_uri uri =
95 (* Simple template variable extraction - could be enhanced with regex *)
96 let template_parts = String.split_on_char '/' template_uri in
97 let uri_parts = String.split_on_char '/' uri in
98
99 if List.length template_parts <> List.length uri_parts then None
100 else
101 (* Match parts and extract variables *)
102 let rec match_parts tparts uparts acc =
103 match (tparts, uparts) with
104 | [], [] -> Some (List.rev acc)
105 | th :: tt, uh :: ut ->
106 (* Check if this part is a template variable *)
107 if
108 String.length th > 2
109 && String.get th 0 = '{'
110 && String.get th (String.length th - 1) = '}'
111 then
112 (* Extract variable value and continue *)
113 match_parts tt ut (uh :: acc)
114 else if th = uh then
115 (* Fixed part matches, continue *)
116 match_parts tt ut acc
117 else
118 (* Fixed part doesn't match, fail *)
119 None
120 | _, _ -> None
121 in
122 match_parts template_parts uri_parts []
123
124 (* Find a matching resource or template for a URI *)
125 let find_match server uri =
126 (* Try direct resource match first *)
127 match
128 List.find_opt
129 (fun resource -> resource.Resource.uri = uri)
130 (resources server)
131 with
132 | Some resource -> DirectResource (resource, [])
133 | None ->
134 (* Try template match next *)
135 let templates = resource_templates server in
136
137 (* Try each template to see if it matches *)
138 let rec try_templates templates =
139 match templates with
140 | [] -> NoMatch
141 | template :: rest -> (
142 match
143 extract_template_vars template.ResourceTemplate.uri_template uri
144 with
145 | Some params -> TemplateResource (template, params)
146 | None -> try_templates rest)
147 in
148 try_templates templates
149end
150
151(* Process resources/read request *)
152let handle_resources_read server (req : JSONRPCMessage.request) =
153 Log.debug (fun m -> m "Processing resources/read request");
154 match req.JSONRPCMessage.params with
155 | None ->
156 Log.err (fun m -> m "Missing params for resources/read request");
157 Some
158 (create_jsonrpc_error req.id ErrorCode.InvalidParams
159 "Missing params for resources/read request" ())
160 | Some params -> (
161 let req_data = Mcp_rpc.ResourcesRead.Request.t_of_yojson params in
162 let uri = req_data.uri in
163 Log.debug (fun m -> m "Resource URI: %s" uri);
164
165 (* Find matching resource or template *)
166 match Resource_matcher.find_match server uri with
167 | Resource_matcher.DirectResource (resource, params) -> (
168 (* Create context for this request *)
169 let ctx =
170 Context.create ?request_id:(Some req.id)
171 ?progress_token:req.progress_token
172 ~lifespan_context:
173 [ ("resources/read", `Assoc [ ("uri", `String uri) ]) ]
174 ()
175 in
176
177 Log.debug (fun m -> m "Handling direct resource: %s" resource.name);
178
179 (* Call the resource handler *)
180 match resource.handler ctx params with
181 | Ok content ->
182 (* Create text resource content *)
183 let mime_type =
184 match resource.mime_type with
185 | Some mime -> mime
186 | None -> "text/plain"
187 in
188 let text_resource =
189 {
190 TextResourceContents.uri;
191 text = content;
192 mime_type = Some mime_type;
193 }
194 in
195 let resource_content =
196 Mcp_rpc.ResourcesRead.ResourceContent.TextResource text_resource
197 in
198 let response =
199 Mcp_rpc.ResourcesRead.create_response ~id:req.id
200 ~contents:[ resource_content ] ()
201 in
202 Some response
203 | Error err ->
204 Log.err (fun m -> m "Error reading resource: %s" err);
205 Some
206 (create_jsonrpc_error req.id ErrorCode.InternalError
207 ("Error reading resource: " ^ err)
208 ()))
209 | Resource_matcher.TemplateResource (template, params) -> (
210 (* Create context for this request *)
211 let ctx =
212 Context.create ?request_id:(Some req.id)
213 ?progress_token:req.progress_token
214 ~lifespan_context:
215 [ ("resources/read", `Assoc [ ("uri", `String uri) ]) ]
216 ()
217 in
218
219 Log.debug (fun m ->
220 m "Handling resource template: %s with params: [%s]" template.name
221 (String.concat ", " params));
222
223 (* Call the template handler *)
224 match template.handler ctx params with
225 | Ok content ->
226 (* Create text resource content *)
227 let mime_type =
228 match template.mime_type with
229 | Some mime -> mime
230 | None -> "text/plain"
231 in
232 let text_resource =
233 {
234 TextResourceContents.uri;
235 text = content;
236 mime_type = Some mime_type;
237 }
238 in
239 let resource_content =
240 Mcp_rpc.ResourcesRead.ResourceContent.TextResource text_resource
241 in
242 let response =
243 Mcp_rpc.ResourcesRead.create_response ~id:req.id
244 ~contents:[ resource_content ] ()
245 in
246 Some response
247 | Error err ->
248 Log.err (fun m -> m "Error reading resource template: %s" err);
249 Some
250 (create_jsonrpc_error req.id ErrorCode.InternalError
251 ("Error reading resource template: " ^ err)
252 ()))
253 | Resource_matcher.NoMatch ->
254 Log.err (fun m -> m "Resource not found: %s" uri);
255 Some
256 (create_jsonrpc_error req.id ErrorCode.InvalidParams
257 ("Resource not found: " ^ uri)
258 ()))
259
260(* Extract the tool name from params *)
261let extract_tool_name params =
262 match List.assoc_opt "name" params with
263 | Some (`String name) ->
264 Log.debug (fun m -> m "Tool name: %s" name);
265 Some name
266 | _ ->
267 Log.err (fun m -> m "Missing or invalid 'name' parameter in tool call");
268 None
269
270(* Extract the tool arguments from params *)
271let extract_tool_arguments params =
272 match List.assoc_opt "arguments" params with
273 | Some args ->
274 Log.debug (fun m -> m "Tool arguments: %s" (Yojson.Safe.to_string args));
275 args
276 | _ ->
277 Log.debug (fun m ->
278 m "No arguments provided for tool call, using empty object");
279 `Assoc [] (* Empty arguments is valid *)
280
281(* Execute a tool *)
282let execute_tool server ctx name args =
283 try
284 let tool = List.find (fun t -> t.Tool.name = name) (tools server) in
285 Log.debug (fun m -> m "Found tool: %s" name);
286
287 (* Call the tool handler *)
288 match tool.handler ctx args with
289 | Ok result ->
290 Log.debug (fun m -> m "Tool execution succeeded");
291 result
292 | Error err -> Tool.handle_execution_error err
293 with
294 | Not_found -> Tool.handle_unknown_tool_error name
295 | exn -> Tool.handle_execution_exception exn
296
297(* Convert JSON tool result to RPC content format *)
298let json_to_rpc_content json =
299 match json with
300 | `Assoc fields -> (
301 match
302 (List.assoc_opt "content" fields, List.assoc_opt "isError" fields)
303 with
304 | Some (`List content_items), Some (`Bool is_error) ->
305 let mcp_content = List.map Mcp.content_of_yojson content_items in
306 let rpc_content = Tool.mcp_content_to_rpc_content mcp_content in
307 (rpc_content, is_error)
308 | _ ->
309 (* Fallback for compatibility with older formats *)
310 let text = Yojson.Safe.to_string json in
311 let text_content = { TextContent.text; annotations = None } in
312 ([ Mcp_rpc.ToolsCall.ToolContent.Text text_content ], false))
313 | _ ->
314 (* Simple fallback for non-object results *)
315 let text = Yojson.Safe.to_string json in
316 let text_content = { TextContent.text; annotations = None } in
317 ([ Mcp_rpc.ToolsCall.ToolContent.Text text_content ], false)
318
319(* Process tools/call request *)
320let handle_tools_call server req =
321 Log.debug (fun m -> m "Processing tools/call request");
322 match req.JSONRPCMessage.params with
323 | Some (`Assoc params) -> (
324 match extract_tool_name params with
325 | Some name ->
326 let args = extract_tool_arguments params in
327
328 (* Create context for this request *)
329 let ctx =
330 Context.create ?request_id:(Some req.id)
331 ?progress_token:req.progress_token
332 ~lifespan_context:[ ("tools/call", `Assoc params) ]
333 ()
334 in
335
336 (* Execute the tool *)
337 let result_json = execute_tool server ctx name args in
338
339 (* Convert JSON result to RPC format *)
340 let content, is_error = json_to_rpc_content result_json in
341
342 (* Create the RPC response *)
343 let response =
344 Mcp_rpc.ToolsCall.create_response ~id:req.id ~content ~is_error ()
345 in
346
347 Some response
348 | None ->
349 Some
350 (create_jsonrpc_error req.id InvalidParams
351 "Missing tool name parameter" ()))
352 | _ ->
353 Log.err (fun m -> m "Invalid params format for tools/call");
354 Some
355 (create_jsonrpc_error req.id InvalidParams
356 "Invalid params format for tools/call" ())
357
358(* Process ping request *)
359let handle_ping (req : JSONRPCMessage.request) =
360 Log.debug (fun m -> m "Processing ping request");
361 Some (create_response ~id:req.JSONRPCMessage.id ~result:(`Assoc []))
362
363(* Handle notifications/initialized *)
364let handle_initialized (notif : JSONRPCMessage.notification) =
365 Log.debug (fun m ->
366 m
367 "Client initialization complete - Server is now ready to receive \
368 requests\n\
369 \ Notification params: %s"
370 (match notif.JSONRPCMessage.params with
371 | Some p -> Yojson.Safe.to_string p
372 | None -> "null"));
373 None
374
375(* Process a single message using the MCP SDK *)
376let process_message server message =
377 try
378 Log.debug (fun m ->
379 m "Processing message: %s" (Yojson.Safe.to_string message));
380 match JSONRPCMessage.t_of_yojson message with
381 | JSONRPCMessage.Request req -> (
382 Log.debug (fun m ->
383 m "Received request with method: %s" (Method.to_string req.meth));
384 match req.meth with
385 | Method.Initialize -> handle_initialize server req
386 | Method.ToolsList -> handle_tools_list server req
387 | Method.ToolsCall -> handle_tools_call server req
388 | Method.PromptsList -> handle_prompts_list server req
389 | Method.ResourcesList -> handle_resources_list server req
390 | Method.ResourcesRead -> handle_resources_read server req
391 | Method.ResourceTemplatesList ->
392 handle_resource_templates_list server req
393 | _ ->
394 Log.err (fun m ->
395 m "Unknown method received: %s" (Method.to_string req.meth));
396 Some
397 (create_jsonrpc_error req.id ErrorCode.MethodNotFound
398 ("Method not found: " ^ Method.to_string req.meth)
399 ()))
400 | JSONRPCMessage.Notification notif -> (
401 Log.debug (fun m ->
402 m "Received notification with method: %s"
403 (Method.to_string notif.meth));
404 match notif.meth with
405 | Method.Initialized -> handle_initialized notif
406 | _ ->
407 Log.debug (fun m ->
408 m "Ignoring notification: %s" (Method.to_string notif.meth));
409 None)
410 | JSONRPCMessage.Response _ ->
411 Log.err (fun m -> m "Unexpected response message received");
412 None
413 | JSONRPCMessage.Error _ ->
414 Log.err (fun m -> m "Unexpected error message received");
415 None
416 with
417 | Json.Of_json (msg, _) ->
418 Log.err (fun m -> m "JSON error: %s" msg);
419 (* Can't respond with error because we don't have a request ID *)
420 None
421 | Yojson.Json_error msg ->
422 Log.err (fun m -> m "JSON parse error: %s" msg);
423 (* Can't respond with error because we don't have a request ID *)
424 None
425 | exc ->
426 Log.err (fun m ->
427 m
428 "Exception during message processing: %s\n\
429 Backtrace: %s\n\
430 Message was: %s"
431 (Printexc.to_string exc)
432 (Printexc.get_backtrace ())
433 (Yojson.Safe.to_string message));
434 None
435
436(* Extract a request ID from a potentially malformed message *)
437let extract_request_id json =
438 try
439 match json with
440 | `Assoc fields -> (
441 match List.assoc_opt "id" fields with
442 | Some (`Int id) -> Some (`Int id)
443 | Some (`String id) -> Some (`String id)
444 | _ -> None)
445 | _ -> None
446 with _ -> None
447
448(* Handle processing for an input line *)
449let process_input_line server line =
450 if line = "" then (
451 Log.debug (fun m -> m "Empty line received, ignoring");
452 None)
453 else (
454 Log.debug (fun m -> m "Raw input: %s" line);
455 try
456 let json = Yojson.Safe.from_string line in
457 Log.debug (fun m -> m "Successfully parsed JSON");
458
459 (* Process the message *)
460 process_message server json
461 with Yojson.Json_error msg ->
462 Log.err (fun m -> m "Error parsing JSON: %s" msg);
463 Log.err (fun m -> m "Input was: %s" line);
464 None)
465
466(* Send a response to the client *)
467let send_response stdout response =
468 let response_json = JSONRPCMessage.yojson_of_t response in
469 let response_str = Yojson.Safe.to_string response_json in
470 Log.debug (fun m -> m "Sending response: %s" response_str);
471
472 (* Write the response followed by a newline *)
473 Eio.Flow.copy_string response_str stdout;
474 Eio.Flow.copy_string "\n" stdout
475
476(* Run the MCP server with the given server configuration *)
477let callback mcp_server _conn (request : Http.Request.t) body =
478 match request.meth with
479 | `POST -> (
480 Log.debug (fun m -> m "Received POST request");
481 let request_body_str =
482 Eio.Buf_read.(parse_exn take_all) body ~max_size:max_int
483 in
484 match process_input_line mcp_server request_body_str with
485 | Some mcp_response ->
486 let response_json = JSONRPCMessage.yojson_of_t mcp_response in
487 let response_str = Yojson.Safe.to_string response_json in
488 Log.debug (fun m -> m "Sending MCP response: %s" response_str);
489 let headers =
490 Http.Header.of_list [ ("Content-Type", "application/json") ]
491 in
492 Cohttp_eio.Server.respond ~status:`OK ~headers
493 ~body:(Cohttp_eio.Body.of_string response_str)
494 ()
495 | None ->
496 Log.debug (fun m -> m "No MCP response needed");
497 Cohttp_eio.Server.respond ~status:`No_content
498 ~body:(Cohttp_eio.Body.of_string "")
499 ())
500 | _ ->
501 Log.info (fun m ->
502 m "Unsupported method: %s" (Http.Method.to_string request.meth));
503 Cohttp_eio.Server.respond ~status:`Method_not_allowed
504 ~body:(Cohttp_eio.Body.of_string "Only POST is supported")
505 ()
506
507let log_warning ex = Logs.warn (fun f -> f "%a" Eio.Exn.pp ex)
508
509(** run the server using http transport *)
510let run_server ?(port = 8080) ?(on_error = log_warning) env server =
511 let net = Eio.Stdenv.net env in
512 let addr = `Tcp (Eio.Net.Ipaddr.V4.loopback, port) in
513
514 Log.info (fun m ->
515 m "Starting http MCP server: %s v%s\nProtocol version: %s" (name server)
516 (version server) (protocol_version server));
517
518 Eio.Switch.run @@ fun sw ->
519 let server_spec = Cohttp_eio.Server.make ~callback:(callback server) () in
520
521 let server_socket =
522 Eio.Net.listen net ~sw ~backlog:128 ~reuse_addr:true addr
523 in
524 Log.info (fun m -> m "MCP HTTP Server listening on http://localhost:%d" port);
525
526 Cohttp_eio.Server.run server_socket server_spec ~on_error
527
528(** run the server using the stdio transport *)
529let run_stdio_server env server =
530 let stdin = Eio.Stdenv.stdin env in
531 let stdout = Eio.Stdenv.stdout env in
532
533 Log.info (fun m ->
534 m "Starting stdio MCP server: %s v%s\nProtocol version: %s" (name server)
535 (version server) (protocol_version server));
536
537 (* Enable exception backtraces *)
538 Printexc.record_backtrace true;
539
540 let buf = Eio.Buf_read.of_flow stdin ~initial_size:100 ~max_size:1_000_000 in
541
542 (* Main processing loop *)
543 try
544 while true do
545 Log.info (fun m -> m "Waiting for message...");
546 let line = Eio.Buf_read.line buf in
547
548 (* Process the input and send response if needed *)
549 match process_input_line server line with
550 | Some response -> send_response stdout response
551 | None -> Log.info (fun m -> m "No response needed for this message")
552 done
553 with
554 | End_of_file ->
555 Log.debug (fun m -> m "End of file received on stdin");
556 ()
557 | Eio.Exn.Io _ as exn ->
558 (* Only a warning since on Windows, once the client closes the connection, we normally fail with `I/O error while reading: Eio.Io Net Connection_reset Unix_error (Broken pipe, "stub_cstruct_read", "")` *)
559 Log.warn (fun m ->
560 m "I/O error while reading: %s" (Printexc.to_string exn));
561 ()
562 | exn ->
563 Log.err (fun m ->
564 m "Exception while reading: %s" (Printexc.to_string exn));
565 ()