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(* Utility module for resource template matching *)
64module Resource_matcher = struct
65 (* Define variants for resource handling result *)
66 type resource_match =
67 | DirectResource of Resource.t * string list
68 | TemplateResource of ResourceTemplate.t * string list
69 | NoMatch
70
71 (* Extract parameters from a template URI *)
72 let extract_template_vars template_uri uri =
73 (* Simple template variable extraction - could be enhanced with regex *)
74 let template_parts = String.split_on_char '/' template_uri in
75 let uri_parts = String.split_on_char '/' uri in
76
77 if List.length template_parts <> List.length uri_parts then
78 None
79 else
80 (* Match parts and extract variables *)
81 let rec match_parts tparts uparts acc =
82 match tparts, uparts with
83 | [], [] -> Some (List.rev acc)
84 | th::tt, uh::ut ->
85 (* Check if this part is a template variable *)
86 if String.length th > 2 &&
87 String.get th 0 = '{' &&
88 String.get th (String.length th - 1) = '}' then
89 (* Extract variable value and continue *)
90 match_parts tt ut (uh::acc)
91 else if th = uh then
92 (* Fixed part matches, continue *)
93 match_parts tt ut acc
94 else
95 (* Fixed part doesn't match, fail *)
96 None
97 | _, _ -> None
98 in
99 match_parts template_parts uri_parts []
100
101 (* Find a matching resource or template for a URI *)
102 let find_match server uri =
103 (* Try direct resource match first *)
104 match List.find_opt (fun resource -> resource.Resource.uri = uri) (resources server) with
105 | Some resource -> DirectResource (resource, [])
106 | None ->
107 (* Try template match next *)
108 let templates = resource_templates server in
109
110 (* Try each template to see if it matches *)
111 let rec try_templates templates =
112 match templates with
113 | [] -> NoMatch
114 | template::rest ->
115 match extract_template_vars template.ResourceTemplate.uri_template uri with
116 | Some params -> TemplateResource (template, params)
117 | None -> try_templates rest
118 in
119 try_templates templates
120end
121
122(* Process resources/read request *)
123let handle_resources_read server (req:JSONRPCMessage.request) =
124 Log.debug "Processing resources/read request";
125 match req.JSONRPCMessage.params with
126 | None ->
127 Log.error "Missing params for resources/read request";
128 Some (create_jsonrpc_error req.id ErrorCode.InvalidParams "Missing params for resources/read request" ())
129 | Some params ->
130 let req_data = Mcp_rpc.ResourcesRead.Request.t_of_yojson params in
131 let uri = req_data.uri in
132 Log.debugf "Resource URI: %s" uri;
133
134 (* Find matching resource or template *)
135 match Resource_matcher.find_match server uri with
136 | Resource_matcher.DirectResource (resource, params) ->
137 (* Create context for this request *)
138 let ctx = Context.create
139 ?request_id:(Some req.id)
140 ?progress_token:req.progress_token
141 ~lifespan_context:[("resources/read", `Assoc [("uri", `String uri)])]
142 ()
143 in
144
145 Log.debugf "Handling direct resource: %s" resource.name;
146
147 (* Call the resource handler *)
148 (match resource.handler ctx params with
149 | Ok content ->
150 (* Create text resource content *)
151 let mime_type = match resource.mime_type with
152 | Some mime -> mime
153 | None -> "text/plain"
154 in
155 let text_resource = {
156 TextResourceContents.uri;
157 text = content;
158 mime_type = Some mime_type
159 } in
160 let resource_content = Mcp_rpc.ResourcesRead.ResourceContent.TextResource text_resource in
161 let response = Mcp_rpc.ResourcesRead.create_response ~id:req.id ~contents:[resource_content] () in
162 Some response
163 | Error err ->
164 Log.errorf "Error reading resource: %s" err;
165 Some (create_jsonrpc_error req.id ErrorCode.InternalError ("Error reading resource: " ^ err) ()))
166
167 | Resource_matcher.TemplateResource (template, params) ->
168 (* Create context for this request *)
169 let ctx = Context.create
170 ?request_id:(Some req.id)
171 ?progress_token:req.progress_token
172 ~lifespan_context:[("resources/read", `Assoc [("uri", `String uri)])]
173 ()
174 in
175
176 Log.debugf "Handling resource template: %s with params: [%s]"
177 template.name
178 (String.concat ", " params);
179
180 (* Call the template handler *)
181 (match template.handler ctx params with
182 | Ok content ->
183 (* Create text resource content *)
184 let mime_type = match template.mime_type with
185 | Some mime -> mime
186 | None -> "text/plain"
187 in
188 let text_resource = {
189 TextResourceContents.uri;
190 text = content;
191 mime_type = Some mime_type
192 } in
193 let resource_content = Mcp_rpc.ResourcesRead.ResourceContent.TextResource text_resource in
194 let response = Mcp_rpc.ResourcesRead.create_response ~id:req.id ~contents:[resource_content] () in
195 Some response
196 | Error err ->
197 Log.errorf "Error reading resource template: %s" err;
198 Some (create_jsonrpc_error req.id ErrorCode.InternalError ("Error reading resource template: " ^ err) ()))
199
200 | Resource_matcher.NoMatch ->
201 Log.errorf "Resource not found: %s" uri;
202 Some (create_jsonrpc_error req.id ErrorCode.InvalidParams ("Resource not found: " ^ uri) ())
203
204(* Extract the tool name from params *)
205let extract_tool_name params =
206 match List.assoc_opt "name" params with
207 | Some (`String name) ->
208 Log.debugf "Tool name: %s" name;
209 Some name
210 | _ ->
211 Log.error "Missing or invalid 'name' parameter in tool call";
212 None
213
214(* Extract the tool arguments from params *)
215let extract_tool_arguments params =
216 match List.assoc_opt "arguments" params with
217 | Some (args) ->
218 Log.debugf "Tool arguments: %s" (Yojson.Safe.to_string args);
219 args
220 | _ ->
221 Log.debug "No arguments provided for tool call, using empty object";
222 `Assoc [] (* Empty arguments is valid *)
223
224(* Execute a tool *)
225let execute_tool server ctx name args =
226 try
227 let tool = List.find (fun t -> t.Tool.name = name) (tools server) in
228 Log.debugf "Found tool: %s" name;
229
230 (* Call the tool handler *)
231 match tool.handler ctx args with
232 | Ok result ->
233 Log.debug "Tool execution succeeded";
234 result
235 | Error err -> Tool.handle_execution_error err
236 with
237 | Not_found -> Tool.handle_unknown_tool_error name
238 | exn -> Tool.handle_execution_exception exn
239
240(* Convert JSON tool result to RPC content format *)
241let json_to_rpc_content json =
242 match json with
243 | `Assoc fields ->
244 (match List.assoc_opt "content" fields, List.assoc_opt "isError" fields with
245 | Some (`List content_items), Some (`Bool is_error) ->
246 let mcp_content = List.map Mcp.content_of_yojson content_items in
247 let rpc_content = Tool.mcp_content_to_rpc_content mcp_content in
248 (rpc_content, is_error)
249 | _ ->
250 (* Fallback for compatibility with older formats *)
251 let text = Yojson.Safe.to_string json in
252 let text_content = { TextContent.text = text; annotations = None } in
253 ([Mcp_rpc.ToolsCall.ToolContent.Text text_content], false))
254 | _ ->
255 (* Simple fallback for non-object results *)
256 let text = Yojson.Safe.to_string json in
257 let text_content = { TextContent.text = text; annotations = None } in
258 ([Mcp_rpc.ToolsCall.ToolContent.Text text_content], false)
259
260(* Process tools/call request *)
261let handle_tools_call server req =
262 Log.debug "Processing tools/call request";
263 match req.JSONRPCMessage.params with
264 | Some (`Assoc params) ->
265 (match extract_tool_name params with
266 | Some name ->
267 let args = extract_tool_arguments params in
268
269 (* Create context for this request *)
270 let ctx = Context.create
271 ?request_id:(Some req.id)
272 ?progress_token:req.progress_token
273 ~lifespan_context:[("tools/call", `Assoc params)]
274 ()
275 in
276
277 (* Execute the tool *)
278 let result_json = execute_tool server ctx name args in
279
280 (* Convert JSON result to RPC format *)
281 let content, is_error = json_to_rpc_content result_json in
282
283 (* Create the RPC response *)
284 let response = Mcp_rpc.ToolsCall.create_response
285 ~id:req.id
286 ~content
287 ~is_error
288 ()
289 in
290
291 Some response
292 | None ->
293 Some (create_jsonrpc_error req.id InvalidParams "Missing tool name parameter" ()))
294 | _ ->
295 Log.error "Invalid params format for tools/call";
296 Some (create_jsonrpc_error req.id InvalidParams "Invalid params format for tools/call" ())
297
298(* Process ping request *)
299let handle_ping (req:JSONRPCMessage.request) =
300 Log.debug "Processing ping request";
301 Some (create_response ~id:req.JSONRPCMessage.id ~result:(`Assoc []))
302
303(* Handle notifications/initialized *)
304let handle_initialized (notif:JSONRPCMessage.notification) =
305 Log.debug "Client initialization complete - Server is now ready to receive requests";
306 Log.debugf "Notification params: %s"
307 (match notif.JSONRPCMessage.params with
308 | Some p -> Yojson.Safe.to_string p
309 | None -> "null");
310 None
311
312(* Process a single message using the MCP SDK *)
313let process_message server message =
314 try
315 Log.debugf "Processing message: %s" (Yojson.Safe.to_string message);
316 match JSONRPCMessage.t_of_yojson message with
317 | JSONRPCMessage.Request req ->
318 Log.debugf "Received request with method: %s" (Method.to_string req.meth);
319 (match req.meth with
320 | Method.Initialize -> handle_initialize server req
321 | Method.ToolsList -> handle_tools_list server req
322 | Method.ToolsCall -> handle_tools_call server req
323 | Method.PromptsList -> handle_prompts_list server req
324 | Method.ResourcesList -> handle_resources_list server req
325 | Method.ResourcesRead -> handle_resources_read server req
326 | _ ->
327 Log.errorf "Unknown method received: %s" (Method.to_string req.meth);
328 Some (create_jsonrpc_error req.id ErrorCode.MethodNotFound ("Method not found: " ^ (Method.to_string req.meth)) ()))
329 | JSONRPCMessage.Notification notif ->
330 Log.debugf "Received notification with method: %s" (Method.to_string notif.meth);
331 (match notif.meth with
332 | Method.Initialized -> handle_initialized notif
333 | _ ->
334 Log.debugf "Ignoring notification: %s" (Method.to_string notif.meth);
335 None)
336 | JSONRPCMessage.Response _ ->
337 Log.error "Unexpected response message received";
338 None
339 | JSONRPCMessage.Error _ ->
340 Log.error "Unexpected error message received";
341 None
342 with
343 | Json.Of_json (msg, _) ->
344 Log.errorf "JSON error: %s" msg;
345 (* Can't respond with error because we don't have a request ID *)
346 None
347 | Yojson.Json_error msg ->
348 Log.errorf "JSON parse error: %s" msg;
349 (* Can't respond with error because we don't have a request ID *)
350 None
351 | exc ->
352 Log.errorf "Exception during message processing: %s" (Printexc.to_string exc);
353 Log.errorf "Backtrace: %s" (Printexc.get_backtrace());
354 Log.errorf "Message was: %s" (Yojson.Safe.to_string message);
355 None
356
357(* Extract a request ID from a potentially malformed message *)
358let extract_request_id json =
359 try
360 match json with
361 | `Assoc fields ->
362 (match List.assoc_opt "id" fields with
363 | Some (`Int id) -> Some (`Int id)
364 | Some (`String id) -> Some (`String id)
365 | _ -> None)
366 | _ -> None
367 with _ -> None
368
369(* Handle processing for an input line *)
370let process_input_line server line =
371 if line = "" then (
372 Log.debug "Empty line received, ignoring";
373 None
374 ) else (
375 Log.debugf "Raw input: %s" line;
376 try
377 let json = Yojson.Safe.from_string line in
378 Log.debug "Successfully parsed JSON";
379
380 (* Process the message *)
381 process_message server json
382 with
383 | Yojson.Json_error msg -> begin
384 Log.errorf "Error parsing JSON: %s" msg;
385 Log.errorf "Input was: %s" line;
386 None
387 end
388 )
389
390(* Send a response to the client *)
391let send_response stdout response =
392 let response_json = JSONRPCMessage.yojson_of_t response in
393 let response_str = Yojson.Safe.to_string response_json in
394 Log.debugf "Sending response: %s" response_str;
395
396 (* Write the response followed by a newline *)
397 Eio.Flow.copy_string response_str stdout;
398 Eio.Flow.copy_string "\n" stdout
399
400(* Run the MCP server with the given server configuration *)
401let run_server env server =
402 let stdin = Eio.Stdenv.stdin env in
403 let stdout = Eio.Stdenv.stdout env in
404
405 Log.debugf "Starting MCP server: %s v%s" (name server) (version server);
406 Log.debugf "Protocol version: %s" (protocol_version server);
407
408 (* Enable exception backtraces *)
409 Printexc.record_backtrace true;
410
411 let buf = Eio.Buf_read.of_flow stdin ~initial_size:100 ~max_size:1_000_000 in
412
413 (* Main processing loop *)
414 try
415 while true do
416 Log.debug "Waiting for message...";
417 let line = Eio.Buf_read.line buf in
418
419 (* Process the input and send response if needed *)
420 match process_input_line server line with
421 | Some response -> send_response stdout response
422 | None -> Log.debug "No response needed for this message"
423 done
424 with
425 | End_of_file ->
426 Log.debug "End of file received on stdin";
427 ()
428 | Eio.Exn.Io _ as exn ->
429 Log.errorf "I/O error while reading: %s" (Printexc.to_string exn);
430 ()
431 | exn ->
432 Log.errorf "Exception while reading: %s" (Printexc.to_string exn);
433 ()