Model Context Protocol in OCaml
anil.recoil.org
1open Mcp
2open Mcp_sdk
3open Mcp_server
4
5(* Helper for extracting string value from JSON *)
6let get_string_param json name =
7 match json with
8 | `Assoc fields ->
9 (match List.assoc_opt name fields with
10 | Some (`String value) -> value
11 | _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
12 | _ -> raise (Failure "Expected JSON object")
13
14(* Create a server *)
15let server = create_server
16 ~name:"OCaml MCP Resource Template Example"
17 ~version:"0.1.0"
18 ~protocol_version:"2024-11-05"
19 ()
20
21(* Define startup and shutdown hooks *)
22let startup () =
23 (* Use stderr for direct printing to avoid interfering with JSON-RPC protocol *)
24 Printf.fprintf stderr "ResourceTemplateServer is starting up!\n";
25 flush stderr;
26 Log.info "ResourceTemplateServer is starting up!"
27
28let shutdown () =
29 Printf.fprintf stderr "ResourceTemplateServer is shutting down. Goodbye!\n";
30 flush stderr;
31 Log.info "ResourceTemplateServer is shutting down. Goodbye!"
32
33(* Register the hooks *)
34let () =
35 set_startup_hook server startup;
36 set_shutdown_hook server shutdown
37
38(* Database of "documents" *)
39let documents = [
40 ("doc1", "This is the first document content");
41 ("doc2", "This document contains information about OCaml");
42 ("doc3", "MCP protocol is a standard for LLM-based applications");
43 ("doc4", "Resource templates allow for parameterized resources");
44]
45
46(* Define and register a resource template for documents *)
47let _ = add_resource server
48 ~uri_template:"document://{id}"
49 ~description:"Get a document by ID"
50 ~mime_type:"text/plain"
51 (fun params ->
52 match params with
53 | [id] ->
54 begin
55 try
56 let content = List.assoc id documents in
57 content
58 with Not_found ->
59 Printf.sprintf "Error: Document '%s' not found" id
60 end
61 | _ -> "Error: Invalid document ID"
62 )
63
64(* Define and register a list documents resource *)
65let _ = add_resource server
66 ~uri_template:"documents://list"
67 ~description:"List all available documents"
68 ~mime_type:"text/plain"
69 (fun _ ->
70 let doc_list =
71 String.concat "\n"
72 (List.map (fun (id, _) -> Printf.sprintf "- %s" id) documents)
73 in
74 Printf.sprintf "Available Documents:\n%s" doc_list
75 )
76
77(* Define and register a tool that uses resource references *)
78let _ = add_tool server
79 ~name:"get_document"
80 ~description:"Gets a document by ID using resource references"
81 ~schema_properties:[
82 ("document_id", "string", "The ID of the document to retrieve");
83 ]
84 ~schema_required:["document_id"]
85 (fun args ->
86 try
87 let doc_id = get_string_param args "document_id" in
88
89 (* Create a resource reference *)
90 let ref = ResourceReference.{ uri = Printf.sprintf "document://%s" doc_id } in
91 (* Convert to JSON for logging purposes *)
92 let _ = ResourceReference.yojson_of_t ref in
93
94 (* Return the reference *)
95 CallToolResult.yojson_of_t CallToolResult.{
96 content = [
97 Text TextContent.{ text = Printf.sprintf "Resource reference for document %s:" doc_id; annotations = None };
98 Resource EmbeddedResource.{
99 resource = `Text TextResourceContents.{
100 uri = Printf.sprintf "document://%s" doc_id;
101 text = (try List.assoc doc_id documents with Not_found -> "Not found");
102 mime_type = Some "text/plain"
103 };
104 annotations = None
105 }
106 ];
107 is_error = false;
108 meta = None
109 }
110 with
111 | Failure msg ->
112 Log.error (Printf.sprintf "Error in get_document tool: %s" msg);
113 CallToolResult.yojson_of_t CallToolResult.{
114 content = [
115 Text TextContent.{
116 text = Printf.sprintf "Error: %s" msg;
117 annotations = None
118 }
119 ];
120 is_error = true;
121 meta = None
122 }
123 )
124
125(* Define and register a prompt that uses resource templates *)
126let _ = add_prompt server
127 ~name:"document-prompt"
128 ~description:"A prompt that references document resources"
129 ~arguments:[
130 ("document_id", Some "ID of the document to include in the prompt", true);
131 ]
132 (fun args ->
133 let doc_id =
134 try List.assoc "document_id" args
135 with Not_found -> "doc1" (* Default to doc1 *)
136 in
137
138 let doc_text =
139 try List.assoc doc_id documents
140 with Not_found -> Printf.sprintf "Document '%s' not found" doc_id
141 in
142
143 [
144 Prompt.{
145 role = `User;
146 content = make_text_content (Printf.sprintf "Please summarize the following document (ID: %s):" doc_id)
147 };
148 Prompt.{
149 role = `User;
150 content = Resource EmbeddedResource.{
151 resource = `Text TextResourceContents.{
152 uri = Printf.sprintf "document://%s" doc_id;
153 text = doc_text;
154 mime_type = Some "text/plain"
155 };
156 annotations = None
157 }
158 };
159 Prompt.{
160 role = `Assistant;
161 content = make_text_content "I'll help summarize this document for you."
162 }
163 ]
164 )
165
166(* Main function *)
167let () =
168 (* Parse command line arguments *)
169 let transport_type = ref Stdio in
170 let args = [
171 ("--http", Arg.Unit (fun () -> transport_type := Http),
172 "Start server with HTTP transport (default is stdio)");
173 ] in
174 let usage_msg = "Usage: resource_template_example [--http]" in
175 Arg.parse args (fun _ -> ()) usage_msg;
176
177 (* Instead of printing directly to stdout which messes up the JSON-RPC protocol,
178 use the logging system which sends output to stderr *)
179 Log.info "Starting ResourceTemplateServer...";
180
181 (* Configure the server with appropriate capabilities *)
182 ignore (configure_server server ());
183
184 (* Create and start MCP server with the selected transport *)
185 let mcp_server = create ~server ~transport:!transport_type () in
186 start mcp_server