Model Context Protocol in OCaml
anil.recoil.org
1open Mcp
2open Jsonrpc
3open Mcp_sdk
4
5(* Process initialize request *)
6let handle_initialize server req =
7 Log.debug "Processing initialize request";
8 let result = match req.JSONRPCMessage.params with
9 | Some params ->
10 let req_data = Initialize.Request.t_of_yojson params in
11 Log.debugf "Client info: %s v%s"
12 req_data.client_info.name req_data.client_info.version;
13 Log.debugf "Client protocol version: %s" req_data.protocol_version;
14
15 (* Create initialize response *)
16 let result = Initialize.Result.create
17 ~capabilities:(capabilities server)
18 ~server_info:Implementation.{
19 name = name server;
20 version = version server
21 }
22 ~protocol_version:(protocol_version server)
23 ~instructions:(Printf.sprintf "This server provides tools for %s." (name server))
24 ()
25 in
26 Initialize.Result.yojson_of_t result
27 | None ->
28 Log.error "Missing params for initialize request";
29 `Assoc [("error", `String "Missing params for initialize request")]
30 in
31 Some (create_response ~id:req.id ~result)
32
33(* Process tools/list request *)
34let handle_tools_list server (req:JSONRPCMessage.request) =
35 Log.debug "Processing tools/list request";
36 let tools_list = Tool.to_rpc_tools_list (tools server) in
37 let response = Mcp_rpc.ToolsList.create_response ~id:req.id ~tools:tools_list () in
38 Some response
39
40(* Process prompts/list request *)
41let handle_prompts_list server (req:JSONRPCMessage.request) =
42 Log.debug "Processing prompts/list request";
43 let prompts_list = Prompt.to_rpc_prompts_list (prompts server) in
44 let response = Mcp_rpc.PromptsList.create_response ~id:req.id ~prompts:prompts_list () in
45 Some response
46
47(* Process resources/list request *)
48let handle_resources_list server (req:JSONRPCMessage.request) =
49 Log.debug "Processing resources/list request";
50 let resources_list = Resource.to_rpc_resources_list (resources server) in
51 let response = Mcp_rpc.ResourcesList.create_response ~id:req.id ~resources:resources_list () in
52 Some response
53
54(* Extract the tool name from params *)
55let extract_tool_name params =
56 match List.assoc_opt "name" params with
57 | Some (`String name) ->
58 Log.debugf "Tool name: %s" name;
59 Some name
60 | _ ->
61 Log.error "Missing or invalid 'name' parameter in tool call";
62 None
63
64(* Extract the tool arguments from params *)
65let extract_tool_arguments params =
66 match List.assoc_opt "arguments" params with
67 | Some (args) ->
68 Log.debugf "Tool arguments: %s" (Yojson.Safe.to_string args);
69 args
70 | _ ->
71 Log.debug "No arguments provided for tool call, using empty object";
72 `Assoc [] (* Empty arguments is valid *)
73
74(* Create a proper JSONRPC error with code and data *)
75let create_jsonrpc_error id code message ?data () =
76 let error_code = ErrorCode.to_int code in
77 let error_data = match data with
78 | Some d -> d
79 | None -> `Null
80 in
81 create_error ~id ~code:error_code ~message ~data:(Some error_data) ()
82
83
84(* Execute a tool *)
85let execute_tool server ctx name args =
86 try
87 let tool = List.find (fun t -> t.Tool.name = name) (tools server) in
88 Log.debugf "Found tool: %s" name;
89
90 (* Call the tool handler *)
91 match tool.handler ctx args with
92 | Ok result ->
93 Log.debug "Tool execution succeeded";
94 result
95 | Error err -> Tool.handle_execution_error err
96 with
97 | Not_found -> Tool.handle_unknown_tool_error name
98 | exn -> Tool.handle_execution_exception exn
99
100(* Convert JSON tool result to RPC content format *)
101let json_to_rpc_content json =
102 match json with
103 | `Assoc fields ->
104 (match List.assoc_opt "content" fields, List.assoc_opt "isError" fields with
105 | Some (`List content_items), Some (`Bool is_error) ->
106 let mcp_content = List.map Mcp.content_of_yojson content_items in
107 let rpc_content = Tool.mcp_content_to_rpc_content mcp_content in
108 (rpc_content, is_error)
109 | _ ->
110 (* Fallback for compatibility with older formats *)
111 let text = Yojson.Safe.to_string json in
112 let text_content = { TextContent.text = text; annotations = None } in
113 ([Mcp_rpc.ToolsCall.ToolContent.Text text_content], false))
114 | _ ->
115 (* Simple fallback for non-object results *)
116 let text = Yojson.Safe.to_string json in
117 let text_content = { TextContent.text = text; annotations = None } in
118 ([Mcp_rpc.ToolsCall.ToolContent.Text text_content], false)
119
120(* Process tools/call request *)
121let handle_tools_call server req =
122 Log.debug "Processing tools/call request";
123 match req.JSONRPCMessage.params with
124 | Some (`Assoc params) ->
125 (match extract_tool_name params with
126 | Some name ->
127 let args = extract_tool_arguments params in
128
129 (* Create context for this request *)
130 let ctx = Context.create
131 ?request_id:(Some req.id)
132 ?progress_token:req.progress_token
133 ~lifespan_context:[("tools/call", `Assoc params)]
134 ()
135 in
136
137 (* Execute the tool *)
138 let result_json = execute_tool server ctx name args in
139
140 (* Convert JSON result to RPC format *)
141 let content, is_error = json_to_rpc_content result_json in
142
143 (* Create the RPC response *)
144 let response = Mcp_rpc.ToolsCall.create_response
145 ~id:req.id
146 ~content
147 ~is_error
148 ()
149 in
150
151 Some response
152 | None ->
153 Some (create_jsonrpc_error req.id InvalidParams "Missing tool name parameter" ()))
154 | _ ->
155 Log.error "Invalid params format for tools/call";
156 Some (create_jsonrpc_error req.id InvalidParams "Invalid params format for tools/call" ())
157
158(* Process ping request *)
159let handle_ping (req:JSONRPCMessage.request) =
160 Log.debug "Processing ping request";
161 Some (create_response ~id:req.JSONRPCMessage.id ~result:(`Assoc []))
162
163(* Handle notifications/initialized *)
164let handle_initialized (notif:JSONRPCMessage.notification) =
165 Log.debug "Client initialization complete - Server is now ready to receive requests";
166 Log.debugf "Notification params: %s"
167 (match notif.JSONRPCMessage.params with
168 | Some p -> Yojson.Safe.to_string p
169 | None -> "null");
170 None
171
172(* Process a single message using the MCP SDK *)
173let process_message server message =
174 try
175 Log.debugf "Processing message: %s" (Yojson.Safe.to_string message);
176 match JSONRPCMessage.t_of_yojson message with
177 | JSONRPCMessage.Request req ->
178 Log.debugf "Received request with method: %s" (Method.to_string req.meth);
179 (match req.meth with
180 | Method.Initialize -> handle_initialize server req
181 | Method.ToolsList -> handle_tools_list server req
182 | Method.ToolsCall -> handle_tools_call server req
183 | Method.PromptsList -> handle_prompts_list server req
184 | Method.ResourcesList -> handle_resources_list server req
185 | _ ->
186 Log.errorf "Unknown method received: %s" (Method.to_string req.meth);
187 Some (create_jsonrpc_error req.id MethodNotFound ("Method not found: " ^ (Method.to_string req.meth)) ()))
188 | JSONRPCMessage.Notification notif ->
189 Log.debugf "Received notification with method: %s" (Method.to_string notif.meth);
190 (match notif.meth with
191 | Method.Initialized -> handle_initialized notif
192 | _ ->
193 Log.debugf "Ignoring notification: %s" (Method.to_string notif.meth);
194 None)
195 | JSONRPCMessage.Response _ ->
196 Log.error "Unexpected response message received";
197 None
198 | JSONRPCMessage.Error _ ->
199 Log.error "Unexpected error message received";
200 None
201 with
202 | Json.Of_json (msg, _) ->
203 Log.errorf "JSON error: %s" msg;
204 (* Can't respond with error because we don't have a request ID *)
205 None
206 | Yojson.Json_error msg ->
207 Log.errorf "JSON parse error: %s" msg;
208 (* Can't respond with error because we don't have a request ID *)
209 None
210 | exc ->
211 Log.errorf "Exception during message processing: %s" (Printexc.to_string exc);
212 Log.errorf "Backtrace: %s" (Printexc.get_backtrace());
213 Log.errorf "Message was: %s" (Yojson.Safe.to_string message);
214 None
215
216(* Extract a request ID from a potentially malformed message *)
217let extract_request_id json =
218 try
219 match json with
220 | `Assoc fields ->
221 (match List.assoc_opt "id" fields with
222 | Some (`Int id) -> Some (`Int id)
223 | Some (`String id) -> Some (`String id)
224 | _ -> None)
225 | _ -> None
226 with _ -> None
227
228(* Handle processing for an input line *)
229let process_input_line server line =
230 if line = "" then (
231 Log.debug "Empty line received, ignoring";
232 None
233 ) else (
234 Log.debugf "Raw input: %s" line;
235 try
236 let json = Yojson.Safe.from_string line in
237 Log.debug "Successfully parsed JSON";
238
239 (* Process the message *)
240 process_message server json
241 with
242 | Yojson.Json_error msg -> begin
243 Log.errorf "Error parsing JSON: %s" msg;
244 Log.errorf "Input was: %s" line;
245 None
246 end
247 )
248
249(* Send a response to the client *)
250let send_response stdout response =
251 let response_json = JSONRPCMessage.yojson_of_t response in
252 let response_str = Yojson.Safe.to_string response_json in
253 Log.debugf "Sending response: %s" response_str;
254
255 (* Write the response followed by a newline *)
256 Eio.Flow.copy_string response_str stdout;
257 Eio.Flow.copy_string "\n" stdout
258
259(* Run the MCP server with the given server configuration *)
260let run_server env server =
261 let stdin = Eio.Stdenv.stdin env in
262 let stdout = Eio.Stdenv.stdout env in
263
264 Log.debugf "Starting MCP server: %s v%s" (name server) (version server);
265 Log.debugf "Protocol version: %s" (protocol_version server);
266
267 (* Enable exception backtraces *)
268 Printexc.record_backtrace true;
269
270 let buf = Eio.Buf_read.of_flow stdin ~initial_size:100 ~max_size:1_000_000 in
271
272 (* Main processing loop *)
273 try
274 while true do
275 Log.debug "Waiting for message...";
276 let line = Eio.Buf_read.line buf in
277
278 (* Process the input and send response if needed *)
279 match process_input_line server line with
280 | Some response -> send_response stdout response
281 | None -> Log.debug "No response needed for this message"
282 done
283 with
284 | End_of_file ->
285 Log.debug "End of file received on stdin";
286 ()
287 | Eio.Exn.Io _ as exn ->
288 Log.errorf "I/O error while reading: %s" (Printexc.to_string exn);
289 ()
290 | exn ->
291 Log.errorf "Exception while reading: %s" (Printexc.to_string exn);
292 ()