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 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.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(* Process tools/call request *)
101let handle_tools_call server req =
102 Log.debug "Processing tools/call request";
103 match req.JSONRPCMessage.params with
104 | Some (`Assoc params) ->
105 (match extract_tool_name params with
106 | Some name ->
107 let args = extract_tool_arguments params in
108
109 (* Create context for this request *)
110 let ctx = Context.create
111 ?request_id:(Some req.id)
112 ?progress_token:req.progress_token
113 ~lifespan_context:[("tools/call", `Assoc params)]
114 ()
115 in
116
117 (* Execute the tool *)
118 let result = execute_tool server ctx name args in
119
120 Some (create_response ~id:req.id ~result)
121 | None ->
122 Some (create_jsonrpc_error req.id InvalidParams "Missing tool name parameter" ()))
123 | _ ->
124 Log.error "Invalid params format for tools/call";
125 Some (create_jsonrpc_error req.id InvalidParams "Invalid params format for tools/call" ())
126
127(* Process ping request *)
128let handle_ping (req:JSONRPCMessage.request) =
129 Log.debug "Processing ping request";
130 Some (create_response ~id:req.JSONRPCMessage.id ~result:(`Assoc []))
131
132(* Handle notifications/initialized *)
133let handle_initialized (notif:JSONRPCMessage.notification) =
134 Log.debug "Client initialization complete - Server is now ready to receive requests";
135 Log.debugf "Notification params: %s"
136 (match notif.JSONRPCMessage.params with
137 | Some p -> Yojson.Safe.to_string p
138 | None -> "null");
139 None
140
141(* Process a single message using the MCP SDK *)
142let process_message server message =
143 try
144 Log.debugf "Processing message: %s" (Yojson.Safe.to_string message);
145 match JSONRPCMessage.t_of_yojson message with
146 | JSONRPCMessage.Request req ->
147 Log.debugf "Received request with method: %s" (Method.to_string req.meth);
148 (match req.meth with
149 | Method.Initialize -> handle_initialize server req
150 | Method.ToolsList -> handle_tools_list server req
151 | Method.ToolsCall -> handle_tools_call server req
152 | Method.PromptsList -> handle_prompts_list server req
153 | Method.ResourcesList -> handle_resources_list server req
154 | _ ->
155 Log.errorf "Unknown method received: %s" (Method.to_string req.meth);
156 Some (create_jsonrpc_error req.id MethodNotFound ("Method not found: " ^ (Method.to_string req.meth)) ()))
157 | JSONRPCMessage.Notification notif ->
158 Log.debugf "Received notification with method: %s" (Method.to_string notif.meth);
159 (match notif.meth with
160 | Method.Initialized -> handle_initialized notif
161 | _ ->
162 Log.debugf "Ignoring notification: %s" (Method.to_string notif.meth);
163 None)
164 | JSONRPCMessage.Response _ ->
165 Log.error "Unexpected response message received";
166 None
167 | JSONRPCMessage.Error _ ->
168 Log.error "Unexpected error message received";
169 None
170 with
171 | Json.Of_json (msg, _) ->
172 Log.errorf "JSON error: %s" msg;
173 (* Can't respond with error because we don't have a request ID *)
174 None
175 | Yojson.Json_error msg ->
176 Log.errorf "JSON parse error: %s" msg;
177 (* Can't respond with error because we don't have a request ID *)
178 None
179 | exc ->
180 Log.errorf "Exception during message processing: %s" (Printexc.to_string exc);
181 Log.errorf "Backtrace: %s" (Printexc.get_backtrace());
182 Log.errorf "Message was: %s" (Yojson.Safe.to_string message);
183 None
184
185(* Extract a request ID from a potentially malformed message *)
186let extract_request_id json =
187 try
188 match json with
189 | `Assoc fields ->
190 (match List.assoc_opt "id" fields with
191 | Some (`Int id) -> Some (`Int id)
192 | Some (`String id) -> Some (`String id)
193 | _ -> None)
194 | _ -> None
195 with _ -> None
196
197(* Handle processing for an input line *)
198let process_input_line server line =
199 if line = "" then (
200 Log.debug "Empty line received, ignoring";
201 None
202 ) else (
203 Log.debugf "Raw input: %s" line;
204 try
205 let json = Yojson.Safe.from_string line in
206 Log.debug "Successfully parsed JSON";
207
208 (* Process the message *)
209 process_message server json
210 with
211 | Yojson.Json_error msg -> begin
212 Log.errorf "Error parsing JSON: %s" msg;
213 Log.errorf "Input was: %s" line;
214 None
215 end
216 )
217
218(* Send a response to the client *)
219let send_response stdout response =
220 let response_json = JSONRPCMessage.yojson_of_t response in
221 let response_str = Yojson.Safe.to_string response_json in
222 Log.debugf "Sending response: %s" response_str;
223
224 (* Write the response followed by a newline *)
225 Eio.Flow.copy_string response_str stdout;
226 Eio.Flow.copy_string "\n" stdout
227
228(* Run the MCP server with the given server configuration *)
229let run_server env server =
230 let stdin = Eio.Stdenv.stdin env in
231 let stdout = Eio.Stdenv.stdout env in
232
233 Log.debugf "Starting MCP server: %s v%s" (name server) (version server);
234 Log.debugf "Protocol version: %s" (protocol_version server);
235
236 (* Enable exception backtraces *)
237 Printexc.record_backtrace true;
238
239 let buf = Eio.Buf_read.of_flow stdin ~initial_size:100 ~max_size:1_000_000 in
240
241 (* Main processing loop *)
242 try
243 while true do
244 Log.debug "Waiting for message...";
245 let line = Eio.Buf_read.line buf in
246
247 (* Process the input and send response if needed *)
248 match process_input_line server line with
249 | Some response -> send_response stdout response
250 | None -> Log.debug "No response needed for this message"
251 done
252 with
253 | End_of_file ->
254 Log.debug "End of file received on stdin";
255 ()
256 | Eio.Exn.Io _ as exn ->
257 Log.errorf "I/O error while reading: %s" (Printexc.to_string exn);
258 ()
259 | exn ->
260 Log.errorf "Exception while reading: %s" (Printexc.to_string exn);
261 ()