Model Context Protocol in OCaml

resource listing

Changed files
+104 -11
bin
lib
+5
bin/dune
···
(modules ocaml_eval_sdk)
(flags (:standard -w -32 -w -33))
(libraries mcp mcp_sdk mcp_server yojson eio_main eio compiler-libs.toplevel))
···
(modules ocaml_eval_sdk)
(flags (:standard -w -32 -w -33))
(libraries mcp mcp_sdk mcp_server yojson eio_main eio compiler-libs.toplevel))
+
+
(executable
+
(name markdown_book_sdk)
+
(modules markdown_book_sdk)
+
(libraries mcp mcp_sdk mcp_server yojson eio_main eio))
+99 -11
lib/mcp_server.ml
···
open Jsonrpc
open Mcp_sdk
(* Process initialize request *)
let handle_initialize server req =
Log.debug "Processing initialize request";
···
let response = Mcp_rpc.ResourcesList.create_response ~id:req.id ~resources:resources_list () in
Some response
(* Extract the tool name from params *)
let extract_tool_name params =
match List.assoc_opt "name" params with
···
| _ ->
Log.debug "No arguments provided for tool call, using empty object";
`Assoc [] (* Empty arguments is valid *)
-
-
(* Create a proper JSONRPC error with code and data *)
-
let create_jsonrpc_error id code message ?data () =
-
let error_code = ErrorCode.to_int code in
-
let error_data = match data with
-
| Some d -> d
-
| None -> `Null
-
in
-
create_error ~id ~code:error_code ~message ~data:(Some error_data) ()
-
(* Execute a tool *)
let execute_tool server ctx name args =
···
| Method.ToolsCall -> handle_tools_call server req
| Method.PromptsList -> handle_prompts_list server req
| Method.ResourcesList -> handle_resources_list server req
| _ ->
Log.errorf "Unknown method received: %s" (Method.to_string req.meth);
-
Some (create_jsonrpc_error req.id MethodNotFound ("Method not found: " ^ (Method.to_string req.meth)) ()))
| JSONRPCMessage.Notification notif ->
Log.debugf "Received notification with method: %s" (Method.to_string notif.meth);
(match notif.meth with
···
open Jsonrpc
open Mcp_sdk
+
(* Create a proper JSONRPC error with code and data *)
+
let create_jsonrpc_error id code message ?data () =
+
let error_code = ErrorCode.to_int code in
+
let error_data = match data with
+
| Some d -> d
+
| None -> `Null
+
in
+
create_error ~id ~code:error_code ~message ~data:(Some error_data) ()
+
(* Process initialize request *)
let handle_initialize server req =
Log.debug "Processing initialize request";
···
let response = Mcp_rpc.ResourcesList.create_response ~id:req.id ~resources:resources_list () in
Some response
+
(* Process resources/read request *)
+
let handle_resources_read server (req:JSONRPCMessage.request) =
+
Log.debug "Processing resources/read request";
+
match req.JSONRPCMessage.params with
+
| None ->
+
Log.error "Missing params for resources/read request";
+
Some (create_jsonrpc_error req.id ErrorCode.InvalidParams "Missing params for resources/read request" ())
+
| Some params ->
+
let req_data = Mcp_rpc.ResourcesRead.Request.t_of_yojson params in
+
let uri = req_data.uri in
+
Log.debugf "Resource URI: %s" uri;
+
+
(* Find matching resource handler by URI template *)
+
let find_resource_handler uri =
+
let parse_uri_template template uri =
+
(* Simple URI template parsing: extract parameters from a URI based on a template *)
+
let template_parts = String.split_on_char '/' template in
+
let uri_parts = String.split_on_char '/' uri in
+
+
(* If parts don't match in length, this template doesn't match *)
+
if List.length template_parts <> List.length uri_parts then
+
None
+
else
+
(* Extract parameters where template has {param} format *)
+
let params, matches =
+
List.fold_left2 (fun (params, matches) template_part uri_part ->
+
if String.length template_part > 2 &&
+
template_part.[0] = '{' &&
+
template_part.[String.length template_part - 1] = '}' then
+
(* This is a parameter, extract its value *)
+
let _param_name = String.sub template_part 1 (String.length template_part - 2) in
+
(uri_part :: params, matches)
+
else if template_part = uri_part then
+
(* Constant part matches *)
+
(params, true && matches)
+
else
+
(* Constant part doesn't match *)
+
(params, false && matches)
+
) ([], true) template_parts uri_parts
+
in
+
+
if matches then Some (List.rev params) else None
+
in
+
+
let rec find_handler = function
+
| [] -> None
+
| resource :: rest ->
+
match parse_uri_template resource.Resource.uri_template uri with
+
| Some params -> Some (resource, params)
+
| None -> find_handler rest
+
in
+
+
find_handler (resources server)
+
in
+
+
match find_resource_handler uri with
+
| Some (resource, params) ->
+
(* Create context for this request *)
+
let ctx = Context.create
+
?request_id:(Some req.id)
+
?progress_token:req.progress_token
+
~lifespan_context:[("resources/read", `Assoc [("uri", `String uri)])]
+
()
+
in
+
+
(* Call the resource handler *)
+
(match resource.handler ctx params with
+
| Ok content ->
+
(* Create text resource content *)
+
let mime_type = match resource.mime_type with
+
| Some mime -> mime
+
| None -> "text/plain"
+
in
+
let text_resource = {
+
TextResourceContents.uri;
+
text = content;
+
mime_type = Some mime_type
+
} in
+
let resource_content = Mcp_rpc.ResourcesRead.ResourceContent.TextResource text_resource in
+
let response = Mcp_rpc.ResourcesRead.create_response ~id:req.id ~contents:[resource_content] () in
+
Some response
+
| Error err ->
+
Log.errorf "Error reading resource: %s" err;
+
Some (create_jsonrpc_error req.id ErrorCode.InternalError ("Error reading resource: " ^ err) ()))
+
| None ->
+
Log.errorf "Resource not found: %s" uri;
+
Some (create_jsonrpc_error req.id ErrorCode.InvalidParams ("Resource not found: " ^ uri) ())
+
(* Extract the tool name from params *)
let extract_tool_name params =
match List.assoc_opt "name" params with
···
| _ ->
Log.debug "No arguments provided for tool call, using empty object";
`Assoc [] (* Empty arguments is valid *)
(* Execute a tool *)
let execute_tool server ctx name args =
···
| Method.ToolsCall -> handle_tools_call server req
| Method.PromptsList -> handle_prompts_list server req
| Method.ResourcesList -> handle_resources_list server req
+
| Method.ResourcesRead -> handle_resources_read server req
| _ ->
Log.errorf "Unknown method received: %s" (Method.to_string req.meth);
+
Some (create_jsonrpc_error req.id ErrorCode.MethodNotFound ("Method not found: " ^ (Method.to_string req.meth)) ()))
| JSONRPCMessage.Notification notif ->
Log.debugf "Received notification with method: %s" (Method.to_string notif.meth);
(match notif.meth with