···

       
1
       
 
       
open Mcp

     

       
2
       
 
       
open Mcp_sdk

     

       
3
       
 
       


     

       
4
       
-
       
(* Create the server module *)

     

       
5
       
-
       
module CapitalizeServer = MakeServer(struct

     

       
6
       
-
       
  let name = "OCaml MCP Capitalizer"

     

       
7
       
-
       
  let version = Some "0.1.0"

     

       
8
       
-
       
end)

     

       
9
       
-
       


     

       
10
       
 
       
(* Helper for extracting string value from JSON *)

     

       
11
       
 
       
let get_string_param json name =

     

       
12
       
 
       
  match json with

     
···

       
16
       
 
       
    | _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))

     

       
17
       
 
       
  | _ -> raise (Failure "Expected JSON object")

     

       
18
       
 
       


     

       
19
       
-
       
(* Define a capitalize tool *)

     

       
20
       
-
       
let _ = CapitalizeServer.tool

     

       
21
       
-
       
  ~name:(Some "capitalize")

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
22
       
 
       
  ~description:"Capitalizes the provided text"

     

       
23
       
 
       
  ~schema_properties:[

     

       
24
       
 
       
    ("text", "string", "The text to capitalize")

     
···

       
41
       
 
       
      }

     

       
42
       
 
       
  )

     

       
43
       
 
       


     

       
44
       
-
       
(* Define a resource example *)

     

       
45
       
-
       
let _ = CapitalizeServer.resource

     

       
46
       
-
       
  ~uri_template:(Some "greeting://{name}")

     

       
47
       
 
       
  ~description:"Get a greeting for a name"

     

       
48
       
 
       
  ~mime_type:"text/plain"

     

       
49
       
 
       
  (fun params ->

     
···

       
52
       
 
       
    | _ -> "Hello, world! Welcome to the OCaml MCP server."

     

       
53
       
 
       
  )

     

       
54
       
 
       


     

       
55
       
-
       
(* Define a prompt example *)

     

       
56
       
-
       
let _ = CapitalizeServer.prompt

     

       
57
       
-
       
  ~name:(Some "capitalize-prompt")

     

       
58
       
 
       
  ~description:"A prompt to help with text capitalization"

     

       
59
       
 
       
  ~arguments:[

     

       
60
       
 
       
    ("text", Some "The text to be capitalized", true)

     
···

       
86
       
 
       
    ]

     

       
87
       
 
       
  )

     

       
88
       
 
       


     

       
89
       
-
       
(* Define startup and shutdown hooks *)

     

       
90
       
-
       
let startup () =

     

       
91
       
-
       
  Printf.printf "CapitalizeServer is starting up!\n";

     

       
92
       
-
       
  flush stdout;

     

       
93
       
-
       
  Log.info "CapitalizeServer is starting up!"

     

       
94
       
-
       


     

       
95
       
-
       
let shutdown () =

     

       
96
       
-
       
  Printf.printf "CapitalizeServer is shutting down. Goodbye!\n";

     

       
97
       
-
       
  flush stdout;

     

       
98
       
-
       
  Log.info "CapitalizeServer is shutting down. Goodbye!"

     

       
99
       
-
       


     

       
100
       
 
       
(* Main function *)

     

       
101
       
 
       
let () =

     

       
102
       
 
       
  (* Print directly to ensure we see output *)

     

       
103
       
 
       
  Printf.printf "Starting CapitalizeServer...\n";

     

       
104
       
 
       
  flush stdout;

     

       
105
       
 
       
  

     

       
106
       
-
       
  (* Run the server with all our registered capabilities *)

     

       
107
       
-
       
  let server_with_hooks = { CapitalizeServer.server with 

     

       
108
       
-
       
    Server.startup_hook = Some startup;

     

       
109
       
-
       
    Server.shutdown_hook = Some shutdown;

     

       
110
       
-
       
  } in

     

       
111
       
-
       
  

     

       
112
       
-
       
  (* Run the startup hook directly *)

     

       
113
       
-
       
  (match server_with_hooks.Server.startup_hook with

     

       
114
       
-
       
   | Some hook -> hook()

     

       
115
       
-
       
   | None -> ());

     

       
116
       
 
       
  

     

       
117
       
-
       
  (* Now run the server *)

     

       
118
       
-
       
  Server.run server_with_hooks
     

···

       
1
       
 
       
open Mcp

     

       
2
       
 
       
open Mcp_sdk

     

       
3
       
 
       


     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
4
       
 
       
(* Helper for extracting string value from JSON *)

     

       
5
       
 
       
let get_string_param json name =

     

       
6
       
 
       
  match json with

     
···

       
10
       
 
       
    | _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))

     

       
11
       
 
       
  | _ -> raise (Failure "Expected JSON object")

     

       
12
       
 
       


     

       
13
       
+
       
(* Create a server *)

     

       
14
       
+
       
let server = create_server 

     

       
15
       
+
       
  ~name:"OCaml MCP Capitalizer" 

     

       
16
       
+
       
  ~version:"0.1.0" 

     

       
17
       
+
       
  ~protocol_version:"2024-11-05" 

     

       
18
       
+
       
  ()

     

       
19
       
+
       


     

       
20
       
+
       
(* Define startup and shutdown hooks *)

     

       
21
       
+
       
let startup () =

     

       
22
       
+
       
  Printf.printf "CapitalizeServer is starting up!\n";

     

       
23
       
+
       
  flush stdout;

     

       
24
       
+
       
  Log.info "CapitalizeServer is starting up!"

     

       
25
       
+
       


     

       
26
       
+
       
let shutdown () =

     

       
27
       
+
       
  Printf.printf "CapitalizeServer is shutting down. Goodbye!\n";

     

       
28
       
+
       
  flush stdout;

     

       
29
       
+
       
  Log.info "CapitalizeServer is shutting down. Goodbye!"

     

       
30
       
+
       


     

       
31
       
+
       
(* Register the hooks *)

     

       
32
       
+
       
let () =

     

       
33
       
+
       
  set_startup_hook server startup;

     

       
34
       
+
       
  set_shutdown_hook server shutdown

     

       
35
       
+
       


     

       
36
       
+
       
(* Define and register a capitalize tool *)

     

       
37
       
+
       
let _ = add_tool server

     

       
38
       
+
       
  ~name:"capitalize"

     

       
39
       
 
       
  ~description:"Capitalizes the provided text"

     

       
40
       
 
       
  ~schema_properties:[

     

       
41
       
 
       
    ("text", "string", "The text to capitalize")

     
···

       
58
       
 
       
      }

     

       
59
       
 
       
  )

     

       
60
       
 
       


     

       
61
       
+
       
(* Define and register a resource example *)

     

       
62
       
+
       
let _ = add_resource server

     

       
63
       
+
       
  ~uri_template:"greeting://{name}"

     

       
64
       
 
       
  ~description:"Get a greeting for a name"

     

       
65
       
 
       
  ~mime_type:"text/plain"

     

       
66
       
 
       
  (fun params ->

     
···

       
69
       
 
       
    | _ -> "Hello, world! Welcome to the OCaml MCP server."

     

       
70
       
 
       
  )

     

       
71
       
 
       


     

       
72
       
+
       
(* Define and register a prompt example *)

     

       
73
       
+
       
let _ = add_prompt server

     

       
74
       
+
       
  ~name:"capitalize-prompt"

     

       
75
       
 
       
  ~description:"A prompt to help with text capitalization"

     

       
76
       
 
       
  ~arguments:[

     

       
77
       
 
       
    ("text", Some "The text to be capitalized", true)

     
···

       
103
       
 
       
    ]

     

       
104
       
 
       
  )

     

       
105
       
 
       


     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
106
       
 
       
(* Main function *)

     

       
107
       
 
       
let () =

     

       
108
       
 
       
  (* Print directly to ensure we see output *)

     

       
109
       
 
       
  Printf.printf "Starting CapitalizeServer...\n";

     

       
110
       
 
       
  flush stdout;

     

       
111
       
 
       
  

     

       
112
       
+
       
  (* Configure the server with appropriate capabilities *)

     

       
113
       
+
       
  ignore (configure_server server ());

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
114
       
 
       
  

     

       
115
       
+
       
  (* Run the server *)

     

       
116
       
+
       
  run_server server
     

···

       
42
       
 
       
  

     

       
43
       
 
       
  let report_progress ctx value total =

     

       
44
       
 
       
    match ctx.progress_token, ctx.request_id with

     

       
45
       
-
       
    | Some token, Some id ->

     

       
46
       
 
       
      let params = `Assoc [

     

       
47
       
 
       
        ("progress", `Float value);

     

       
48
       
 
       
        ("total", `Float total);

     
···

       
185
       
 
       
    ("required", required_json)

     

       
186
       
 
       
  ]

     

       
187
       
 
       


     

       
188
       
-
       
(* Server implementation *)

     

       
189
       
-
       
module Server = struct

     

       
190
       
-
       
  type startup_hook = unit -> unit

     

       
191
       
-
       
  type shutdown_hook = unit -> unit

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
192
       
 
       


     

       
193
       
-
       
  type t = {

     

       
194
       
-
       
    name: string;

     

       
195
       
-
       
    version: string;

     

       
196
       
-
       
    protocol_version: string;

     

       
197
       
-
       
    mutable capabilities: Json.t;

     

       
198
       
-
       
    mutable tools: Tool.t list;

     

       
199
       
-
       
    mutable resources: Resource.t list;

     

       
200
       
-
       
    mutable prompts: Prompt.t list;

     

       
201
       
-
       
    mutable lifespan_context: (string * Json.t) list;

     

       
202
       
-
       
    startup_hook: startup_hook option;

     

       
203
       
-
       
    shutdown_hook: shutdown_hook option;

     

       
0
       
 
       

     

       
0
       
 
       

     

       
204
       
 
       
  }

     

       
205
       
 
       


     

       
206
       
-
       
  let create ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") ?startup_hook ?shutdown_hook () =

     

       
207
       
-
       
    { 

     

       
208
       
-
       
      name;

     

       
209
       
-
       
      version;

     

       
210
       
-
       
      protocol_version;

     

       
211
       
-
       
      capabilities = `Assoc [];

     

       
212
       
-
       
      tools = [];

     

       
213
       
-
       
      resources = [];

     

       
214
       
-
       
      prompts = [];

     

       
215
       
-
       
      lifespan_context = [];

     

       
216
       
-
       
      startup_hook;

     

       
217
       
-
       
      shutdown_hook;

     

       
218
       
-
       
    }

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
219
       
 
       


     

       
220
       
-
       
  (* Register a tool *)

     

       
221
       
-
       
  let register_tool server tool =

     

       
222
       
-
       
    server.tools <- tool :: server.tools;

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
223
       
 
       
    ()

     

       
0
       
 
       

     

       
0
       
 
       

     

       
224
       
 
       


     

       
225
       
-
       
  (* Register a resource *)

     

       
226
       
-
       
  let register_resource server resource =

     

       
227
       
-
       
    server.resources <- resource :: server.resources;

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
228
       
 
       
    ()

     

       
0
       
 
       

     

       
0
       
 
       

     

       
229
       
 
       


     

       
230
       
-
       
  (* Register a prompt *)

     

       
231
       
-
       
  let register_prompt server prompt =

     

       
232
       
-
       
    server.prompts <- prompt :: server.prompts;

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
233
       
 
       
    ()

     

       
234
       
-
       
  

     

       
235
       
-
       
  (* Default server capabilities *)

     

       
236
       
-
       
  let default_capabilities ?(with_tools=true) ?(with_resources=false) ?(with_prompts=false) () =

     

       
237
       
-
       
    let caps = [] in

     

       
238
       
-
       
    let caps = 

     

       
239
       
-
       
      if with_tools then

     

       
240
       
-
       
        ("tools", `Assoc [

     

       
241
       
-
       
          ("listChanged", `Bool true)

     

       
242
       
-
       
        ]) :: caps

     

       
243
       
-
       
      else

     

       
244
       
-
       
        caps

     

       
245
       
-
       
    in

     

       
246
       
-
       
    let caps = 

     

       
247
       
-
       
      if with_resources then

     

       
248
       
-
       
        ("resources", `Assoc [

     

       
249
       
-
       
          ("listChanged", `Bool true);

     

       
250
       
-
       
          ("subscribe", `Bool false)

     

       
251
       
-
       
        ]) :: caps

     

       
252
       
-
       
      else if not with_resources then

     

       
253
       
-
       
        ("resources", `Assoc [

     

       
254
       
-
       
          ("listChanged", `Bool false);

     

       
255
       
-
       
          ("subscribe", `Bool false)

     

       
256
       
-
       
        ]) :: caps

     

       
257
       
-
       
      else

     

       
258
       
-
       
        caps

     

       
259
       
-
       
    in

     

       
260
       
-
       
    let caps = 

     

       
261
       
-
       
      if with_prompts then

     

       
262
       
-
       
        ("prompts", `Assoc [

     

       
263
       
-
       
          ("listChanged", `Bool true)

     

       
264
       
-
       
        ]) :: caps

     

       
265
       
-
       
      else if not with_prompts then

     

       
266
       
-
       
        ("prompts", `Assoc [

     

       
267
       
-
       
          ("listChanged", `Bool false)

     

       
268
       
-
       
        ]) :: caps

     

       
269
       
-
       
      else

     

       
270
       
-
       
        caps

     

       
271
       
-
       
    in

     

       
272
       
-
       
    `Assoc caps

     

       
273
       
 
       


     

       
274
       
-
       
  (* Update server capabilities *)

     

       
275
       
-
       
  let update_capabilities server capabilities =

     

       
276
       
-
       
    server.capabilities <- capabilities

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
277
       
 
       


     

       
278
       
-
       
  (* Process a message *)

     

       
279
       
-
       
  let process_message _server _json =

     

       
280
       
-
       
    None

     

       
281
       
-
       
  

     

       
282
       
-
       
  (* Main server loop *)

     

       
283
       
-
       
  let run _server =

     

       
284
       
-
       
    (* Placeholder implementation *)

     

       
285
       
-
       
    ()

     

       
286
       
-
       
end

     

       
287
       
 
       


     

       
288
       
-
       
(* Helper function for default capabilities *)

     

       
289
       
-
       
let default_capabilities = Server.default_capabilities

     

       
290
       
 
       


     

       
291
       
-
       
(* Add syntactic sugar for creating a server *)

     

       
292
       
-
       
module MakeServer(S: sig val name: string val version: string option end) = struct

     

       
293
       
-
       
  let _config = (S.name, S.version) (* Used to prevent unused parameter warning *)

     

       
0
       
 
       

     

       
0
       
 
       

     

       
294
       
 
       
  

     

       
295
       
-
       
  (* Create server *)

     

       
296
       
-
       
  let server = Server.create 

     

       
297
       
-
       
    ~name:S.name 

     

       
298
       
-
       
    ?version:S.version 

     

       
299
       
-
       
    ~protocol_version:"2024-11-05" 

     

       
300
       
-
       
    ()

     

       
301
       
-
       
    

     

       
302
       
-
       
  (* Create a tool *)

     

       
303
       
-
       
  let tool ?name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =

     

       
304
       
-
       
    let name = match name with 

     

       
305
       
-
       
               | Some (Some n) -> n 

     

       
306
       
-
       
               | Some None | None -> "tool" in

     

       
307
       
-
       
    let input_schema = make_tool_schema schema_properties schema_required in

     

       
308
       
-
       
    let handler' ctx args =

     

       
309
       
-
       
      try

     

       
310
       
-
       
        Ok (handler args)

     

       
311
       
-
       
      with exn ->

     

       
312
       
-
       
        Error (Printexc.to_string exn)

     

       
313
       
-
       
    in

     

       
314
       
-
       
    let tool = Tool.create

     

       
315
       
-
       
      ~name

     

       
316
       
-
       
      ?description

     

       
317
       
-
       
      ~input_schema

     

       
318
       
-
       
      ~handler:handler'

     

       
319
       
-
       
      ()

     

       
320
       
-
       
    in

     

       
321
       
-
       
    server.tools <- tool :: server.tools;

     

       
322
       
-
       
    tool

     

       
323
       
-
       
    

     

       
324
       
-
       
  (* Create a resource *)

     

       
325
       
-
       
  let resource ?uri_template ?description ?mime_type handler =

     

       
326
       
-
       
    let uri_template = match uri_template with 

     

       
327
       
-
       
                      | Some (Some uri) -> uri 

     

       
328
       
-
       
                      | Some None | None -> "resource://" in

     

       
329
       
-
       
    let handler' ctx params =

     

       
330
       
-
       
      try

     

       
331
       
-
       
        Ok (handler params)

     

       
332
       
-
       
      with exn ->

     

       
333
       
-
       
        Error (Printexc.to_string exn)

     

       
334
       
-
       
    in

     

       
335
       
-
       
    let resource = Resource.create

     

       
336
       
-
       
      ~uri_template

     

       
337
       
-
       
      ?description

     

       
338
       
-
       
      ?mime_type

     

       
339
       
-
       
      ~handler:handler'

     

       
340
       
-
       
      ()

     

       
341
       
-
       
    in

     

       
342
       
-
       
    server.resources <- resource :: server.resources;

     

       
343
       
-
       
    resource

     

       
344
       
-
       
    

     

       
345
       
-
       
  (* Create a prompt *)

     

       
346
       
-
       
  let prompt ?name ?description ?(arguments=[]) handler =

     

       
347
       
-
       
    let name = match name with 

     

       
348
       
-
       
              | Some (Some n) -> n 

     

       
349
       
-
       
              | Some None | None -> "prompt" in

     

       
350
       
-
       
    let prompt_args = List.map (fun (name, desc, required) ->

     

       
351
       
-
       
      Prompt.create_argument ~name ?description:desc ~required ()

     

       
352
       
-
       
    ) arguments in

     

       
353
       
-
       
    let handler' ctx args =

     

       
354
       
-
       
      try

     

       
355
       
-
       
        Ok (handler args)

     

       
356
       
-
       
      with exn ->

     

       
357
       
-
       
        Error (Printexc.to_string exn)

     

       
358
       
-
       
    in

     

       
359
       
-
       
    let prompt = Prompt.create

     

       
360
       
-
       
      ~name

     

       
361
       
-
       
      ?description

     

       
362
       
-
       
      ~arguments:prompt_args

     

       
363
       
-
       
      ~handler:handler'

     

       
364
       
-
       
      ()

     

       
365
       
-
       
    in

     

       
366
       
-
       
    server.prompts <- prompt :: server.prompts;

     

       
367
       
-
       
    prompt

     

       
368
       
-
       
    

     

       
369
       
-
       
  (* Run the server *)

     

       
370
       
-
       
  let run ?with_tools ?with_resources ?with_prompts () =

     

       
371
       
-
       
    let with_tools = match with_tools with

     

       
372
       
-
       
      | Some b -> b

     

       
373
       
-
       
      | None -> server.tools <> []

     

       
374
       
-
       
    in

     

       
375
       
-
       
    let with_resources = match with_resources with

     

       
376
       
-
       
      | Some b -> b

     

       
377
       
-
       
      | None -> server.resources <> []

     

       
378
       
-
       
    in

     

       
379
       
-
       
    let with_prompts = match with_prompts with

     

       
380
       
-
       
      | Some b -> b

     

       
381
       
-
       
      | None -> server.prompts <> []

     

       
382
       
-
       
    in

     

       
383
       
-
       
    let capabilities = Server.default_capabilities ~with_tools ~with_resources ~with_prompts () in

     

       
384
       
-
       
    server.capabilities <- capabilities;

     

       
385
       
-
       
    Log.info "Starting server...";

     

       
386
       
-
       
    Log.info (Printf.sprintf "Server info: %s v%s" server.name 

     

       
387
       
-
       
              (match S.version with Some v -> v | None -> "unknown"));

     

       
388
       
-
       
    Printexc.record_backtrace true;

     

       
389
       
-
       
    set_binary_mode_out stdout false;

     

       
390
       
-
       
    Log.info "This is just a placeholder server implementation."

     

       
391
       
-
       
end
     

···

       
42
       
 
       
  

     

       
43
       
 
       
  let report_progress ctx value total =

     

       
44
       
 
       
    match ctx.progress_token, ctx.request_id with

     

       
45
       
+
       
    | Some token, Some _id ->

     

       
46
       
 
       
      let params = `Assoc [

     

       
47
       
 
       
        ("progress", `Float value);

     

       
48
       
 
       
        ("total", `Float total);

     
···

       
185
       
 
       
    ("required", required_json)

     

       
186
       
 
       
  ]

     

       
187
       
 
       


     

       
188
       
+
       
(* Main server type *)

     

       
189
       
+
       
type server = {

     

       
190
       
+
       
  name: string;

     

       
191
       
+
       
  version: string;

     

       
192
       
+
       
  protocol_version: string;

     

       
193
       
+
       
  mutable capabilities: Json.t;

     

       
194
       
+
       
  mutable tools: Tool.t list;

     

       
195
       
+
       
  mutable resources: Resource.t list;

     

       
196
       
+
       
  mutable prompts: Prompt.t list;

     

       
197
       
+
       
  mutable lifespan_context: (string * Json.t) list;

     

       
198
       
+
       
  mutable startup_hook: (unit -> unit) option;

     

       
199
       
+
       
  mutable shutdown_hook: (unit -> unit) option;

     

       
200
       
+
       
}

     

       
201
       
 
       


     

       
202
       
+
       
(* Create a new server *)

     

       
203
       
+
       
let create_server ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") () =

     

       
204
       
+
       
  { 

     

       
205
       
+
       
    name;

     

       
206
       
+
       
    version;

     

       
207
       
+
       
    protocol_version;

     

       
208
       
+
       
    capabilities = `Assoc [];

     

       
209
       
+
       
    tools = [];

     

       
210
       
+
       
    resources = [];

     

       
211
       
+
       
    prompts = [];

     

       
212
       
+
       
    lifespan_context = [];

     

       
213
       
+
       
    startup_hook = None;

     

       
214
       
+
       
    shutdown_hook = None;

     

       
215
       
 
       
  }

     

       
216
       
 
       


     

       
217
       
+
       
(* Default capabilities for the server *)

     

       
218
       
+
       
let default_capabilities ?(with_tools=true) ?(with_resources=false) ?(with_prompts=false) () =

     

       
219
       
+
       
  let caps = [] in

     

       
220
       
+
       
  let caps = 

     

       
221
       
+
       
    if with_tools then

     

       
222
       
+
       
      ("tools", `Assoc [

     

       
223
       
+
       
        ("listChanged", `Bool true)

     

       
224
       
+
       
      ]) :: caps

     

       
225
       
+
       
    else

     

       
226
       
+
       
      caps

     

       
227
       
+
       
  in

     

       
228
       
+
       
  let caps = 

     

       
229
       
+
       
    if with_resources then

     

       
230
       
+
       
      ("resources", `Assoc [

     

       
231
       
+
       
        ("listChanged", `Bool true);

     

       
232
       
+
       
        ("subscribe", `Bool false)

     

       
233
       
+
       
      ]) :: caps

     

       
234
       
+
       
    else if not with_resources then

     

       
235
       
+
       
      ("resources", `Assoc [

     

       
236
       
+
       
        ("listChanged", `Bool false);

     

       
237
       
+
       
        ("subscribe", `Bool false)

     

       
238
       
+
       
      ]) :: caps

     

       
239
       
+
       
    else

     

       
240
       
+
       
      caps

     

       
241
       
+
       
  in

     

       
242
       
+
       
  let caps = 

     

       
243
       
+
       
    if with_prompts then

     

       
244
       
+
       
      ("prompts", `Assoc [

     

       
245
       
+
       
        ("listChanged", `Bool true)

     

       
246
       
+
       
      ]) :: caps

     

       
247
       
+
       
    else if not with_prompts then

     

       
248
       
+
       
      ("prompts", `Assoc [

     

       
249
       
+
       
        ("listChanged", `Bool false)

     

       
250
       
+
       
      ]) :: caps

     

       
251
       
+
       
    else

     

       
252
       
+
       
      caps

     

       
253
       
+
       
  in

     

       
254
       
+
       
  `Assoc caps

     

       
255
       
+
       


     

       
256
       
+
       
(* Register a tool *)

     

       
257
       
+
       
let register_tool server tool =

     

       
258
       
+
       
  server.tools <- tool :: server.tools;

     

       
259
       
+
       
  tool

     

       
260
       
 
       


     

       
261
       
+
       
(* Create and register a tool in one step *)

     

       
262
       
+
       
let add_tool server ~name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =

     

       
263
       
+
       
  let input_schema = make_tool_schema schema_properties schema_required in

     

       
264
       
+
       
  let handler' ctx args =

     

       
265
       
+
       
    try

     

       
266
       
+
       
      Ok (handler args)

     

       
267
       
+
       
    with exn ->

     

       
268
       
+
       
      Error (Printexc.to_string exn)

     

       
269
       
+
       
  in

     

       
270
       
+
       
  let tool = Tool.create

     

       
271
       
+
       
    ~name

     

       
272
       
+
       
    ?description

     

       
273
       
+
       
    ~input_schema

     

       
274
       
+
       
    ~handler:handler'

     

       
275
       
 
       
    ()

     

       
276
       
+
       
  in

     

       
277
       
+
       
  register_tool server tool

     

       
278
       
 
       


     

       
279
       
+
       
(* Register a resource *)

     

       
280
       
+
       
let register_resource server resource =

     

       
281
       
+
       
  server.resources <- resource :: server.resources;

     

       
282
       
+
       
  resource

     

       
283
       
+
       


     

       
284
       
+
       
(* Create and register a resource in one step *)

     

       
285
       
+
       
let add_resource server ~uri_template ?description ?mime_type handler =

     

       
286
       
+
       
  let handler' _ctx params =

     

       
287
       
+
       
    try

     

       
288
       
+
       
      Ok (handler params)

     

       
289
       
+
       
    with exn ->

     

       
290
       
+
       
      Error (Printexc.to_string exn)

     

       
291
       
+
       
  in

     

       
292
       
+
       
  let resource = Resource.create

     

       
293
       
+
       
    ~uri_template

     

       
294
       
+
       
    ?description

     

       
295
       
+
       
    ?mime_type

     

       
296
       
+
       
    ~handler:handler'

     

       
297
       
 
       
    ()

     

       
298
       
+
       
  in

     

       
299
       
+
       
  register_resource server resource

     

       
300
       
 
       


     

       
301
       
+
       
(* Register a prompt *)

     

       
302
       
+
       
let register_prompt server prompt =

     

       
303
       
+
       
  server.prompts <- prompt :: server.prompts;

     

       
304
       
+
       
  prompt

     

       
305
       
+
       


     

       
306
       
+
       
(* Create and register a prompt in one step *)

     

       
307
       
+
       
let add_prompt server ~name ?description ?(arguments=[]) handler =

     

       
308
       
+
       
  let prompt_args = List.map (fun (name, desc, required) ->

     

       
309
       
+
       
    Prompt.create_argument ~name ?description:desc ~required ()

     

       
310
       
+
       
  ) arguments in

     

       
311
       
+
       
  let handler' _ctx args =

     

       
312
       
+
       
    try

     

       
313
       
+
       
      Ok (handler args)

     

       
314
       
+
       
    with exn ->

     

       
315
       
+
       
      Error (Printexc.to_string exn)

     

       
316
       
+
       
  in

     

       
317
       
+
       
  let prompt = Prompt.create

     

       
318
       
+
       
    ~name

     

       
319
       
+
       
    ?description

     

       
320
       
+
       
    ~arguments:prompt_args

     

       
321
       
+
       
    ~handler:handler'

     

       
322
       
 
       
    ()

     

       
323
       
+
       
  in

     

       
324
       
+
       
  register_prompt server prompt

     

       
325
       
+
       


     

       
326
       
+
       
(* Set server capabilities *)

     

       
327
       
+
       
let set_capabilities server capabilities =

     

       
328
       
+
       
  server.capabilities <- capabilities

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
329
       
 
       


     

       
330
       
+
       
(* Configure server with default capabilities based on registered components *)

     

       
331
       
+
       
let configure_server server ?with_tools ?with_resources ?with_prompts () =

     

       
332
       
+
       
  let with_tools = match with_tools with

     

       
333
       
+
       
    | Some b -> b

     

       
334
       
+
       
    | None -> server.tools <> []

     

       
335
       
+
       
  in

     

       
336
       
+
       
  let with_resources = match with_resources with

     

       
337
       
+
       
    | Some b -> b

     

       
338
       
+
       
    | None -> server.resources <> []

     

       
339
       
+
       
  in

     

       
340
       
+
       
  let with_prompts = match with_prompts with

     

       
341
       
+
       
    | Some b -> b

     

       
342
       
+
       
    | None -> server.prompts <> []

     

       
343
       
+
       
  in

     

       
344
       
+
       
  let capabilities = default_capabilities ~with_tools ~with_resources ~with_prompts () in

     

       
345
       
+
       
  set_capabilities server capabilities;

     

       
346
       
+
       
  server

     

       
347
       
 
       


     

       
348
       
+
       
(* Set startup and shutdown hooks *)

     

       
349
       
+
       
let set_startup_hook server hook =

     

       
350
       
+
       
  server.startup_hook <- Some hook

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
351
       
 
       


     

       
352
       
+
       
let set_shutdown_hook server hook =

     

       
353
       
+
       
  server.shutdown_hook <- Some hook

     

       
354
       
 
       


     

       
355
       
+
       
(* Run the server *)

     

       
356
       
+
       
let run_server server =

     

       
357
       
+
       
  (* Setup *)

     

       
358
       
+
       
  Printexc.record_backtrace true;

     

       
359
       
+
       
  set_binary_mode_out stdout false;

     

       
360
       
 
       
  

     

       
361
       
+
       
  Log.info (Printf.sprintf "%s server started" server.name);

     

       
362
       
+
       
  Log.debug (Printf.sprintf "Protocol version: %s" server.protocol_version);

     

       
363
       
+
       
  Log.debug (Printf.sprintf "Server info: %s v%s" server.name server.version);

     

       
364
       
+
       
  

     

       
365
       
+
       
  (* Initialize capabilities if not already set *)

     

       
366
       
+
       
  if server.capabilities = `Assoc [] then

     

       
367
       
+
       
    ignore (configure_server server ());

     

       
368
       
+
       
  

     

       
369
       
+
       
  (* Run startup hook if provided *)

     

       
370
       
+
       
  (match server.startup_hook with

     

       
371
       
+
       
   | Some hook -> hook ()

     

       
372
       
+
       
   | None -> ());

     

       
373
       
+
       
  

     

       
374
       
+
       
  Log.info "Server initialized and ready."
     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

···

       
89
       
 
       
  val to_json : t -> Json.t

     

       
90
       
 
       
end

     

       
91
       
 
       


     

       
92
       
-
       
(** Server implementation *)

     

       
93
       
-
       
module Server : sig

     

       
94
       
-
       
  type startup_hook = unit -> unit

     

       
95
       
-
       
  type shutdown_hook = unit -> unit

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
96
       
 
       


     

       
97
       
-
       
  type t = {

     

       
98
       
-
       
    name: string;

     

       
99
       
-
       
    version: string;

     

       
100
       
-
       
    protocol_version: string;

     

       
101
       
-
       
    mutable capabilities: Json.t;

     

       
102
       
-
       
    mutable tools: Tool.t list;

     

       
103
       
-
       
    mutable resources: Resource.t list;

     

       
104
       
-
       
    mutable prompts: Prompt.t list;

     

       
105
       
-
       
    mutable lifespan_context: (string * Json.t) list;

     

       
106
       
-
       
    startup_hook: startup_hook option;

     

       
107
       
-
       
    shutdown_hook: shutdown_hook option;

     

       
108
       
-
       
  }

     

       
109
       
 
       


     

       
110
       
-
       
  val create : name:string -> ?version:string -> ?protocol_version:string -> ?startup_hook:startup_hook -> ?shutdown_hook:shutdown_hook -> unit -> t

     

       
111
       
-
       
  val register_tool : t -> Tool.t -> unit

     

       
112
       
-
       
  val register_resource : t -> Resource.t -> unit

     

       
113
       
-
       
  val register_prompt : t -> Prompt.t -> unit

     

       
114
       
-
       
  val default_capabilities : ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> Json.t

     

       
115
       
-
       
  val update_capabilities : t -> Json.t -> unit

     

       
116
       
 
       


     

       
117
       
-
       
  val process_message : t -> Json.t -> JSONRPCMessage.t option

     

       
118
       
-
       
  val run : t -> unit

     

       
119
       
-
       
end

     

       
120
       
 
       


     

       
121
       
-
       
(** Helper functions for creating common objects *)

     

       
122
       
-
       
val make_text_content : string -> content

     

       
123
       
-
       
val make_tool_schema : (string * string * string) list -> string list -> Json.t

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
124
       
 
       


     

       
125
       
-
       
(** Syntax sugar for creating an MCP server *)

     

       
126
       
-
       
module MakeServer : functor (S : sig

     

       
127
       
-
       
  val name : string

     

       
128
       
-
       
  val version : string option

     

       
129
       
-
       
end) -> sig

     

       
130
       
-
       
  val _config : string * string option  (* Used to prevent unused parameter warning *)

     

       
131
       
-
       
  val server : Server.t

     

       
132
       
 
       


     

       
133
       
-
       
  val tool : ?name:string option -> ?description:string -> ?schema_properties:(string * string * string) list -> ?schema_required:string list -> (Json.t -> Json.t) -> Tool.t

     

       
134
       
-
       
  val resource : ?uri_template:string option -> ?description:string -> ?mime_type:string -> (string list -> string) -> Resource.t

     

       
135
       
-
       
  val prompt : ?name:string option -> ?description:string -> ?arguments:(string * string option * bool) list -> ((string * string) list -> Prompt.message list) -> Prompt.t

     

       
136
       
-
       
  val run : ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> unit

     

       
137
       
-
       
end
     

       
0
       
 
       

     

···

       
89
       
 
       
  val to_json : t -> Json.t

     

       
90
       
 
       
end

     

       
91
       
 
       


     

       
92
       
+
       
(** Main server type *)

     

       
93
       
+
       
type server = {

     

       
94
       
+
       
  name: string;

     

       
95
       
+
       
  version: string;

     

       
96
       
+
       
  protocol_version: string;

     

       
97
       
+
       
  mutable capabilities: Json.t;

     

       
98
       
+
       
  mutable tools: Tool.t list;

     

       
99
       
+
       
  mutable resources: Resource.t list;

     

       
100
       
+
       
  mutable prompts: Prompt.t list;

     

       
101
       
+
       
  mutable lifespan_context: (string * Json.t) list;

     

       
102
       
+
       
  mutable startup_hook: (unit -> unit) option;

     

       
103
       
+
       
  mutable shutdown_hook: (unit -> unit) option;

     

       
104
       
+
       
}

     

       
105
       
 
       


     

       
106
       
+
       
(** Create a new server *)

     

       
107
       
+
       
val create_server : name:string -> ?version:string -> ?protocol_version:string -> unit -> server

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
108
       
 
       


     

       
109
       
+
       
(** Default capabilities for the server *)

     

       
110
       
+
       
val default_capabilities : ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> Json.t

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
111
       
 
       


     

       
112
       
+
       
(** Register a tool with the server *)

     

       
113
       
+
       
val register_tool : server -> Tool.t -> Tool.t

     

       
0
       
 
       

     

       
114
       
 
       


     

       
115
       
+
       
(** Create and register a tool in one step *)

     

       
116
       
+
       
val add_tool : server -> name:string -> ?description:string -> ?schema_properties:(string * string * string) list -> ?schema_required:string list -> (Json.t -> Json.t) -> Tool.t

     

       
117
       
+
       


     

       
118
       
+
       
(** Register a resource with the server *)

     

       
119
       
+
       
val register_resource : server -> Resource.t -> Resource.t

     

       
120
       
+
       


     

       
121
       
+
       
(** Create and register a resource in one step *)

     

       
122
       
+
       
val add_resource : server -> uri_template:string -> ?description:string -> ?mime_type:string -> (string list -> string) -> Resource.t

     

       
123
       
+
       


     

       
124
       
+
       
(** Register a prompt with the server *)

     

       
125
       
+
       
val register_prompt : server -> Prompt.t -> Prompt.t

     

       
126
       
+
       


     

       
127
       
+
       
(** Create and register a prompt in one step *)

     

       
128
       
+
       
val add_prompt : server -> name:string -> ?description:string -> ?arguments:(string * string option * bool) list -> ((string * string) list -> Prompt.message list) -> Prompt.t

     

       
129
       
+
       


     

       
130
       
+
       
(** Set server capabilities *)

     

       
131
       
+
       
val set_capabilities : server -> Json.t -> unit

     

       
132
       
+
       


     

       
133
       
+
       
(** Configure server with default capabilities based on registered components *)

     

       
134
       
+
       
val configure_server : server -> ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> server

     

       
135
       
+
       


     

       
136
       
+
       
(** Set startup hook *)

     

       
137
       
+
       
val set_startup_hook : server -> (unit -> unit) -> unit

     

       
138
       
 
       


     

       
139
       
+
       
(** Set shutdown hook *)

     

       
140
       
+
       
val set_shutdown_hook : server -> (unit -> unit) -> unit

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
0
       
 
       

     

       
141
       
 
       


     

       
142
       
+
       
(** Run the server *)

     

       
143
       
+
       
val run_server : server -> unit

     

       
144
       
+
       


     

       
145
       
+
       
(** Helper functions for creating common objects *)

     

       
146
       
+
       
val make_text_content : string -> content

     

       
147
       
+
       
val make_tool_schema : (string * string * string) list -> string list -> Json.t