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.debug (Printf.sprintf "Client info: %s v%s"
12 req_data.client_info.name req_data.client_info.version);
13 Log.debug (Printf.sprintf "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 tool_list = List.map Tool.to_json (tools server) in
37 let result = `Assoc [("tools", `List tool_list)] in
38 Some (create_response ~id:req.id ~result)
39
40(* Process prompts/list request *)
41let handle_prompts_list server (req:JSONRPCMessage.request) =
42 Log.debug "Processing prompts/list request";
43 let prompt_list = List.map Prompt.to_json (prompts server) in
44 let result = `Assoc [("prompts", `List prompt_list)] in
45 Some (create_response ~id:req.id ~result)
46
47(* Process resources/list request *)
48let handle_resources_list server (req:JSONRPCMessage.request) =
49 Log.debug "Processing resources/list request";
50 let resource_list = List.map Resource.to_json (resources server) in
51 let result = `Assoc [("resources", `List resource_list)] in
52 Some (create_response ~id:req.id ~result)
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.debug (Printf.sprintf "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.debug (Printf.sprintf "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 = error_code_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(* Create a tool error result with structured content *)
84let create_tool_error_result error =
85 create_tool_result [TextContent error] ~is_error:true
86
87(* Handle tool execution errors *)
88let handle_tool_execution_error err =
89 Log.error (Printf.sprintf "Tool execution failed: %s" err);
90 create_tool_error_result (Printf.sprintf "Error executing tool: %s" err)
91
92(* Handle unknown tool error *)
93let handle_unknown_tool_error name =
94 Log.error (Printf.sprintf "Unknown tool: %s" name);
95 create_tool_error_result (Printf.sprintf "Unknown tool: %s" name)
96
97(* Handle general tool execution exception *)
98let handle_tool_execution_exception exn =
99 Log.error (Printf.sprintf "Exception executing tool: %s" (Printexc.to_string exn));
100 create_tool_error_result (Printf.sprintf "Internal error: %s" (Printexc.to_string exn))
101
102(* Execute a tool *)
103let execute_tool server ctx name args =
104 try
105 let tool = List.find (fun t -> t.Tool.name = name) (tools server) in
106 Log.debug (Printf.sprintf "Found tool: %s" name);
107
108 (* Call the tool handler *)
109 match tool.handler ctx args with
110 | Ok result ->
111 Log.debug "Tool execution succeeded";
112 result
113 | Error err -> handle_tool_execution_error err
114 with
115 | Not_found -> handle_unknown_tool_error name
116 | exn -> handle_tool_execution_exception exn
117
118(* Process tools/call request *)
119let handle_tools_call server req =
120 Log.debug "Processing tools/call request";
121 match req.JSONRPCMessage.params with
122 | Some (`Assoc params) ->
123 (match extract_tool_name params with
124 | Some name ->
125 let args = extract_tool_arguments params in
126
127 (* Create context for this request *)
128 let ctx = Context.create
129 ?request_id:(Some req.id) (* Store request ID for progress reporting *)
130 ~lifespan_context:[("tools/call", `Assoc params)] (* Store params for reference *)
131 ()
132 in
133
134 (* Set progress token if present *)
135 ctx.progress_token <- req.progress_token;
136
137 (* Execute the tool *)
138 let result = execute_tool server ctx name args in
139
140 (* Process progress messages if any *)
141 let progress_msg = Context.report_progress ctx 1.0 1.0 in
142 (match progress_msg with
143 | Some msg -> Log.debug "Progress complete notification would be sent here";
144 | None -> ());
145
146 Some (create_response ~id:req.id ~result)
147 | None ->
148 Some (create_jsonrpc_error req.id InvalidParams "Missing tool name parameter" ()))
149 | _ ->
150 Log.error "Invalid params format for tools/call";
151 Some (create_jsonrpc_error req.id InvalidParams "Invalid params format for tools/call" ())
152
153(* Process ping request *)
154let handle_ping (req:JSONRPCMessage.request) =
155 Log.debug "Processing ping request";
156 Some (create_response ~id:req.JSONRPCMessage.id ~result:(`Assoc []))
157
158(* Handle notifications/initialized *)
159let handle_initialized (notif:JSONRPCMessage.notification) =
160 Log.debug "Client initialization complete - Server is now ready to receive requests";
161 Log.debug (Printf.sprintf "Notification params: %s"
162 (match notif.JSONRPCMessage.params with
163 | Some p -> Yojson.Safe.to_string p
164 | None -> "null"));
165 None
166
167(* Process a single message using the MCP SDK *)
168let process_message server message =
169 try
170 Log.debug (Printf.sprintf "Processing message: %s" (Yojson.Safe.to_string message));
171 match JSONRPCMessage.t_of_yojson message with
172 | JSONRPCMessage.Request req ->
173 Log.debug (Printf.sprintf "Received request with method: %s" req.method_);
174 (match req.method_ with
175 | "initialize" -> handle_initialize server req
176 | "tools/list" -> handle_tools_list server req
177 | "tools/call" -> handle_tools_call server req
178 | "prompts/list" -> handle_prompts_list server req
179 | "resources/list" -> handle_resources_list server req
180 | "ping" -> handle_ping req
181 | _ ->
182 Log.error (Printf.sprintf "Unknown method received: %s" req.method_);
183 Some (create_jsonrpc_error req.id MethodNotFound ("Method not found: " ^ req.method_) ()))
184 | JSONRPCMessage.Notification notif ->
185 Log.debug (Printf.sprintf "Received notification with method: %s" notif.method_);
186 (match notif.method_ with
187 | "notifications/initialized" -> handle_initialized notif
188 | _ ->
189 Log.debug (Printf.sprintf "Ignoring notification: %s" notif.method_);
190 None)
191 | JSONRPCMessage.Response _ ->
192 Log.error "Unexpected response message received";
193 None
194 | JSONRPCMessage.Error _ ->
195 Log.error "Unexpected error message received";
196 None
197 with
198 | Json.Of_json (msg, _) ->
199 Log.error (Printf.sprintf "JSON error: %s" msg);
200 (* Can't respond with error because we don't have a request ID *)
201 None
202 | Yojson.Json_error msg ->
203 Log.error (Printf.sprintf "JSON parse error: %s" msg);
204 (* Can't respond with error because we don't have a request ID *)
205 None
206 | exc ->
207 Log.error (Printf.sprintf "Exception during message processing: %s" (Printexc.to_string exc));
208 Log.error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));
209 Log.error (Printf.sprintf "Message was: %s" (Yojson.Safe.to_string message));
210 None
211
212(* Extract a request ID from a potentially malformed message *)
213let extract_request_id json =
214 try
215 match json with
216 | `Assoc fields ->
217 (match List.assoc_opt "id" fields with
218 | Some (`Int id) -> Some (`Int id)
219 | Some (`String id) -> Some (`String id)
220 | _ -> None)
221 | _ -> None
222 with _ -> None
223
224(* Handle processing for an input line *)
225let process_input_line server line =
226 if line = "" then (
227 Log.debug "Empty line received, ignoring";
228 None
229 ) else (
230 Log.debug (Printf.sprintf "Raw input: %s" line);
231 try
232 let json = Yojson.Safe.from_string line in
233 Log.debug "Successfully parsed JSON";
234
235 (* Process the message *)
236 process_message server json
237 with
238 | Yojson.Json_error msg -> begin
239 Log.error (Printf.sprintf "Error parsing JSON: %s" msg);
240 Log.error (Printf.sprintf "Input was: %s" line);
241 None
242 end
243 )
244
245(* Send a response to the client *)
246let send_response stdout response =
247 let response_json = JSONRPCMessage.yojson_of_t response in
248 let response_str = Yojson.Safe.to_string response_json in
249 Log.debug (Printf.sprintf "Sending response: %s" response_str);
250
251 (* Write the response followed by a newline *)
252 Eio.Flow.copy_string response_str stdout;
253 Eio.Flow.copy_string "\n" stdout
254
255(* Run the MCP server with the given server configuration *)
256let run_server env server =
257 let stdin = Eio.Stdenv.stdin env in
258 let stdout = Eio.Stdenv.stdout env in
259
260 Log.debug (Printf.sprintf "Starting MCP server: %s v%s" (name server) (version server));
261 Log.debug (Printf.sprintf "Protocol version: %s" (protocol_version server));
262
263 (* Enable exception backtraces *)
264 Printexc.record_backtrace true;
265
266 let buf = Eio.Buf_read.of_flow stdin ~initial_size:100 ~max_size:1_000_000 in
267
268 (* Main processing loop *)
269 try
270 while true do
271 Log.debug "Waiting for message...";
272 let line = Eio.Buf_read.line buf in
273
274 (* Process the input and send response if needed *)
275 match process_input_line server line with
276 | Some response -> send_response stdout response
277 | None -> Log.debug "No response needed for this message"
278 done
279 with
280 | End_of_file ->
281 Log.debug "End of file received on stdin";
282 ()
283 | Eio.Exn.Io _ as exn ->
284 Log.error (Printf.sprintf "I/O error while reading: %s" (Printexc.to_string exn));
285 ()
286 | exn ->
287 Log.error (Printf.sprintf "Exception while reading: %s" (Printexc.to_string exn));
288 ()