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