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