this repo has no description
Remove OCaml functors from Mcp_sdk module
This commit refactors the Mcp_sdk module to use a direct approach instead of
OCaml functors for creating servers. The changes include:
- Remove the MakeServer functor and Server module
- Create direct functions for working with servers
- Expose register_* and add_* functions for tools, resources, and prompts
- Update the capitalize_sdk.ml example to use the new API
- Simplify the server creation and configuration process
The non-functor API provides a more straightforward approach for creating
MCP servers in OCaml.
🤖 Generated with [Claude Code](https://claude.ai/code)
Co-Authored-By: Claude <noreply@anthropic.com>
+260
-269
+36
-38
bin/capitalize_sdk.ml
+36
-38
bin/capitalize_sdk.ml
···
1
1
open Mcp
2
2
open Mcp_sdk
3
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
4
(* Helper for extracting string value from JSON *)
11
5
let get_string_param json name =
12
6
match json with
···
16
10
| _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
17
11
| _ -> raise (Failure "Expected JSON object")
18
12
19
-
(* Define a capitalize tool *)
20
-
let _ = CapitalizeServer.tool
21
-
~name:(Some "capitalize")
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"
22
39
~description:"Capitalizes the provided text"
23
40
~schema_properties:[
24
41
("text", "string", "The text to capitalize")
···
41
58
}
42
59
)
43
60
44
-
(* Define a resource example *)
45
-
let _ = CapitalizeServer.resource
46
-
~uri_template:(Some "greeting://{name}")
61
+
(* Define and register a resource example *)
62
+
let _ = add_resource server
63
+
~uri_template:"greeting://{name}"
47
64
~description:"Get a greeting for a name"
48
65
~mime_type:"text/plain"
49
66
(fun params ->
···
52
69
| _ -> "Hello, world! Welcome to the OCaml MCP server."
53
70
)
54
71
55
-
(* Define a prompt example *)
56
-
let _ = CapitalizeServer.prompt
57
-
~name:(Some "capitalize-prompt")
72
+
(* Define and register a prompt example *)
73
+
let _ = add_prompt server
74
+
~name:"capitalize-prompt"
58
75
~description:"A prompt to help with text capitalization"
59
76
~arguments:[
60
77
("text", Some "The text to be capitalized", true)
···
86
103
]
87
104
)
88
105
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
106
(* Main function *)
101
107
let () =
102
108
(* Print directly to ensure we see output *)
103
109
Printf.printf "Starting CapitalizeServer...\n";
104
110
flush stdout;
105
111
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 -> ());
112
+
(* Configure the server with appropriate capabilities *)
113
+
ignore (configure_server server ());
116
114
117
-
(* Now run the server *)
118
-
Server.run server_with_hooks
115
+
(* Run the server *)
116
+
run_server server
+174
-191
lib/mcp_sdk.ml
+174
-191
lib/mcp_sdk.ml
···
42
42
43
43
let report_progress ctx value total =
44
44
match ctx.progress_token, ctx.request_id with
45
-
| Some token, Some id ->
45
+
| Some token, Some _id ->
46
46
let params = `Assoc [
47
47
("progress", `Float value);
48
48
("total", `Float total);
···
185
185
("required", required_json)
186
186
]
187
187
188
-
(* Server implementation *)
189
-
module Server = struct
190
-
type startup_hook = unit -> unit
191
-
type shutdown_hook = unit -> unit
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
+
}
192
201
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;
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;
204
215
}
205
216
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
-
}
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
219
260
220
-
(* Register a tool *)
221
-
let register_tool server tool =
222
-
server.tools <- tool :: server.tools;
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'
223
275
()
276
+
in
277
+
register_tool server tool
224
278
225
-
(* Register a resource *)
226
-
let register_resource server resource =
227
-
server.resources <- resource :: server.resources;
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'
228
297
()
298
+
in
299
+
register_resource server resource
229
300
230
-
(* Register a prompt *)
231
-
let register_prompt server prompt =
232
-
server.prompts <- prompt :: server.prompts;
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'
233
322
()
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
323
+
in
324
+
register_prompt server prompt
325
+
326
+
(* Set server capabilities *)
327
+
let set_capabilities server capabilities =
328
+
server.capabilities <- capabilities
273
329
274
-
(* Update server capabilities *)
275
-
let update_capabilities server capabilities =
276
-
server.capabilities <- capabilities
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
277
347
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
348
+
(* Set startup and shutdown hooks *)
349
+
let set_startup_hook server hook =
350
+
server.startup_hook <- Some hook
287
351
288
-
(* Helper function for default capabilities *)
289
-
let default_capabilities = Server.default_capabilities
352
+
let set_shutdown_hook server hook =
353
+
server.shutdown_hook <- Some hook
290
354
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 *)
355
+
(* Run the server *)
356
+
let run_server server =
357
+
(* Setup *)
358
+
Printexc.record_backtrace true;
359
+
set_binary_mode_out stdout false;
294
360
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
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."
+50
-40
lib/mcp_sdk.mli
+50
-40
lib/mcp_sdk.mli
···
89
89
val to_json : t -> Json.t
90
90
end
91
91
92
-
(** Server implementation *)
93
-
module Server : sig
94
-
type startup_hook = unit -> unit
95
-
type shutdown_hook = unit -> unit
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
+
}
96
105
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
-
}
106
+
(** Create a new server *)
107
+
val create_server : name:string -> ?version:string -> ?protocol_version:string -> unit -> server
109
108
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
109
+
(** Default capabilities for the server *)
110
+
val default_capabilities : ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> Json.t
116
111
117
-
val process_message : t -> Json.t -> JSONRPCMessage.t option
118
-
val run : t -> unit
119
-
end
112
+
(** Register a tool with the server *)
113
+
val register_tool : server -> Tool.t -> Tool.t
120
114
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
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
124
138
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
139
+
(** Set shutdown hook *)
140
+
val set_shutdown_hook : server -> (unit -> unit) -> unit
132
141
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
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