Model Context Protocol in OCaml
anil.recoil.org
1open Mcp
2open Jsonrpc
3
4(* Logging utilities *)
5let log_debug msg =
6 Printf.eprintf "[DEBUG] %s\n" msg;
7 flush stderr
8
9let log_error msg =
10 Printf.eprintf "[ERROR] %s\n" msg;
11 flush stderr
12
13(* Server state *)
14let protocol_version = "2024-11-05"
15let server_info = Implementation.{ name = "ocaml-mcp-capitalizer"; version = "0.1.0" }
16let server_capabilities = `Assoc [
17 (* We support tools *)
18 ("tools", `Assoc [
19 ("listChanged", `Bool true)
20 ]);
21 (* We don't support resources - make this explicit *)
22 ("resources", `Assoc [
23 ("listChanged", `Bool false);
24 ("subscribe", `Bool false)
25 ]);
26 (* We don't support prompts - make this explicit *)
27 ("prompts", `Assoc [
28 ("listChanged", `Bool false)
29 ])
30]
31
32(* Tool implementation *)
33module CapitalizeTool = struct
34 let name = "capitalize"
35 let description = "Capitalizes the provided text"
36 let input_schema = `Assoc [
37 ("type", `String "object");
38 ("properties", `Assoc [
39 ("text", `Assoc [
40 ("type", `String "string");
41 ("description", `String "The text to capitalize")
42 ])
43 ]);
44 ("required", `List [`String "text"])
45 ]
46
47 let call json =
48 match json with
49 | `Assoc fields ->
50 (match List.assoc_opt "text" fields with
51 | Some (`String text) ->
52 let capitalized_text = String.uppercase_ascii text in
53 let content = TextContent.{
54 text = capitalized_text;
55 annotations = None
56 } in
57 `Assoc [
58 ("content", `List [TextContent.yojson_of_t content]);
59 ("isError", `Bool false)
60 ]
61 | _ ->
62 let error_content = TextContent.{
63 text = "Missing or invalid 'text' parameter";
64 annotations = None
65 } in
66 `Assoc [
67 ("content", `List [TextContent.yojson_of_t error_content]);
68 ("isError", `Bool true)
69 ])
70 | _ ->
71 let error_content = TextContent.{
72 text = "Invalid arguments format";
73 annotations = None
74 } in
75 `Assoc [
76 ("content", `List [TextContent.yojson_of_t error_content]);
77 ("isError", `Bool true)
78 ]
79end
80
81(* Handle tool listing *)
82let list_tools () =
83 let tool = `Assoc [
84 ("name", `String CapitalizeTool.name);
85 ("description", `String CapitalizeTool.description);
86 ("inputSchema", CapitalizeTool.input_schema)
87 ] in
88 `Assoc [
89 ("tools", `List [tool])
90 ]
91
92(* Handle tool calls *)
93let call_tool name args =
94 if name = CapitalizeTool.name then
95 CapitalizeTool.call args
96 else
97 let error_content = TextContent.{
98 text = Printf.sprintf "Unknown tool: %s" name;
99 annotations = None
100 } in
101 `Assoc [
102 ("content", `List [TextContent.yojson_of_t error_content]);
103 ("isError", `Bool true)
104 ]
105
106(* Handle initialization *)
107let handle_initialize id json =
108 try
109 log_debug (Printf.sprintf "Processing initialize request with id: %s"
110 (match id with
111 | `Int i -> string_of_int i
112 | `String s -> s));
113
114 log_debug (Printf.sprintf "Initialize params: %s"
115 (match json with
116 | Some j -> Yojson.Safe.to_string j
117 | None -> "null"));
118
119 let _ = match json with
120 | Some params ->
121 log_debug "Parsing initialize request params...";
122 let req = Initialize.Request.t_of_yojson params in
123 log_debug (Printf.sprintf "Client info: %s v%s" req.client_info.name req.client_info.version);
124 log_debug (Printf.sprintf "Client protocol version: %s" req.protocol_version);
125
126 (* Check protocol version compatibility *)
127 if req.protocol_version <> protocol_version then
128 log_debug (Printf.sprintf "Protocol version mismatch: client=%s server=%s - will use server version"
129 req.protocol_version protocol_version);
130
131 req
132 | None ->
133 log_error "Missing params for initialize request";
134 raise (Json.Of_json ("Missing params for initialize request", `Null))
135 in
136
137 log_debug "Creating initialize response...";
138 let result = Initialize.Result.create
139 ~capabilities:server_capabilities
140 ~server_info
141 ~protocol_version
142 ~instructions:"This server provides a tool to capitalize text."
143 ()
144 in
145
146 log_debug "Serializing initialize response...";
147 let response = create_response ~id ~result:(Initialize.Result.yojson_of_t result) in
148 log_debug "Initialize response created successfully";
149 response
150 with
151 | Json.Of_json (msg, _) ->
152 log_error (Printf.sprintf "JSON error in initialize: %s" msg);
153 create_error ~id ~code:(-32602) ~message:("Invalid params: " ^ msg) ()
154 | exc ->
155 log_error (Printf.sprintf "Exception in initialize: %s" (Printexc.to_string exc));
156 log_error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));
157 create_error ~id ~code:(-32603) ~message:("Internal error: " ^ (Printexc.to_string exc)) ()
158
159(* Handle tools/list *)
160let handle_list_tools id =
161 log_debug "Processing tools/list request";
162 let result = list_tools () in
163 log_debug (Printf.sprintf "Tools list result: %s" (Yojson.Safe.to_string result));
164 create_response ~id ~result
165
166(* Handle tools/call *)
167let handle_call_tool id json =
168 try
169 log_debug (Printf.sprintf "Processing tool call request with id: %s"
170 (match id with
171 | `Int i -> string_of_int i
172 | `String s -> s));
173
174 log_debug (Printf.sprintf "Tool call params: %s"
175 (match json with
176 | Some j -> Yojson.Safe.to_string j
177 | None -> "null"));
178
179 match json with
180 | Some (`Assoc params) ->
181 let name = match List.assoc_opt "name" params with
182 | Some (`String name) ->
183 log_debug (Printf.sprintf "Tool name: %s" name);
184 name
185 | _ ->
186 log_error "Missing or invalid 'name' parameter in tool call";
187 raise (Json.Of_json ("Missing or invalid 'name' parameter", `Assoc params))
188 in
189 let args = match List.assoc_opt "arguments" params with
190 | Some (args) ->
191 log_debug (Printf.sprintf "Tool arguments: %s" (Yojson.Safe.to_string args));
192 args
193 | _ ->
194 log_debug "No arguments provided for tool call, using empty object";
195 `Assoc [] (* Empty arguments is valid *)
196 in
197 log_debug (Printf.sprintf "Calling tool: %s" name);
198 let result = call_tool name args in
199 log_debug (Printf.sprintf "Tool call result: %s" (Yojson.Safe.to_string result));
200 create_response ~id ~result
201 | _ ->
202 log_error "Invalid params format for tools/call";
203 create_error ~id ~code:(-32602) ~message:"Invalid params for tools/call" ()
204 with
205 | Json.Of_json (msg, _) ->
206 log_error (Printf.sprintf "JSON error in tool call: %s" msg);
207 create_error ~id ~code:(-32602) ~message:("Invalid params: " ^ msg) ()
208 | exc ->
209 log_error (Printf.sprintf "Exception in tool call: %s" (Printexc.to_string exc));
210 log_error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));
211 create_error ~id ~code:(-32603) ~message:("Internal error: " ^ (Printexc.to_string exc)) ()
212
213(* Handle ping *)
214let handle_ping id =
215 create_response ~id ~result:(`Assoc [])
216
217(* Process a single message *)
218let process_message message =
219 try
220 log_debug "Parsing message as JSONRPC message...";
221 match JSONRPCMessage.t_of_yojson message with
222 | JSONRPCMessage.Request req ->
223 log_debug (Printf.sprintf "Received request with method: %s" req.method_);
224 (match req.method_ with
225 | "initialize" ->
226 log_debug "Processing initialize request";
227 Some (handle_initialize req.id req.params)
228 | "tools/list" ->
229 log_debug "Processing tools/list request";
230 Some (handle_list_tools req.id)
231 | "tools/call" ->
232 log_debug "Processing tools/call request";
233 Some (handle_call_tool req.id req.params)
234 | "ping" ->
235 log_debug "Processing ping request";
236 Some (handle_ping req.id)
237 | _ ->
238 log_error (Printf.sprintf "Unknown method received: %s" req.method_);
239 Some (create_error ~id:req.id ~code:(-32601) ~message:("Method not found: " ^ req.method_) ()))
240 | JSONRPCMessage.Notification notif ->
241 log_debug (Printf.sprintf "Received notification with method: %s" notif.method_);
242 (match notif.method_ with
243 | "notifications/initialized" ->
244 log_debug "Client initialization complete - Server is now ready to receive requests";
245 log_debug (Printf.sprintf "Notification params: %s"
246 (match notif.params with
247 | Some p -> Yojson.Safe.to_string p
248 | None -> "null"));
249 None
250 | _ ->
251 log_debug (Printf.sprintf "Ignoring notification: %s" notif.method_);
252 None)
253 | JSONRPCMessage.Response _ ->
254 log_error "Unexpected response message received";
255 None
256 | JSONRPCMessage.Error _ ->
257 log_error "Unexpected error message received";
258 None
259 with
260 | exc ->
261 log_error (Printf.sprintf "Exception during message processing: %s" (Printexc.to_string exc));
262 log_error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));
263 log_error (Printf.sprintf "Message was: %s" (Yojson.Safe.to_string message));
264 None
265
266(* Main loop *)
267let rec read_message () =
268 try
269 log_debug "Attempting to read line from stdin...";
270 let line = read_line () in
271 if line = "" then (
272 log_debug "Empty line received, ignoring";
273 None
274 ) else (
275 log_debug (Printf.sprintf "Raw input: %s" line);
276 try
277 let json = Yojson.Safe.from_string line in
278 log_debug "Successfully parsed JSON";
279 Some json
280 with
281 | Yojson.Json_error msg ->
282 log_error (Printf.sprintf "Error parsing JSON: %s" msg);
283 log_error (Printf.sprintf "Input was: %s" line);
284 read_message ()
285 )
286 with
287 | End_of_file ->
288 log_debug "End of file received on stdin";
289 None
290 | Sys_error msg ->
291 log_error (Printf.sprintf "System error while reading: %s" msg);
292 None
293 | exc ->
294 log_error (Printf.sprintf "Exception while reading: %s" (Printexc.to_string exc));
295 None
296
297let () =
298 try
299 (* Enable exception backtraces *)
300 Printexc.record_backtrace true;
301
302 (* Enable line buffering for stdout *)
303 set_binary_mode_out stdout false;
304
305 log_debug "MCP Capitalizer server started";
306 log_debug (Printf.sprintf "Protocol version: %s" protocol_version);
307 log_debug (Printf.sprintf "Server info: %s v%s" server_info.name server_info.version);
308
309 (* Print environment info for debugging *)
310 log_debug "Environment variables:";
311 Unix.environment()
312 |> Array.iter (fun s ->
313 try
314 let i = String.index s '=' in
315 let name = String.sub s 0 i in
316 if String.length name > 0 then
317 log_debug (Printf.sprintf " %s" s)
318 with Not_found -> ()
319 );
320
321 let rec server_loop count =
322 log_debug (Printf.sprintf "Waiting for message #%d..." count);
323 match read_message () with
324 | Some json ->
325 log_debug (Printf.sprintf "Received message: %s" (Yojson.Safe.to_string json));
326 (match process_message json with
327 | Some response ->
328 let response_json = JSONRPCMessage.yojson_of_t response in
329 let response_str = Yojson.Safe.to_string response_json in
330 log_debug (Printf.sprintf "Sending response: %s" response_str);
331 (* Make sure we emit properly formatted JSON on a single line with a newline at the end *)
332 Printf.printf "%s\n" response_str;
333 flush stdout;
334 (* Give the client a moment to process the response *)
335 Unix.sleepf 0.01;
336 server_loop (count + 1)
337 | None ->
338 log_debug "No response needed for this message";
339 server_loop (count + 1))
340 | None ->
341 log_debug "End of input stream, terminating server";
342 ()
343 in
344
345 log_debug "Starting server loop...";
346 log_debug "Waiting for the initialize request...";
347
348 (* Set up signal handler to gracefully exit *)
349 Sys.(set_signal sigint (Signal_handle (fun _ ->
350 log_debug "Received interrupt signal, exiting...";
351 exit 0
352 )));
353
354 server_loop 1;
355 log_debug "Server terminated normally";
356 with
357 | End_of_file ->
358 log_error "Unexpected end of file";
359 | Sys_error msg ->
360 log_error (Printf.sprintf "System error: %s" msg);
361 | Unix.Unix_error(err, func, arg) ->
362 log_error (Printf.sprintf "Unix error in %s(%s): %s" func arg (Unix.error_message err));
363 | exc ->
364 log_error (Printf.sprintf "Unhandled exception: %s" (Printexc.to_string exc));
365 log_error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()))