My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** Example MCP server using the Server_session API.
2
3 This example demonstrates how to create a simple MCP server that provides:
4 - A few example tools (add, echo)
5 - A simple resource (example://greeting)
6 - Basic ping support
7
8 Note: This is a template/demonstration. A real MCP server would typically:
9 1. Read JSON-RPC messages from stdin
10 2. Write JSON-RPC responses to stdout
11 3. Use proper error handling and logging
12
13 To use this as a real server, you would need to:
14 - Create a custom Transport that reads/writes to stdio
15 - Handle process lifecycle properly
16 - Add comprehensive error handling
17*)
18
19open Mcp
20
21(* Helper to find field in Jsont.Object *)
22let find_field name fields =
23 List.find_map (fun ((n, _), value) ->
24 if n = name then Some value else None
25 ) fields
26
27(* Example tool: Add two numbers *)
28let handle_add_tool ~name:_ ~arguments =
29 let open Messages.Tools in
30 match arguments with
31 | Some (Jsont.Object (fields, _)) ->
32 let a = match find_field "a" fields with
33 | Some (Jsont.Number (n, _)) -> n
34 | _ -> 0.0
35 in
36 let b = match find_field "b" fields with
37 | Some (Jsont.Number (n, _)) -> n
38 | _ -> 0.0
39 in
40 let result = a +. b in
41 let content = [
42 Content.text (Printf.sprintf "Result: %.2f" result)
43 ] in
44 make_call_result ~content ()
45 | _ ->
46 make_call_result
47 ~content:[Content.text "Invalid arguments"]
48 ~is_error:true
49 ()
50
51(* Example tool: Echo a message *)
52let handle_echo_tool ~name:_ ~arguments =
53 let open Messages.Tools in
54 match arguments with
55 | Some (Jsont.Object (fields, _)) ->
56 (match find_field "message" fields with
57 | Some (Jsont.String (msg, _)) ->
58 let content = [Content.text msg] in
59 make_call_result ~content ()
60 | _ ->
61 make_call_result
62 ~content:[Content.text "No message provided"]
63 ~is_error:true
64 ())
65 | _ ->
66 make_call_result
67 ~content:[Content.text "Invalid arguments"]
68 ~is_error:true
69 ()
70
71(* Tool dispatcher *)
72let call_tool ~name ~arguments =
73 match name with
74 | "add" -> handle_add_tool ~name ~arguments
75 | "echo" -> handle_echo_tool ~name ~arguments
76 | _ ->
77 Messages.Tools.make_call_result
78 ~content:[Content.text (Printf.sprintf "Unknown tool: %s" name)]
79 ~is_error:true
80 ()
81
82(* List available tools *)
83let list_tools ~cursor:_ =
84 let open Messages.Tools in
85 let meta = Jsont.Meta.none in
86 let tools = [
87 make_tool
88 ~name:"add"
89 ~description:"Add two numbers together"
90 ~input_schema:(Jsont.Object ([
91 (("type", meta), Jsont.String ("object", meta));
92 (("properties", meta), Jsont.Object ([
93 (("a", meta), Jsont.Object ([(("type", meta), Jsont.String ("number", meta))], meta));
94 (("b", meta), Jsont.Object ([(("type", meta), Jsont.String ("number", meta))], meta));
95 ], meta));
96 (("required", meta), Jsont.Array ([Jsont.String ("a", meta); Jsont.String ("b", meta)], meta));
97 ], meta))
98 ();
99 make_tool
100 ~name:"echo"
101 ~description:"Echo a message back"
102 ~input_schema:(Jsont.Object ([
103 (("type", meta), Jsont.String ("object", meta));
104 (("properties", meta), Jsont.Object ([
105 (("message", meta), Jsont.Object ([(("type", meta), Jsont.String ("string", meta))], meta));
106 ], meta));
107 (("required", meta), Jsont.Array ([Jsont.String ("message", meta)], meta));
108 ], meta))
109 ();
110 ] in
111 make_list_result ~tools ()
112
113(* Example resource *)
114let read_resource ~uri =
115 let open Messages.Resources in
116 match uri with
117 | "example://greeting" ->
118 let contents = [
119 make_text_contents
120 ~uri
121 ~text:"Hello from the MCP server!"
122 ~mime_type:"text/plain"
123 ()
124 ] in
125 make_read_result ~contents
126 | _ ->
127 failwith (Printf.sprintf "Unknown resource: %s" uri)
128
129let list_resources ~cursor:_ =
130 let open Messages.Resources in
131 let resources = [
132 make_resource
133 ~uri:"example://greeting"
134 ~name:"Greeting"
135 ~description:"A simple greeting message"
136 ~mime_type:"text/plain"
137 ()
138 ] in
139 make_list_result ~resources ()
140
141(* Ping handler *)
142let ping () = ()
143
144(* Main server function *)
145let run_server env =
146 let open Eio in
147
148 Switch.run @@ fun sw ->
149 (* Create stdio transport for the server *)
150 (* Note: For a real server, you would typically use a transport that
151 reads from stdin and writes to stdout. Here we create a simple
152 in-process transport for demonstration. *)
153 let params = {
154 Transport_stdio.command = "cat"; (* Echo back for demo *)
155 args = [];
156 env = None;
157 max_buffer_size = None;
158 } in
159 let transport = Transport_stdio.create
160 ~sw
161 ~process_mgr:(Eio.Stdenv.process_mgr env)
162 params
163 in
164
165 (* Configure server *)
166 let config = {
167 Server_session.server_info = Capabilities.Implementation.make
168 ~name:"example-mcp-server"
169 ~version:"1.0.0";
170 server_capabilities = Capabilities.Server.make
171 ~tools:(Capabilities.Tools.make ())
172 ~resources:(Capabilities.Resources.make ())
173 ()
174 ;
175 instructions = Some "Example MCP server with basic tools and resources";
176 } in
177
178 (* Set up handlers *)
179 let handlers = {
180 Server_session.list_resources = Some list_resources;
181 list_resource_templates = None;
182 read_resource = Some read_resource;
183 subscribe_resource = None;
184 unsubscribe_resource = None;
185 list_tools = Some list_tools;
186 call_tool = Some call_tool;
187 list_prompts = None;
188 get_prompt = None;
189 complete = None;
190 ping = Some ping;
191 } in
192
193 (* Create and run server *)
194 let server = Server_session.create
195 ~sw
196 ~transport
197 config
198 handlers
199 in
200
201 (* Log server startup *)
202 let client_info = Server_session.client_info server in
203 Eio.traceln "MCP server started, connected to client: %s v%s"
204 client_info.Capabilities.Implementation.name
205 client_info.Capabilities.Implementation.version;
206
207 (* The server runs in the background via the Session's receive loop *)
208 (* The switch will keep the server alive until it's explicitly closed or an error occurs *)
209 (* For this example, we just let it run until the process is terminated *)
210 ()
211 (* Note: In a real server, you would wait for some termination signal or condition *)
212
213let () =
214 Eio_main.run @@ fun env ->
215 try
216 run_server env
217 with
218 | exn ->
219 Printf.eprintf "Server error: %s\n%!" (Printexc.to_string exn);
220 exit 1