Model Context Protocol in OCaml

Add audio content support and improve error handling

- Add proper AudioContent module to Mcp
- Add Audio content type to content type
- Update content serialization/deserialization functions
- Support JSON-RPC error code standardization
- Improve tool result handling with structured content
- Add helper functions for creating rich tool results with multiple content types
- Ensure content types match MCP specification

🤖 Generated with [Claude Code](https://claude.ai/code)

Co-Authored-By: Claude <noreply@anthropic.com>

+45 -2
lib/mcp.ml
···
let yojson_of_t { data; mime_type; annotations } =
let assoc = [
+
("type", `String "image");
("data", `String data);
("mimeType", `String mime_type);
-
("type", `String "image");
] in
let assoc = match annotations with
| Some annotations -> ("annotations", Annotated.yojson_of_annotation annotations) :: assoc
···
let annotations = List.assoc_opt "annotations" fields |> Option.map Annotated.annotation_of_yojson in
{ data; mime_type; annotations }
| j -> raise (Json.Of_json ("Expected object for ImageContent", j))
+
end
+
+
module AudioContent = struct
+
type t = {
+
data: string;
+
mime_type: string;
+
annotations: Annotated.annotation option;
+
}
+
+
let yojson_of_t { data; mime_type; annotations } =
+
let assoc = [
+
("type", `String "audio");
+
("data", `String data);
+
("mimeType", `String mime_type);
+
] in
+
let assoc = match annotations with
+
| Some annotations -> ("annotations", Annotated.yojson_of_annotation annotations) :: assoc
+
| None -> assoc
+
in
+
`Assoc assoc
+
+
let t_of_yojson = function
+
| `Assoc fields ->
+
let data = match List.assoc_opt "data" fields with
+
| Some (`String s) -> s
+
| _ -> raise (Json.Of_json ("Missing or invalid 'data' field", `Assoc fields))
+
in
+
let mime_type = match List.assoc_opt "mimeType" fields with
+
| Some (`String s) -> s
+
| _ -> raise (Json.Of_json ("Missing or invalid 'mimeType' field", `Assoc fields))
+
in
+
let _ = match List.assoc_opt "type" fields with
+
| Some (`String "audio") -> ()
+
| _ -> raise (Json.Of_json ("Missing or invalid 'type' field", `Assoc fields))
+
in
+
let annotations = List.assoc_opt "annotations" fields |> Option.map Annotated.annotation_of_yojson in
+
{ data; mime_type; annotations }
+
| j -> raise (Json.Of_json ("Expected object for AudioContent", j))
end
module ResourceContents = struct
···
type content =
| Text of TextContent.t
| Image of ImageContent.t
+
| Audio of AudioContent.t
| Resource of EmbeddedResource.t
let yojson_of_content = function
| Text t -> TextContent.yojson_of_t t
| Image i -> ImageContent.yojson_of_t i
+
| Audio a -> AudioContent.yojson_of_t a
| Resource r -> EmbeddedResource.yojson_of_t r
let content_of_yojson = function
···
(match List.assoc_opt "type" fields with
| Some (`String "text") -> Text (TextContent.t_of_yojson (`Assoc fields))
| Some (`String "image") -> Image (ImageContent.t_of_yojson (`Assoc fields))
+
| Some (`String "audio") -> Audio (AudioContent.t_of_yojson (`Assoc fields))
| Some (`String "resource") -> Resource (EmbeddedResource.t_of_yojson (`Assoc fields))
| _ -> raise (Json.Of_json ("Invalid or missing content type", `Assoc fields)))
| j -> raise (Json.Of_json ("Expected object for content", j))
···
module SamplingMessage = struct
type t = {
role: Role.t;
-
content: [ `Text of TextContent.t | `Image of ImageContent.t ];
+
content: [ `Text of TextContent.t | `Image of ImageContent.t | `Audio of AudioContent.t ];
}
let yojson_of_t { role; content } =
let content_json = match content with
| `Text t -> TextContent.yojson_of_t t
| `Image i -> ImageContent.yojson_of_t i
+
| `Audio a -> AudioContent.yojson_of_t a
in
`Assoc [
("role", Role.yojson_of_t role);
···
(match List.assoc_opt "type" content_fields with
| Some (`String "text") -> `Text (TextContent.t_of_yojson (`Assoc content_fields))
| Some (`String "image") -> `Image (ImageContent.t_of_yojson (`Assoc content_fields))
+
| Some (`String "audio") -> `Audio (AudioContent.t_of_yojson (`Assoc content_fields))
| _ -> raise (Json.Of_json ("Invalid content type", `Assoc content_fields)))
| _ -> raise (Json.Of_json ("Missing or invalid content field", `Assoc fields))
in
+14 -1
lib/mcp.mli
···
val t_of_yojson : Json.t -> t
end
+
(** Audio content *)
+
module AudioContent : sig
+
type t = {
+
data: string;
+
mime_type: string;
+
annotations: Annotated.annotation option;
+
}
+
+
val yojson_of_t : t -> Json.t
+
val t_of_yojson : Json.t -> t
+
end
+
(** Base resource contents *)
module ResourceContents : sig
type t = {
···
type content =
| Text of TextContent.t
| Image of ImageContent.t
+
| Audio of AudioContent.t
| Resource of EmbeddedResource.t
val yojson_of_content : content -> Json.t
···
module SamplingMessage : sig
type t = {
role: Role.t;
-
content: [ `Text of TextContent.t | `Image of ImageContent.t ];
+
content: [ `Text of TextContent.t | `Image of ImageContent.t | `Audio of AudioContent.t ];
}
val yojson_of_t : t -> Json.t
+128
lib/mcp_sdk.ml
···
end
(* Helper functions for creating common objects *)
+
(* Content type constructors *)
let make_text_content text =
Text (TextContent.{ text; annotations = None })
+
let make_image_content data mime_type =
+
Image (ImageContent.{ data; mime_type; annotations = None })
+
+
(* Create audio content using the AudioContent module *)
+
let make_audio_content data mime_type =
+
Audio (AudioContent.{ data; mime_type; annotations = None })
+
+
let make_resource_text_content uri text mime_type =
+
Resource (EmbeddedResource.{
+
resource = `Text TextResourceContents.{ uri; text; mime_type };
+
annotations = None;
+
})
+
+
let make_resource_blob_content uri blob mime_type =
+
Resource (EmbeddedResource.{
+
resource = `Blob BlobResourceContents.{ uri; blob; mime_type };
+
annotations = None;
+
})
+
+
(* Tool result handling *)
+
type tool_content =
+
| TextContent of string
+
| ImageContent of { data: string; mime_type: string }
+
| AudioContent of { data: string; mime_type: string }
+
| ResourceContent of { uri: string; data: string; is_blob: bool; mime_type: string option }
+
+
let create_tool_result contents ~is_error =
+
let content_json = List.map (function
+
| TextContent text ->
+
`Assoc [
+
("type", `String "text");
+
("text", `String text)
+
]
+
| ImageContent { data; mime_type } ->
+
`Assoc [
+
("type", `String "image");
+
("data", `String data);
+
("mimeType", `String mime_type)
+
]
+
| AudioContent { data; mime_type } ->
+
`Assoc [
+
("type", `String "audio");
+
("data", `String data);
+
("mimeType", `String mime_type)
+
]
+
| ResourceContent { uri; data; is_blob; mime_type } ->
+
let resource_data = if is_blob then
+
`Assoc (
+
[("uri", `String uri);
+
("blob", `String data)] @
+
(match mime_type with
+
| Some mime -> [("mimeType", `String mime)]
+
| None -> [])
+
)
+
else
+
`Assoc (
+
[("uri", `String uri);
+
("text", `String data)] @
+
(match mime_type with
+
| Some mime -> [("mimeType", `String mime)]
+
| None -> [])
+
)
+
in
+
`Assoc [
+
("type", `String "resource");
+
("resource", resource_data)
+
]
+
) contents in
+
+
`Assoc [
+
("content", `List content_json);
+
("isError", `Bool is_error)
+
]
+
+
(* Error types with standard JSON-RPC error codes *)
+
type error_code =
+
| ParseError (* -32700 *)
+
| InvalidRequest (* -32600 *)
+
| MethodNotFound (* -32601 *)
+
| InvalidParams (* -32602 *)
+
| InternalError (* -32603 *)
+
| ResourceNotFound (* -32002 Custom code for MCP *)
+
| AuthenticationRequired (* -32001 Custom code for MCP *)
+
| CustomError of int
+
+
let error_code_to_int = function
+
| ParseError -> -32700
+
| InvalidRequest -> -32600
+
| MethodNotFound -> -32601
+
| InvalidParams -> -32602
+
| InternalError -> -32603
+
| ResourceNotFound -> -32002
+
| AuthenticationRequired -> -32001
+
| CustomError code -> code
+
let make_tool_schema properties required =
let props = List.map (fun (name, schema_type, description) ->
(name, `Assoc [
···
let register_tool server tool =
server.tools <- tool :: server.tools;
tool
+
+
(* Create a rich tool result with multiple content types *)
+
let create_rich_tool_result ?(text=None) ?(image=None) ?(audio=None) ?(resource=None) ~is_error () =
+
let contents = [] in
+
+
(* Add text content if provided *)
+
let contents = match text with
+
| Some text -> (TextContent text) :: contents
+
| None -> contents
+
in
+
+
(* Add image content if provided *)
+
let contents = match image with
+
| Some (data, mime_type) -> (ImageContent { data; mime_type }) :: contents
+
| None -> contents
+
in
+
+
(* Add audio content if provided *)
+
let contents = match audio with
+
| Some (data, mime_type) -> (AudioContent { data; mime_type }) :: contents
+
| None -> contents
+
in
+
+
(* Add resource content if provided *)
+
let contents = match resource with
+
| Some (uri, data, is_blob, mime_type) ->
+
(ResourceContent { uri; data; is_blob; mime_type }) :: contents
+
| None -> contents
+
in
+
+
(* Create the final tool result *)
+
create_tool_result (List.rev contents) ~is_error
(* Create and register a tool in one step *)
let add_tool server ~name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =
+38 -1
lib/mcp_sdk.mli
···
(** Configure server with default capabilities based on registered components *)
val configure_server : server -> ?with_tools:bool -> ?with_resources:bool -> ?with_prompts:bool -> unit -> server
+
(** Content type constructors *)
+
val make_text_content : string -> content
+
val make_image_content : string -> string -> content
+
val make_audio_content : string -> string -> content
+
val make_resource_text_content : string -> string -> string option -> content
+
val make_resource_blob_content : string -> string -> string option -> content
+
+
(** Error types with standard JSON-RPC error codes *)
+
type error_code =
+
| ParseError (** -32700 *)
+
| InvalidRequest (** -32600 *)
+
| MethodNotFound (** -32601 *)
+
| InvalidParams (** -32602 *)
+
| InternalError (** -32603 *)
+
| ResourceNotFound (** -32002 Custom code for MCP *)
+
| AuthenticationRequired (** -32001 Custom code for MCP *)
+
| CustomError of int
+
+
val error_code_to_int : error_code -> int
+
+
(** Tool result handling *)
+
type tool_content =
+
| TextContent of string
+
| ImageContent of { data: string; mime_type: string }
+
| AudioContent of { data: string; mime_type: string }
+
| ResourceContent of { uri: string; data: string; is_blob: bool; mime_type: string option }
+
+
val create_tool_result : tool_content list -> is_error:bool -> Json.t
+
+
(** Create a rich tool result with multiple content types *)
+
val create_rich_tool_result :
+
?text:string option ->
+
?image:(string * string) option ->
+
?audio:(string * string) option ->
+
?resource:(string * string * bool * string option) option ->
+
is_error:bool ->
+
unit -> Json.t
+
(** Helper functions for creating common objects *)
-
val make_text_content : string -> content
val make_tool_schema : (string * string * string) list -> string list -> Json.t
+51 -18
lib/mcp_server.ml
···
let result = `Assoc [("resources", `List resource_list)] in
Some (create_response ~id:req.id ~result)
-
(* Create an error result with text content *)
-
let create_error_content err =
-
let error_content = TextContent.{
-
text = err;
-
annotations = None
-
} in
-
`Assoc [
-
("content", `List [TextContent.yojson_of_t error_content]);
-
("isError", `Bool true)
-
]
-
(* 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 = error_code_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) ()
+
+
(* Create a tool error result with structured content *)
+
let create_tool_error_result error =
+
create_tool_result [TextContent error] ~is_error:true
+
(* Handle tool execution errors *)
let handle_tool_execution_error err =
Log.error (Printf.sprintf "Tool execution failed: %s" err);
-
create_error_content (Printf.sprintf "Error executing tool: %s" err)
+
create_tool_error_result (Printf.sprintf "Error executing tool: %s" err)
(* Handle unknown tool error *)
let handle_unknown_tool_error name =
Log.error (Printf.sprintf "Unknown tool: %s" name);
-
create_error_content (Printf.sprintf "Unknown tool: %s" name)
+
create_tool_error_result (Printf.sprintf "Unknown tool: %s" name)
(* Handle general tool execution exception *)
let handle_tool_execution_exception exn =
Log.error (Printf.sprintf "Exception executing tool: %s" (Printexc.to_string exn));
-
create_error_content (Printf.sprintf "Internal error: %s" (Printexc.to_string exn))
+
create_tool_error_result (Printf.sprintf "Internal error: %s" (Printexc.to_string exn))
(* Execute a tool *)
let execute_tool server ctx name args =
···
let args = extract_tool_arguments params in
(* Create context for this request *)
-
let ctx = Context.create ?request_id:req.progress_token () in
+
let ctx = Context.create
+
?request_id:(Some req.id) (* Store request ID for progress reporting *)
+
~lifespan_context:[("tools/call", `Assoc params)] (* Store params for reference *)
+
()
+
in
+
+
(* Set progress token if present *)
+
ctx.progress_token <- req.progress_token;
(* Execute the tool *)
let result = execute_tool server ctx name args in
+
+
(* Process progress messages if any *)
+
let progress_msg = Context.report_progress ctx 1.0 1.0 in
+
(match progress_msg with
+
| Some msg -> Log.debug "Progress complete notification would be sent here";
+
| None -> ());
+
Some (create_response ~id:req.id ~result)
| None ->
-
Some (create_error ~id:req.id ~code:(-32602) ~message:"Missing tool name parameter" ()))
+
Some (create_jsonrpc_error req.id InvalidParams "Missing tool name parameter" ()))
| _ ->
Log.error "Invalid params format for tools/call";
-
Some (create_error ~id:req.id ~code:(-32602) ~message:"Invalid params for tools/call" ())
+
Some (create_jsonrpc_error req.id InvalidParams "Invalid params format for tools/call" ())
(* Process ping request *)
let handle_ping (req:JSONRPCMessage.request) =
···
| "ping" -> handle_ping req
| _ ->
Log.error (Printf.sprintf "Unknown method received: %s" req.method_);
-
Some (create_error ~id:req.id ~code:(-32601) ~message:("Method not found: " ^ req.method_) ()))
+
Some (create_jsonrpc_error req.id MethodNotFound ("Method not found: " ^ req.method_) ()))
| JSONRPCMessage.Notification notif ->
Log.debug (Printf.sprintf "Received notification with method: %s" notif.method_);
(match notif.method_ with
···
with
| Json.Of_json (msg, _) ->
Log.error (Printf.sprintf "JSON error: %s" msg);
+
(* Can't respond with error because we don't have a request ID *)
+
None
+
| Yojson.Json_error msg ->
+
Log.error (Printf.sprintf "JSON parse error: %s" msg);
+
(* Can't respond with error because we don't have a request ID *)
None
| exc ->
Log.error (Printf.sprintf "Exception during message processing: %s" (Printexc.to_string exc));
Log.error (Printf.sprintf "Backtrace: %s" (Printexc.get_backtrace()));
Log.error (Printf.sprintf "Message was: %s" (Yojson.Safe.to_string message));
None
+
+
(* Extract a request ID from a potentially malformed message *)
+
let extract_request_id json =
+
try
+
match json with
+
| `Assoc fields ->
+
(match List.assoc_opt "id" fields with
+
| Some (`Int id) -> Some (`Int id)
+
| Some (`String id) -> Some (`String id)
+
| _ -> None)
+
| _ -> None
+
with _ -> None
(* Handle processing for an input line *)
let process_input_line server line =