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(* Create an error result with text content *)
55let create_error_content err =
56 let error_content = TextContent.{
57 text = err;
58 annotations = None
59 } in
60 `Assoc [
61 ("content", `List [TextContent.yojson_of_t error_content]);
62 ("isError", `Bool true)
63 ]
64
65(* Extract the tool name from params *)
66let extract_tool_name params =
67 match List.assoc_opt "name" params with
68 | Some (`String name) ->
69 Log.debug (Printf.sprintf "Tool name: %s" name);
70 Some name
71 | _ ->
72 Log.error "Missing or invalid 'name' parameter in tool call";
73 None
74
75(* Extract the tool arguments from params *)
76let extract_tool_arguments params =
77 match List.assoc_opt "arguments" params with
78 | Some (args) ->
79 Log.debug (Printf.sprintf "Tool arguments: %s" (Yojson.Safe.to_string args));
80 args
81 | _ ->
82 Log.debug "No arguments provided for tool call, using empty object";
83 `Assoc [] (* Empty arguments is valid *)
84
85(* Handle tool execution errors *)
86let handle_tool_execution_error err =
87 Log.error (Printf.sprintf "Tool execution failed: %s" err);
88 create_error_content (Printf.sprintf "Error executing tool: %s" err)
89
90(* Handle unknown tool error *)
91let handle_unknown_tool_error name =
92 Log.error (Printf.sprintf "Unknown tool: %s" name);
93 create_error_content (Printf.sprintf "Unknown tool: %s" name)
94
95(* Handle general tool execution exception *)
96let handle_tool_execution_exception exn =
97 Log.error (Printf.sprintf "Exception executing tool: %s" (Printexc.to_string exn));
98 create_error_content (Printf.sprintf "Internal error: %s" (Printexc.to_string exn))
99
100(* Execute a tool *)
101let execute_tool server ctx name args =
102 try
103 let tool = List.find (fun t -> t.Tool.name = name) (tools server) in
104 Log.debug (Printf.sprintf "Found tool: %s" name);
105
106 (* Call the tool handler *)
107 match tool.handler ctx args with
108 | Ok result ->
109 Log.debug "Tool execution succeeded";
110 result
111 | Error err -> handle_tool_execution_error err
112 with
113 | Not_found -> handle_unknown_tool_error name
114 | exn -> handle_tool_execution_exception exn
115
116(* Process tools/call request *)
117let handle_tools_call server req =
118 Log.debug "Processing tools/call request";
119 match req.JSONRPCMessage.params with
120 | Some (`Assoc params) ->
121 (match extract_tool_name params with
122 | Some name ->
123 let args = extract_tool_arguments params in
124
125 (* Create context for this request *)
126 let ctx = Context.create ?request_id:req.progress_token () in
127
128 (* Execute the tool *)
129 let result = execute_tool server ctx name args in
130 Some (create_response ~id:req.id ~result)
131 | None ->
132 Some (create_error ~id:req.id ~code:(-32602) ~message:"Missing tool name parameter" ()))
133 | _ ->
134 Log.error "Invalid params format for tools/call";
135 Some (create_error ~id:req.id ~code:(-32602) ~message:"Invalid params for tools/call" ())
136
137(* Process ping request *)
138let handle_ping (req:JSONRPCMessage.request) =
139 Log.debug "Processing ping request";
140 Some (create_response ~id:req.JSONRPCMessage.id ~result:(`Assoc []))
141
142(* Handle notifications/initialized *)
143let handle_initialized (notif:JSONRPCMessage.notification) =
144 Log.debug "Client initialization complete - Server is now ready to receive requests";
145 Log.debug (Printf.sprintf "Notification params: %s"
146 (match notif.JSONRPCMessage.params with
147 | Some p -> Yojson.Safe.to_string p
148 | None -> "null"));
149 None
150
151(* Process a single message using the MCP SDK *)
152let process_message server message =
153 try
154 Log.debug (Printf.sprintf "Processing message: %s" (Yojson.Safe.to_string message));
155 match JSONRPCMessage.t_of_yojson message with
156 | JSONRPCMessage.Request req ->
157 Log.debug (Printf.sprintf "Received request with method: %s" req.method_);
158 (match req.method_ with
159 | "initialize" -> handle_initialize server req
160 | "tools/list" -> handle_tools_list server req
161 | "tools/call" -> handle_tools_call server req
162 | "prompts/list" -> handle_prompts_list server req
163 | "resources/list" -> handle_resources_list server req
164 | "ping" -> handle_ping req
165 | _ ->
166 Log.error (Printf.sprintf "Unknown method received: %s" req.method_);
167 Some (create_error ~id:req.id ~code:(-32601) ~message:("Method not found: " ^ req.method_) ()))
168 | JSONRPCMessage.Notification notif ->
169 Log.debug (Printf.sprintf "Received notification with method: %s" notif.method_);
170 (match notif.method_ with
171 | "notifications/initialized" -> handle_initialized notif
172 | _ ->
173 Log.debug (Printf.sprintf "Ignoring notification: %s" notif.method_);
174 None)
175 | JSONRPCMessage.Response _ ->
176 Log.error "Unexpected response message received";
177 None
178 | JSONRPCMessage.Error _ ->
179 Log.error "Unexpected error message received";
180 None
181 with
182 | Json.Of_json (msg, _) ->
183 Log.error (Printf.sprintf "JSON error: %s" msg);
184 None
185 | exc ->
186 Log.error (Printf.sprintf "Exception during message processing: %s" (Printexc.to_string exc));
187 Log.error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));
188 Log.error (Printf.sprintf "Message was: %s" (Yojson.Safe.to_string message));
189 None
190
191(* Handle processing for an input line *)
192let process_input_line server line =
193 if line = "" then (
194 Log.debug "Empty line received, ignoring";
195 None
196 ) else (
197 Log.debug (Printf.sprintf "Raw input: %s" line);
198 try
199 let json = Yojson.Safe.from_string line in
200 Log.debug "Successfully parsed JSON";
201
202 (* Process the message *)
203 process_message server json
204 with
205 | Yojson.Json_error msg -> begin
206 Log.error (Printf.sprintf "Error parsing JSON: %s" msg);
207 Log.error (Printf.sprintf "Input was: %s" line);
208 None
209 end
210 )
211
212(* Send a response to the client *)
213let send_response stdout response =
214 let response_json = JSONRPCMessage.yojson_of_t response in
215 let response_str = Yojson.Safe.to_string response_json in
216 Log.debug (Printf.sprintf "Sending response: %s" response_str);
217
218 (* Write the response followed by a newline *)
219 Eio.Flow.copy_string response_str stdout;
220 Eio.Flow.copy_string "\n" stdout
221
222(* Run the MCP server with the given server configuration *)
223let run_server env server =
224 let stdin = Eio.Stdenv.stdin env in
225 let stdout = Eio.Stdenv.stdout env in
226
227 Log.debug (Printf.sprintf "Starting MCP server: %s v%s" (name server) (version server));
228 Log.debug (Printf.sprintf "Protocol version: %s" (protocol_version server));
229
230 (* Enable exception backtraces *)
231 Printexc.record_backtrace true;
232
233 let buf = Eio.Buf_read.of_flow stdin ~initial_size:100 ~max_size:1_000_000 in
234
235 (* Main processing loop *)
236 try
237 while true do
238 Log.debug "Waiting for message...";
239 let line = Eio.Buf_read.line buf in
240
241 (* Process the input and send response if needed *)
242 match process_input_line server line with
243 | Some response -> send_response stdout response
244 | None -> Log.debug "No response needed for this message"
245 done
246 with
247 | End_of_file ->
248 Log.debug "End of file received on stdin";
249 ()
250 | Eio.Exn.Io _ as exn ->
251 Log.error (Printf.sprintf "I/O error while reading: %s" (Printexc.to_string exn));
252 ()
253 | exn ->
254 Log.error (Printf.sprintf "Exception while reading: %s" (Printexc.to_string exn));
255 ()