this repo has no description
Use ocamlformat
Signed-off-by: Marcello Seri <marcello.seri@gmail.com>
+3146
-2806
.ocamlformat
.ocamlformat
This is a binary file and will not be displayed.
+65
-77
bin/capitalize_sdk.ml
+65
-77
bin/capitalize_sdk.ml
···
4
4
(* Helper for extracting string value from JSON *)
5
5
let get_string_param json name =
6
6
match json with
7
-
| `Assoc fields ->
8
-
(match List.assoc_opt name fields with
9
-
| Some (`String value) -> value
10
-
| _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
7
+
| `Assoc fields -> (
8
+
match List.assoc_opt name fields with
9
+
| Some (`String value) -> value
10
+
| _ ->
11
+
raise
12
+
(Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
11
13
| _ -> raise (Failure "Expected JSON object")
12
14
13
15
(* 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
-
fun server ->
16
+
let server =
17
+
create_server ~name:"OCaml MCP Capitalizer" ~version:"0.1.0"
18
+
~protocol_version:"2024-11-05" ()
19
+
|> fun server ->
19
20
(* Set default capabilities *)
20
-
configure_server server ~with_tools:true ~with_resources:true ~with_prompts:true ()
21
+
configure_server server ~with_tools:true ~with_resources:true
22
+
~with_prompts:true ()
21
23
22
24
(* Define and register a capitalize tool *)
23
-
let _ = add_tool server
24
-
~name:"capitalize"
25
-
~description:"Capitalizes the provided text"
26
-
~schema_properties:[
27
-
("text", "string", "The text to capitalize")
28
-
]
29
-
~schema_required:["text"]
30
-
(fun args ->
31
-
try
32
-
let text = get_string_param args "text" in
33
-
let capitalized_text = String.uppercase_ascii text in
34
-
TextContent.yojson_of_t TextContent.{
35
-
text = capitalized_text;
36
-
annotations = None
37
-
}
38
-
with
39
-
| Failure msg ->
40
-
Log.errorf "Error in capitalize tool: %s" msg;
41
-
TextContent.yojson_of_t TextContent.{
42
-
text = Printf.sprintf "Error: %s" msg;
43
-
annotations = None
44
-
}
45
-
)
25
+
let _ =
26
+
add_tool server ~name:"capitalize"
27
+
~description:"Capitalizes the provided text"
28
+
~schema_properties:[ ("text", "string", "The text to capitalize") ]
29
+
~schema_required:[ "text" ]
30
+
(fun args ->
31
+
try
32
+
let text = get_string_param args "text" in
33
+
let capitalized_text = String.uppercase_ascii text in
34
+
TextContent.yojson_of_t
35
+
TextContent.{ text = capitalized_text; annotations = None }
36
+
with Failure msg ->
37
+
Log.errorf "Error in capitalize tool: %s" msg;
38
+
TextContent.yojson_of_t
39
+
TextContent.
40
+
{ text = Printf.sprintf "Error: %s" msg; annotations = None })
46
41
47
42
(* Define and register a resource template example *)
48
-
let _ = add_resource_template server
49
-
~uri_template:"greeting://{name}"
50
-
~name:"Greeting"
51
-
~description:"Get a greeting for a name"
52
-
~mime_type:"text/plain"
53
-
(fun params ->
54
-
match params with
55
-
| [name] -> Printf.sprintf "Hello, %s! Welcome to the OCaml MCP server." name
56
-
| _ -> "Hello, world! Welcome to the OCaml MCP server."
57
-
)
43
+
let _ =
44
+
add_resource_template server ~uri_template:"greeting://{name}"
45
+
~name:"Greeting" ~description:"Get a greeting for a name"
46
+
~mime_type:"text/plain" (fun params ->
47
+
match params with
48
+
| [ name ] ->
49
+
Printf.sprintf "Hello, %s! Welcome to the OCaml MCP server." name
50
+
| _ -> "Hello, world! Welcome to the OCaml MCP server.")
58
51
59
52
(* Define and register a prompt example *)
60
-
let _ = add_prompt server
61
-
~name:"capitalize-prompt"
62
-
~description:"A prompt to help with text capitalization"
63
-
~arguments:[
64
-
("text", Some "The text to be capitalized", true)
65
-
]
66
-
(fun args ->
67
-
let text =
68
-
try
69
-
List.assoc "text" args
70
-
with
71
-
| Not_found -> "No text provided"
72
-
in
73
-
[
74
-
Prompt.{
75
-
role = `User;
76
-
content = Mcp.make_text_content "Please help me capitalize the following text:"
77
-
};
78
-
Prompt.{
79
-
role = `User;
80
-
content = Mcp.make_text_content text
81
-
};
82
-
Prompt.{
83
-
role = `Assistant;
84
-
content = Mcp.make_text_content "Here's the capitalized version:"
85
-
};
86
-
Prompt.{
87
-
role = `Assistant;
88
-
content = Mcp.make_text_content (String.uppercase_ascii text)
89
-
}
90
-
]
91
-
)
53
+
let _ =
54
+
add_prompt server ~name:"capitalize-prompt"
55
+
~description:"A prompt to help with text capitalization"
56
+
~arguments:[ ("text", Some "The text to be capitalized", true) ]
57
+
(fun args ->
58
+
let text =
59
+
try List.assoc "text" args with Not_found -> "No text provided"
60
+
in
61
+
[
62
+
Prompt.
63
+
{
64
+
role = `User;
65
+
content =
66
+
Mcp.make_text_content
67
+
"Please help me capitalize the following text:";
68
+
};
69
+
Prompt.{ role = `User; content = Mcp.make_text_content text };
70
+
Prompt.
71
+
{
72
+
role = `Assistant;
73
+
content = Mcp.make_text_content "Here's the capitalized version:";
74
+
};
75
+
Prompt.
76
+
{
77
+
role = `Assistant;
78
+
content = Mcp.make_text_content (String.uppercase_ascii text);
79
+
};
80
+
])
92
81
93
82
let () =
94
83
(* Run the server with the default scheduler *)
95
-
Eio_main.run @@ fun env->
96
-
Mcp_server.run_server env server
84
+
Eio_main.run @@ fun env -> Mcp_server.run_server env server
+10
-2
bin/dune
+10
-2
bin/dune
···
12
12
(name ocaml_eval_sdk)
13
13
(modes byte)
14
14
(modules ocaml_eval_sdk)
15
-
(flags (:standard -w -32 -w -33))
16
-
(libraries mcp mcp_sdk mcp_server yojson eio_main eio compiler-libs.toplevel))
15
+
(flags
16
+
(:standard -w -32 -w -33))
17
+
(libraries
18
+
mcp
19
+
mcp_sdk
20
+
mcp_server
21
+
yojson
22
+
eio_main
23
+
eio
24
+
compiler-libs.toplevel))
17
25
18
26
(executable
19
27
(name markdown_book_sdk)
+90
-97
bin/markdown_book_sdk.ml
+90
-97
bin/markdown_book_sdk.ml
···
2
2
3
3
(* Helper module for working with markdown book chapters *)
4
4
module BookChapter = struct
5
-
type t = {
6
-
id: string;
7
-
title: string;
8
-
contents: string;
9
-
}
5
+
type t = { id : string; title : string; contents : string }
10
6
11
7
(* Book chapters as a series of markdown files *)
12
-
let chapters = [
13
-
{
14
-
id = "chapter1";
15
-
title = "# Introduction to OCaml";
16
-
contents = {|
8
+
let chapters =
9
+
[
10
+
{
11
+
id = "chapter1";
12
+
title = "# Introduction to OCaml";
13
+
contents =
14
+
{|
17
15
# Introduction to OCaml
18
16
19
17
OCaml is a general-purpose, multi-paradigm programming language which extends the Caml dialect of ML with object-oriented features.
···
41
39
- **Web Development**: Modern frameworks like Dream make web development straightforward
42
40
43
41
In the following chapters, we'll explore the language features in depth and learn how to leverage OCaml's strengths for building robust, maintainable software.
44
-
|}
45
-
};
46
-
{
47
-
id = "chapter2";
48
-
title = "# Basic Syntax and Types";
49
-
contents = {|
42
+
|};
43
+
};
44
+
{
45
+
id = "chapter2";
46
+
title = "# Basic Syntax and Types";
47
+
contents =
48
+
{|
50
49
# Basic Syntax and Types
51
50
52
51
OCaml has a clean, consistent syntax that emphasizes readability and minimizes boilerplate.
···
128
127
```
129
128
130
129
This introduction to basic syntax sets the foundation for understanding OCaml's more advanced features, which we'll explore in the next chapters.
131
-
|}
132
-
};
133
-
{
134
-
id = "chapter3";
135
-
title = "# Data Structures";
136
-
contents = {|
130
+
|};
131
+
};
132
+
{
133
+
id = "chapter3";
134
+
title = "# Data Structures";
135
+
contents =
136
+
{|
137
137
# Data Structures
138
138
139
139
OCaml provides several built-in data structures and makes it easy to define custom ones.
···
264
264
```
265
265
266
266
These data structures form the backbone of OCaml programming and allow for expressing complex data relationships in a type-safe way.
267
-
|}
268
-
};
269
-
{
270
-
id = "chapter4";
271
-
title = "# Modules and Functors";
272
-
contents = {|
267
+
|};
268
+
};
269
+
{
270
+
id = "chapter4";
271
+
title = "# Modules and Functors";
272
+
contents =
273
+
{|
273
274
# Modules and Functors
274
275
275
276
OCaml's module system is one of its most powerful features. It allows for organizing code into reusable components with clear interfaces.
···
430
431
```
431
432
432
433
The module system enables OCaml programmers to build highly modular, reusable code with clear boundaries between components.
433
-
|}
434
-
};
435
-
{
436
-
id = "chapter5";
437
-
title = "# Advanced Features";
438
-
contents = {|
434
+
|};
435
+
};
436
+
{
437
+
id = "chapter5";
438
+
title = "# Advanced Features";
439
+
contents =
440
+
{|
439
441
# Advanced Features
440
442
441
443
OCaml offers several advanced features that set it apart from other languages. This chapter explores some of the more powerful language constructs.
···
648
650
```
649
651
650
652
These advanced features make OCaml a uniquely powerful language for expressing complex programs with strong guarantees about correctness.
651
-
|}
652
-
};
653
-
]
653
+
|};
654
+
};
655
+
]
654
656
655
657
(* Get a chapter by ID *)
656
658
let get_by_id id =
657
-
try Some (List.find (fun c -> c.id = id) chapters)
658
-
with Not_found -> None
659
-
659
+
try Some (List.find (fun c -> c.id = id) chapters) with Not_found -> None
660
+
660
661
(* Get chapter titles *)
661
-
let get_all_titles () =
662
-
List.map (fun c -> (c.id, c.title)) chapters
662
+
let get_all_titles () = List.map (fun c -> (c.id, c.title)) chapters
663
663
end
664
664
665
665
(* Create a server *)
666
-
let server = create_server
667
-
~name:"OCaml MCP Book Resource Example"
668
-
~version:"0.1.0" () |>
669
-
fun server ->
670
-
(* Set default capabilities *)
671
-
configure_server server
672
-
~with_tools:false
673
-
~with_resources:true
674
-
~with_resource_templates:true
675
-
~with_prompts:false ()
666
+
let server =
667
+
create_server ~name:"OCaml MCP Book Resource Example" ~version:"0.1.0" ()
668
+
|> fun server ->
669
+
(* Set default capabilities *)
670
+
configure_server server ~with_tools:false ~with_resources:true
671
+
~with_resource_templates:true ~with_prompts:false ()
676
672
677
673
(* Add a resource template to get book chapters *)
678
-
let _ = add_resource_template server
679
-
~uri_template:"book/chapter/{id}"
680
-
~name:"Chapter Resource"
681
-
~description:"Get a specific chapter from the OCaml book by its ID"
682
-
~mime_type:"text/markdown"
683
-
(fun params ->
684
-
match params with
685
-
| [id] ->
686
-
(match BookChapter.get_by_id id with
687
-
| Some chapter -> chapter.contents
688
-
| None -> Printf.sprintf "# Error\n\nChapter with ID '%s' not found." id)
689
-
| _ -> "# Error\n\nInvalid parameters. Expected chapter ID."
690
-
)
674
+
let _ =
675
+
add_resource_template server ~uri_template:"book/chapter/{id}"
676
+
~name:"Chapter Resource"
677
+
~description:"Get a specific chapter from the OCaml book by its ID"
678
+
~mime_type:"text/markdown" (fun params ->
679
+
match params with
680
+
| [ id ] -> (
681
+
match BookChapter.get_by_id id with
682
+
| Some chapter -> chapter.contents
683
+
| None ->
684
+
Printf.sprintf "# Error\n\nChapter with ID '%s' not found." id)
685
+
| _ -> "# Error\n\nInvalid parameters. Expected chapter ID.")
691
686
692
687
(* Add a regular resource to get table of contents (no variables) *)
693
-
let _ = add_resource server
694
-
~uri:"book/toc"
695
-
~name:"Table of Contents"
696
-
~description:"Get the table of contents for the OCaml book"
697
-
~mime_type:"text/markdown"
698
-
(fun _params ->
699
-
let titles = BookChapter.get_all_titles() in
700
-
let toc = "# OCaml Book - Table of Contents\n\n" ^
701
-
(List.mapi (fun i (id, title) ->
702
-
Printf.sprintf "%d. [%s](book/chapter/%s)\n"
703
-
(i + 1)
704
-
(String.sub title 2 (String.length title - 2)) (* Remove "# " prefix *)
705
-
id
706
-
) titles |> String.concat "")
707
-
in
708
-
toc
709
-
)
688
+
let _ =
689
+
add_resource server ~uri:"book/toc" ~name:"Table of Contents"
690
+
~description:"Get the table of contents for the OCaml book"
691
+
~mime_type:"text/markdown" (fun _params ->
692
+
let titles = BookChapter.get_all_titles () in
693
+
let toc =
694
+
"# OCaml Book - Table of Contents\n\n"
695
+
^ (List.mapi
696
+
(fun i (id, title) ->
697
+
Printf.sprintf "%d. [%s](book/chapter/%s)\n" (i + 1)
698
+
(String.sub title 2 (String.length title - 2))
699
+
(* Remove "# " prefix *)
700
+
id)
701
+
titles
702
+
|> String.concat "")
703
+
in
704
+
toc)
710
705
711
706
(* Add a regular resource for a complete book (no variables) *)
712
-
let _ = add_resource server
713
-
~uri:"book/complete"
714
-
~name:"Full contents"
715
-
~description:"Get the complete OCaml book as a single document"
716
-
~mime_type:"text/markdown"
717
-
(fun _params ->
718
-
let chapter_contents = List.map (fun c -> c.BookChapter.contents) BookChapter.chapters in
719
-
let content = "# The OCaml Book\n\n*A comprehensive guide to OCaml programming*\n\n" ^
720
-
(String.concat "\n\n---\n\n" chapter_contents)
721
-
in
722
-
content
723
-
)
707
+
let _ =
708
+
add_resource server ~uri:"book/complete" ~name:"Full contents"
709
+
~description:"Get the complete OCaml book as a single document"
710
+
~mime_type:"text/markdown" (fun _params ->
711
+
let chapter_contents =
712
+
List.map (fun c -> c.BookChapter.contents) BookChapter.chapters
713
+
in
714
+
let content =
715
+
"# The OCaml Book\n\n*A comprehensive guide to OCaml programming*\n\n"
716
+
^ String.concat "\n\n---\n\n" chapter_contents
717
+
in
718
+
content)
724
719
725
720
(* Run the server with the default scheduler *)
726
-
let () =
727
-
Eio_main.run @@ fun env ->
728
-
Mcp_server.run_server env server
721
+
let () = Eio_main.run @@ fun env -> Mcp_server.run_server env server
+265
-204
bin/multimodal_sdk.ml
+265
-204
bin/multimodal_sdk.ml
···
3
3
(* Helper for extracting string value from JSON *)
4
4
let get_string_param json name =
5
5
match json with
6
-
| `Assoc fields ->
7
-
(match List.assoc_opt name fields with
8
-
| Some (`String value) -> value
9
-
| _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
6
+
| `Assoc fields -> (
7
+
match List.assoc_opt name fields with
8
+
| Some (`String value) -> value
9
+
| _ ->
10
+
raise
11
+
(Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
10
12
| _ -> raise (Failure "Expected JSON object")
11
13
12
14
(* Helper for extracting integer value from JSON *)
13
15
let get_int_param json name =
14
16
match json with
15
-
| `Assoc fields ->
16
-
(match List.assoc_opt name fields with
17
-
| Some (`Int value) -> value
18
-
| Some (`String value) -> int_of_string value
19
-
| _ -> raise (Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
17
+
| `Assoc fields -> (
18
+
match List.assoc_opt name fields with
19
+
| Some (`Int value) -> value
20
+
| Some (`String value) -> int_of_string value
21
+
| _ ->
22
+
raise
23
+
(Failure (Printf.sprintf "Missing or invalid parameter: %s" name)))
20
24
| _ -> raise (Failure "Expected JSON object")
21
25
22
26
(* Base64 encoding - simplified version *)
23
27
module Base64 = struct
24
28
let encode_char idx =
25
29
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/".[idx]
26
-
30
+
27
31
let encode s =
28
32
let len = String.length s in
29
-
let result = Bytes.create (((len + 2) / 3) * 4) in
30
-
33
+
let result = Bytes.create ((len + 2) / 3 * 4) in
34
+
31
35
let rec loop i j =
32
36
if i >= len then j
33
37
else
34
38
let n =
35
39
let n = Char.code s.[i] lsl 16 in
36
-
let n = if i + 1 < len then n lor (Char.code s.[i+1] lsl 8) else n in
37
-
if i + 2 < len then n lor Char.code s.[i+2] else n
40
+
let n =
41
+
if i + 1 < len then n lor (Char.code s.[i + 1] lsl 8) else n
42
+
in
43
+
if i + 2 < len then n lor Char.code s.[i + 2] else n
38
44
in
39
45
Bytes.set result j (encode_char ((n lsr 18) land 63));
40
-
Bytes.set result (j+1) (encode_char ((n lsr 12) land 63));
41
-
Bytes.set result (j+2)
46
+
Bytes.set result (j + 1) (encode_char ((n lsr 12) land 63));
47
+
Bytes.set result (j + 2)
42
48
(if i + 1 < len then encode_char ((n lsr 6) land 63) else '=');
43
-
Bytes.set result (j+3)
49
+
Bytes.set result (j + 3)
44
50
(if i + 2 < len then encode_char (n land 63) else '=');
45
51
loop (i + 3) (j + 4)
46
52
in
···
50
56
(* Generate a simple GIF format image *)
51
57
let generate_random_image width height =
52
58
(* Ensure dimensions are reasonable *)
53
-
let width = min 256 (max 16 width) in
59
+
let width = min 256 (max 16 width) in
54
60
let height = min 256 (max 16 height) in
55
-
61
+
56
62
(* Create a buffer for GIF data *)
57
63
let buf = Buffer.create 1024 in
58
-
64
+
59
65
(* GIF Header - "GIF89a" *)
60
66
Buffer.add_string buf "GIF89a";
61
-
67
+
62
68
(* Logical Screen Descriptor *)
63
69
(* Width - 2 bytes little endian *)
64
70
Buffer.add_char buf (Char.chr (width land 0xff));
65
71
Buffer.add_char buf (Char.chr ((width lsr 8) land 0xff));
66
-
72
+
67
73
(* Height - 2 bytes little endian *)
68
74
Buffer.add_char buf (Char.chr (height land 0xff));
69
75
Buffer.add_char buf (Char.chr ((height lsr 8) land 0xff));
70
-
76
+
71
77
(* Packed fields - 1 byte:
72
78
Global Color Table Flag - 1 bit (1)
73
79
Color Resolution - 3 bits (7 = 8 bits per color)
74
80
Sort Flag - 1 bit (0)
75
81
Size of Global Color Table - 3 bits (2 = 8 colors) *)
76
82
Buffer.add_char buf (Char.chr 0xF2);
77
-
83
+
78
84
(* Background color index - 1 byte *)
79
85
Buffer.add_char buf (Char.chr 0);
80
-
86
+
81
87
(* Pixel aspect ratio - 1 byte *)
82
88
Buffer.add_char buf (Char.chr 0);
83
-
89
+
84
90
(* Global Color Table - 8 colors x 3 bytes (R,G,B) *)
85
91
(* Simple 8-color palette *)
86
-
Buffer.add_string buf "\xFF\xFF\xFF"; (* White (0) *)
87
-
Buffer.add_string buf "\xFF\x00\x00"; (* Red (1) *)
88
-
Buffer.add_string buf "\x00\xFF\x00"; (* Green (2) *)
89
-
Buffer.add_string buf "\x00\x00\xFF"; (* Blue (3) *)
90
-
Buffer.add_string buf "\xFF\xFF\x00"; (* Yellow (4) *)
91
-
Buffer.add_string buf "\xFF\x00\xFF"; (* Magenta (5) *)
92
-
Buffer.add_string buf "\x00\xFF\xFF"; (* Cyan (6) *)
93
-
Buffer.add_string buf "\x00\x00\x00"; (* Black (7) *)
94
-
92
+
Buffer.add_string buf "\xFF\xFF\xFF";
93
+
(* White (0) *)
94
+
Buffer.add_string buf "\xFF\x00\x00";
95
+
(* Red (1) *)
96
+
Buffer.add_string buf "\x00\xFF\x00";
97
+
(* Green (2) *)
98
+
Buffer.add_string buf "\x00\x00\xFF";
99
+
(* Blue (3) *)
100
+
Buffer.add_string buf "\xFF\xFF\x00";
101
+
(* Yellow (4) *)
102
+
Buffer.add_string buf "\xFF\x00\xFF";
103
+
(* Magenta (5) *)
104
+
Buffer.add_string buf "\x00\xFF\xFF";
105
+
(* Cyan (6) *)
106
+
Buffer.add_string buf "\x00\x00\x00";
107
+
108
+
(* Black (7) *)
109
+
95
110
(* Graphics Control Extension (optional) *)
96
-
Buffer.add_char buf (Char.chr 0x21); (* Extension Introducer *)
97
-
Buffer.add_char buf (Char.chr 0xF9); (* Graphic Control Label *)
98
-
Buffer.add_char buf (Char.chr 0x04); (* Block Size *)
99
-
Buffer.add_char buf (Char.chr 0x01); (* Packed field: 1 bit for transparency *)
100
-
Buffer.add_char buf (Char.chr 0x00); (* Delay time (1/100s) - 2 bytes *)
111
+
Buffer.add_char buf (Char.chr 0x21);
112
+
(* Extension Introducer *)
113
+
Buffer.add_char buf (Char.chr 0xF9);
114
+
(* Graphic Control Label *)
115
+
Buffer.add_char buf (Char.chr 0x04);
116
+
(* Block Size *)
117
+
Buffer.add_char buf (Char.chr 0x01);
118
+
(* Packed field: 1 bit for transparency *)
119
+
Buffer.add_char buf (Char.chr 0x00);
120
+
(* Delay time (1/100s) - 2 bytes *)
121
+
Buffer.add_char buf (Char.chr 0x00);
122
+
Buffer.add_char buf (Char.chr 0x00);
123
+
(* Transparent color index *)
101
124
Buffer.add_char buf (Char.chr 0x00);
102
-
Buffer.add_char buf (Char.chr 0x00); (* Transparent color index *)
103
-
Buffer.add_char buf (Char.chr 0x00); (* Block terminator *)
104
-
125
+
126
+
(* Block terminator *)
127
+
105
128
(* Image Descriptor *)
106
-
Buffer.add_char buf (Char.chr 0x2C); (* Image Separator *)
107
-
Buffer.add_char buf (Char.chr 0x00); (* Left position - 2 bytes *)
129
+
Buffer.add_char buf (Char.chr 0x2C);
130
+
(* Image Separator *)
131
+
Buffer.add_char buf (Char.chr 0x00);
132
+
(* Left position - 2 bytes *)
108
133
Buffer.add_char buf (Char.chr 0x00);
109
-
Buffer.add_char buf (Char.chr 0x00); (* Top position - 2 bytes *)
134
+
Buffer.add_char buf (Char.chr 0x00);
135
+
(* Top position - 2 bytes *)
110
136
Buffer.add_char buf (Char.chr 0x00);
111
-
137
+
112
138
(* Image width - 2 bytes little endian *)
113
139
Buffer.add_char buf (Char.chr (width land 0xff));
114
140
Buffer.add_char buf (Char.chr ((width lsr 8) land 0xff));
115
-
141
+
116
142
(* Image height - 2 bytes little endian *)
117
143
Buffer.add_char buf (Char.chr (height land 0xff));
118
144
Buffer.add_char buf (Char.chr ((height lsr 8) land 0xff));
119
-
145
+
120
146
(* Packed fields - 1 byte - no local color table *)
121
147
Buffer.add_char buf (Char.chr 0x00);
122
-
148
+
123
149
(* LZW Minimum Code Size - 1 byte *)
124
-
Buffer.add_char buf (Char.chr 0x03); (* Minimum code size 3 for 8 colors *)
125
-
150
+
Buffer.add_char buf (Char.chr 0x03);
151
+
152
+
(* Minimum code size 3 for 8 colors *)
153
+
126
154
(* Generate a simple image - a checkerboard pattern *)
127
155
let step = width / 8 in
128
156
let image_data = Buffer.create (width * height / 4) in
129
-
157
+
130
158
(* Very simple LZW compression - just store raw clear codes and color indexes *)
131
159
(* Start with Clear code *)
132
-
Buffer.add_char image_data (Char.chr 0x08); (* Clear code 8 *)
133
-
160
+
Buffer.add_char image_data (Char.chr 0x08);
161
+
162
+
(* Clear code 8 *)
163
+
134
164
(* For very simple encoding, we'll just use a sequence of color indexes *)
135
165
for y = 0 to height - 1 do
136
166
for x = 0 to width - 1 do
137
167
(* Checkerboard pattern with different colors *)
138
168
let color =
139
-
if ((x / step) + (y / step)) mod 2 = 0 then
140
-
3 (* Blue *)
141
-
else
142
-
1 (* Red *)
169
+
if ((x / step) + (y / step)) mod 2 = 0 then 3 (* Blue *)
170
+
else 1 (* Red *)
143
171
in
144
-
Buffer.add_char image_data (Char.chr color);
172
+
Buffer.add_char image_data (Char.chr color)
145
173
done
146
174
done;
147
-
175
+
148
176
(* End with End of Information code *)
149
177
Buffer.add_char image_data (Char.chr 0x09);
150
-
178
+
151
179
(* Add image data blocks - GIF uses 255-byte max chunks *)
152
180
let data = Buffer.contents image_data in
153
181
let data_len = String.length data in
154
182
let pos = ref 0 in
155
-
183
+
156
184
while !pos < data_len do
157
185
let chunk_size = min 255 (data_len - !pos) in
158
186
Buffer.add_char buf (Char.chr chunk_size);
159
187
for i = 0 to chunk_size - 1 do
160
-
Buffer.add_char buf (String.get data (!pos + i));
188
+
Buffer.add_char buf (String.get data (!pos + i))
161
189
done;
162
-
pos := !pos + chunk_size;
190
+
pos := !pos + chunk_size
163
191
done;
164
-
192
+
165
193
(* Zero-length block to end the image data *)
166
194
Buffer.add_char buf (Char.chr 0x00);
167
-
195
+
168
196
(* GIF Trailer *)
169
197
Buffer.add_char buf (Char.chr 0x3B);
170
-
198
+
171
199
(* Base64 encode the GIF data *)
172
200
Base64.encode (Buffer.contents buf)
173
201
···
189
217
let sample_rate = 8000 in
190
218
let num_samples = sample_rate * duration in
191
219
let header_buf = Buffer.create 44 in
192
-
220
+
193
221
(* Fill WAV header properly *)
194
222
Buffer.add_string header_buf "RIFF";
195
-
write_int32_le header_buf (36 + num_samples * 2); (* File size minus 8 *)
223
+
write_int32_le header_buf (36 + (num_samples * 2));
224
+
(* File size minus 8 *)
196
225
Buffer.add_string header_buf "WAVE";
197
-
226
+
198
227
(* Format chunk *)
199
228
Buffer.add_string header_buf "fmt ";
200
-
write_int32_le header_buf 16; (* Format chunk size *)
201
-
write_int16_le header_buf 1; (* PCM format *)
202
-
write_int16_le header_buf 1; (* Mono *)
203
-
write_int32_le header_buf sample_rate; (* Sample rate *)
204
-
write_int32_le header_buf (sample_rate * 2); (* Byte rate *)
205
-
write_int16_le header_buf 2; (* Block align *)
206
-
write_int16_le header_buf 16; (* Bits per sample *)
207
-
229
+
write_int32_le header_buf 16;
230
+
(* Format chunk size *)
231
+
write_int16_le header_buf 1;
232
+
(* PCM format *)
233
+
write_int16_le header_buf 1;
234
+
(* Mono *)
235
+
write_int32_le header_buf sample_rate;
236
+
(* Sample rate *)
237
+
write_int32_le header_buf (sample_rate * 2);
238
+
(* Byte rate *)
239
+
write_int16_le header_buf 2;
240
+
(* Block align *)
241
+
write_int16_le header_buf 16;
242
+
243
+
(* Bits per sample *)
244
+
208
245
(* Data chunk *)
209
246
Buffer.add_string header_buf "data";
210
-
write_int32_le header_buf (num_samples * 2); (* Data size *)
211
-
247
+
write_int32_le header_buf (num_samples * 2);
248
+
249
+
(* Data size *)
250
+
212
251
(* Generate sine wave samples *)
213
252
let samples_buf = Buffer.create (num_samples * 2) in
214
-
let amplitude = 16384.0 in (* 16-bit with headroom *)
215
-
253
+
let amplitude = 16384.0 in
254
+
(* 16-bit with headroom *)
255
+
216
256
for i = 0 to num_samples - 1 do
217
257
let t = float_of_int i /. float_of_int sample_rate in
218
258
let value = amplitude *. sin (2.0 *. Float.pi *. frequency *. t) in
219
259
let sample = int_of_float value in
220
-
260
+
221
261
(* Convert to 16-bit little-endian *)
222
262
let sample = if sample < 0 then sample + 65536 else sample in
223
-
write_int16_le samples_buf sample;
263
+
write_int16_le samples_buf sample
224
264
done;
225
-
265
+
226
266
(* Combine header and samples, then encode as Base64 *)
227
267
let wav_data = Buffer.contents header_buf ^ Buffer.contents samples_buf in
228
268
Base64.encode wav_data
229
269
230
270
(* Create a server *)
231
-
let server = create_server
232
-
~name:"OCaml MCP Multimodal Example"
233
-
~version:"0.1.0"
234
-
~protocol_version:"2024-11-05" () |>
235
-
fun server ->
236
-
(* Set default capabilities *)
237
-
configure_server server ~with_tools:true ~with_resources:true ~with_prompts:true ()
271
+
let server =
272
+
create_server ~name:"OCaml MCP Multimodal Example" ~version:"0.1.0"
273
+
~protocol_version:"2024-11-05" ()
274
+
|> fun server ->
275
+
(* Set default capabilities *)
276
+
configure_server server ~with_tools:true ~with_resources:true
277
+
~with_prompts:true ()
238
278
239
279
(* Define and register a multimodal tool that returns text, images, and audio *)
240
-
let _ = add_tool server
241
-
~name:"multimodal_demo"
242
-
~description:"Demonstrates multimodal content with text, image, and audio"
243
-
~schema_properties:[
244
-
("width", "integer", "Width of the generated image (pixels)");
245
-
("height", "integer", "Height of the generated image (pixels)");
246
-
("frequency", "integer", "Frequency of the generated audio tone (Hz)");
247
-
("duration", "integer", "Duration of the generated audio (seconds)");
248
-
("message", "string", "Text message to include")
249
-
]
250
-
~schema_required:["message"]
251
-
(fun args ->
252
-
try
253
-
(* Extract parameters with defaults if not provided *)
254
-
let message = get_string_param args "message" in
255
-
let width = try get_int_param args "width" with _ -> 128 in
256
-
let height = try get_int_param args "height" with _ -> 128 in
257
-
let frequency = try get_int_param args "frequency" with _ -> 440 in
258
-
let duration = try get_int_param args "duration" with _ -> 1 in
259
-
260
-
(* Generate image and audio data *)
261
-
let image_data = generate_random_image width height in
262
-
let audio_data = generate_sine_wave_audio (float_of_int frequency) duration in
263
-
264
-
(* Create a multimodal tool result *)
265
-
Tool.create_tool_result [
266
-
Mcp.make_text_content message;
267
-
Mcp.make_image_content image_data "image/gif";
268
-
Mcp.make_audio_content audio_data "audio/wav"
269
-
] ~is_error:false
270
-
with
271
-
| Failure msg ->
272
-
Log.errorf "Error in multimodal tool: %s" msg;
273
-
Tool.create_tool_result [Mcp.make_text_content (Printf.sprintf "Error: %s" msg)] ~is_error:true
274
-
)
280
+
let _ =
281
+
add_tool server ~name:"multimodal_demo"
282
+
~description:"Demonstrates multimodal content with text, image, and audio"
283
+
~schema_properties:
284
+
[
285
+
("width", "integer", "Width of the generated image (pixels)");
286
+
("height", "integer", "Height of the generated image (pixels)");
287
+
("frequency", "integer", "Frequency of the generated audio tone (Hz)");
288
+
("duration", "integer", "Duration of the generated audio (seconds)");
289
+
("message", "string", "Text message to include");
290
+
]
291
+
~schema_required:[ "message" ]
292
+
(fun args ->
293
+
try
294
+
(* Extract parameters with defaults if not provided *)
295
+
let message = get_string_param args "message" in
296
+
let width = try get_int_param args "width" with _ -> 128 in
297
+
let height = try get_int_param args "height" with _ -> 128 in
298
+
let frequency = try get_int_param args "frequency" with _ -> 440 in
299
+
let duration = try get_int_param args "duration" with _ -> 1 in
275
300
276
-
(* Define and register a tool for generating only images *)
277
-
let _ = add_tool server
278
-
~name:"generate_image"
279
-
~description:"Generates a random image with specified dimensions"
280
-
~schema_properties:[
281
-
("width", "integer", "Width of the generated image (pixels)");
282
-
("height", "integer", "Height of the generated image (pixels)")
283
-
]
284
-
~schema_required:["width"; "height"]
285
-
(fun args ->
286
-
try
287
-
let width = get_int_param args "width" in
288
-
let height = get_int_param args "height" in
289
-
290
-
if width < 1 || width > 1024 || height < 1 || height > 1024 then
291
-
Tool.create_tool_result
292
-
[Mcp.make_text_content "Error: Dimensions must be between 1 and 1024 pixels"]
293
-
~is_error:true
294
-
else
301
+
(* Generate image and audio data *)
295
302
let image_data = generate_random_image width height in
296
-
Tool.create_tool_result
297
-
[Mcp.make_image_content image_data "image/gif"]
303
+
let audio_data =
304
+
generate_sine_wave_audio (float_of_int frequency) duration
305
+
in
306
+
307
+
(* Create a multimodal tool result *)
308
+
Tool.create_tool_result
309
+
[
310
+
Mcp.make_text_content message;
311
+
Mcp.make_image_content image_data "image/gif";
312
+
Mcp.make_audio_content audio_data "audio/wav";
313
+
]
298
314
~is_error:false
299
-
with
300
-
| Failure msg ->
301
-
Log.errorf "Error in generate_image tool: %s" msg;
302
-
Tool.create_tool_result [Mcp.make_text_content (Printf.sprintf "Error: %s" msg)] ~is_error:true
303
-
)
315
+
with Failure msg ->
316
+
Log.errorf "Error in multimodal tool: %s" msg;
317
+
Tool.create_tool_result
318
+
[ Mcp.make_text_content (Printf.sprintf "Error: %s" msg) ]
319
+
~is_error:true)
320
+
321
+
(* Define and register a tool for generating only images *)
322
+
let _ =
323
+
add_tool server ~name:"generate_image"
324
+
~description:"Generates a random image with specified dimensions"
325
+
~schema_properties:
326
+
[
327
+
("width", "integer", "Width of the generated image (pixels)");
328
+
("height", "integer", "Height of the generated image (pixels)");
329
+
]
330
+
~schema_required:[ "width"; "height" ]
331
+
(fun args ->
332
+
try
333
+
let width = get_int_param args "width" in
334
+
let height = get_int_param args "height" in
335
+
336
+
if width < 1 || width > 1024 || height < 1 || height > 1024 then
337
+
Tool.create_tool_result
338
+
[
339
+
Mcp.make_text_content
340
+
"Error: Dimensions must be between 1 and 1024 pixels";
341
+
]
342
+
~is_error:true
343
+
else
344
+
let image_data = generate_random_image width height in
345
+
Tool.create_tool_result
346
+
[ Mcp.make_image_content image_data "image/gif" ]
347
+
~is_error:false
348
+
with Failure msg ->
349
+
Log.errorf "Error in generate_image tool: %s" msg;
350
+
Tool.create_tool_result
351
+
[ Mcp.make_text_content (Printf.sprintf "Error: %s" msg) ]
352
+
~is_error:true)
304
353
305
354
(* Define and register a tool for generating only audio *)
306
-
let _ = add_tool server
307
-
~name:"generate_audio"
308
-
~description:"Generates an audio tone with specified frequency and duration"
309
-
~schema_properties:[
310
-
("frequency", "integer", "Frequency of the tone in Hz (20-20000)");
311
-
("duration", "integer", "Duration of the tone in seconds (1-10)")
312
-
]
313
-
~schema_required:["frequency"; "duration"]
314
-
(fun args ->
315
-
try
316
-
let frequency = get_int_param args "frequency" in
317
-
let duration = get_int_param args "duration" in
318
-
319
-
if frequency < 20 || frequency > 20000 then
320
-
Tool.create_tool_result
321
-
[Mcp.make_text_content "Error: Frequency must be between 20Hz and 20,000Hz"]
322
-
~is_error:true
323
-
else if duration < 1 || duration > 10 then
324
-
Tool.create_tool_result
325
-
[Mcp.make_text_content "Error: Duration must be between 1 and 10 seconds"]
326
-
~is_error:true
327
-
else
328
-
let audio_data = generate_sine_wave_audio (float_of_int frequency) duration in
329
-
Tool.create_tool_result
330
-
[Mcp.make_audio_content audio_data "audio/wav"]
331
-
~is_error:false
332
-
with
333
-
| Failure msg ->
334
-
Log.errorf "Error in generate_audio tool: %s" msg;
335
-
Tool.create_tool_result [Mcp.make_text_content (Printf.sprintf "Error: %s" msg)] ~is_error:true
336
-
)
355
+
let _ =
356
+
add_tool server ~name:"generate_audio"
357
+
~description:"Generates an audio tone with specified frequency and duration"
358
+
~schema_properties:
359
+
[
360
+
("frequency", "integer", "Frequency of the tone in Hz (20-20000)");
361
+
("duration", "integer", "Duration of the tone in seconds (1-10)");
362
+
]
363
+
~schema_required:[ "frequency"; "duration" ]
364
+
(fun args ->
365
+
try
366
+
let frequency = get_int_param args "frequency" in
367
+
let duration = get_int_param args "duration" in
368
+
369
+
if frequency < 20 || frequency > 20000 then
370
+
Tool.create_tool_result
371
+
[
372
+
Mcp.make_text_content
373
+
"Error: Frequency must be between 20Hz and 20,000Hz";
374
+
]
375
+
~is_error:true
376
+
else if duration < 1 || duration > 10 then
377
+
Tool.create_tool_result
378
+
[
379
+
Mcp.make_text_content
380
+
"Error: Duration must be between 1 and 10 seconds";
381
+
]
382
+
~is_error:true
383
+
else
384
+
let audio_data =
385
+
generate_sine_wave_audio (float_of_int frequency) duration
386
+
in
387
+
Tool.create_tool_result
388
+
[ Mcp.make_audio_content audio_data "audio/wav" ]
389
+
~is_error:false
390
+
with Failure msg ->
391
+
Log.errorf "Error in generate_audio tool: %s" msg;
392
+
Tool.create_tool_result
393
+
[ Mcp.make_text_content (Printf.sprintf "Error: %s" msg) ]
394
+
~is_error:true)
337
395
338
396
(* Define and register a resource template example with multimodal content *)
339
-
let _ = add_resource_template server
340
-
~uri_template:"multimodal://{name}"
341
-
~name:"Multimodal Greeting"
342
-
~description:"Get a multimodal greeting with text, image and audio"
343
-
~mime_type:"application/json"
344
-
(fun params ->
345
-
match params with
346
-
| [name] ->
347
-
let greeting = Printf.sprintf "Hello, %s! Welcome to the multimodal MCP example." name in
348
-
let image_data = generate_random_image 128 128 in
349
-
let audio_data = generate_sine_wave_audio 440.0 1 in
350
-
351
-
Printf.sprintf {|
397
+
let _ =
398
+
add_resource_template server ~uri_template:"multimodal://{name}"
399
+
~name:"Multimodal Greeting"
400
+
~description:"Get a multimodal greeting with text, image and audio"
401
+
~mime_type:"application/json" (fun params ->
402
+
match params with
403
+
| [ name ] ->
404
+
let greeting =
405
+
Printf.sprintf "Hello, %s! Welcome to the multimodal MCP example."
406
+
name
407
+
in
408
+
let image_data = generate_random_image 128 128 in
409
+
let audio_data = generate_sine_wave_audio 440.0 1 in
410
+
411
+
Printf.sprintf
412
+
{|
352
413
{
353
414
"greeting": "%s",
354
415
"image": {
···
360
421
"mimeType": "audio/wav"
361
422
}
362
423
}
363
-
|} greeting image_data audio_data
364
-
| _ -> Printf.sprintf {|{"error": "Invalid parameters"}|}
365
-
)
424
+
|}
425
+
greeting image_data audio_data
426
+
| _ -> Printf.sprintf {|{"error": "Invalid parameters"}|})
366
427
367
428
(* Run the server with the default scheduler *)
368
429
let () =
369
-
Random.self_init(); (* Initialize random generator *)
370
-
Eio_main.run @@ fun env ->
371
-
Mcp_server.run_server env server
430
+
Random.self_init ();
431
+
(* Initialize random generator *)
432
+
Eio_main.run @@ fun env -> Mcp_server.run_server env server
+104
-111
bin/ocaml_eval_sdk.ml
+104
-111
bin/ocaml_eval_sdk.ml
···
12
12
(* Helper for extracting string value from JSON *)
13
13
let get_string_param json name =
14
14
match json with
15
-
| `Assoc fields ->
16
-
(match List.assoc_opt name fields with
17
-
| Some (`String value) -> value
18
-
| _ -> failwith (Printf.sprintf "Missing or invalid parameter: %s" name))
15
+
| `Assoc fields -> (
16
+
match List.assoc_opt name fields with
17
+
| Some (`String value) -> value
18
+
| _ -> failwith (Printf.sprintf "Missing or invalid parameter: %s" name))
19
19
| _ -> failwith "Expected JSON object"
20
-
20
+
21
21
(* Initialize the OCaml toploop with standard libraries *)
22
22
let initialize_toploop () =
23
23
(* Initialize the toplevel environment *)
24
24
Toploop.initialize_toplevel_env ();
25
-
25
+
26
26
(* Set up the toplevel as if using the standard OCaml REPL *)
27
27
Clflags.nopervasives := false;
28
28
Clflags.real_paths := true;
29
29
Clflags.recursive_types := false;
30
30
Clflags.strict_sequence := false;
31
31
Clflags.applicative_functors := true;
32
-
32
+
33
33
(* Return success message *)
34
34
"OCaml evaluation environment initialized"
35
35
···
37
37
let evaluate_phrase phrase =
38
38
(* Parse the input text as a toplevel phrase *)
39
39
let lexbuf = Lexing.from_string phrase in
40
-
40
+
41
41
(* Capture both success/failure status and output *)
42
42
try
43
43
let parsed_phrase = !Toploop.parse_toplevel_phrase lexbuf in
44
-
let (success, output) = capture_output (fun fmt ->
45
-
Toploop.execute_phrase true fmt parsed_phrase
46
-
) in
47
-
44
+
let success, output =
45
+
capture_output (fun fmt -> Toploop.execute_phrase true fmt parsed_phrase)
46
+
in
47
+
48
48
(* Return structured result with status and captured output *)
49
49
if success then
50
-
`Assoc [
51
-
("success", `Bool true);
52
-
("output", `String output);
53
-
]
50
+
`Assoc [ ("success", `Bool true); ("output", `String output) ]
54
51
else
55
-
`Assoc [
56
-
("success", `Bool false);
57
-
("error", `String "Execution failed");
58
-
("output", `String output);
59
-
]
52
+
`Assoc
53
+
[
54
+
("success", `Bool false);
55
+
("error", `String "Execution failed");
56
+
("output", `String output);
57
+
]
60
58
with e ->
61
59
(* Handle parsing or other errors with more detailed messages *)
62
-
let error_msg = match e with
63
-
| Syntaxerr.Error err ->
64
-
let msg = match err with
65
-
| Syntaxerr.Unclosed _ -> "Syntax error: Unclosed delimiter"
66
-
| Syntaxerr.Expecting _ -> "Syntax error: Expecting a different token"
67
-
| Syntaxerr.Not_expecting _ -> "Syntax error: Unexpected token"
68
-
| Syntaxerr.Applicative_path _ -> "Syntax error: Invalid applicative path"
69
-
| Syntaxerr.Variable_in_scope _ -> "Syntax error: Variable in scope"
70
-
| Syntaxerr.Other _ -> "Syntax error"
71
-
| _ -> "Syntax error (unknown kind)"
72
-
in
73
-
msg
74
-
75
-
| Lexer.Error (err, _) ->
76
-
let msg = match err with
77
-
| Lexer.Illegal_character _ -> "Lexer error: Illegal character"
78
-
| Lexer.Illegal_escape _ -> "Lexer error: Illegal escape sequence"
79
-
| Lexer.Unterminated_comment _ -> "Lexer error: Unterminated comment"
80
-
| Lexer.Unterminated_string -> "Lexer error: Unterminated string"
81
-
| Lexer.Unterminated_string_in_comment _ -> "Lexer error: Unterminated string in comment"
82
-
| Lexer.Invalid_literal _ -> "Lexer error: Invalid literal"
83
-
| _ -> "Lexer error (unknown kind)"
84
-
in
85
-
msg
86
-
| _ -> Printexc.to_string e
60
+
let error_msg =
61
+
match e with
62
+
| Syntaxerr.Error err ->
63
+
let msg =
64
+
match err with
65
+
| Syntaxerr.Unclosed _ -> "Syntax error: Unclosed delimiter"
66
+
| Syntaxerr.Expecting _ ->
67
+
"Syntax error: Expecting a different token"
68
+
| Syntaxerr.Not_expecting _ -> "Syntax error: Unexpected token"
69
+
| Syntaxerr.Applicative_path _ ->
70
+
"Syntax error: Invalid applicative path"
71
+
| Syntaxerr.Variable_in_scope _ -> "Syntax error: Variable in scope"
72
+
| Syntaxerr.Other _ -> "Syntax error"
73
+
| _ -> "Syntax error (unknown kind)"
74
+
in
75
+
msg
76
+
| Lexer.Error (err, _) ->
77
+
let msg =
78
+
match err with
79
+
| Lexer.Illegal_character _ -> "Lexer error: Illegal character"
80
+
| Lexer.Illegal_escape _ -> "Lexer error: Illegal escape sequence"
81
+
| Lexer.Unterminated_comment _ ->
82
+
"Lexer error: Unterminated comment"
83
+
| Lexer.Unterminated_string -> "Lexer error: Unterminated string"
84
+
| Lexer.Unterminated_string_in_comment _ ->
85
+
"Lexer error: Unterminated string in comment"
86
+
| Lexer.Invalid_literal _ -> "Lexer error: Invalid literal"
87
+
| _ -> "Lexer error (unknown kind)"
88
+
in
89
+
msg
90
+
| _ -> Printexc.to_string e
87
91
in
88
-
`Assoc [
89
-
("success", `Bool false);
90
-
("error", `String error_msg);
91
-
]
92
+
`Assoc [ ("success", `Bool false); ("error", `String error_msg) ]
92
93
93
94
(* Create evaluation server *)
94
-
let server = create_server
95
-
~name:"OCaml Evaluation Server"
96
-
~version:"0.1.0" () |>
97
-
fun server ->
98
-
(* Set default capabilities *)
99
-
configure_server server ~with_tools:true ()
95
+
let server =
96
+
create_server ~name:"OCaml Evaluation Server" ~version:"0.1.0" ()
97
+
|> fun server ->
98
+
(* Set default capabilities *)
99
+
configure_server server ~with_tools:true ()
100
100
101
101
(* Toplevel environment state management *)
102
102
let toplevel_initialized = ref false
103
103
104
104
(* Initialize OCaml toplevel on first use *)
105
105
let ensure_toploop_initialized () =
106
-
if not !toplevel_initialized then begin
106
+
if not !toplevel_initialized then
107
107
let _ = initialize_toploop () in
108
-
toplevel_initialized := true;
109
-
end
108
+
toplevel_initialized := true
110
109
111
110
(* Register eval tool *)
112
-
let _ = add_tool server
113
-
~name:"ocaml_eval"
114
-
~description:"Evaluates OCaml toplevel phrases and returns the result"
115
-
~schema_properties:[
116
-
("code", "string", "OCaml code to evaluate")
117
-
]
118
-
~schema_required:["code"]
119
-
(fun args ->
120
-
ensure_toploop_initialized ();
121
-
122
-
try
123
-
(* Extract code parameter *)
124
-
let code = get_string_param args "code" in
125
-
126
-
(* Execute the code *)
127
-
let result = evaluate_phrase code in
128
-
129
-
(* Return formatted result *)
130
-
let success = match result with
131
-
| `Assoc fields -> (
132
-
match List.assoc_opt "success" fields with
133
-
| Some (`Bool true) -> true
111
+
let _ =
112
+
add_tool server ~name:"ocaml_eval"
113
+
~description:"Evaluates OCaml toplevel phrases and returns the result"
114
+
~schema_properties:[ ("code", "string", "OCaml code to evaluate") ]
115
+
~schema_required:[ "code" ]
116
+
(fun args ->
117
+
ensure_toploop_initialized ();
118
+
119
+
try
120
+
(* Extract code parameter *)
121
+
let code = get_string_param args "code" in
122
+
123
+
(* Execute the code *)
124
+
let result = evaluate_phrase code in
125
+
126
+
(* Return formatted result *)
127
+
let success =
128
+
match result with
129
+
| `Assoc fields -> (
130
+
match List.assoc_opt "success" fields with
131
+
| Some (`Bool true) -> true
132
+
| _ -> false)
134
133
| _ -> false
135
-
)
136
-
| _ -> false
137
-
in
138
-
139
-
let output = match result with
140
-
| `Assoc fields -> (
141
-
match List.assoc_opt "output" fields with
142
-
| Some (`String s) -> s
143
-
| _ -> (
144
-
match List.assoc_opt "error" fields with
145
-
| Some (`String s) -> s
146
-
| _ -> "Unknown result"
147
-
)
148
-
)
149
-
| _ -> "Unknown result"
150
-
in
151
-
152
-
(* Create a tool result with colorized output *)
153
-
Tool.create_tool_result [
154
-
Mcp.make_text_content output
155
-
] ~is_error:(not success)
156
-
157
-
with
158
-
| Failure msg ->
159
-
Log.errorf "Error in OCaml eval tool: %s" msg;
160
-
Tool.create_tool_result [Mcp.make_text_content (Printf.sprintf "Error: %s" msg)] ~is_error:true
161
-
)
134
+
in
135
+
136
+
let output =
137
+
match result with
138
+
| `Assoc fields -> (
139
+
match List.assoc_opt "output" fields with
140
+
| Some (`String s) -> s
141
+
| _ -> (
142
+
match List.assoc_opt "error" fields with
143
+
| Some (`String s) -> s
144
+
| _ -> "Unknown result"))
145
+
| _ -> "Unknown result"
146
+
in
147
+
148
+
(* Create a tool result with colorized output *)
149
+
Tool.create_tool_result
150
+
[ Mcp.make_text_content output ]
151
+
~is_error:(not success)
152
+
with Failure msg ->
153
+
Log.errorf "Error in OCaml eval tool: %s" msg;
154
+
Tool.create_tool_result
155
+
[ Mcp.make_text_content (Printf.sprintf "Error: %s" msg) ]
156
+
~is_error:true)
162
157
163
158
(* Run the server with the default scheduler *)
164
-
let () =
165
-
Eio_main.run @@ fun env->
166
-
Mcp_server.run_server env server
159
+
let () = Eio_main.run @@ fun env -> Mcp_server.run_server env server
+20
-19
lib/dune
+20
-19
lib/dune
···
1
1
(library
2
-
(name mcp)
3
-
(public_name mcp)
4
-
(libraries jsonrpc unix yojson)
5
-
(modules mcp))
2
+
(name mcp)
3
+
(public_name mcp)
4
+
(libraries jsonrpc unix yojson)
5
+
(modules mcp))
6
6
7
7
(library
8
-
(name mcp_rpc)
9
-
(public_name mcp.rpc)
10
-
(libraries mcp jsonrpc unix yojson)
11
-
(modules mcp_rpc)
12
-
(flags (:standard -w -67 -w -27 -w -32 -w -33 -w -34)))
8
+
(name mcp_rpc)
9
+
(public_name mcp.rpc)
10
+
(libraries mcp jsonrpc unix yojson)
11
+
(modules mcp_rpc)
12
+
(flags
13
+
(:standard -w -67 -w -27 -w -32 -w -33 -w -34)))
13
14
14
15
(library
15
-
(name mcp_sdk)
16
-
(public_name mcp.sdk)
17
-
(libraries mcp mcp_rpc jsonrpc unix yojson)
18
-
(modules mcp_sdk)
19
-
(flags (:standard -w -67 -w -27 -w -32)))
16
+
(name mcp_sdk)
17
+
(public_name mcp.sdk)
18
+
(libraries mcp mcp_rpc jsonrpc unix yojson)
19
+
(modules mcp_sdk)
20
+
(flags
21
+
(:standard -w -67 -w -27 -w -32)))
20
22
21
23
(library
22
-
(name mcp_server)
23
-
(public_name mcp.server)
24
-
(libraries mcp_sdk jsonrpc eio_main eio http cohttp-eio)
25
-
(modules mcp_server)
26
-
)
24
+
(name mcp_server)
25
+
(public_name mcp.server)
26
+
(libraries mcp_sdk jsonrpc eio_main eio http cohttp-eio)
27
+
(modules mcp_server))
+477
-436
lib/mcp.ml
+477
-436
lib/mcp.ml
···
3
3
(* Utility functions for JSON parsing *)
4
4
module Util = struct
5
5
(* Helper to raise a Json.Of_json exception with formatted message *)
6
-
let json_error fmt json =
6
+
let json_error fmt json =
7
7
Printf.ksprintf (fun msg -> raise (Json.Of_json (msg, json))) fmt
8
-
8
+
9
9
(* Extract a string field from JSON object or raise an error *)
10
10
let get_string_field fields name json =
11
11
match List.assoc_opt name fields with
12
12
| Some (`String s) -> s
13
13
| _ -> json_error "Missing or invalid '%s' field" json name
14
-
14
+
15
15
(* Extract an optional string field from JSON object *)
16
16
let get_optional_string_field fields name =
17
-
List.assoc_opt name fields |> Option.map (function
18
-
| `String s -> s
19
-
| j -> json_error "Expected string for %s" j name
20
-
)
21
-
17
+
List.assoc_opt name fields
18
+
|> Option.map (function
19
+
| `String s -> s
20
+
| j -> json_error "Expected string for %s" j name)
21
+
22
22
(* Extract an int field from JSON object or raise an error *)
23
23
let get_int_field fields name json =
24
24
match List.assoc_opt name fields with
25
25
| Some (`Int i) -> i
26
26
| _ -> json_error "Missing or invalid '%s' field" json name
27
-
27
+
28
28
(* Extract a float field from JSON object or raise an error *)
29
29
let get_float_field fields name json =
30
30
match List.assoc_opt name fields with
31
31
| Some (`Float f) -> f
32
32
| _ -> json_error "Missing or invalid '%s' field" json name
33
-
33
+
34
34
(* Extract a boolean field from JSON object or raise an error *)
35
35
let get_bool_field fields name json =
36
36
match List.assoc_opt name fields with
37
37
| Some (`Bool b) -> b
38
38
| _ -> json_error "Missing or invalid '%s' field" json name
39
-
39
+
40
40
(* Extract an object field from JSON object or raise an error *)
41
41
let get_object_field fields name json =
42
42
match List.assoc_opt name fields with
43
43
| Some (`Assoc obj) -> obj
44
44
| _ -> json_error "Missing or invalid '%s' field" json name
45
-
45
+
46
46
(* Extract a list field from JSON object or raise an error *)
47
47
let get_list_field fields name json =
48
48
match List.assoc_opt name fields with
49
49
| Some (`List items) -> items
50
50
| _ -> json_error "Missing or invalid '%s' field" json name
51
-
51
+
52
52
(* Verify a specific string value in a field *)
53
53
let verify_string_field fields name expected_value json =
54
54
match List.assoc_opt name fields with
55
55
| Some (`String s) when s = expected_value -> ()
56
-
| _ -> json_error "Field '%s' missing or not equal to '%s'" json name expected_value
56
+
| _ ->
57
+
json_error "Field '%s' missing or not equal to '%s'" json name
58
+
expected_value
57
59
end
58
60
59
61
(* Error codes for JSON-RPC *)
60
62
module ErrorCode = struct
61
-
type t =
62
-
| ParseError (* -32700 - Invalid JSON *)
63
-
| InvalidRequest (* -32600 - Invalid JSON-RPC request *)
64
-
| MethodNotFound (* -32601 - Method not available *)
65
-
| InvalidParams (* -32602 - Invalid method parameters *)
66
-
| InternalError (* -32603 - Internal JSON-RPC error *)
67
-
| ResourceNotFound (* -32002 - Custom MCP error: requested resource not found *)
68
-
| AuthRequired (* -32001 - Custom MCP error: authentication required *)
63
+
type t =
64
+
| ParseError (* -32700 - Invalid JSON *)
65
+
| InvalidRequest (* -32600 - Invalid JSON-RPC request *)
66
+
| MethodNotFound (* -32601 - Method not available *)
67
+
| InvalidParams (* -32602 - Invalid method parameters *)
68
+
| InternalError (* -32603 - Internal JSON-RPC error *)
69
+
| ResourceNotFound
70
+
(* -32002 - Custom MCP error: requested resource not found *)
71
+
| AuthRequired (* -32001 - Custom MCP error: authentication required *)
69
72
| CustomError of int (* For any other error codes *)
70
-
73
+
71
74
(* Convert the error code to its integer representation *)
72
75
let to_int = function
73
76
| ParseError -> -32700
···
78
81
| ResourceNotFound -> -32002
79
82
| AuthRequired -> -32001
80
83
| CustomError code -> code
81
-
84
+
82
85
(* Get error message for standard error codes *)
83
86
let to_message = function
84
87
| ParseError -> "Parse error"
···
98
101
(* Initialization and lifecycle methods *)
99
102
| Initialize
100
103
| Initialized
101
-
102
104
(* Resource methods *)
103
105
| ResourcesList
104
106
| ResourcesRead
···
106
108
| ResourcesSubscribe
107
109
| ResourcesListChanged
108
110
| ResourcesUpdated
109
-
110
111
(* Tool methods *)
111
112
| ToolsList
112
113
| ToolsCall
113
114
| ToolsListChanged
114
-
115
115
(* Prompt methods *)
116
116
| PromptsList
117
117
| PromptsGet
118
118
| PromptsListChanged
119
-
120
119
(* Progress notifications *)
121
120
| Progress
122
-
121
+
123
122
(* Convert method type to string representation *)
124
123
let to_string = function
125
124
| Initialize -> "initialize"
···
137
136
| PromptsGet -> "prompts/get"
138
137
| PromptsListChanged -> "notifications/prompts/list_changed"
139
138
| Progress -> "notifications/progress"
140
-
139
+
141
140
(* Convert string to method type *)
142
141
let of_string = function
143
142
| "initialize" -> Initialize
···
163
162
module Role = struct
164
163
type t = [ `User | `Assistant ]
165
164
166
-
let to_string = function
167
-
| `User -> "user"
168
-
| `Assistant -> "assistant"
165
+
let to_string = function `User -> "user" | `Assistant -> "assistant"
169
166
170
167
let of_string = function
171
168
| "user" -> `User
···
173
170
| s -> Util.json_error "Unknown role: %s" (`String s) s
174
171
175
172
let yojson_of_t t = `String (to_string t)
173
+
176
174
let t_of_yojson = function
177
175
| `String s -> of_string s
178
176
| j -> Util.json_error "Expected string for Role" j
···
190
188
type t = string
191
189
192
190
let yojson_of_t t = `String t
191
+
193
192
let t_of_yojson = function
194
193
| `String s -> s
195
194
| j -> Util.json_error "Expected string for Cursor" j
···
198
197
(* Annotations *)
199
198
200
199
module Annotated = struct
201
-
type t = {
202
-
annotations: annotation option;
203
-
}
204
-
and annotation = {
205
-
audience: Role.t list option;
206
-
priority: float option;
207
-
}
200
+
type t = { annotations : annotation option }
201
+
and annotation = { audience : Role.t list option; priority : float option }
208
202
209
203
let yojson_of_annotation { audience; priority } =
210
204
let assoc = [] in
211
-
let assoc = match audience with
212
-
| Some audience -> ("audience", `List (List.map Role.yojson_of_t audience)) :: assoc
205
+
let assoc =
206
+
match audience with
207
+
| Some audience ->
208
+
("audience", `List (List.map Role.yojson_of_t audience)) :: assoc
213
209
| None -> assoc
214
210
in
215
-
let assoc = match priority with
211
+
let assoc =
212
+
match priority with
216
213
| Some priority -> ("priority", `Float priority) :: assoc
217
214
| None -> assoc
218
215
in
···
220
217
221
218
let annotation_of_yojson = function
222
219
| `Assoc fields ->
223
-
let audience = List.assoc_opt "audience" fields |> Option.map (function
224
-
| `List items -> List.map Role.t_of_yojson items
225
-
| j -> Util.json_error "Expected list for audience" j
226
-
) in
227
-
let priority = List.assoc_opt "priority" fields |> Option.map (function
228
-
| `Float f -> f
229
-
| j -> Util.json_error "Expected float for priority" j
230
-
) in
231
-
{ audience; priority }
220
+
let audience =
221
+
List.assoc_opt "audience" fields
222
+
|> Option.map (function
223
+
| `List items -> List.map Role.t_of_yojson items
224
+
| j -> Util.json_error "Expected list for audience" j)
225
+
in
226
+
let priority =
227
+
List.assoc_opt "priority" fields
228
+
|> Option.map (function
229
+
| `Float f -> f
230
+
| j -> Util.json_error "Expected float for priority" j)
231
+
in
232
+
{ audience; priority }
232
233
| j -> Util.json_error "Expected object for annotation" j
233
234
234
235
let yojson_of_t { annotations } =
235
236
match annotations with
236
-
| Some annotations -> `Assoc [ "annotations", yojson_of_annotation annotations ]
237
+
| Some annotations ->
238
+
`Assoc [ ("annotations", yojson_of_annotation annotations) ]
237
239
| None -> `Assoc []
238
240
239
241
let t_of_yojson = function
240
242
| `Assoc fields ->
241
-
let annotations = List.assoc_opt "annotations" fields |> Option.map annotation_of_yojson in
242
-
{ annotations }
243
+
let annotations =
244
+
List.assoc_opt "annotations" fields |> Option.map annotation_of_yojson
245
+
in
246
+
{ annotations }
243
247
| j -> Util.json_error "Expected object for Annotated" j
244
248
end
245
249
246
250
(* Content types *)
247
251
248
252
module TextContent = struct
249
-
type t = {
250
-
text: string;
251
-
annotations: Annotated.annotation option;
252
-
}
253
+
type t = { text : string; annotations : Annotated.annotation option }
253
254
254
255
let yojson_of_t { text; annotations } =
255
-
let assoc = [
256
-
("text", `String text);
257
-
("type", `String "text");
258
-
] in
259
-
let assoc = match annotations with
260
-
| Some annotations -> ("annotations", Annotated.yojson_of_annotation annotations) :: assoc
256
+
let assoc = [ ("text", `String text); ("type", `String "text") ] in
257
+
let assoc =
258
+
match annotations with
259
+
| Some annotations ->
260
+
("annotations", Annotated.yojson_of_annotation annotations) :: assoc
261
261
| None -> assoc
262
262
in
263
263
`Assoc assoc
264
264
265
265
let t_of_yojson = function
266
266
| `Assoc fields as json ->
267
-
let text = Util.get_string_field fields "text" json in
268
-
Util.verify_string_field fields "type" "text" json;
269
-
let annotations = List.assoc_opt "annotations" fields |> Option.map Annotated.annotation_of_yojson in
270
-
{ text; annotations }
267
+
let text = Util.get_string_field fields "text" json in
268
+
Util.verify_string_field fields "type" "text" json;
269
+
let annotations =
270
+
List.assoc_opt "annotations" fields
271
+
|> Option.map Annotated.annotation_of_yojson
272
+
in
273
+
{ text; annotations }
271
274
| j -> Util.json_error "Expected object for TextContent" j
272
275
end
273
276
274
277
module ImageContent = struct
275
278
type t = {
276
-
data: string;
277
-
mime_type: string;
278
-
annotations: Annotated.annotation option;
279
+
data : string;
280
+
mime_type : string;
281
+
annotations : Annotated.annotation option;
279
282
}
280
283
281
284
let yojson_of_t { data; mime_type; annotations } =
282
-
let assoc = [
283
-
("type", `String "image");
284
-
("data", `String data);
285
-
("mimeType", `String mime_type);
286
-
] in
287
-
let assoc = match annotations with
288
-
| Some annotations -> ("annotations", Annotated.yojson_of_annotation annotations) :: assoc
285
+
let assoc =
286
+
[
287
+
("type", `String "image");
288
+
("data", `String data);
289
+
("mimeType", `String mime_type);
290
+
]
291
+
in
292
+
let assoc =
293
+
match annotations with
294
+
| Some annotations ->
295
+
("annotations", Annotated.yojson_of_annotation annotations) :: assoc
289
296
| None -> assoc
290
297
in
291
298
`Assoc assoc
292
299
293
300
let t_of_yojson = function
294
301
| `Assoc fields as json ->
295
-
let data = Util.get_string_field fields "data" json in
296
-
let mime_type = Util.get_string_field fields "mimeType" json in
297
-
Util.verify_string_field fields "type" "image" json;
298
-
let annotations = List.assoc_opt "annotations" fields |> Option.map Annotated.annotation_of_yojson in
299
-
{ data; mime_type; annotations }
302
+
let data = Util.get_string_field fields "data" json in
303
+
let mime_type = Util.get_string_field fields "mimeType" json in
304
+
Util.verify_string_field fields "type" "image" json;
305
+
let annotations =
306
+
List.assoc_opt "annotations" fields
307
+
|> Option.map Annotated.annotation_of_yojson
308
+
in
309
+
{ data; mime_type; annotations }
300
310
| j -> Util.json_error "Expected object for ImageContent" j
301
311
end
302
312
303
313
module AudioContent = struct
304
314
type t = {
305
-
data: string;
306
-
mime_type: string;
307
-
annotations: Annotated.annotation option;
315
+
data : string;
316
+
mime_type : string;
317
+
annotations : Annotated.annotation option;
308
318
}
309
319
310
320
let yojson_of_t { data; mime_type; annotations } =
311
-
let assoc = [
312
-
("type", `String "audio");
313
-
("data", `String data);
314
-
("mimeType", `String mime_type);
315
-
] in
316
-
let assoc = match annotations with
317
-
| Some annotations -> ("annotations", Annotated.yojson_of_annotation annotations) :: assoc
321
+
let assoc =
322
+
[
323
+
("type", `String "audio");
324
+
("data", `String data);
325
+
("mimeType", `String mime_type);
326
+
]
327
+
in
328
+
let assoc =
329
+
match annotations with
330
+
| Some annotations ->
331
+
("annotations", Annotated.yojson_of_annotation annotations) :: assoc
318
332
| None -> assoc
319
333
in
320
334
`Assoc assoc
321
335
322
336
let t_of_yojson = function
323
337
| `Assoc fields as json ->
324
-
let data = Util.get_string_field fields "data" json in
325
-
let mime_type = Util.get_string_field fields "mimeType" json in
326
-
Util.verify_string_field fields "type" "audio" json;
327
-
let annotations = List.assoc_opt "annotations" fields |> Option.map Annotated.annotation_of_yojson in
328
-
{ data; mime_type; annotations }
338
+
let data = Util.get_string_field fields "data" json in
339
+
let mime_type = Util.get_string_field fields "mimeType" json in
340
+
Util.verify_string_field fields "type" "audio" json;
341
+
let annotations =
342
+
List.assoc_opt "annotations" fields
343
+
|> Option.map Annotated.annotation_of_yojson
344
+
in
345
+
{ data; mime_type; annotations }
329
346
| j -> Util.json_error "Expected object for AudioContent" j
330
347
end
331
348
332
349
module ResourceContents = struct
333
-
type t = {
334
-
uri: string;
335
-
mime_type: string option;
336
-
}
350
+
type t = { uri : string; mime_type : string option }
337
351
338
352
let yojson_of_t { uri; mime_type } =
339
-
let assoc = [
340
-
("uri", `String uri);
341
-
] in
342
-
let assoc = match mime_type with
353
+
let assoc = [ ("uri", `String uri) ] in
354
+
let assoc =
355
+
match mime_type with
343
356
| Some mime_type -> ("mimeType", `String mime_type) :: assoc
344
357
| None -> assoc
345
358
in
···
347
360
348
361
let t_of_yojson = function
349
362
| `Assoc fields as json ->
350
-
let uri = Util.get_string_field fields "uri" json in
351
-
let mime_type = Util.get_optional_string_field fields "mimeType" in
352
-
{ uri; mime_type }
363
+
let uri = Util.get_string_field fields "uri" json in
364
+
let mime_type = Util.get_optional_string_field fields "mimeType" in
365
+
{ uri; mime_type }
353
366
| j -> Util.json_error "Expected object for ResourceContents" j
354
367
end
355
368
356
369
module TextResourceContents = struct
357
-
type t = {
358
-
uri: string;
359
-
text: string;
360
-
mime_type: string option;
361
-
}
370
+
type t = { uri : string; text : string; mime_type : string option }
362
371
363
372
let yojson_of_t { uri; text; mime_type } =
364
-
let assoc = [
365
-
("uri", `String uri);
366
-
("text", `String text);
367
-
] in
368
-
let assoc = match mime_type with
373
+
let assoc = [ ("uri", `String uri); ("text", `String text) ] in
374
+
let assoc =
375
+
match mime_type with
369
376
| Some mime_type -> ("mimeType", `String mime_type) :: assoc
370
377
| None -> assoc
371
378
in
···
373
380
374
381
let t_of_yojson = function
375
382
| `Assoc fields as json ->
376
-
let uri = Util.get_string_field fields "uri" json in
377
-
let text = Util.get_string_field fields "text" json in
378
-
let mime_type = Util.get_optional_string_field fields "mimeType" in
379
-
{ uri; text; mime_type }
383
+
let uri = Util.get_string_field fields "uri" json in
384
+
let text = Util.get_string_field fields "text" json in
385
+
let mime_type = Util.get_optional_string_field fields "mimeType" in
386
+
{ uri; text; mime_type }
380
387
| j -> Util.json_error "Expected object for TextResourceContents" j
381
388
end
382
389
383
390
module BlobResourceContents = struct
384
-
type t = {
385
-
uri: string;
386
-
blob: string;
387
-
mime_type: string option;
388
-
}
391
+
type t = { uri : string; blob : string; mime_type : string option }
389
392
390
393
let yojson_of_t { uri; blob; mime_type } =
391
-
let assoc = [
392
-
("uri", `String uri);
393
-
("blob", `String blob);
394
-
] in
395
-
let assoc = match mime_type with
394
+
let assoc = [ ("uri", `String uri); ("blob", `String blob) ] in
395
+
let assoc =
396
+
match mime_type with
396
397
| Some mime_type -> ("mimeType", `String mime_type) :: assoc
397
398
| None -> assoc
398
399
in
···
400
401
401
402
let t_of_yojson = function
402
403
| `Assoc fields as json ->
403
-
let uri = Util.get_string_field fields "uri" json in
404
-
let blob = Util.get_string_field fields "blob" json in
405
-
let mime_type = Util.get_optional_string_field fields "mimeType" in
406
-
{ uri; blob; mime_type }
404
+
let uri = Util.get_string_field fields "uri" json in
405
+
let blob = Util.get_string_field fields "blob" json in
406
+
let mime_type = Util.get_optional_string_field fields "mimeType" in
407
+
{ uri; blob; mime_type }
407
408
| j -> Util.json_error "Expected object for BlobResourceContents" j
408
409
end
409
410
410
411
module EmbeddedResource = struct
411
412
type t = {
412
-
resource: [ `Text of TextResourceContents.t | `Blob of BlobResourceContents.t ];
413
-
annotations: Annotated.annotation option;
413
+
resource :
414
+
[ `Text of TextResourceContents.t | `Blob of BlobResourceContents.t ];
415
+
annotations : Annotated.annotation option;
414
416
}
415
417
416
418
let yojson_of_t { resource; annotations } =
417
-
let resource_json = match resource with
419
+
let resource_json =
420
+
match resource with
418
421
| `Text txt -> TextResourceContents.yojson_of_t txt
419
422
| `Blob blob -> BlobResourceContents.yojson_of_t blob
420
423
in
421
-
let assoc = [
422
-
("resource", resource_json);
423
-
("type", `String "resource");
424
-
] in
425
-
let assoc = match annotations with
426
-
| Some annotations -> ("annotations", Annotated.yojson_of_annotation annotations) :: assoc
424
+
let assoc = [ ("resource", resource_json); ("type", `String "resource") ] in
425
+
let assoc =
426
+
match annotations with
427
+
| Some annotations ->
428
+
("annotations", Annotated.yojson_of_annotation annotations) :: assoc
427
429
| None -> assoc
428
430
in
429
431
`Assoc assoc
430
432
431
433
let t_of_yojson = function
432
434
| `Assoc fields as json ->
433
-
Util.verify_string_field fields "type" "resource" json;
434
-
let resource_fields = match List.assoc_opt "resource" fields with
435
-
| Some (`Assoc res_fields) -> res_fields
436
-
| _ -> Util.json_error "Missing or invalid 'resource' field" json
437
-
in
438
-
let resource =
439
-
if List.mem_assoc "text" resource_fields then
440
-
`Text (TextResourceContents.t_of_yojson (`Assoc resource_fields))
441
-
else if List.mem_assoc "blob" resource_fields then
442
-
`Blob (BlobResourceContents.t_of_yojson (`Assoc resource_fields))
443
-
else
444
-
Util.json_error "Invalid resource content" (`Assoc resource_fields)
445
-
in
446
-
let annotations = List.assoc_opt "annotations" fields |> Option.map Annotated.annotation_of_yojson in
447
-
{ resource; annotations }
435
+
Util.verify_string_field fields "type" "resource" json;
436
+
let resource_fields =
437
+
match List.assoc_opt "resource" fields with
438
+
| Some (`Assoc res_fields) -> res_fields
439
+
| _ -> Util.json_error "Missing or invalid 'resource' field" json
440
+
in
441
+
let resource =
442
+
if List.mem_assoc "text" resource_fields then
443
+
`Text (TextResourceContents.t_of_yojson (`Assoc resource_fields))
444
+
else if List.mem_assoc "blob" resource_fields then
445
+
`Blob (BlobResourceContents.t_of_yojson (`Assoc resource_fields))
446
+
else
447
+
Util.json_error "Invalid resource content" (`Assoc resource_fields)
448
+
in
449
+
let annotations =
450
+
List.assoc_opt "annotations" fields
451
+
|> Option.map Annotated.annotation_of_yojson
452
+
in
453
+
{ resource; annotations }
448
454
| j -> Util.json_error "Expected object for EmbeddedResource" j
449
455
end
450
456
451
-
type content =
457
+
type content =
452
458
| Text of TextContent.t
453
459
| Image of ImageContent.t
454
460
| Audio of AudioContent.t
···
461
467
| Resource r -> EmbeddedResource.yojson_of_t r
462
468
463
469
let content_of_yojson = function
464
-
| `Assoc fields as json ->
465
-
(match List.assoc_opt "type" fields with
466
-
| Some (`String "text") -> Text (TextContent.t_of_yojson json)
467
-
| Some (`String "image") -> Image (ImageContent.t_of_yojson json)
468
-
| Some (`String "audio") -> Audio (AudioContent.t_of_yojson json)
469
-
| Some (`String "resource") -> Resource (EmbeddedResource.t_of_yojson json)
470
-
| _ -> Util.json_error "Invalid or missing content type" json)
470
+
| `Assoc fields as json -> (
471
+
match List.assoc_opt "type" fields with
472
+
| Some (`String "text") -> Text (TextContent.t_of_yojson json)
473
+
| Some (`String "image") -> Image (ImageContent.t_of_yojson json)
474
+
| Some (`String "audio") -> Audio (AudioContent.t_of_yojson json)
475
+
| Some (`String "resource") ->
476
+
Resource (EmbeddedResource.t_of_yojson json)
477
+
| _ -> Util.json_error "Invalid or missing content type" json)
471
478
| j -> Util.json_error "Expected object for content" j
472
479
473
480
(* Message types *)
474
481
475
482
module PromptMessage = struct
476
-
type t = {
477
-
role: Role.t;
478
-
content: content;
479
-
}
483
+
type t = { role : Role.t; content : content }
480
484
481
485
let yojson_of_t { role; content } =
482
-
`Assoc [
483
-
("role", Role.yojson_of_t role);
484
-
("content", yojson_of_content content);
485
-
]
486
+
`Assoc
487
+
[
488
+
("role", Role.yojson_of_t role); ("content", yojson_of_content content);
489
+
]
486
490
487
491
let t_of_yojson = function
488
492
| `Assoc fields as json ->
489
-
let role = match List.assoc_opt "role" fields with
490
-
| Some json -> Role.t_of_yojson json
491
-
| None -> Util.json_error "Missing role field" json
492
-
in
493
-
let content = match List.assoc_opt "content" fields with
494
-
| Some json -> content_of_yojson json
495
-
| None -> Util.json_error "Missing content field" json
496
-
in
497
-
{ role; content }
493
+
let role =
494
+
match List.assoc_opt "role" fields with
495
+
| Some json -> Role.t_of_yojson json
496
+
| None -> Util.json_error "Missing role field" json
497
+
in
498
+
let content =
499
+
match List.assoc_opt "content" fields with
500
+
| Some json -> content_of_yojson json
501
+
| None -> Util.json_error "Missing content field" json
502
+
in
503
+
{ role; content }
498
504
| j -> Util.json_error "Expected object for PromptMessage" j
499
505
end
500
506
501
507
module SamplingMessage = struct
502
508
type t = {
503
-
role: Role.t;
504
-
content: [ `Text of TextContent.t | `Image of ImageContent.t | `Audio of AudioContent.t ];
509
+
role : Role.t;
510
+
content :
511
+
[ `Text of TextContent.t
512
+
| `Image of ImageContent.t
513
+
| `Audio of AudioContent.t ];
505
514
}
506
515
507
516
let yojson_of_t { role; content } =
508
-
let content_json = match content with
517
+
let content_json =
518
+
match content with
509
519
| `Text t -> TextContent.yojson_of_t t
510
520
| `Image i -> ImageContent.yojson_of_t i
511
521
| `Audio a -> AudioContent.yojson_of_t a
512
522
in
513
-
`Assoc [
514
-
("role", Role.yojson_of_t role);
515
-
("content", content_json);
516
-
]
523
+
`Assoc [ ("role", Role.yojson_of_t role); ("content", content_json) ]
517
524
518
525
let t_of_yojson = function
519
526
| `Assoc fields as json ->
520
-
let role = match List.assoc_opt "role" fields with
521
-
| Some json -> Role.t_of_yojson json
522
-
| None -> Util.json_error "Missing role field" json
523
-
in
524
-
let content_obj = match List.assoc_opt "content" fields with
525
-
| Some (`Assoc content_fields) -> content_fields
526
-
| _ -> Util.json_error "Missing or invalid content field" json
527
-
in
528
-
let content_type = match List.assoc_opt "type" content_obj with
529
-
| Some (`String ty) -> ty
530
-
| _ -> Util.json_error "Missing or invalid content type" (`Assoc content_obj)
531
-
in
532
-
let content =
533
-
match content_type with
534
-
| "text" -> `Text (TextContent.t_of_yojson (`Assoc content_obj))
535
-
| "image" -> `Image (ImageContent.t_of_yojson (`Assoc content_obj))
536
-
| "audio" -> `Audio (AudioContent.t_of_yojson (`Assoc content_obj))
537
-
| _ -> Util.json_error "Invalid content type: %s" (`Assoc content_obj) content_type
538
-
in
539
-
{ role; content }
527
+
let role =
528
+
match List.assoc_opt "role" fields with
529
+
| Some json -> Role.t_of_yojson json
530
+
| None -> Util.json_error "Missing role field" json
531
+
in
532
+
let content_obj =
533
+
match List.assoc_opt "content" fields with
534
+
| Some (`Assoc content_fields) -> content_fields
535
+
| _ -> Util.json_error "Missing or invalid content field" json
536
+
in
537
+
let content_type =
538
+
match List.assoc_opt "type" content_obj with
539
+
| Some (`String ty) -> ty
540
+
| _ ->
541
+
Util.json_error "Missing or invalid content type"
542
+
(`Assoc content_obj)
543
+
in
544
+
let content =
545
+
match content_type with
546
+
| "text" -> `Text (TextContent.t_of_yojson (`Assoc content_obj))
547
+
| "image" -> `Image (ImageContent.t_of_yojson (`Assoc content_obj))
548
+
| "audio" -> `Audio (AudioContent.t_of_yojson (`Assoc content_obj))
549
+
| _ ->
550
+
Util.json_error "Invalid content type: %s" (`Assoc content_obj)
551
+
content_type
552
+
in
553
+
{ role; content }
540
554
| j -> Util.json_error "Expected object for SamplingMessage" j
541
555
end
542
556
543
557
(* Implementation info *)
544
558
545
559
module Implementation = struct
546
-
type t = {
547
-
name: string;
548
-
version: string;
549
-
}
560
+
type t = { name : string; version : string }
550
561
551
562
let yojson_of_t { name; version } =
552
-
`Assoc [
553
-
("name", `String name);
554
-
("version", `String version);
555
-
]
563
+
`Assoc [ ("name", `String name); ("version", `String version) ]
556
564
557
565
let t_of_yojson = function
558
566
| `Assoc fields as json ->
559
-
let name = Util.get_string_field fields "name" json in
560
-
let version = Util.get_string_field fields "version" json in
561
-
{ name; version }
567
+
let name = Util.get_string_field fields "name" json in
568
+
let version = Util.get_string_field fields "version" json in
569
+
{ name; version }
562
570
| j -> Util.json_error "Expected object for Implementation" j
563
571
end
564
572
565
573
(* JSONRPC Message types *)
566
574
567
575
module JSONRPCMessage = struct
568
-
type notification = {
569
-
meth: Method.t;
570
-
params: Json.t option;
571
-
}
576
+
type notification = { meth : Method.t; params : Json.t option }
572
577
573
578
type request = {
574
-
id: RequestId.t;
575
-
meth: Method.t;
576
-
params: Json.t option;
577
-
progress_token: ProgressToken.t option;
579
+
id : RequestId.t;
580
+
meth : Method.t;
581
+
params : Json.t option;
582
+
progress_token : ProgressToken.t option;
578
583
}
579
584
580
-
type response = {
581
-
id: RequestId.t;
582
-
result: Json.t;
583
-
}
585
+
type response = { id : RequestId.t; result : Json.t }
584
586
585
587
type error = {
586
-
id: RequestId.t;
587
-
code: int;
588
-
message: string;
589
-
data: Json.t option;
588
+
id : RequestId.t;
589
+
code : int;
590
+
message : string;
591
+
data : Json.t option;
590
592
}
591
593
592
594
type t =
···
595
597
| Response of response
596
598
| Error of error
597
599
598
-
let yojson_of_notification (n: notification) =
599
-
let assoc = [
600
-
("jsonrpc", `String "2.0");
601
-
("method", `String (Method.to_string n.meth));
602
-
] in
603
-
let assoc = match n.params with
600
+
let yojson_of_notification (n : notification) =
601
+
let assoc =
602
+
[
603
+
("jsonrpc", `String "2.0"); ("method", `String (Method.to_string n.meth));
604
+
]
605
+
in
606
+
let assoc =
607
+
match n.params with
604
608
| Some params -> ("params", params) :: assoc
605
609
| None -> assoc
606
610
in
607
611
`Assoc assoc
608
612
609
-
let yojson_of_request (r: request) =
610
-
let assoc = [
611
-
("jsonrpc", `String "2.0");
612
-
("id", Id.yojson_of_t r.id);
613
-
("method", `String (Method.to_string r.meth));
614
-
] in
615
-
let assoc = match r.params with
613
+
let yojson_of_request (r : request) =
614
+
let assoc =
615
+
[
616
+
("jsonrpc", `String "2.0");
617
+
("id", Id.yojson_of_t r.id);
618
+
("method", `String (Method.to_string r.meth));
619
+
]
620
+
in
621
+
let assoc =
622
+
match r.params with
616
623
| Some params ->
617
-
let params_json = match params with
618
-
| `Assoc fields ->
619
-
let fields = match r.progress_token with
620
-
| Some token ->
621
-
let meta = `Assoc [ "progressToken", ProgressToken.yojson_of_t token ] in
622
-
("_meta", meta) :: fields
623
-
| None -> fields
624
-
in
625
-
`Assoc fields
626
-
| _ -> params
627
-
in
628
-
("params", params_json) :: assoc
624
+
let params_json =
625
+
match params with
626
+
| `Assoc fields ->
627
+
let fields =
628
+
match r.progress_token with
629
+
| Some token ->
630
+
let meta =
631
+
`Assoc
632
+
[ ("progressToken", ProgressToken.yojson_of_t token) ]
633
+
in
634
+
("_meta", meta) :: fields
635
+
| None -> fields
636
+
in
637
+
`Assoc fields
638
+
| _ -> params
639
+
in
640
+
("params", params_json) :: assoc
629
641
| None -> assoc
630
642
in
631
643
`Assoc assoc
632
644
633
-
let yojson_of_response (r: response) =
634
-
`Assoc [
635
-
("jsonrpc", `String "2.0");
636
-
("id", Id.yojson_of_t r.id);
637
-
("result", r.result);
638
-
]
645
+
let yojson_of_response (r : response) =
646
+
`Assoc
647
+
[
648
+
("jsonrpc", `String "2.0");
649
+
("id", Id.yojson_of_t r.id);
650
+
("result", r.result);
651
+
]
639
652
640
-
let yojson_of_error (e: error) =
641
-
let error_assoc = [
642
-
("code", `Int e.code);
643
-
("message", `String e.message);
644
-
] in
645
-
let error_assoc = match e.data with
653
+
let yojson_of_error (e : error) =
654
+
let error_assoc =
655
+
[ ("code", `Int e.code); ("message", `String e.message) ]
656
+
in
657
+
let error_assoc =
658
+
match e.data with
646
659
| Some data -> ("data", data) :: error_assoc
647
660
| None -> error_assoc
648
661
in
649
-
`Assoc [
650
-
("jsonrpc", `String "2.0");
651
-
("id", Id.yojson_of_t e.id);
652
-
("error", `Assoc error_assoc);
653
-
]
662
+
`Assoc
663
+
[
664
+
("jsonrpc", `String "2.0");
665
+
("id", Id.yojson_of_t e.id);
666
+
("error", `Assoc error_assoc);
667
+
]
654
668
655
669
let yojson_of_t = function
656
670
| Notification n -> yojson_of_notification n
···
660
674
661
675
let notification_of_yojson = function
662
676
| `Assoc fields ->
663
-
let meth = match List.assoc_opt "method" fields with
664
-
| Some (`String s) ->
665
-
(try Method.of_string s
666
-
with Failure msg -> Util.json_error "%s" (`String s) msg)
667
-
| _ -> Util.json_error "Missing or invalid 'method' field" (`Assoc fields)
668
-
in
669
-
let params = List.assoc_opt "params" fields in
670
-
{ meth; params }
677
+
let meth =
678
+
match List.assoc_opt "method" fields with
679
+
| Some (`String s) -> (
680
+
try Method.of_string s
681
+
with Failure msg -> Util.json_error "%s" (`String s) msg)
682
+
| _ ->
683
+
Util.json_error "Missing or invalid 'method' field"
684
+
(`Assoc fields)
685
+
in
686
+
let params = List.assoc_opt "params" fields in
687
+
{ meth; params }
671
688
| j -> Util.json_error "Expected object for notification" j
672
689
673
690
let request_of_yojson = function
674
691
| `Assoc fields ->
675
-
let id = match List.assoc_opt "id" fields with
676
-
| Some id_json -> Id.t_of_yojson id_json
677
-
| _ -> Util.json_error "Missing or invalid 'id' field" (`Assoc fields)
678
-
in
679
-
let meth = match List.assoc_opt "method" fields with
680
-
| Some (`String s) ->
681
-
(try Method.of_string s
682
-
with Failure msg -> Util.json_error "%s" (`String s) msg)
683
-
| _ -> Util.json_error "Missing or invalid 'method' field" (`Assoc fields)
684
-
in
685
-
let params = List.assoc_opt "params" fields in
686
-
let progress_token =
687
-
match params with
688
-
| Some (`Assoc param_fields) ->
689
-
(match List.assoc_opt "_meta" param_fields with
690
-
| Some (`Assoc meta_fields) ->
691
-
(match List.assoc_opt "progressToken" meta_fields with
692
-
| Some token_json -> Some (ProgressToken.t_of_yojson token_json)
693
-
| None -> None)
694
-
| _ -> None)
695
-
| _ -> None
696
-
in
697
-
{ id; meth; params; progress_token }
692
+
let id =
693
+
match List.assoc_opt "id" fields with
694
+
| Some id_json -> Id.t_of_yojson id_json
695
+
| _ -> Util.json_error "Missing or invalid 'id' field" (`Assoc fields)
696
+
in
697
+
let meth =
698
+
match List.assoc_opt "method" fields with
699
+
| Some (`String s) -> (
700
+
try Method.of_string s
701
+
with Failure msg -> Util.json_error "%s" (`String s) msg)
702
+
| _ ->
703
+
Util.json_error "Missing or invalid 'method' field"
704
+
(`Assoc fields)
705
+
in
706
+
let params = List.assoc_opt "params" fields in
707
+
let progress_token =
708
+
match params with
709
+
| Some (`Assoc param_fields) -> (
710
+
match List.assoc_opt "_meta" param_fields with
711
+
| Some (`Assoc meta_fields) -> (
712
+
match List.assoc_opt "progressToken" meta_fields with
713
+
| Some token_json ->
714
+
Some (ProgressToken.t_of_yojson token_json)
715
+
| None -> None)
716
+
| _ -> None)
717
+
| _ -> None
718
+
in
719
+
{ id; meth; params; progress_token }
698
720
| j -> Util.json_error "Expected object for request" j
699
721
700
722
let response_of_yojson = function
701
723
| `Assoc fields ->
702
-
let id = match List.assoc_opt "id" fields with
703
-
| Some id_json -> Id.t_of_yojson id_json
704
-
| _ -> Util.json_error "Missing or invalid 'id' field" (`Assoc fields)
705
-
in
706
-
let result = match List.assoc_opt "result" fields with
707
-
| Some result -> result
708
-
| _ -> Util.json_error "Missing 'result' field" (`Assoc fields)
709
-
in
710
-
{ id; result }
724
+
let id =
725
+
match List.assoc_opt "id" fields with
726
+
| Some id_json -> Id.t_of_yojson id_json
727
+
| _ -> Util.json_error "Missing or invalid 'id' field" (`Assoc fields)
728
+
in
729
+
let result =
730
+
match List.assoc_opt "result" fields with
731
+
| Some result -> result
732
+
| _ -> Util.json_error "Missing 'result' field" (`Assoc fields)
733
+
in
734
+
{ id; result }
711
735
| j -> Util.json_error "Expected object for response" j
712
736
713
737
let error_of_yojson = function
714
738
| `Assoc fields as json ->
715
-
let id = match List.assoc_opt "id" fields with
716
-
| Some id_json -> Id.t_of_yojson id_json
717
-
| _ -> Util.json_error "Missing or invalid 'id' field" json
718
-
in
719
-
let error = match List.assoc_opt "error" fields with
720
-
| Some (`Assoc error_fields) -> error_fields
721
-
| _ -> Util.json_error "Missing or invalid 'error' field" json
722
-
in
723
-
let code = match List.assoc_opt "code" error with
724
-
| Some (`Int code) -> code
725
-
| _ -> Util.json_error "Missing or invalid 'code' field in error" (`Assoc error)
726
-
in
727
-
let message = match List.assoc_opt "message" error with
728
-
| Some (`String msg) -> msg
729
-
| _ -> Util.json_error "Missing or invalid 'message' field in error" (`Assoc error)
730
-
in
731
-
let data = List.assoc_opt "data" error in
732
-
{ id; code; message; data }
739
+
let id =
740
+
match List.assoc_opt "id" fields with
741
+
| Some id_json -> Id.t_of_yojson id_json
742
+
| _ -> Util.json_error "Missing or invalid 'id' field" json
743
+
in
744
+
let error =
745
+
match List.assoc_opt "error" fields with
746
+
| Some (`Assoc error_fields) -> error_fields
747
+
| _ -> Util.json_error "Missing or invalid 'error' field" json
748
+
in
749
+
let code =
750
+
match List.assoc_opt "code" error with
751
+
| Some (`Int code) -> code
752
+
| _ ->
753
+
Util.json_error "Missing or invalid 'code' field in error"
754
+
(`Assoc error)
755
+
in
756
+
let message =
757
+
match List.assoc_opt "message" error with
758
+
| Some (`String msg) -> msg
759
+
| _ ->
760
+
Util.json_error "Missing or invalid 'message' field in error"
761
+
(`Assoc error)
762
+
in
763
+
let data = List.assoc_opt "data" error in
764
+
{ id; code; message; data }
733
765
| j -> Util.json_error "Expected object for error" j
734
766
735
767
let t_of_yojson json =
736
768
match json with
737
769
| `Assoc fields ->
738
-
let _jsonrpc = match List.assoc_opt "jsonrpc" fields with
739
-
| Some (`String "2.0") -> ()
740
-
| _ -> Util.json_error "Missing or invalid 'jsonrpc' field" json
741
-
in
742
-
if List.mem_assoc "method" fields then
743
-
if List.mem_assoc "id" fields then
744
-
Request (request_of_yojson json)
745
-
else
746
-
Notification (notification_of_yojson json)
747
-
else if List.mem_assoc "result" fields then
748
-
Response (response_of_yojson json)
749
-
else if List.mem_assoc "error" fields then
750
-
Error (error_of_yojson json)
751
-
else
752
-
Util.json_error "Invalid JSONRPC message format" json
770
+
let _jsonrpc =
771
+
match List.assoc_opt "jsonrpc" fields with
772
+
| Some (`String "2.0") -> ()
773
+
| _ -> Util.json_error "Missing or invalid 'jsonrpc' field" json
774
+
in
775
+
if List.mem_assoc "method" fields then
776
+
if List.mem_assoc "id" fields then Request (request_of_yojson json)
777
+
else Notification (notification_of_yojson json)
778
+
else if List.mem_assoc "result" fields then
779
+
Response (response_of_yojson json)
780
+
else if List.mem_assoc "error" fields then Error (error_of_yojson json)
781
+
else Util.json_error "Invalid JSONRPC message format" json
753
782
| j -> Util.json_error "Expected object for JSONRPC message" j
754
783
755
-
let create_notification ?(params=None) ~meth () =
784
+
let create_notification ?(params = None) ~meth () =
756
785
Notification { meth; params }
757
786
758
-
let create_request ?(params=None) ?(progress_token=None) ~id ~meth () =
787
+
let create_request ?(params = None) ?(progress_token = None) ~id ~meth () =
759
788
Request { id; meth; params; progress_token }
760
789
761
-
let create_response ~id ~result =
762
-
Response { id; result }
790
+
let create_response ~id ~result = Response { id; result }
763
791
764
-
let create_error ~id ~code ~message ?(data=None) () =
792
+
let create_error ~id ~code ~message ?(data = None) () =
765
793
Error { id; code; message; data }
766
794
end
767
795
···
770
798
module Initialize = struct
771
799
module Request = struct
772
800
type t = {
773
-
capabilities: Json.t; (* ClientCapabilities *)
774
-
client_info: Implementation.t;
775
-
protocol_version: string;
801
+
capabilities : Json.t; (* ClientCapabilities *)
802
+
client_info : Implementation.t;
803
+
protocol_version : string;
776
804
}
777
805
778
806
let yojson_of_t { capabilities; client_info; protocol_version } =
779
-
`Assoc [
780
-
("capabilities", capabilities);
781
-
("clientInfo", Implementation.yojson_of_t client_info);
782
-
("protocolVersion", `String protocol_version);
783
-
]
807
+
`Assoc
808
+
[
809
+
("capabilities", capabilities);
810
+
("clientInfo", Implementation.yojson_of_t client_info);
811
+
("protocolVersion", `String protocol_version);
812
+
]
784
813
785
814
let t_of_yojson = function
786
815
| `Assoc fields as json ->
787
-
let capabilities = match List.assoc_opt "capabilities" fields with
788
-
| Some json -> json
789
-
| None -> Util.json_error "Missing capabilities field" json
790
-
in
791
-
let client_info = match List.assoc_opt "clientInfo" fields with
792
-
| Some json -> Implementation.t_of_yojson json
793
-
| None -> Util.json_error "Missing clientInfo field" json
794
-
in
795
-
let protocol_version = Util.get_string_field fields "protocolVersion" json in
796
-
{ capabilities; client_info; protocol_version }
816
+
let capabilities =
817
+
match List.assoc_opt "capabilities" fields with
818
+
| Some json -> json
819
+
| None -> Util.json_error "Missing capabilities field" json
820
+
in
821
+
let client_info =
822
+
match List.assoc_opt "clientInfo" fields with
823
+
| Some json -> Implementation.t_of_yojson json
824
+
| None -> Util.json_error "Missing clientInfo field" json
825
+
in
826
+
let protocol_version =
827
+
Util.get_string_field fields "protocolVersion" json
828
+
in
829
+
{ capabilities; client_info; protocol_version }
797
830
| j -> Util.json_error "Expected object for InitializeRequest" j
798
831
799
832
let create ~capabilities ~client_info ~protocol_version =
···
801
834
802
835
let to_jsonrpc ~id t =
803
836
let params = yojson_of_t t in
804
-
JSONRPCMessage.create_request ~id ~meth:Method.Initialize ~params:(Some params) ()
837
+
JSONRPCMessage.create_request ~id ~meth:Method.Initialize
838
+
~params:(Some params) ()
805
839
end
806
840
807
841
module Result = struct
808
842
type t = {
809
-
capabilities: Json.t; (* ServerCapabilities *)
810
-
server_info: Implementation.t;
811
-
protocol_version: string;
812
-
instructions: string option;
813
-
meta: Json.t option;
843
+
capabilities : Json.t; (* ServerCapabilities *)
844
+
server_info : Implementation.t;
845
+
protocol_version : string;
846
+
instructions : string option;
847
+
meta : Json.t option;
814
848
}
815
849
816
-
let yojson_of_t { capabilities; server_info; protocol_version; instructions; meta } =
817
-
let assoc = [
818
-
("capabilities", capabilities);
819
-
("serverInfo", Implementation.yojson_of_t server_info);
820
-
("protocolVersion", `String protocol_version);
821
-
] in
822
-
let assoc = match instructions with
850
+
let yojson_of_t
851
+
{ capabilities; server_info; protocol_version; instructions; meta } =
852
+
let assoc =
853
+
[
854
+
("capabilities", capabilities);
855
+
("serverInfo", Implementation.yojson_of_t server_info);
856
+
("protocolVersion", `String protocol_version);
857
+
]
858
+
in
859
+
let assoc =
860
+
match instructions with
823
861
| Some instr -> ("instructions", `String instr) :: assoc
824
862
| None -> assoc
825
863
in
826
-
let assoc = match meta with
827
-
| Some meta -> ("_meta", meta) :: assoc
828
-
| None -> assoc
864
+
let assoc =
865
+
match meta with Some meta -> ("_meta", meta) :: assoc | None -> assoc
829
866
in
830
867
`Assoc assoc
831
868
832
869
let t_of_yojson = function
833
870
| `Assoc fields as json ->
834
-
let capabilities = match List.assoc_opt "capabilities" fields with
835
-
| Some json -> json
836
-
| None -> Util.json_error "Missing capabilities field" json
837
-
in
838
-
let server_info = match List.assoc_opt "serverInfo" fields with
839
-
| Some json -> Implementation.t_of_yojson json
840
-
| None -> Util.json_error "Missing serverInfo field" json
841
-
in
842
-
let protocol_version = Util.get_string_field fields "protocolVersion" json in
843
-
let instructions = Util.get_optional_string_field fields "instructions" in
844
-
let meta = List.assoc_opt "_meta" fields in
845
-
{ capabilities; server_info; protocol_version; instructions; meta }
871
+
let capabilities =
872
+
match List.assoc_opt "capabilities" fields with
873
+
| Some json -> json
874
+
| None -> Util.json_error "Missing capabilities field" json
875
+
in
876
+
let server_info =
877
+
match List.assoc_opt "serverInfo" fields with
878
+
| Some json -> Implementation.t_of_yojson json
879
+
| None -> Util.json_error "Missing serverInfo field" json
880
+
in
881
+
let protocol_version =
882
+
Util.get_string_field fields "protocolVersion" json
883
+
in
884
+
let instructions =
885
+
Util.get_optional_string_field fields "instructions"
886
+
in
887
+
let meta = List.assoc_opt "_meta" fields in
888
+
{ capabilities; server_info; protocol_version; instructions; meta }
846
889
| j -> Util.json_error "Expected object for InitializeResult" j
847
890
848
-
let create ~capabilities ~server_info ~protocol_version ?instructions ?meta () =
891
+
let create ~capabilities ~server_info ~protocol_version ?instructions ?meta
892
+
() =
849
893
{ capabilities; server_info; protocol_version; instructions; meta }
850
894
851
895
let to_jsonrpc ~id t =
···
855
899
856
900
module Initialized = struct
857
901
module Notification = struct
858
-
type t = {
859
-
meta: Json.t option;
860
-
}
902
+
type t = { meta : Json.t option }
861
903
862
904
let yojson_of_t { meta } =
863
905
let assoc = [] in
864
-
let assoc = match meta with
865
-
| Some meta -> ("_meta", meta) :: assoc
866
-
| None -> assoc
906
+
let assoc =
907
+
match meta with Some meta -> ("_meta", meta) :: assoc | None -> assoc
867
908
in
868
909
`Assoc assoc
869
910
870
911
let t_of_yojson = function
871
912
| `Assoc fields ->
872
-
let meta = List.assoc_opt "_meta" fields in
873
-
{ meta }
913
+
let meta = List.assoc_opt "_meta" fields in
914
+
{ meta }
874
915
| j -> Util.json_error "Expected object for InitializedNotification" j
875
916
876
917
let create ?meta () = { meta }
877
918
878
919
let to_jsonrpc t =
879
-
let params = match yojson_of_t t with
880
-
| `Assoc [] -> None
881
-
| json -> Some json
920
+
let params =
921
+
match yojson_of_t t with `Assoc [] -> None | json -> Some json
882
922
in
883
923
JSONRPCMessage.create_notification ~meth:Method.Initialized ~params ()
884
924
end
885
925
end
886
926
887
-
888
927
(* Export the main interface for using the MCP protocol *)
889
928
890
-
let parse_message json =
891
-
JSONRPCMessage.t_of_yojson json
929
+
let parse_message json = JSONRPCMessage.t_of_yojson json
892
930
893
-
let create_notification ?(params=None) ~meth () =
931
+
let create_notification ?(params = None) ~meth () =
894
932
JSONRPCMessage.create_notification ~params ~meth ()
895
933
896
-
let create_request ?(params=None) ?(progress_token=None) ~id ~meth () =
934
+
let create_request ?(params = None) ?(progress_token = None) ~id ~meth () =
897
935
JSONRPCMessage.create_request ~params ~progress_token ~id ~meth ()
898
936
899
937
let create_response = JSONRPCMessage.create_response
900
938
let create_error = JSONRPCMessage.create_error
901
939
902
940
(* Content type constructors *)
903
-
let make_text_content text =
904
-
Text (TextContent.{ text; annotations = None })
941
+
let make_text_content text = Text TextContent.{ text; annotations = None }
905
942
906
943
let make_image_content data mime_type =
907
-
Image (ImageContent.{ data; mime_type; annotations = None })
944
+
Image ImageContent.{ data; mime_type; annotations = None }
908
945
909
946
let make_audio_content data mime_type =
910
-
Audio (AudioContent.{ data; mime_type; annotations = None })
947
+
Audio AudioContent.{ data; mime_type; annotations = None }
911
948
912
949
let make_resource_text_content uri text mime_type =
913
-
Resource (EmbeddedResource.{
914
-
resource = `Text TextResourceContents.{ uri; text; mime_type };
915
-
annotations = None;
916
-
})
950
+
Resource
951
+
EmbeddedResource.
952
+
{
953
+
resource = `Text TextResourceContents.{ uri; text; mime_type };
954
+
annotations = None;
955
+
}
917
956
918
957
let make_resource_blob_content uri blob mime_type =
919
-
Resource (EmbeddedResource.{
920
-
resource = `Blob BlobResourceContents.{ uri; blob; mime_type };
921
-
annotations = None;
922
-
})
958
+
Resource
959
+
EmbeddedResource.
960
+
{
961
+
resource = `Blob BlobResourceContents.{ uri; blob; mime_type };
962
+
annotations = None;
963
+
}
+667
-609
lib/mcp.mli
+667
-609
lib/mcp.mli
···
1
-
(** MCP - Model Context Protocol implementation
2
-
3
-
The Model Context Protocol (MCP) is a standardized protocol for AI agents to exchange context
4
-
with servers. This module provides the core OCaml implementation of MCP including
5
-
all message types, content representations, and serialization functionality.
6
-
1
+
(** MCP - Model Context Protocol implementation
2
+
3
+
The Model Context Protocol (MCP) is a standardized protocol for AI agents to
4
+
exchange context with servers. This module provides the core OCaml
5
+
implementation of MCP including all message types, content representations,
6
+
and serialization functionality.
7
+
7
8
MCP Architecture:
8
9
- Uses JSON-RPC 2.0 as its underlying message format with UTF-8 encoding
9
-
- Follows a client-server model where clients (often LLM-integrated applications) communicate with MCP servers
10
+
- Follows a client-server model where clients (often LLM-integrated
11
+
applications) communicate with MCP servers
10
12
- Supports multiple transport methods including stdio and streamable HTTP
11
-
- Implements a three-phase connection lifecycle: initialization, operation, and shutdown
12
-
- Provides capability negotiation during initialization to determine available features
13
-
- Offers four primary context exchange mechanisms:
14
-
1. Resources: Server-exposed data that provides context to language models
15
-
2. Tools: Server-exposed functionality that can be invoked by language models
16
-
3. Prompts: Server-defined templates for structuring interactions with models
13
+
- Implements a three-phase connection lifecycle: initialization, operation,
14
+
and shutdown
15
+
- Provides capability negotiation during initialization to determine
16
+
available features
17
+
- Offers four primary context exchange mechanisms: 1. Resources:
18
+
Server-exposed data that provides context to language models 2. Tools:
19
+
Server-exposed functionality that can be invoked by language models 3.
20
+
Prompts: Server-defined templates for structuring interactions with models
17
21
4. Sampling: Client-exposed ability to generate completions from LLMs
18
-
- Supports multimodal content types: text, images, audio, and embedded resources
22
+
- Supports multimodal content types: text, images, audio, and embedded
23
+
resources
19
24
- Includes standardized error handling with defined error codes
20
-
21
-
This implementation follows Protocol Revision 2025-03-26.
22
-
*)
25
+
26
+
This implementation follows Protocol Revision 2025-03-26. *)
23
27
24
28
open Jsonrpc
25
29
26
30
(** Utility functions for JSON parsing *)
27
31
module Util : sig
32
+
val json_error : ('a, unit, string, 'b) format4 -> Json.t -> 'a
28
33
(** Helper to raise a Json.Of_json exception with formatted message
29
34
@param fmt Format string for the error message
30
35
@param json JSON value to include in the exception
31
36
@return Never returns, always raises an exception
32
-
@raise Json.Of_json with the formatted message and JSON value
33
-
*)
34
-
val json_error : ('a, unit, string, 'b) format4 -> Json.t -> 'a
35
-
36
-
(** Extract a string field from JSON object or raise an error
37
+
@raise Json.Of_json with the formatted message and JSON value *)
38
+
39
+
val get_string_field : (string * Json.t) list -> string -> Json.t -> string
40
+
(** Extract a string field from JSON object or raise an error
37
41
@param fields Assoc list of fields from JSON object
38
42
@param name Field name to extract
39
43
@param json Original JSON for error context
40
44
@return The string value of the field
41
-
@raise Json.Of_json if the field is missing or not a string
42
-
*)
43
-
val get_string_field : (string * Json.t) list -> string -> Json.t -> string
44
-
45
+
@raise Json.Of_json if the field is missing or not a string *)
46
+
47
+
val get_optional_string_field :
48
+
(string * Json.t) list -> string -> string option
45
49
(** Extract an optional string field from JSON object
46
50
@param fields Assoc list of fields from JSON object
47
51
@param name Field name to extract
48
52
@return Some string if present and a string, None if missing
49
-
@raise Json.Of_json if the field exists but is not a string
50
-
*)
51
-
val get_optional_string_field : (string * Json.t) list -> string -> string option
52
-
53
+
@raise Json.Of_json if the field exists but is not a string *)
54
+
55
+
val get_int_field : (string * Json.t) list -> string -> Json.t -> int
53
56
(** Extract an int field from JSON object or raise an error
54
57
@param fields Assoc list of fields from JSON object
55
58
@param name Field name to extract
56
59
@param json Original JSON for error context
57
60
@return The int value of the field
58
-
@raise Json.Of_json if the field is missing or not an int
59
-
*)
60
-
val get_int_field : (string * Json.t) list -> string -> Json.t -> int
61
-
61
+
@raise Json.Of_json if the field is missing or not an int *)
62
+
63
+
val get_float_field : (string * Json.t) list -> string -> Json.t -> float
62
64
(** Extract a float field from JSON object or raise an error
63
65
@param fields Assoc list of fields from JSON object
64
66
@param name Field name to extract
65
67
@param json Original JSON for error context
66
68
@return The float value of the field
67
-
@raise Json.Of_json if the field is missing or not a float
68
-
*)
69
-
val get_float_field : (string * Json.t) list -> string -> Json.t -> float
70
-
69
+
@raise Json.Of_json if the field is missing or not a float *)
70
+
71
+
val get_bool_field : (string * Json.t) list -> string -> Json.t -> bool
71
72
(** Extract a boolean field from JSON object or raise an error
72
73
@param fields Assoc list of fields from JSON object
73
74
@param name Field name to extract
74
75
@param json Original JSON for error context
75
76
@return The boolean value of the field
76
-
@raise Json.Of_json if the field is missing or not a boolean
77
-
*)
78
-
val get_bool_field : (string * Json.t) list -> string -> Json.t -> bool
79
-
77
+
@raise Json.Of_json if the field is missing or not a boolean *)
78
+
79
+
val get_object_field :
80
+
(string * Json.t) list -> string -> Json.t -> (string * Json.t) list
80
81
(** Extract an object field from JSON object or raise an error
81
82
@param fields Assoc list of fields from JSON object
82
83
@param name Field name to extract
83
84
@param json Original JSON for error context
84
85
@return The object as an assoc list
85
-
@raise Json.Of_json if the field is missing or not an object
86
-
*)
87
-
val get_object_field : (string * Json.t) list -> string -> Json.t -> (string * Json.t) list
88
-
86
+
@raise Json.Of_json if the field is missing or not an object *)
87
+
88
+
val get_list_field : (string * Json.t) list -> string -> Json.t -> Json.t list
89
89
(** Extract a list field from JSON object or raise an error
90
90
@param fields Assoc list of fields from JSON object
91
91
@param name Field name to extract
92
92
@param json Original JSON for error context
93
93
@return The list items
94
-
@raise Json.Of_json if the field is missing or not a list
95
-
*)
96
-
val get_list_field : (string * Json.t) list -> string -> Json.t -> Json.t list
97
-
94
+
@raise Json.Of_json if the field is missing or not a list *)
95
+
96
+
val verify_string_field :
97
+
(string * Json.t) list -> string -> string -> Json.t -> unit
98
98
(** Verify a specific string value in a field
99
99
@param fields Assoc list of fields from JSON object
100
100
@param name Field name to check
···
102
102
@param json Original JSON for error context
103
103
@raise Json.Of_json if the field is missing or not equal to expected_value
104
104
*)
105
-
val verify_string_field : (string * Json.t) list -> string -> string -> Json.t -> unit
106
105
end
107
106
108
107
(** Error codes for JSON-RPC *)
109
108
module ErrorCode : sig
110
109
(** Standard JSON-RPC error codes with MCP-specific additions *)
111
-
type t =
112
-
| ParseError (** -32700 - Invalid JSON *)
113
-
| InvalidRequest (** -32600 - Invalid JSON-RPC request *)
114
-
| MethodNotFound (** -32601 - Method not available *)
115
-
| InvalidParams (** -32602 - Invalid method parameters *)
116
-
| InternalError (** -32603 - Internal JSON-RPC error *)
117
-
| ResourceNotFound (** -32002 - Custom MCP error: requested resource not found *)
118
-
| AuthRequired (** -32001 - Custom MCP error: authentication required *)
119
-
| CustomError of int (** For any other error codes *)
120
-
110
+
type t =
111
+
| ParseError (** -32700 - Invalid JSON *)
112
+
| InvalidRequest (** -32600 - Invalid JSON-RPC request *)
113
+
| MethodNotFound (** -32601 - Method not available *)
114
+
| InvalidParams (** -32602 - Invalid method parameters *)
115
+
| InternalError (** -32603 - Internal JSON-RPC error *)
116
+
| ResourceNotFound
117
+
(** -32002 - Custom MCP error: requested resource not found *)
118
+
| AuthRequired (** -32001 - Custom MCP error: authentication required *)
119
+
| CustomError of int (** For any other error codes *)
120
+
121
+
val to_int : t -> int
121
122
(** Convert the error code to its integer representation
122
123
@param code The error code to convert
123
-
@return The integer error code as defined in the JSON-RPC spec
124
-
*)
125
-
val to_int : t -> int
126
-
124
+
@return The integer error code as defined in the JSON-RPC spec *)
125
+
126
+
val to_message : t -> string
127
127
(** Get error message for standard error codes
128
128
@param code The error code to get message for
129
-
@return A standard message for the error code
130
-
*)
131
-
val to_message : t -> string
129
+
@return A standard message for the error code *)
132
130
end
133
131
134
132
(** MCP Protocol Methods - Algebraic data type representing all MCP methods *)
···
136
134
(** Method type representing all MCP protocol methods *)
137
135
type t =
138
136
(* Initialization and lifecycle methods *)
139
-
| Initialize (** Start the MCP lifecycle *)
140
-
| Initialized (** Signal readiness after initialization *)
141
-
137
+
| Initialize (** Start the MCP lifecycle *)
138
+
| Initialized (** Signal readiness after initialization *)
142
139
(* Resource methods *)
143
-
| ResourcesList (** Discover available resources *)
144
-
| ResourcesRead (** Retrieve resource contents *)
140
+
| ResourcesList (** Discover available resources *)
141
+
| ResourcesRead (** Retrieve resource contents *)
145
142
| ResourceTemplatesList (** List available resource templates *)
146
-
| ResourcesSubscribe (** Subscribe to resource changes *)
147
-
| ResourcesListChanged (** Resource list has changed *)
148
-
| ResourcesUpdated (** Resource has been updated *)
149
-
143
+
| ResourcesSubscribe (** Subscribe to resource changes *)
144
+
| ResourcesListChanged (** Resource list has changed *)
145
+
| ResourcesUpdated (** Resource has been updated *)
150
146
(* Tool methods *)
151
-
| ToolsList (** Discover available tools *)
152
-
| ToolsCall (** Invoke a tool *)
153
-
| ToolsListChanged (** Tool list has changed *)
154
-
147
+
| ToolsList (** Discover available tools *)
148
+
| ToolsCall (** Invoke a tool *)
149
+
| ToolsListChanged (** Tool list has changed *)
155
150
(* Prompt methods *)
156
-
| PromptsList (** Discover available prompts *)
157
-
| PromptsGet (** Retrieve a prompt template with arguments *)
158
-
| PromptsListChanged (** Prompt list has changed *)
159
-
151
+
| PromptsList (** Discover available prompts *)
152
+
| PromptsGet (** Retrieve a prompt template with arguments *)
153
+
| PromptsListChanged (** Prompt list has changed *)
160
154
(* Progress notifications *)
161
-
| Progress (** Progress update for long-running operations *)
162
-
155
+
| Progress (** Progress update for long-running operations *)
156
+
157
+
val to_string : t -> string
163
158
(** Convert method type to string representation
164
159
@param meth The method to convert
165
-
@return The string representation of the method (e.g., "initialize", "resources/list")
166
-
*)
167
-
val to_string : t -> string
168
-
160
+
@return
161
+
The string representation of the method (e.g., "initialize",
162
+
"resources/list") *)
163
+
164
+
val of_string : string -> t
169
165
(** Convert string to method type
170
166
@param s The string representation of the method
171
167
@return The corresponding method type
172
-
@raise Failure if the string is not a valid MCP method
173
-
*)
174
-
val of_string : string -> t
168
+
@raise Failure if the string is not a valid MCP method *)
175
169
end
176
-
177
170
178
171
(** Common types *)
179
172
180
173
(** Roles for conversation participants *)
181
174
module Role : sig
182
-
(** Role represents conversation participants in MCP messages.
183
-
Roles can be either 'user' or 'assistant', determining the
184
-
source of each message in a conversation. *)
185
175
type t = [ `User | `Assistant ]
176
+
(** Role represents conversation participants in MCP messages. Roles can be
177
+
either 'user' or 'assistant', determining the source of each message in a
178
+
conversation. *)
179
+
186
180
include Json.Jsonable.S with type t := t
187
181
end
188
182
189
183
(** Progress tokens for long-running operations *)
190
184
module ProgressToken : sig
191
-
(** Progress tokens identify long-running operations and enable
192
-
servers to provide progress updates to clients. This is used
193
-
to track operations that may take significant time to complete. *)
194
185
type t = [ `String of string | `Int of int ]
186
+
(** Progress tokens identify long-running operations and enable servers to
187
+
provide progress updates to clients. This is used to track operations that
188
+
may take significant time to complete. *)
189
+
195
190
include Json.Jsonable.S with type t := t
196
191
end
197
192
198
193
(** Request IDs *)
199
194
module RequestId : sig
200
-
(** Request IDs uniquely identify JSON-RPC requests, allowing responses
201
-
to be correlated with their originating requests. They can be either
202
-
string or integer values. *)
203
195
type t = [ `String of string | `Int of int ]
196
+
(** Request IDs uniquely identify JSON-RPC requests, allowing responses to be
197
+
correlated with their originating requests. They can be either string or
198
+
integer values. *)
199
+
204
200
include Json.Jsonable.S with type t := t
205
201
end
206
202
207
203
(** Cursors for pagination *)
208
204
module Cursor : sig
209
-
(** Cursors enable pagination in list operations for resources, tools, and prompts.
210
-
When a server has more items than can be returned in a single response,
211
-
it provides a cursor for the client to retrieve subsequent pages. *)
212
205
type t = string
206
+
(** Cursors enable pagination in list operations for resources, tools, and
207
+
prompts. When a server has more items than can be returned in a single
208
+
response, it provides a cursor for the client to retrieve subsequent
209
+
pages. *)
210
+
213
211
include Json.Jsonable.S with type t := t
214
212
end
215
213
216
214
(** Annotations for objects *)
217
215
module Annotated : sig
218
-
(** Annotations provide metadata for content objects, allowing
219
-
role-specific targeting and priority settings. *)
220
-
type t = {
221
-
annotations: annotation option;
222
-
}
216
+
type t = { annotations : annotation option }
217
+
(** Annotations provide metadata for content objects, allowing role-specific
218
+
targeting and priority settings. *)
219
+
223
220
and annotation = {
224
-
audience: Role.t list option;
225
-
(** Optional list of roles that should receive this content *)
226
-
priority: float option;
227
-
(** Optional priority value for this content *)
221
+
audience : Role.t list option;
222
+
(** Optional list of roles that should receive this content *)
223
+
priority : float option; (** Optional priority value for this content *)
228
224
}
225
+
229
226
include Json.Jsonable.S with type t := t
230
227
end
231
228
232
229
(** Text content - Core textual message representation in MCP *)
233
230
module TextContent : sig
234
-
(** TextContent represents plain text messages in MCP conversations.
235
-
This is the most common content type used for natural language interactions
236
-
between users and assistants. Text content is used in prompts, tool results,
237
-
and model responses.
238
-
231
+
type t = {
232
+
text : string; (** The actual text content as a UTF-8 encoded string *)
233
+
annotations : Annotated.annotation option;
234
+
(** Optional annotations for audience targeting and priority.
235
+
Annotations can restrict content visibility to specific roles
236
+
(user/assistant) and indicate relative importance of different
237
+
content elements. *)
238
+
}
239
+
(** TextContent represents plain text messages in MCP conversations. This is
240
+
the most common content type used for natural language interactions
241
+
between users and assistants. Text content is used in prompts, tool
242
+
results, and model responses.
243
+
239
244
In JSON-RPC, this is represented as:
240
245
{v
241
246
{
···
243
248
"text": "The text content of the message"
244
249
}
245
250
v}
246
-
251
+
247
252
For security, implementations must sanitize text content to prevent
248
253
injection attacks or unauthorized access to resources. *)
249
-
type t = {
250
-
text: string;
251
-
(** The actual text content as a UTF-8 encoded string *)
252
-
annotations: Annotated.annotation option;
253
-
(** Optional annotations for audience targeting and priority.
254
-
Annotations can restrict content visibility to specific roles (user/assistant)
255
-
and indicate relative importance of different content elements. *)
256
-
}
254
+
257
255
include Json.Jsonable.S with type t := t
258
256
end
259
257
260
258
(** Image content - Visual data representation in MCP *)
261
259
module ImageContent : sig
260
+
type t = {
261
+
data : string;
262
+
(** Base64-encoded image data. All binary image data must be encoded
263
+
using standard base64 encoding (RFC 4648) to safely transmit within
264
+
JSON. *)
265
+
mime_type : string;
266
+
(** MIME type of the image (e.g., "image/png", "image/jpeg",
267
+
"image/gif", "image/svg+xml"). This field is required and must
268
+
accurately represent the image format to ensure proper handling by
269
+
clients. *)
270
+
annotations : Annotated.annotation option;
271
+
(** Optional annotations for audience targeting and priority.
272
+
Annotations can restrict content visibility to specific roles
273
+
(user/assistant) and indicate relative importance of different
274
+
content elements. *)
275
+
}
262
276
(** ImageContent enables including visual information in MCP messages,
263
277
supporting multimodal interactions where visual context is important.
264
-
278
+
265
279
Images can be used in several scenarios:
266
280
- As user inputs for visual understanding tasks
267
281
- As context for generating descriptions or analysis
268
282
- As outputs from tools that generate visualizations
269
283
- As part of prompt templates with visual components
270
-
284
+
271
285
In JSON-RPC, this is represented as:
272
286
{v
273
287
{
···
276
290
"mimeType": "image/png"
277
291
}
278
292
v}
279
-
293
+
280
294
The data MUST be base64-encoded to ensure safe transmission in JSON.
281
-
Common mime types include image/png, image/jpeg, image/gif, and image/svg+xml. *)
282
-
type t = {
283
-
data: string;
284
-
(** Base64-encoded image data. All binary image data must be encoded using
285
-
standard base64 encoding (RFC 4648) to safely transmit within JSON. *)
286
-
mime_type: string;
287
-
(** MIME type of the image (e.g., "image/png", "image/jpeg", "image/gif", "image/svg+xml").
288
-
This field is required and must accurately represent the image format to ensure
289
-
proper handling by clients. *)
290
-
annotations: Annotated.annotation option;
291
-
(** Optional annotations for audience targeting and priority.
292
-
Annotations can restrict content visibility to specific roles (user/assistant)
293
-
and indicate relative importance of different content elements. *)
294
-
}
295
+
Common mime types include image/png, image/jpeg, image/gif, and
296
+
image/svg+xml. *)
297
+
295
298
include Json.Jsonable.S with type t := t
296
299
end
297
300
298
301
(** Audio content - Sound data representation in MCP *)
299
302
module AudioContent : sig
303
+
type t = {
304
+
data : string;
305
+
(** Base64-encoded audio data. All binary audio data must be encoded
306
+
using standard base64 encoding (RFC 4648) to safely transmit within
307
+
JSON. *)
308
+
mime_type : string;
309
+
(** MIME type of the audio (e.g., "audio/wav", "audio/mp3", "audio/ogg",
310
+
"audio/mpeg"). This field is required and must accurately represent
311
+
the audio format to ensure proper handling by clients. *)
312
+
annotations : Annotated.annotation option;
313
+
(** Optional annotations for audience targeting and priority.
314
+
Annotations can restrict content visibility to specific roles
315
+
(user/assistant) and indicate relative importance of different
316
+
content elements. *)
317
+
}
300
318
(** AudioContent enables including audio information in MCP messages,
301
319
supporting multimodal interactions where audio context is important.
302
-
320
+
303
321
Audio can be used in several scenarios:
304
322
- As user inputs for speech recognition or audio analysis
305
323
- As context for transcription or sound classification tasks
306
324
- As outputs from tools that generate audio samples
307
325
- As part of prompt templates with audio components
308
-
326
+
309
327
In JSON-RPC, this is represented as:
310
328
{v
311
329
{
···
314
332
"mimeType": "audio/wav"
315
333
}
316
334
v}
317
-
335
+
318
336
The data MUST be base64-encoded to ensure safe transmission in JSON.
319
-
Common mime types include audio/wav, audio/mp3, audio/ogg, and audio/mpeg. *)
320
-
type t = {
321
-
data: string;
322
-
(** Base64-encoded audio data. All binary audio data must be encoded using
323
-
standard base64 encoding (RFC 4648) to safely transmit within JSON. *)
324
-
mime_type: string;
325
-
(** MIME type of the audio (e.g., "audio/wav", "audio/mp3", "audio/ogg", "audio/mpeg").
326
-
This field is required and must accurately represent the audio format to ensure
327
-
proper handling by clients. *)
328
-
annotations: Annotated.annotation option;
329
-
(** Optional annotations for audience targeting and priority.
330
-
Annotations can restrict content visibility to specific roles (user/assistant)
331
-
and indicate relative importance of different content elements. *)
332
-
}
337
+
Common mime types include audio/wav, audio/mp3, audio/ogg, and audio/mpeg.
338
+
*)
339
+
333
340
include Json.Jsonable.S with type t := t
334
341
end
335
342
336
343
(** Base resource contents - Core resource metadata in MCP *)
337
344
module ResourceContents : sig
338
-
(** ResourceContents provides basic metadata for resources in MCP.
339
-
340
-
Resources are server-exposed data that provides context to language models,
341
-
such as files, database schemas, or application-specific information.
342
-
Each resource is uniquely identified by a URI.
343
-
344
-
The MCP resources architecture is designed to be application-driven, with
345
-
host applications determining how to incorporate context based on their needs.
346
-
347
-
In the protocol, resources are discovered via the 'resources/list' endpoint
348
-
and retrieved via the 'resources/read' endpoint. Servers that support resources
349
-
must declare the 'resources' capability during initialization. *)
350
345
type t = {
351
-
uri: string;
352
-
(** URI that uniquely identifies the resource.
353
-
354
-
Resources use standard URI schemes including:
355
-
- file:// - For filesystem-like resources
356
-
- https:// - For web-accessible resources
357
-
- git:// - For version control integration
358
-
359
-
The URI serves as a stable identifier even if the underlying content changes. *)
360
-
mime_type: string option;
361
-
(** Optional MIME type of the resource content to aid in client rendering.
362
-
Common MIME types include text/plain, application/json, image/png, etc.
363
-
For directories, the XDG MIME type inode/directory may be used. *)
346
+
uri : string;
347
+
(** URI that uniquely identifies the resource.
348
+
349
+
Resources use standard URI schemes including:
350
+
- file:// - For filesystem-like resources
351
+
- https:// - For web-accessible resources
352
+
- git:// - For version control integration
353
+
354
+
The URI serves as a stable identifier even if the underlying content
355
+
changes. *)
356
+
mime_type : string option;
357
+
(** Optional MIME type of the resource content to aid in client
358
+
rendering. Common MIME types include text/plain, application/json,
359
+
image/png, etc. For directories, the XDG MIME type inode/directory
360
+
may be used. *)
364
361
}
362
+
(** ResourceContents provides basic metadata for resources in MCP.
363
+
364
+
Resources are server-exposed data that provides context to language
365
+
models, such as files, database schemas, or application-specific
366
+
information. Each resource is uniquely identified by a URI.
367
+
368
+
The MCP resources architecture is designed to be application-driven, with
369
+
host applications determining how to incorporate context based on their
370
+
needs.
371
+
372
+
In the protocol, resources are discovered via the 'resources/list'
373
+
endpoint and retrieved via the 'resources/read' endpoint. Servers that
374
+
support resources must declare the 'resources' capability during
375
+
initialization. *)
376
+
365
377
include Json.Jsonable.S with type t := t
366
378
end
367
379
368
380
(** Text resource contents - Textual resource data *)
369
381
module TextResourceContents : sig
382
+
type t = {
383
+
uri : string;
384
+
(** URI that uniquely identifies the resource. This URI can be
385
+
referenced in subsequent requests to fetch updates. *)
386
+
text : string;
387
+
(** The actual text content of the resource as a UTF-8 encoded string.
388
+
This may be sanitized by the server to remove sensitive information.
389
+
*)
390
+
mime_type : string option;
391
+
(** Optional MIME type of the text content to aid in client rendering.
392
+
Common text MIME types include: text/plain, text/markdown,
393
+
text/x-python, application/json, text/html, text/csv, etc. *)
394
+
}
370
395
(** TextResourceContents represents a text-based resource in MCP.
371
-
396
+
372
397
Text resources are used for sharing code snippets, documentation, logs,
373
398
configuration files, and other textual information with language models.
374
-
399
+
375
400
The server handles access control and security, ensuring that only
376
401
authorized resources are shared with clients.
377
-
402
+
378
403
In JSON-RPC, this is represented as:
379
404
{v
380
405
{
···
382
407
"mimeType": "text/plain",
383
408
"text": "Resource content"
384
409
}
385
-
v}
386
-
*)
387
-
type t = {
388
-
uri: string;
389
-
(** URI that uniquely identifies the resource.
390
-
This URI can be referenced in subsequent requests to fetch updates. *)
391
-
text: string;
392
-
(** The actual text content of the resource as a UTF-8 encoded string.
393
-
This may be sanitized by the server to remove sensitive information. *)
394
-
mime_type: string option;
395
-
(** Optional MIME type of the text content to aid in client rendering.
396
-
Common text MIME types include: text/plain, text/markdown, text/x-python,
397
-
application/json, text/html, text/csv, etc. *)
398
-
}
410
+
v} *)
411
+
399
412
include Json.Jsonable.S with type t := t
400
413
end
401
414
402
415
(** Binary resource contents - Binary resource data *)
403
416
module BlobResourceContents : sig
417
+
type t = {
418
+
uri : string;
419
+
(** URI that uniquely identifies the resource. This URI can be
420
+
referenced in subsequent requests to fetch updates. *)
421
+
blob : string;
422
+
(** Base64-encoded binary data using standard base64 encoding (RFC
423
+
4648). This encoding ensures that binary data can be safely
424
+
transmitted in JSON. *)
425
+
mime_type : string option;
426
+
(** Optional MIME type of the binary content to aid in client rendering.
427
+
Common binary MIME types include: image/png, image/jpeg,
428
+
application/pdf, audio/wav, video/mp4, application/octet-stream,
429
+
etc. *)
430
+
}
404
431
(** BlobResourceContents represents a binary resource in MCP.
405
-
432
+
406
433
Binary resources allow sharing non-textual data like images, audio files,
407
-
PDFs, and other binary formats with language models that support processing
408
-
such content.
409
-
434
+
PDFs, and other binary formats with language models that support
435
+
processing such content.
436
+
410
437
In JSON-RPC, this is represented as:
411
438
{v
412
439
{
···
415
442
"blob": "base64-encoded-data"
416
443
}
417
444
v}
418
-
419
-
Binary data MUST be properly base64-encoded to ensure safe transmission
420
-
in JSON payloads. *)
421
-
type t = {
422
-
uri: string;
423
-
(** URI that uniquely identifies the resource.
424
-
This URI can be referenced in subsequent requests to fetch updates. *)
425
-
blob: string;
426
-
(** Base64-encoded binary data using standard base64 encoding (RFC 4648).
427
-
This encoding ensures that binary data can be safely transmitted in JSON. *)
428
-
mime_type: string option;
429
-
(** Optional MIME type of the binary content to aid in client rendering.
430
-
Common binary MIME types include: image/png, image/jpeg, application/pdf,
431
-
audio/wav, video/mp4, application/octet-stream, etc. *)
432
-
}
445
+
446
+
Binary data MUST be properly base64-encoded to ensure safe transmission in
447
+
JSON payloads. *)
448
+
433
449
include Json.Jsonable.S with type t := t
434
450
end
435
451
436
452
(** Embedded resource - Resource included directly in messages *)
437
453
module EmbeddedResource : sig
438
-
(** EmbeddedResource allows referencing server-side resources directly
439
-
in MCP messages, enabling seamless incorporation of managed content.
440
-
454
+
type t = {
455
+
resource :
456
+
[ `Text of TextResourceContents.t | `Blob of BlobResourceContents.t ];
457
+
(** The resource content, either as text or binary blob. *)
458
+
annotations : Annotated.annotation option;
459
+
(** Optional annotations for audience targeting and priority.
460
+
Annotations can restrict resource visibility to specific roles
461
+
(user/assistant) and indicate relative importance of different
462
+
content elements. *)
463
+
}
464
+
(** EmbeddedResource allows referencing server-side resources directly in MCP
465
+
messages, enabling seamless incorporation of managed content.
466
+
441
467
Embedded resources can be included in:
442
468
- Tool results to provide rich context
443
469
- Prompt templates to include reference materials
444
470
- Messages to provide additional context to language models
445
-
471
+
446
472
In contrast to direct content (TextContent, ImageContent, AudioContent),
447
-
embedded resources have the advantage of being persistently stored on the server
448
-
with a stable URI, allowing later retrieval and updates through the resources API.
449
-
450
-
For example, a tool might return an embedded resource containing a chart or
451
-
a large dataset that the client can later reference or update. *)
452
-
type t = {
453
-
resource: [ `Text of TextResourceContents.t | `Blob of BlobResourceContents.t ];
454
-
(** The resource content, either as text or binary blob. *)
455
-
annotations: Annotated.annotation option;
456
-
(** Optional annotations for audience targeting and priority.
457
-
Annotations can restrict resource visibility to specific roles (user/assistant)
458
-
and indicate relative importance of different content elements. *)
459
-
}
473
+
embedded resources have the advantage of being persistently stored on the
474
+
server with a stable URI, allowing later retrieval and updates through the
475
+
resources API.
476
+
477
+
For example, a tool might return an embedded resource containing a chart
478
+
or a large dataset that the client can later reference or update. *)
479
+
460
480
include Json.Jsonable.S with type t := t
461
481
end
462
482
463
-
(** Content type used in messages - Unified multimodal content representation in MCP *)
464
-
type content =
465
-
| Text of TextContent.t (** Text content for natural language messages. This is the most common content type for user-assistant interactions. *)
466
-
| Image of ImageContent.t (** Image content for visual data. Used for sharing visual context in multimodal conversations. *)
467
-
| Audio of AudioContent.t (** Audio content for audio data. Used for sharing audio context in multimodal conversations. *)
468
-
| Resource of EmbeddedResource.t (** Resource content for referencing server-side resources. Used for incorporating managed server content with stable URIs. *)
483
+
(** Content type used in messages - Unified multimodal content representation in
484
+
MCP *)
485
+
type content =
486
+
| Text of TextContent.t
487
+
(** Text content for natural language messages. This is the most common
488
+
content type for user-assistant interactions. *)
489
+
| Image of ImageContent.t
490
+
(** Image content for visual data. Used for sharing visual context in
491
+
multimodal conversations. *)
492
+
| Audio of AudioContent.t
493
+
(** Audio content for audio data. Used for sharing audio context in
494
+
multimodal conversations. *)
495
+
| Resource of EmbeddedResource.t
496
+
(** Resource content for referencing server-side resources. Used for
497
+
incorporating managed server content with stable URIs. *)
469
498
470
-
(** Convert content to Yojson representation
471
-
@param content The content to convert
472
-
@return JSON representation of the content
473
-
*)
474
499
val yojson_of_content : content -> Json.t
500
+
(** Convert content to Yojson representation
501
+
@param content The content to convert
502
+
@return JSON representation of the content *)
475
503
476
-
(** Convert Yojson representation to content
477
-
@param json JSON representation of content
478
-
@return Parsed content object
479
-
*)
480
504
val content_of_yojson : Json.t -> content
505
+
(** Convert Yojson representation to content
506
+
@param json JSON representation of content
507
+
@return Parsed content object *)
481
508
482
509
(** Message for prompts - Template messages in the MCP prompts feature *)
483
510
module PromptMessage : sig
484
-
(** PromptMessage represents a message in an MCP prompt template,
485
-
containing a role and content which can be customized with arguments.
486
-
511
+
type t = {
512
+
role : Role.t;
513
+
(** The role of the message sender (user or assistant). Prompt templates
514
+
typically alternate between user and assistant messages to create a
515
+
conversation structure. *)
516
+
content : content;
517
+
(** The message content, which can be text, image, audio, or resource.
518
+
This unified content type supports rich multimodal prompts. *)
519
+
}
520
+
(** PromptMessage represents a message in an MCP prompt template, containing a
521
+
role and content which can be customized with arguments.
522
+
487
523
Prompt messages are part of prompt templates exposed by servers through
488
524
the prompts/get endpoint. They define structured conversation templates
489
525
that can be instantiated with user-provided arguments.
490
-
491
-
The prompt feature is designed to be user-controlled, with prompts typically
492
-
exposed through UI elements like slash commands that users can explicitly select.
493
-
526
+
527
+
The prompt feature is designed to be user-controlled, with prompts
528
+
typically exposed through UI elements like slash commands that users can
529
+
explicitly select.
530
+
494
531
In JSON-RPC, prompt messages are represented as:
495
532
{v
496
533
{
···
501
538
}
502
539
}
503
540
v}
504
-
541
+
505
542
Where $code would be replaced with a user-provided argument. *)
506
-
type t = {
507
-
role: Role.t;
508
-
(** The role of the message sender (user or assistant).
509
-
Prompt templates typically alternate between user and assistant messages
510
-
to create a conversation structure. *)
511
-
content: content;
512
-
(** The message content, which can be text, image, audio, or resource.
513
-
This unified content type supports rich multimodal prompts. *)
514
-
}
543
+
515
544
include Json.Jsonable.S with type t := t
516
545
end
517
546
518
547
(** Message for sampling - Messages used in LLM completion requests *)
519
548
module SamplingMessage : sig
520
-
(** SamplingMessage represents a message in an MCP sampling request,
521
-
used for AI model generation based on a prompt.
522
-
549
+
type t = {
550
+
role : Role.t;
551
+
(** The role of the message sender (user or assistant). Typically, a
552
+
sampling request will contain multiple messages representing a
553
+
conversation history, with alternating roles. *)
554
+
content :
555
+
[ `Text of TextContent.t
556
+
| `Image of ImageContent.t
557
+
| `Audio of AudioContent.t ];
558
+
(** The message content, restricted to text, image, or audio (no
559
+
resources). Resources are not included since sampling messages
560
+
represent the actual context window for the LLM, not template
561
+
definitions. *)
562
+
}
563
+
(** SamplingMessage represents a message in an MCP sampling request, used for
564
+
AI model generation based on a prompt.
565
+
523
566
The sampling feature allows clients to expose language model capabilities
524
567
to servers, enabling servers to request completions from the client's LLM.
525
568
This is effectively the reverse of the normal MCP flow, with the server
526
569
requesting generative capabilities from the client.
527
-
570
+
528
571
Sampling messages differ from prompt messages in that they don't support
529
-
embedded resources, as they represent the actual context window being
530
-
sent to the LLM rather than template definitions.
531
-
572
+
embedded resources, as they represent the actual context window being sent
573
+
to the LLM rather than template definitions.
574
+
532
575
Clients that support sampling must declare the 'sampling' capability
533
576
during initialization. *)
534
-
type t = {
535
-
role: Role.t;
536
-
(** The role of the message sender (user or assistant).
537
-
Typically, a sampling request will contain multiple messages
538
-
representing a conversation history, with alternating roles. *)
539
-
content: [ `Text of TextContent.t | `Image of ImageContent.t | `Audio of AudioContent.t ];
540
-
(** The message content, restricted to text, image, or audio (no resources).
541
-
Resources are not included since sampling messages represent the
542
-
actual context window for the LLM, not template definitions. *)
543
-
}
577
+
544
578
include Json.Jsonable.S with type t := t
545
579
end
546
580
547
581
(** Implementation information *)
548
582
module Implementation : sig
583
+
type t = {
584
+
name : string; (** Name of the implementation *)
585
+
version : string; (** Version of the implementation *)
586
+
}
549
587
(** Implementation provides metadata about client and server implementations,
550
588
used during the initialization phase to identify each party. *)
551
-
type t = {
552
-
name: string;
553
-
(** Name of the implementation *)
554
-
version: string;
555
-
(** Version of the implementation *)
556
-
}
589
+
557
590
include Json.Jsonable.S with type t := t
558
591
end
559
592
560
593
(** JSONRPC message types - Core message protocol for MCP
561
594
562
-
MCP uses JSON-RPC 2.0 as its underlying messaging protocol.
563
-
All MCP messages are encoded as JSON-RPC 2.0 messages with UTF-8 encoding,
564
-
following the standard JSON-RPC message formats with some MCP-specific extensions.
565
-
566
-
MCP defines four message types:
567
-
1. Notifications: One-way messages that don't expect a response
568
-
2. Requests: Messages that expect a corresponding response
569
-
3. Responses: Replies to requests with successful results
570
-
4. Errors: Replies to requests with error information
571
-
595
+
MCP uses JSON-RPC 2.0 as its underlying messaging protocol. All MCP messages
596
+
are encoded as JSON-RPC 2.0 messages with UTF-8 encoding, following the
597
+
standard JSON-RPC message formats with some MCP-specific extensions.
598
+
599
+
MCP defines four message types: 1. Notifications: One-way messages that
600
+
don't expect a response 2. Requests: Messages that expect a corresponding
601
+
response 3. Responses: Replies to requests with successful results 4.
602
+
Errors: Replies to requests with error information
603
+
572
604
These can be transported over multiple transport mechanisms:
573
605
- stdio: Communication over standard input/output
574
606
- Streamable HTTP: HTTP POST/GET with SSE for server streaming
575
607
- Custom transports: Implementation-specific transports
576
-
577
-
Messages may be sent individually or as part of a JSON-RPC batch.
578
-
*)
608
+
609
+
Messages may be sent individually or as part of a JSON-RPC batch. *)
579
610
module JSONRPCMessage : sig
580
-
(** Notification represents a JSON-RPC notification (one-way message without a response).
581
-
611
+
type notification = {
612
+
meth : Method.t;
613
+
(** Method for the notification, using the Method.t type to ensure type
614
+
safety. Examples: Method.Initialized, Method.ResourcesUpdated *)
615
+
params : Json.t option;
616
+
(** Optional parameters for the notification as arbitrary JSON. The
617
+
structure depends on the specific notification method. *)
618
+
}
619
+
(** Notification represents a JSON-RPC notification (one-way message without a
620
+
response).
621
+
582
622
Notifications are used for events that don't require a response, such as:
583
623
- The 'initialized' notification completing initialization
584
624
- Resource change notifications
585
625
- Progress updates for long-running operations
586
626
- List changed notifications for tools, resources, and prompts
587
-
627
+
588
628
In JSON-RPC, notifications are identified by the absence of an 'id' field:
589
629
{v
590
630
{
···
594
634
"uri": "file:///project/src/main.rs"
595
635
}
596
636
}
597
-
v}
598
-
*)
599
-
type notification = {
600
-
meth: Method.t;
601
-
(** Method for the notification, using the Method.t type to ensure type safety.
602
-
Examples: Method.Initialized, Method.ResourcesUpdated *)
603
-
params: Json.t option;
604
-
(** Optional parameters for the notification as arbitrary JSON.
605
-
The structure depends on the specific notification method. *)
606
-
}
637
+
v} *)
607
638
639
+
type request = {
640
+
id : RequestId.t;
641
+
(** Unique identifier for the request, which will be echoed in the
642
+
response. This can be a string or integer and should be unique
643
+
within the session. *)
644
+
meth : Method.t;
645
+
(** Method for the request, using the Method.t type to ensure type
646
+
safety. Examples: Method.Initialize, Method.ResourcesRead,
647
+
Method.ToolsCall *)
648
+
params : Json.t option;
649
+
(** Optional parameters for the request as arbitrary JSON. The structure
650
+
depends on the specific request method. *)
651
+
progress_token : ProgressToken.t option;
652
+
(** Optional progress token for long-running operations. If provided,
653
+
the server can send progress notifications using this token to
654
+
inform the client about the operation's status. *)
655
+
}
608
656
(** Request represents a JSON-RPC request that expects a response.
609
-
657
+
610
658
Requests are used for operations that require a response, such as:
611
659
- Initialization
612
660
- Listing resources, tools, or prompts
613
661
- Reading resources
614
662
- Calling tools
615
663
- Getting prompts
616
-
617
-
In JSON-RPC, requests include an 'id' field that correlates with the response:
664
+
665
+
In JSON-RPC, requests include an 'id' field that correlates with the
666
+
response:
618
667
{v
619
668
{
620
669
"jsonrpc": "2.0",
···
624
673
"uri": "file:///project/src/main.rs"
625
674
}
626
675
}
627
-
v}
628
-
*)
629
-
type request = {
630
-
id: RequestId.t;
631
-
(** Unique identifier for the request, which will be echoed in the response.
632
-
This can be a string or integer and should be unique within the session. *)
633
-
meth: Method.t;
634
-
(** Method for the request, using the Method.t type to ensure type safety.
635
-
Examples: Method.Initialize, Method.ResourcesRead, Method.ToolsCall *)
636
-
params: Json.t option;
637
-
(** Optional parameters for the request as arbitrary JSON.
638
-
The structure depends on the specific request method. *)
639
-
progress_token: ProgressToken.t option;
640
-
(** Optional progress token for long-running operations.
641
-
If provided, the server can send progress notifications using this token
642
-
to inform the client about the operation's status. *)
643
-
}
676
+
v} *)
644
677
678
+
type response = {
679
+
id : RequestId.t;
680
+
(** ID matching the original request, allowing clients to correlate
681
+
responses with their originating requests, especially important when
682
+
multiple requests are in flight. *)
683
+
result : Json.t;
684
+
(** Result of the successful request as arbitrary JSON. The structure
685
+
depends on the specific request method that was called. *)
686
+
}
645
687
(** Response represents a successful JSON-RPC response to a request.
646
-
688
+
647
689
Responses are sent in reply to requests and contain the successful result.
648
690
Each response must include the same ID as its corresponding request.
649
-
691
+
650
692
In JSON-RPC, responses include the 'id' field matching the request:
651
693
{v
652
694
{
···
662
704
]
663
705
}
664
706
}
665
-
v}
666
-
*)
667
-
type response = {
668
-
id: RequestId.t;
669
-
(** ID matching the original request, allowing clients to correlate
670
-
responses with their originating requests, especially important
671
-
when multiple requests are in flight. *)
672
-
result: Json.t;
673
-
(** Result of the successful request as arbitrary JSON.
674
-
The structure depends on the specific request method that was called. *)
675
-
}
707
+
v} *)
676
708
709
+
type error = {
710
+
id : RequestId.t;
711
+
(** ID matching the original request, allowing clients to correlate
712
+
errors with their originating requests. *)
713
+
code : int;
714
+
(** Error code indicating the type of error, following the JSON-RPC
715
+
standard. Common codes include:
716
+
- -32700: Parse error
717
+
- -32600: Invalid request
718
+
- -32601: Method not found
719
+
- -32602: Invalid params
720
+
- -32603: Internal error
721
+
- -32002: Resource not found (MCP-specific)
722
+
- -32001: Authentication required (MCP-specific) *)
723
+
message : string;
724
+
(** Human-readable error message describing the issue. This should be
725
+
concise but informative enough for debugging. *)
726
+
data : Json.t option;
727
+
(** Optional additional error data as arbitrary JSON. This can provide
728
+
more context about the error, such as which resource wasn't found or
729
+
which parameter was invalid. *)
730
+
}
677
731
(** Error represents an error response to a JSON-RPC request.
678
-
679
-
Errors are sent in reply to requests when processing fails.
680
-
Each error must include the same ID as its corresponding request.
681
-
732
+
733
+
Errors are sent in reply to requests when processing fails. Each error
734
+
must include the same ID as its corresponding request.
735
+
682
736
MCP defines several standard error codes:
683
737
- Standard JSON-RPC errors (-32700 to -32603)
684
738
- MCP-specific errors (-32002 for resource not found, etc.)
685
-
739
+
686
740
In JSON-RPC, errors follow this structure:
687
741
{v
688
742
{
···
696
750
}
697
751
}
698
752
}
699
-
v}
700
-
*)
701
-
type error = {
702
-
id: RequestId.t;
703
-
(** ID matching the original request, allowing clients to correlate
704
-
errors with their originating requests. *)
705
-
code: int;
706
-
(** Error code indicating the type of error, following the JSON-RPC standard.
707
-
Common codes include:
708
-
- -32700: Parse error
709
-
- -32600: Invalid request
710
-
- -32601: Method not found
711
-
- -32602: Invalid params
712
-
- -32603: Internal error
713
-
- -32002: Resource not found (MCP-specific)
714
-
- -32001: Authentication required (MCP-specific) *)
715
-
message: string;
716
-
(** Human-readable error message describing the issue.
717
-
This should be concise but informative enough for debugging. *)
718
-
data: Json.t option;
719
-
(** Optional additional error data as arbitrary JSON.
720
-
This can provide more context about the error, such as which
721
-
resource wasn't found or which parameter was invalid. *)
722
-
}
753
+
v} *)
723
754
724
-
(** Union type for all JSON-RPC message kinds, providing a single type
725
-
that can represent any MCP message. *)
755
+
(** Union type for all JSON-RPC message kinds, providing a single type that
756
+
can represent any MCP message. *)
726
757
type t =
727
758
| Notification of notification
728
759
| Request of request
729
760
| Response of response
730
761
| Error of error
731
762
732
-
(** Convert notification to Yojson representation
733
-
@param notification The notification to convert
734
-
@return JSON representation of the notification
735
-
*)
736
763
val yojson_of_notification : notification -> Json.t
737
-
738
-
(** Convert request to Yojson representation
739
-
@param request The request to convert
740
-
@return JSON representation of the request
741
-
*)
764
+
(** Convert notification to Yojson representation
765
+
@param notification The notification to convert
766
+
@return JSON representation of the notification *)
767
+
742
768
val yojson_of_request : request -> Json.t
743
-
744
-
(** Convert response to Yojson representation
745
-
@param response The response to convert
746
-
@return JSON representation of the response
747
-
*)
769
+
(** Convert request to Yojson representation
770
+
@param request The request to convert
771
+
@return JSON representation of the request *)
772
+
748
773
val yojson_of_response : response -> Json.t
749
-
750
-
(** Convert error to Yojson representation
751
-
@param error The error to convert
752
-
@return JSON representation of the error
753
-
*)
774
+
(** Convert response to Yojson representation
775
+
@param response The response to convert
776
+
@return JSON representation of the response *)
777
+
754
778
val yojson_of_error : error -> Json.t
755
-
756
-
(** Convert any message to Yojson representation
757
-
@param message The message to convert
758
-
@return JSON representation of the message
759
-
*)
779
+
(** Convert error to Yojson representation
780
+
@param error The error to convert
781
+
@return JSON representation of the error *)
782
+
760
783
val yojson_of_t : t -> Json.t
784
+
(** Convert any message to Yojson representation
785
+
@param message The message to convert
786
+
@return JSON representation of the message *)
761
787
762
-
(** Convert Yojson representation to notification
788
+
val notification_of_yojson : Json.t -> notification
789
+
(** Convert Yojson representation to notification
763
790
@param json JSON representation of a notification
764
791
@return Parsed notification object
765
-
@raise Parse error if the JSON is not a valid notification
766
-
*)
767
-
val notification_of_yojson : Json.t -> notification
768
-
769
-
(** Convert Yojson representation to request
792
+
@raise Parse error if the JSON is not a valid notification *)
793
+
794
+
val request_of_yojson : Json.t -> request
795
+
(** Convert Yojson representation to request
770
796
@param json JSON representation of a request
771
797
@return Parsed request object
772
-
@raise Parse error if the JSON is not a valid request
773
-
*)
774
-
val request_of_yojson : Json.t -> request
775
-
776
-
(** Convert Yojson representation to response
798
+
@raise Parse error if the JSON is not a valid request *)
799
+
800
+
val response_of_yojson : Json.t -> response
801
+
(** Convert Yojson representation to response
777
802
@param json JSON representation of a response
778
803
@return Parsed response object
779
-
@raise Parse error if the JSON is not a valid response
780
-
*)
781
-
val response_of_yojson : Json.t -> response
782
-
783
-
(** Convert Yojson representation to error
804
+
@raise Parse error if the JSON is not a valid response *)
805
+
806
+
val error_of_yojson : Json.t -> error
807
+
(** Convert Yojson representation to error
784
808
@param json JSON representation of an error
785
809
@return Parsed error object
786
-
@raise Parse error if the JSON is not a valid error
787
-
*)
788
-
val error_of_yojson : Json.t -> error
789
-
790
-
(** Convert Yojson representation to any message
810
+
@raise Parse error if the JSON is not a valid error *)
811
+
812
+
val t_of_yojson : Json.t -> t
813
+
(** Convert Yojson representation to any message
791
814
@param json JSON representation of any message type
792
815
@return Parsed message object
793
-
@raise Parse error if the JSON is not a valid message
794
-
*)
795
-
val t_of_yojson : Json.t -> t
816
+
@raise Parse error if the JSON is not a valid message *)
796
817
818
+
val create_notification : ?params:Json.t option -> meth:Method.t -> unit -> t
797
819
(** Create a new notification message
798
820
@param params Optional parameters for the notification
799
821
@param meth Method name for the notification
800
-
@return A new JSON-RPC notification message
801
-
*)
802
-
val create_notification : ?params:Json.t option -> meth:Method.t -> unit -> t
803
-
822
+
@return A new JSON-RPC notification message *)
823
+
824
+
val create_request :
825
+
?params:Json.t option ->
826
+
?progress_token:ProgressToken.t option ->
827
+
id:RequestId.t ->
828
+
meth:Method.t ->
829
+
unit ->
830
+
t
804
831
(** Create a new request message
805
832
@param params Optional parameters for the request
806
833
@param progress_token Optional progress token for long-running operations
807
834
@param id Unique identifier for the request
808
835
@param meth Method name for the request
809
-
@return A new JSON-RPC request message
810
-
*)
811
-
val create_request : ?params:Json.t option -> ?progress_token:ProgressToken.t option -> id:RequestId.t -> meth:Method.t -> unit -> t
812
-
836
+
@return A new JSON-RPC request message *)
837
+
838
+
val create_response : id:RequestId.t -> result:Json.t -> t
813
839
(** Create a new response message
814
840
@param id ID matching the original request
815
841
@param result Result of the successful request
816
-
@return A new JSON-RPC response message
817
-
*)
818
-
val create_response : id:RequestId.t -> result:Json.t -> t
819
-
842
+
@return A new JSON-RPC response message *)
843
+
844
+
val create_error :
845
+
id:RequestId.t ->
846
+
code:int ->
847
+
message:string ->
848
+
?data:Json.t option ->
849
+
unit ->
850
+
t
820
851
(** Create a new error message
821
852
@param id ID matching the original request
822
853
@param code Error code indicating the type of error
823
854
@param message Human-readable error message
824
855
@param data Optional additional error data
825
-
@return A new JSON-RPC error message
826
-
*)
827
-
val create_error : id:RequestId.t -> code:int -> message:string -> ?data:Json.t option -> unit -> t
856
+
@return A new JSON-RPC error message *)
828
857
end
829
858
830
-
(** Initialize request/response - The first phase of the MCP lifecycle
831
-
832
-
The initialization phase is the mandatory first interaction between client and server.
833
-
During this phase, the protocol version is negotiated and capabilities are exchanged
834
-
to determine which optional features will be available during the session.
835
-
836
-
This follows a strict sequence:
837
-
1. Client sends an InitializeRequest containing its capabilities and protocol version
838
-
2. Server responds with an InitializeResult containing its capabilities and protocol version
839
-
3. Client sends an InitializedNotification to signal it's ready for normal operations
840
-
841
-
The Initialize module handles steps 1 and 2 of this process.
842
-
*)
859
+
(** Initialize request/response - The first phase of the MCP lifecycle
860
+
861
+
The initialization phase is the mandatory first interaction between client
862
+
and server. During this phase, the protocol version is negotiated and
863
+
capabilities are exchanged to determine which optional features will be
864
+
available during the session.
865
+
866
+
This follows a strict sequence: 1. Client sends an InitializeRequest
867
+
containing its capabilities and protocol version 2. Server responds with an
868
+
InitializeResult containing its capabilities and protocol version 3. Client
869
+
sends an InitializedNotification to signal it's ready for normal operations
870
+
871
+
The Initialize module handles steps 1 and 2 of this process. *)
843
872
module Initialize : sig
844
873
(** Initialize request *)
845
874
module Request : sig
846
-
(** InitializeRequest starts the MCP lifecycle, negotiating capabilities
847
-
and protocol versions between client and server. This is always the first
848
-
message sent by the client and MUST NOT be part of a JSON-RPC batch.
849
-
850
-
The client SHOULD send the latest protocol version it supports. If the server
851
-
does not support this version, it will respond with a version it does support,
852
-
and the client must either use that version or disconnect. *)
853
875
type t = {
854
-
capabilities: Json.t; (** ClientCapabilities that define supported optional features.
855
-
This includes which optional protocol features the client supports,
856
-
such as 'roots' (filesystem access), 'sampling' (LLM generation),
857
-
and any experimental features. *)
858
-
client_info: Implementation.t;
859
-
(** Client implementation details (name and version) used for identification
860
-
and debugging. Helps servers understand which client they're working with. *)
861
-
protocol_version: string;
862
-
(** MCP protocol version supported by the client, formatted as YYYY-MM-DD
863
-
according to the MCP versioning scheme. Example: "2025-03-26" *)
876
+
capabilities : Json.t;
877
+
(** ClientCapabilities that define supported optional features. This
878
+
includes which optional protocol features the client supports,
879
+
such as 'roots' (filesystem access), 'sampling' (LLM generation),
880
+
and any experimental features. *)
881
+
client_info : Implementation.t;
882
+
(** Client implementation details (name and version) used for
883
+
identification and debugging. Helps servers understand which
884
+
client they're working with. *)
885
+
protocol_version : string;
886
+
(** MCP protocol version supported by the client, formatted as
887
+
YYYY-MM-DD according to the MCP versioning scheme. Example:
888
+
"2025-03-26" *)
864
889
}
890
+
(** InitializeRequest starts the MCP lifecycle, negotiating capabilities and
891
+
protocol versions between client and server. This is always the first
892
+
message sent by the client and MUST NOT be part of a JSON-RPC batch.
893
+
894
+
The client SHOULD send the latest protocol version it supports. If the
895
+
server does not support this version, it will respond with a version it
896
+
does support, and the client must either use that version or disconnect.
897
+
*)
898
+
865
899
include Json.Jsonable.S with type t := t
866
900
901
+
val create :
902
+
capabilities:Json.t ->
903
+
client_info:Implementation.t ->
904
+
protocol_version:string ->
905
+
t
867
906
(** Create a new initialization request
868
-
@param capabilities Client capabilities that define supported optional features
907
+
@param capabilities
908
+
Client capabilities that define supported optional features
869
909
@param client_info Client implementation details
870
910
@param protocol_version MCP protocol version supported by the client
871
-
@return A new initialization request
872
-
*)
873
-
val create : capabilities:Json.t -> client_info:Implementation.t -> protocol_version:string -> t
874
-
911
+
@return A new initialization request *)
912
+
913
+
val to_jsonrpc : id:RequestId.t -> t -> JSONRPCMessage.t
875
914
(** Convert to JSON-RPC message
876
915
@param id Unique request identifier
877
916
@param t Initialization request
878
-
@return JSON-RPC message containing the initialization request
879
-
*)
880
-
val to_jsonrpc : id:RequestId.t -> t -> JSONRPCMessage.t
917
+
@return JSON-RPC message containing the initialization request *)
881
918
end
882
919
883
920
(** Initialize result *)
884
921
module Result : sig
885
-
(** InitializeResult is the server's response to an initialization request,
886
-
completing capability negotiation and establishing the protocol version.
887
-
888
-
After receiving this message, the client must send an InitializedNotification.
889
-
The server should not send any requests other than pings and logging before
890
-
receiving the initialized notification. *)
891
922
type t = {
892
-
capabilities: Json.t; (** ServerCapabilities that define supported optional features.
893
-
This declares which server features are available, including:
894
-
- prompts: Server provides prompt templates
895
-
- resources: Server provides readable resources
896
-
- tools: Server exposes callable tools
897
-
- logging: Server emits structured log messages
898
-
899
-
Each capability may have sub-capabilities like:
900
-
- listChanged: Server will notify when available items change
901
-
- subscribe: Clients can subscribe to individual resources *)
902
-
server_info: Implementation.t;
903
-
(** Server implementation details (name and version) used for identification
904
-
and debugging. Helps clients understand which server they're working with. *)
905
-
protocol_version: string;
906
-
(** MCP protocol version supported by the server, formatted as YYYY-MM-DD.
907
-
If the server supports the client's requested version, it responds with
908
-
the same version. Otherwise, it responds with a version it does support. *)
909
-
instructions: string option;
910
-
(** Optional instructions for using the server. These can provide human-readable
911
-
guidance on how to interact with this specific server implementation. *)
912
-
meta: Json.t option;
913
-
(** Optional additional metadata as arbitrary JSON. Can contain server-specific
914
-
information not covered by the standard fields. *)
923
+
capabilities : Json.t;
924
+
(** ServerCapabilities that define supported optional features. This
925
+
declares which server features are available, including:
926
+
- prompts: Server provides prompt templates
927
+
- resources: Server provides readable resources
928
+
- tools: Server exposes callable tools
929
+
- logging: Server emits structured log messages
930
+
931
+
Each capability may have sub-capabilities like:
932
+
- listChanged: Server will notify when available items change
933
+
- subscribe: Clients can subscribe to individual resources *)
934
+
server_info : Implementation.t;
935
+
(** Server implementation details (name and version) used for
936
+
identification and debugging. Helps clients understand which
937
+
server they're working with. *)
938
+
protocol_version : string;
939
+
(** MCP protocol version supported by the server, formatted as
940
+
YYYY-MM-DD. If the server supports the client's requested version,
941
+
it responds with the same version. Otherwise, it responds with a
942
+
version it does support. *)
943
+
instructions : string option;
944
+
(** Optional instructions for using the server. These can provide
945
+
human-readable guidance on how to interact with this specific
946
+
server implementation. *)
947
+
meta : Json.t option;
948
+
(** Optional additional metadata as arbitrary JSON. Can contain
949
+
server-specific information not covered by the standard fields. *)
915
950
}
951
+
(** InitializeResult is the server's response to an initialization request,
952
+
completing capability negotiation and establishing the protocol version.
953
+
954
+
After receiving this message, the client must send an
955
+
InitializedNotification. The server should not send any requests other
956
+
than pings and logging before receiving the initialized notification. *)
957
+
916
958
include Json.Jsonable.S with type t := t
917
959
960
+
val create :
961
+
capabilities:Json.t ->
962
+
server_info:Implementation.t ->
963
+
protocol_version:string ->
964
+
?instructions:string ->
965
+
?meta:Json.t ->
966
+
unit ->
967
+
t
918
968
(** Create a new initialization result
919
-
@param capabilities Server capabilities that define supported optional features
969
+
@param capabilities
970
+
Server capabilities that define supported optional features
920
971
@param server_info Server implementation details
921
972
@param protocol_version MCP protocol version supported by the server
922
973
@param instructions Optional instructions for using the server
923
974
@param meta Optional additional metadata
924
-
@return A new initialization result
925
-
*)
926
-
val create : capabilities:Json.t -> server_info:Implementation.t -> protocol_version:string -> ?instructions:string -> ?meta:Json.t -> unit -> t
927
-
975
+
@return A new initialization result *)
976
+
977
+
val to_jsonrpc : id:RequestId.t -> t -> JSONRPCMessage.t
928
978
(** Convert to JSON-RPC message
929
979
@param id ID matching the original request
930
980
@param t Initialization result
931
-
@return JSON-RPC message containing the initialization result
932
-
*)
933
-
val to_jsonrpc : id:RequestId.t -> t -> JSONRPCMessage.t
981
+
@return JSON-RPC message containing the initialization result *)
934
982
end
935
983
end
936
984
937
-
(** Initialized notification - Completes the initialization phase of the MCP lifecycle *)
985
+
(** Initialized notification - Completes the initialization phase of the MCP
986
+
lifecycle *)
938
987
module Initialized : sig
939
988
module Notification : sig
940
-
(** InitializedNotification is sent by the client after receiving the initialization
941
-
response, indicating it's ready to begin normal operations. This completes the
942
-
three-step initialization process, after which both client and server can
943
-
freely exchange messages according to the negotiated capabilities.
944
-
945
-
Only after this notification has been sent should the client begin normal operations
946
-
like listing resources, calling tools, or requesting prompts. *)
947
989
type t = {
948
-
meta: Json.t option;
949
-
(** Optional additional metadata as arbitrary JSON. Can contain client-specific
950
-
information not covered by the standard fields. *)
990
+
meta : Json.t option;
991
+
(** Optional additional metadata as arbitrary JSON. Can contain
992
+
client-specific information not covered by the standard fields. *)
951
993
}
994
+
(** InitializedNotification is sent by the client after receiving the
995
+
initialization response, indicating it's ready to begin normal
996
+
operations. This completes the three-step initialization process, after
997
+
which both client and server can freely exchange messages according to
998
+
the negotiated capabilities.
999
+
1000
+
Only after this notification has been sent should the client begin
1001
+
normal operations like listing resources, calling tools, or requesting
1002
+
prompts. *)
1003
+
952
1004
include Json.Jsonable.S with type t := t
953
1005
1006
+
val create : ?meta:Json.t -> unit -> t
954
1007
(** Create a new initialized notification
955
1008
@param meta Optional additional metadata
956
-
@return A new initialized notification
957
-
*)
958
-
val create : ?meta:Json.t -> unit -> t
959
-
1009
+
@return A new initialized notification *)
1010
+
1011
+
val to_jsonrpc : t -> JSONRPCMessage.t
960
1012
(** Convert to JSON-RPC message
961
1013
@param t Initialized notification
962
-
@return JSON-RPC message containing the initialized notification
963
-
*)
964
-
val to_jsonrpc : t -> JSONRPCMessage.t
1014
+
@return JSON-RPC message containing the initialized notification *)
965
1015
end
966
1016
end
967
1017
968
-
(** Parse a JSON message into an MCP message
969
-
970
-
This function takes a raw JSON value and parses it into a structured MCP message.
971
-
It's the primary entry point for processing incoming JSON-RPC messages in the MCP protocol.
972
-
973
-
The function determines the message type (notification, request, response, or error)
974
-
based on the presence and values of specific fields:
1018
+
val parse_message : Json.t -> JSONRPCMessage.t
1019
+
(** Parse a JSON message into an MCP message
1020
+
1021
+
This function takes a raw JSON value and parses it into a structured MCP
1022
+
message. It's the primary entry point for processing incoming JSON-RPC
1023
+
messages in the MCP protocol.
1024
+
1025
+
The function determines the message type (notification, request, response,
1026
+
or error) based on the presence and values of specific fields:
975
1027
- A message with "method" but no "id" is a notification
976
1028
- A message with "method" and "id" is a request
977
1029
- A message with "id" and "result" is a response
978
1030
- A message with "id" and "error" is an error
979
-
980
-
@param json The JSON message to parse, typically received from the transport layer
1031
+
1032
+
@param json
1033
+
The JSON message to parse, typically received from the transport layer
981
1034
@return The parsed MCP message as a structured JSONRPCMessage.t value
982
-
@raise Parse error if the JSON cannot be parsed as a valid MCP message
983
-
*)
984
-
val parse_message : Json.t -> JSONRPCMessage.t
1035
+
@raise Parse error if the JSON cannot be parsed as a valid MCP message *)
985
1036
1037
+
val create_notification :
1038
+
?params:Json.t option -> meth:Method.t -> unit -> JSONRPCMessage.t
986
1039
(** Create a new notification message
987
-
988
-
Notifications are one-way messages that don't expect a response.
989
-
This is a convenience wrapper around JSONRPCMessage.create_notification.
990
-
1040
+
1041
+
Notifications are one-way messages that don't expect a response. This is a
1042
+
convenience wrapper around JSONRPCMessage.create_notification.
1043
+
991
1044
Common notifications in MCP include:
992
1045
- "notifications/initialized" - Sent after initialization
993
1046
- "notifications/progress" - Updates on long-running operations
994
1047
- "notifications/resources/updated" - Resource content changed
995
1048
- "notifications/prompts/list_changed" - Available prompts changed
996
1049
- "notifications/tools/list_changed" - Available tools changed
997
-
1050
+
998
1051
@param params Optional parameters for the notification as a JSON value
999
1052
@param meth Method type for the notification
1000
-
@return A new JSON-RPC notification message
1001
-
*)
1002
-
val create_notification : ?params:Json.t option -> meth:Method.t -> unit -> JSONRPCMessage.t
1053
+
@return A new JSON-RPC notification message *)
1003
1054
1055
+
val create_request :
1056
+
?params:Json.t option ->
1057
+
?progress_token:ProgressToken.t option ->
1058
+
id:RequestId.t ->
1059
+
meth:Method.t ->
1060
+
unit ->
1061
+
JSONRPCMessage.t
1004
1062
(** Create a new request message
1005
-
1006
-
Requests are messages that expect a corresponding response.
1007
-
This is a convenience wrapper around JSONRPCMessage.create_request.
1008
-
1063
+
1064
+
Requests are messages that expect a corresponding response. This is a
1065
+
convenience wrapper around JSONRPCMessage.create_request.
1066
+
1009
1067
Common requests in MCP include:
1010
1068
- "initialize" - Start the MCP lifecycle
1011
1069
- "resources/list" - Discover available resources
···
1014
1072
- "tools/call" - Invoke a tool
1015
1073
- "prompts/list" - Discover available prompts
1016
1074
- "prompts/get" - Retrieve a prompt template
1017
-
1075
+
1018
1076
@param params Optional parameters for the request as a JSON value
1019
-
@param progress_token Optional progress token for long-running operations
1020
-
that can report progress updates
1021
-
@param id Unique identifier for the request, used to correlate with the response
1077
+
@param progress_token
1078
+
Optional progress token for long-running operations that can report
1079
+
progress updates
1080
+
@param id
1081
+
Unique identifier for the request, used to correlate with the response
1022
1082
@param meth Method type for the request
1023
-
@return A new JSON-RPC request message
1024
-
*)
1025
-
val create_request : ?params:Json.t option -> ?progress_token:ProgressToken.t option -> id:RequestId.t -> meth:Method.t -> unit -> JSONRPCMessage.t
1083
+
@return A new JSON-RPC request message *)
1026
1084
1085
+
val create_response : id:RequestId.t -> result:Json.t -> JSONRPCMessage.t
1027
1086
(** Create a new response message
1028
-
1029
-
Responses are sent in reply to requests and contain successful results.
1030
-
This is a convenience wrapper around JSONRPCMessage.create_response.
1031
-
1032
-
Each response must include the same ID as its corresponding request
1033
-
to allow the client to correlate them, especially when multiple
1034
-
requests are in flight simultaneously.
1035
-
1087
+
1088
+
Responses are sent in reply to requests and contain successful results. This
1089
+
is a convenience wrapper around JSONRPCMessage.create_response.
1090
+
1091
+
Each response must include the same ID as its corresponding request to allow
1092
+
the client to correlate them, especially when multiple requests are in
1093
+
flight simultaneously.
1094
+
1036
1095
@param id ID matching the original request
1037
1096
@param result Result of the successful request as a JSON value
1038
-
@return A new JSON-RPC response message
1039
-
*)
1040
-
val create_response : id:RequestId.t -> result:Json.t -> JSONRPCMessage.t
1097
+
@return A new JSON-RPC response message *)
1041
1098
1099
+
val create_error :
1100
+
id:RequestId.t ->
1101
+
code:int ->
1102
+
message:string ->
1103
+
?data:Json.t option ->
1104
+
unit ->
1105
+
JSONRPCMessage.t
1042
1106
(** Create a new error message
1043
-
1044
-
Errors are sent in reply to requests when processing fails.
1045
-
This is a convenience wrapper around JSONRPCMessage.create_error.
1046
-
1047
-
MCP uses standard JSON-RPC error codes as well as some protocol-specific codes:
1107
+
1108
+
Errors are sent in reply to requests when processing fails. This is a
1109
+
convenience wrapper around JSONRPCMessage.create_error.
1110
+
1111
+
MCP uses standard JSON-RPC error codes as well as some protocol-specific
1112
+
codes:
1048
1113
- -32700: Parse error (invalid JSON)
1049
1114
- -32600: Invalid request (malformed JSON-RPC)
1050
1115
- -32601: Method not found
···
1052
1117
- -32603: Internal error
1053
1118
- -32002: Resource not found (MCP-specific)
1054
1119
- -32001: Authentication required (MCP-specific)
1055
-
1120
+
1056
1121
@param id ID matching the original request
1057
1122
@param code Error code indicating the type of error
1058
1123
@param message Human-readable error message describing the issue
1059
1124
@param data Optional additional error data providing more context
1060
-
@return A new JSON-RPC error message
1061
-
*)
1062
-
val create_error : id:RequestId.t -> code:int -> message:string -> ?data:Json.t option -> unit -> JSONRPCMessage.t
1125
+
@return A new JSON-RPC error message *)
1063
1126
1127
+
val make_text_content : string -> content
1064
1128
(** Create a new text content object
1065
1129
@param text The text content
1066
-
@return A content value with the text
1067
-
*)
1068
-
val make_text_content : string -> content
1130
+
@return A content value with the text *)
1069
1131
1132
+
val make_image_content : string -> string -> content
1070
1133
(** Create a new image content object
1071
1134
@param data Base64-encoded image data
1072
-
@param mime_type MIME type of the image (e.g., "image/png", "image/jpeg")
1073
-
@return A content value with the image
1074
-
*)
1075
-
val make_image_content : string -> string -> content
1135
+
@param mime_type MIME type of the image (e.g., "image/png", "image/jpeg")
1136
+
@return A content value with the image *)
1076
1137
1138
+
val make_audio_content : string -> string -> content
1077
1139
(** Create a new audio content object
1078
1140
@param data Base64-encoded audio data
1079
1141
@param mime_type MIME type of the audio (e.g., "audio/wav", "audio/mp3")
1080
-
@return A content value with the audio
1081
-
*)
1082
-
val make_audio_content : string -> string -> content
1142
+
@return A content value with the audio *)
1083
1143
1144
+
val make_resource_text_content : string -> string -> string option -> content
1084
1145
(** Create a new text resource content object
1085
1146
@param uri URI that uniquely identifies the resource
1086
1147
@param text The text content of the resource
1087
1148
@param mime_type Optional MIME type of the text content
1088
-
@return A content value with the text resource
1089
-
*)
1090
-
val make_resource_text_content : string -> string -> string option -> content
1149
+
@return A content value with the text resource *)
1091
1150
1151
+
val make_resource_blob_content : string -> string -> string option -> content
1092
1152
(** Create a new binary resource content object
1093
1153
@param uri URI that uniquely identifies the resource
1094
1154
@param blob Base64-encoded binary data
1095
1155
@param mime_type Optional MIME type of the binary content
1096
-
@return A content value with the binary resource
1097
-
*)
1098
-
val make_resource_blob_content : string -> string -> string option -> content
1156
+
@return A content value with the binary resource *)
+500
-501
lib/mcp_rpc.ml
+500
-501
lib/mcp_rpc.ml
···
6
6
(* Resources/List *)
7
7
module ResourcesList = struct
8
8
module Request = struct
9
-
type t = {
10
-
cursor: Cursor.t option;
11
-
}
12
-
9
+
type t = { cursor : Cursor.t option }
10
+
13
11
let yojson_of_t { cursor } =
14
12
let assoc = [] in
15
-
let assoc = match cursor with
13
+
let assoc =
14
+
match cursor with
16
15
| Some c -> ("cursor", Cursor.yojson_of_t c) :: assoc
17
16
| None -> assoc
18
17
in
19
18
`Assoc assoc
20
-
19
+
21
20
let t_of_yojson = function
22
21
| `Assoc fields ->
23
-
let cursor = List.assoc_opt "cursor" fields |> Option.map Cursor.t_of_yojson in
24
-
{ cursor }
22
+
let cursor =
23
+
List.assoc_opt "cursor" fields |> Option.map Cursor.t_of_yojson
24
+
in
25
+
{ cursor }
25
26
| j -> Util.json_error "Expected object for ResourcesList.Request.t" j
26
-
27
27
end
28
-
28
+
29
29
module Resource = struct
30
30
type t = {
31
-
uri: string;
32
-
name: string;
33
-
description: string option;
34
-
mime_type: string option;
35
-
size: int option;
31
+
uri : string;
32
+
name : string;
33
+
description : string option;
34
+
mime_type : string option;
35
+
size : int option;
36
36
}
37
-
37
+
38
38
let yojson_of_t { uri; name; description; mime_type; size } =
39
-
let assoc = [
40
-
("uri", `String uri);
41
-
("name", `String name);
42
-
] in
43
-
let assoc = match description with
39
+
let assoc = [ ("uri", `String uri); ("name", `String name) ] in
40
+
let assoc =
41
+
match description with
44
42
| Some desc -> ("description", `String desc) :: assoc
45
43
| None -> assoc
46
44
in
47
-
let assoc = match mime_type with
45
+
let assoc =
46
+
match mime_type with
48
47
| Some mime -> ("mimeType", `String mime) :: assoc
49
48
| None -> assoc
50
49
in
51
-
let assoc = match size with
52
-
| Some s -> ("size", `Int s) :: assoc
53
-
| None -> assoc
50
+
let assoc =
51
+
match size with Some s -> ("size", `Int s) :: assoc | None -> assoc
54
52
in
55
53
`Assoc assoc
56
-
54
+
57
55
let t_of_yojson = function
58
56
| `Assoc fields as json ->
59
-
let uri = match List.assoc_opt "uri" fields with
60
-
| Some (`String s) -> s
61
-
| _ -> Util.json_error "Missing or invalid 'uri' field" json
62
-
in
63
-
let name = match List.assoc_opt "name" fields with
64
-
| Some (`String s) -> s
65
-
| _ -> Util.json_error "Missing or invalid 'name' field" json
66
-
in
67
-
let description = List.assoc_opt "description" fields |> Option.map (function
68
-
| `String s -> s
69
-
| j -> Util.json_error "Expected string for description" j
70
-
) in
71
-
let mime_type = List.assoc_opt "mimeType" fields |> Option.map (function
72
-
| `String s -> s
73
-
| j -> Util.json_error "Expected string for mimeType" j
74
-
) in
75
-
let size = List.assoc_opt "size" fields |> Option.map (function
76
-
| `Int i -> i
77
-
| j -> Util.json_error "Expected int for size" j
78
-
) in
79
-
{ uri; name; description; mime_type; size }
57
+
let uri =
58
+
match List.assoc_opt "uri" fields with
59
+
| Some (`String s) -> s
60
+
| _ -> Util.json_error "Missing or invalid 'uri' field" json
61
+
in
62
+
let name =
63
+
match List.assoc_opt "name" fields with
64
+
| Some (`String s) -> s
65
+
| _ -> Util.json_error "Missing or invalid 'name' field" json
66
+
in
67
+
let description =
68
+
List.assoc_opt "description" fields
69
+
|> Option.map (function
70
+
| `String s -> s
71
+
| j -> Util.json_error "Expected string for description" j)
72
+
in
73
+
let mime_type =
74
+
List.assoc_opt "mimeType" fields
75
+
|> Option.map (function
76
+
| `String s -> s
77
+
| j -> Util.json_error "Expected string for mimeType" j)
78
+
in
79
+
let size =
80
+
List.assoc_opt "size" fields
81
+
|> Option.map (function
82
+
| `Int i -> i
83
+
| j -> Util.json_error "Expected int for size" j)
84
+
in
85
+
{ uri; name; description; mime_type; size }
80
86
| j -> Util.json_error "Expected object for ResourcesList.Resource.t" j
81
87
end
82
-
88
+
83
89
module Response = struct
84
-
type t = {
85
-
resources: Resource.t list;
86
-
next_cursor: Cursor.t option;
87
-
}
88
-
90
+
type t = { resources : Resource.t list; next_cursor : Cursor.t option }
91
+
89
92
let yojson_of_t { resources; next_cursor } =
90
-
let assoc = [
91
-
("resources", `List (List.map Resource.yojson_of_t resources));
92
-
] in
93
-
let assoc = match next_cursor with
93
+
let assoc =
94
+
[ ("resources", `List (List.map Resource.yojson_of_t resources)) ]
95
+
in
96
+
let assoc =
97
+
match next_cursor with
94
98
| Some c -> ("nextCursor", Cursor.yojson_of_t c) :: assoc
95
99
| None -> assoc
96
100
in
97
101
`Assoc assoc
98
-
102
+
99
103
let t_of_yojson = function
100
104
| `Assoc fields as json ->
101
-
let resources = match List.assoc_opt "resources" fields with
102
-
| Some (`List items) -> List.map Resource.t_of_yojson items
103
-
| _ -> Util.json_error "Missing or invalid 'resources' field" json
104
-
in
105
-
let next_cursor = List.assoc_opt "nextCursor" fields |> Option.map Cursor.t_of_yojson in
106
-
{ resources; next_cursor }
105
+
let resources =
106
+
match List.assoc_opt "resources" fields with
107
+
| Some (`List items) -> List.map Resource.t_of_yojson items
108
+
| _ -> Util.json_error "Missing or invalid 'resources' field" json
109
+
in
110
+
let next_cursor =
111
+
List.assoc_opt "nextCursor" fields |> Option.map Cursor.t_of_yojson
112
+
in
113
+
{ resources; next_cursor }
107
114
| j -> Util.json_error "Expected object for ResourcesList.Response.t" j
108
-
109
115
end
110
-
116
+
111
117
(* Request/response creation helpers *)
112
118
let create_request ?cursor ?id () =
113
-
let id = match id with
114
-
| Some i -> i
115
-
| None -> `Int (Random.int 10000)
116
-
in
119
+
let id = match id with Some i -> i | None -> `Int (Random.int 10000) in
117
120
let params = Request.yojson_of_t { cursor } in
118
-
JSONRPCMessage.create_request ~id ~meth:Method.ResourcesList ~params:(Some params) ()
119
-
121
+
JSONRPCMessage.create_request ~id ~meth:Method.ResourcesList
122
+
~params:(Some params) ()
123
+
120
124
let create_response ~id ~resources ?next_cursor () =
121
125
let result = Response.yojson_of_t { resources; next_cursor } in
122
126
JSONRPCMessage.create_response ~id ~result
···
124
128
125
129
(* Resources/Templates/List *)
126
130
module ListResourceTemplatesRequest = struct
127
-
type t = {
128
-
cursor: Cursor.t option;
129
-
}
130
-
131
+
type t = { cursor : Cursor.t option }
132
+
131
133
let yojson_of_t { cursor } =
132
134
let assoc = [] in
133
-
let assoc = match cursor with
135
+
let assoc =
136
+
match cursor with
134
137
| Some c -> ("cursor", Cursor.yojson_of_t c) :: assoc
135
138
| None -> assoc
136
139
in
137
140
`Assoc assoc
138
-
141
+
139
142
let t_of_yojson = function
140
143
| `Assoc fields ->
141
-
let cursor = List.assoc_opt "cursor" fields |> Option.map Cursor.t_of_yojson in
142
-
{ cursor }
143
-
| j -> Util.json_error "Expected object for ListResourceTemplatesRequest.t" j
144
-
144
+
let cursor =
145
+
List.assoc_opt "cursor" fields |> Option.map Cursor.t_of_yojson
146
+
in
147
+
{ cursor }
148
+
| j ->
149
+
Util.json_error "Expected object for ListResourceTemplatesRequest.t" j
145
150
end
146
151
147
152
(* Resources/Templates/List Response *)
148
153
module ListResourceTemplatesResult = struct
149
154
module ResourceTemplate = struct
150
155
type t = {
151
-
uri_template: string;
152
-
name: string;
153
-
description: string option;
154
-
mime_type: string option;
156
+
uri_template : string;
157
+
name : string;
158
+
description : string option;
159
+
mime_type : string option;
155
160
}
156
-
161
+
157
162
let yojson_of_t { uri_template; name; description; mime_type } =
158
-
let assoc = [
159
-
("uriTemplate", `String uri_template);
160
-
("name", `String name);
161
-
] in
162
-
let assoc = match description with
163
+
let assoc =
164
+
[ ("uriTemplate", `String uri_template); ("name", `String name) ]
165
+
in
166
+
let assoc =
167
+
match description with
163
168
| Some desc -> ("description", `String desc) :: assoc
164
169
| None -> assoc
165
170
in
166
-
let assoc = match mime_type with
171
+
let assoc =
172
+
match mime_type with
167
173
| Some mime -> ("mimeType", `String mime) :: assoc
168
174
| None -> assoc
169
175
in
170
176
`Assoc assoc
171
-
177
+
172
178
let t_of_yojson = function
173
179
| `Assoc fields as json ->
174
-
let uri_template = match List.assoc_opt "uriTemplate" fields with
175
-
| Some (`String s) -> s
176
-
| _ -> Util.json_error "Missing or invalid 'uriTemplate' field" json
177
-
in
178
-
let name = match List.assoc_opt "name" fields with
179
-
| Some (`String s) -> s
180
-
| _ -> Util.json_error "Missing or invalid 'name' field" json
181
-
in
182
-
let description = List.assoc_opt "description" fields |> Option.map (function
183
-
| `String s -> s
184
-
| j -> Util.json_error "Expected string for description" j
185
-
) in
186
-
let mime_type = List.assoc_opt "mimeType" fields |> Option.map (function
187
-
| `String s -> s
188
-
| j -> Util.json_error "Expected string for mimeType" j
189
-
) in
190
-
{ uri_template; name; description; mime_type }
191
-
| j -> Util.json_error "Expected object for ListResourceTemplatesResult.ResourceTemplate.t" j
180
+
let uri_template =
181
+
match List.assoc_opt "uriTemplate" fields with
182
+
| Some (`String s) -> s
183
+
| _ -> Util.json_error "Missing or invalid 'uriTemplate' field" json
184
+
in
185
+
let name =
186
+
match List.assoc_opt "name" fields with
187
+
| Some (`String s) -> s
188
+
| _ -> Util.json_error "Missing or invalid 'name' field" json
189
+
in
190
+
let description =
191
+
List.assoc_opt "description" fields
192
+
|> Option.map (function
193
+
| `String s -> s
194
+
| j -> Util.json_error "Expected string for description" j)
195
+
in
196
+
let mime_type =
197
+
List.assoc_opt "mimeType" fields
198
+
|> Option.map (function
199
+
| `String s -> s
200
+
| j -> Util.json_error "Expected string for mimeType" j)
201
+
in
202
+
{ uri_template; name; description; mime_type }
203
+
| j ->
204
+
Util.json_error
205
+
"Expected object for ListResourceTemplatesResult.ResourceTemplate.t"
206
+
j
192
207
end
193
-
208
+
194
209
type t = {
195
-
resource_templates: ResourceTemplate.t list;
196
-
next_cursor: Cursor.t option;
210
+
resource_templates : ResourceTemplate.t list;
211
+
next_cursor : Cursor.t option;
197
212
}
198
-
213
+
199
214
let yojson_of_t { resource_templates; next_cursor } =
200
-
let assoc = [
201
-
("resourceTemplates", `List (List.map ResourceTemplate.yojson_of_t resource_templates));
202
-
] in
203
-
let assoc = match next_cursor with
215
+
let assoc =
216
+
[
217
+
( "resourceTemplates",
218
+
`List (List.map ResourceTemplate.yojson_of_t resource_templates) );
219
+
]
220
+
in
221
+
let assoc =
222
+
match next_cursor with
204
223
| Some c -> ("nextCursor", Cursor.yojson_of_t c) :: assoc
205
224
| None -> assoc
206
225
in
207
226
`Assoc assoc
208
-
227
+
209
228
let t_of_yojson = function
210
229
| `Assoc fields as json ->
211
-
let resource_templates = match List.assoc_opt "resourceTemplates" fields with
212
-
| Some (`List items) -> List.map ResourceTemplate.t_of_yojson items
213
-
| _ -> Util.json_error "Missing or invalid 'resourceTemplates' field" json
214
-
in
215
-
let next_cursor = List.assoc_opt "nextCursor" fields |> Option.map Cursor.t_of_yojson in
216
-
{ resource_templates; next_cursor }
230
+
let resource_templates =
231
+
match List.assoc_opt "resourceTemplates" fields with
232
+
| Some (`List items) -> List.map ResourceTemplate.t_of_yojson items
233
+
| _ ->
234
+
Util.json_error "Missing or invalid 'resourceTemplates' field"
235
+
json
236
+
in
237
+
let next_cursor =
238
+
List.assoc_opt "nextCursor" fields |> Option.map Cursor.t_of_yojson
239
+
in
240
+
{ resource_templates; next_cursor }
217
241
| j -> Util.json_error "Expected object for ListResourceTemplatesResult.t" j
218
-
242
+
219
243
(* Request/response creation helpers *)
220
244
let create_request ?cursor ?id () =
221
-
let id = match id with
222
-
| Some i -> i
223
-
| None -> `Int (Random.int 10000)
224
-
in
245
+
let id = match id with Some i -> i | None -> `Int (Random.int 10000) in
225
246
let params = ListResourceTemplatesRequest.yojson_of_t { cursor } in
226
-
JSONRPCMessage.create_request ~id ~meth:Method.ResourceTemplatesList ~params:(Some params) ()
227
-
247
+
JSONRPCMessage.create_request ~id ~meth:Method.ResourceTemplatesList
248
+
~params:(Some params) ()
249
+
228
250
let create_response ~id ~resource_templates ?next_cursor () =
229
251
let result = yojson_of_t { resource_templates; next_cursor } in
230
252
JSONRPCMessage.create_response ~id ~result
···
233
255
(* Resources/Read *)
234
256
module ResourcesRead = struct
235
257
module Request = struct
236
-
type t = {
237
-
uri: string;
238
-
}
239
-
240
-
let yojson_of_t { uri } =
241
-
`Assoc [
242
-
("uri", `String uri);
243
-
]
244
-
258
+
type t = { uri : string }
259
+
260
+
let yojson_of_t { uri } = `Assoc [ ("uri", `String uri) ]
261
+
245
262
let t_of_yojson = function
246
263
| `Assoc fields as json ->
247
-
let uri = match List.assoc_opt "uri" fields with
248
-
| Some (`String s) -> s
249
-
| _ -> Util.json_error "Missing or invalid 'uri' field" json
250
-
in
251
-
{ uri }
264
+
let uri =
265
+
match List.assoc_opt "uri" fields with
266
+
| Some (`String s) -> s
267
+
| _ -> Util.json_error "Missing or invalid 'uri' field" json
268
+
in
269
+
{ uri }
252
270
| j -> Util.json_error "Expected object for ResourcesRead.Request.t" j
253
-
254
271
end
255
-
272
+
256
273
module ResourceContent = struct
257
-
type t =
274
+
type t =
258
275
| TextResource of TextResourceContents.t
259
276
| BlobResource of BlobResourceContents.t
260
-
277
+
261
278
let yojson_of_t = function
262
279
| TextResource tr -> TextResourceContents.yojson_of_t tr
263
280
| BlobResource br -> BlobResourceContents.yojson_of_t br
264
-
281
+
265
282
let t_of_yojson json =
266
283
match json with
267
284
| `Assoc fields ->
268
-
if List.mem_assoc "text" fields then
269
-
TextResource (TextResourceContents.t_of_yojson json)
270
-
else if List.mem_assoc "blob" fields then
271
-
BlobResource (BlobResourceContents.t_of_yojson json)
272
-
else
273
-
Util.json_error "Invalid resource content" json
274
-
| j -> Util.json_error "Expected object for ResourcesRead.ResourceContent.t" j
275
-
285
+
if List.mem_assoc "text" fields then
286
+
TextResource (TextResourceContents.t_of_yojson json)
287
+
else if List.mem_assoc "blob" fields then
288
+
BlobResource (BlobResourceContents.t_of_yojson json)
289
+
else Util.json_error "Invalid resource content" json
290
+
| j ->
291
+
Util.json_error "Expected object for ResourcesRead.ResourceContent.t"
292
+
j
276
293
end
277
-
294
+
278
295
module Response = struct
279
-
type t = {
280
-
contents: ResourceContent.t list;
281
-
}
282
-
296
+
type t = { contents : ResourceContent.t list }
297
+
283
298
let yojson_of_t { contents } =
284
-
`Assoc [
285
-
("contents", `List (List.map ResourceContent.yojson_of_t contents));
286
-
]
287
-
299
+
`Assoc
300
+
[ ("contents", `List (List.map ResourceContent.yojson_of_t contents)) ]
301
+
288
302
let t_of_yojson = function
289
303
| `Assoc fields as json ->
290
-
let contents = match List.assoc_opt "contents" fields with
291
-
| Some (`List items) -> List.map ResourceContent.t_of_yojson items
292
-
| _ -> Util.json_error "Missing or invalid 'contents' field" json
293
-
in
294
-
{ contents }
304
+
let contents =
305
+
match List.assoc_opt "contents" fields with
306
+
| Some (`List items) -> List.map ResourceContent.t_of_yojson items
307
+
| _ -> Util.json_error "Missing or invalid 'contents' field" json
308
+
in
309
+
{ contents }
295
310
| j -> Util.json_error "Expected object for ResourcesRead.Response.t" j
296
-
297
311
end
298
-
312
+
299
313
(* Request/response creation helpers *)
300
314
let create_request ~uri ?id () =
301
-
let id = match id with
302
-
| Some i -> i
303
-
| None -> `Int (Random.int 10000)
304
-
in
315
+
let id = match id with Some i -> i | None -> `Int (Random.int 10000) in
305
316
let params = Request.yojson_of_t { uri } in
306
-
JSONRPCMessage.create_request ~id ~meth:Method.ResourcesRead ~params:(Some params) ()
307
-
317
+
JSONRPCMessage.create_request ~id ~meth:Method.ResourcesRead
318
+
~params:(Some params) ()
319
+
308
320
let create_response ~id ~contents () =
309
321
let result = Response.yojson_of_t { contents } in
310
322
JSONRPCMessage.create_response ~id ~result
···
313
325
(* Tools/List *)
314
326
module ToolsList = struct
315
327
module Request = struct
316
-
type t = {
317
-
cursor: Cursor.t option;
318
-
}
319
-
328
+
type t = { cursor : Cursor.t option }
329
+
320
330
let yojson_of_t { cursor } =
321
331
let assoc = [] in
322
-
let assoc = match cursor with
332
+
let assoc =
333
+
match cursor with
323
334
| Some c -> ("cursor", Cursor.yojson_of_t c) :: assoc
324
335
| None -> assoc
325
336
in
326
337
`Assoc assoc
327
-
338
+
328
339
let t_of_yojson = function
329
340
| `Assoc fields ->
330
-
let cursor = List.assoc_opt "cursor" fields |> Option.map Cursor.t_of_yojson in
331
-
{ cursor }
341
+
let cursor =
342
+
List.assoc_opt "cursor" fields |> Option.map Cursor.t_of_yojson
343
+
in
344
+
{ cursor }
332
345
| j -> Util.json_error "Expected object for ToolsList.Request.t" j
333
-
334
346
end
335
-
347
+
336
348
module Tool = struct
337
349
type t = {
338
-
name: string;
339
-
description: string option;
340
-
input_schema: Json.t;
341
-
annotations: Json.t option;
350
+
name : string;
351
+
description : string option;
352
+
input_schema : Json.t;
353
+
annotations : Json.t option;
342
354
}
343
-
355
+
344
356
let yojson_of_t { name; description; input_schema; annotations } =
345
-
let assoc = [
346
-
("name", `String name);
347
-
("inputSchema", input_schema);
348
-
] in
349
-
let assoc = match description with
357
+
let assoc = [ ("name", `String name); ("inputSchema", input_schema) ] in
358
+
let assoc =
359
+
match description with
350
360
| Some desc -> ("description", `String desc) :: assoc
351
361
| None -> assoc
352
362
in
353
-
let assoc = match annotations with
363
+
let assoc =
364
+
match annotations with
354
365
| Some anno -> ("annotations", anno) :: assoc
355
366
| None -> assoc
356
367
in
357
368
`Assoc assoc
358
-
369
+
359
370
let t_of_yojson = function
360
371
| `Assoc fields as json ->
361
-
let name = match List.assoc_opt "name" fields with
362
-
| Some (`String s) -> s
363
-
| _ -> Util.json_error "Missing or invalid 'name' field" json
364
-
in
365
-
let description = List.assoc_opt "description" fields |> Option.map (function
366
-
| `String s -> s
367
-
| j -> Util.json_error "Expected string for description" j
368
-
) in
369
-
let input_schema = match List.assoc_opt "inputSchema" fields with
370
-
| Some schema -> schema
371
-
| None -> Util.json_error "Missing 'inputSchema' field" json
372
-
in
373
-
let annotations = List.assoc_opt "annotations" fields in
374
-
{ name; description; input_schema; annotations }
372
+
let name =
373
+
match List.assoc_opt "name" fields with
374
+
| Some (`String s) -> s
375
+
| _ -> Util.json_error "Missing or invalid 'name' field" json
376
+
in
377
+
let description =
378
+
List.assoc_opt "description" fields
379
+
|> Option.map (function
380
+
| `String s -> s
381
+
| j -> Util.json_error "Expected string for description" j)
382
+
in
383
+
let input_schema =
384
+
match List.assoc_opt "inputSchema" fields with
385
+
| Some schema -> schema
386
+
| None -> Util.json_error "Missing 'inputSchema' field" json
387
+
in
388
+
let annotations = List.assoc_opt "annotations" fields in
389
+
{ name; description; input_schema; annotations }
375
390
| j -> Util.json_error "Expected object for ToolsList.Tool.t" j
376
-
377
391
end
378
-
392
+
379
393
module Response = struct
380
-
type t = {
381
-
tools: Tool.t list;
382
-
next_cursor: Cursor.t option;
383
-
}
384
-
394
+
type t = { tools : Tool.t list; next_cursor : Cursor.t option }
395
+
385
396
let yojson_of_t { tools; next_cursor } =
386
-
let assoc = [
387
-
("tools", `List (List.map Tool.yojson_of_t tools));
388
-
] in
389
-
let assoc = match next_cursor with
397
+
let assoc = [ ("tools", `List (List.map Tool.yojson_of_t tools)) ] in
398
+
let assoc =
399
+
match next_cursor with
390
400
| Some c -> ("nextCursor", Cursor.yojson_of_t c) :: assoc
391
401
| None -> assoc
392
402
in
393
403
`Assoc assoc
394
-
404
+
395
405
let t_of_yojson = function
396
406
| `Assoc fields as json ->
397
-
let tools = match List.assoc_opt "tools" fields with
398
-
| Some (`List items) -> List.map Tool.t_of_yojson items
399
-
| _ -> Util.json_error "Missing or invalid 'tools' field" json
400
-
in
401
-
let next_cursor = List.assoc_opt "nextCursor" fields |> Option.map Cursor.t_of_yojson in
402
-
{ tools; next_cursor }
407
+
let tools =
408
+
match List.assoc_opt "tools" fields with
409
+
| Some (`List items) -> List.map Tool.t_of_yojson items
410
+
| _ -> Util.json_error "Missing or invalid 'tools' field" json
411
+
in
412
+
let next_cursor =
413
+
List.assoc_opt "nextCursor" fields |> Option.map Cursor.t_of_yojson
414
+
in
415
+
{ tools; next_cursor }
403
416
| j -> Util.json_error "Expected object for ToolsList.Response.t" j
404
-
405
417
end
406
-
418
+
407
419
(* Request/response creation helpers *)
408
420
let create_request ?cursor ?id () =
409
-
let id = match id with
410
-
| Some i -> i
411
-
| None -> `Int (Random.int 10000)
412
-
in
421
+
let id = match id with Some i -> i | None -> `Int (Random.int 10000) in
413
422
let params = Request.yojson_of_t { cursor } in
414
-
JSONRPCMessage.create_request ~id ~meth:Method.ToolsList ~params:(Some params) ()
415
-
423
+
JSONRPCMessage.create_request ~id ~meth:Method.ToolsList
424
+
~params:(Some params) ()
425
+
416
426
let create_response ~id ~tools ?next_cursor () =
417
427
let result = Response.yojson_of_t { tools; next_cursor } in
418
428
JSONRPCMessage.create_response ~id ~result
···
421
431
(* Tools/Call *)
422
432
module ToolsCall = struct
423
433
module Request = struct
424
-
type t = {
425
-
name: string;
426
-
arguments: Json.t;
427
-
}
428
-
434
+
type t = { name : string; arguments : Json.t }
435
+
429
436
let yojson_of_t { name; arguments } =
430
-
`Assoc [
431
-
("name", `String name);
432
-
("arguments", arguments);
433
-
]
434
-
437
+
`Assoc [ ("name", `String name); ("arguments", arguments) ]
438
+
435
439
let t_of_yojson = function
436
440
| `Assoc fields as json ->
437
-
let name = match List.assoc_opt "name" fields with
438
-
| Some (`String s) -> s
439
-
| _ -> Util.json_error "Missing or invalid 'name' field" json
440
-
in
441
-
let arguments = match List.assoc_opt "arguments" fields with
442
-
| Some json -> json
443
-
| None -> Util.json_error "Missing 'arguments' field" json
444
-
in
445
-
{ name; arguments }
441
+
let name =
442
+
match List.assoc_opt "name" fields with
443
+
| Some (`String s) -> s
444
+
| _ -> Util.json_error "Missing or invalid 'name' field" json
445
+
in
446
+
let arguments =
447
+
match List.assoc_opt "arguments" fields with
448
+
| Some json -> json
449
+
| None -> Util.json_error "Missing 'arguments' field" json
450
+
in
451
+
{ name; arguments }
446
452
| j -> Util.json_error "Expected object for ToolsCall.Request.t" j
447
-
448
453
end
449
-
454
+
450
455
module ToolContent = struct
451
-
type t =
456
+
type t =
452
457
| Text of TextContent.t
453
458
| Image of ImageContent.t
454
459
| Audio of AudioContent.t
455
460
| Resource of EmbeddedResource.t
456
-
461
+
457
462
let yojson_of_t = function
458
463
| Text t -> TextContent.yojson_of_t t
459
464
| Image i -> ImageContent.yojson_of_t i
460
465
| Audio a -> AudioContent.yojson_of_t a
461
466
| Resource r -> EmbeddedResource.yojson_of_t r
462
-
467
+
463
468
let t_of_yojson json =
464
469
match json with
465
-
| `Assoc fields ->
466
-
(match List.assoc_opt "type" fields with
467
-
| Some (`String "text") -> Text (TextContent.t_of_yojson json)
468
-
| Some (`String "image") -> Image (ImageContent.t_of_yojson json)
469
-
| Some (`String "audio") -> Audio (AudioContent.t_of_yojson json)
470
-
| Some (`String "resource") -> Resource (EmbeddedResource.t_of_yojson json)
471
-
| _ -> Util.json_error "Invalid or missing content type" json)
470
+
| `Assoc fields -> (
471
+
match List.assoc_opt "type" fields with
472
+
| Some (`String "text") -> Text (TextContent.t_of_yojson json)
473
+
| Some (`String "image") -> Image (ImageContent.t_of_yojson json)
474
+
| Some (`String "audio") -> Audio (AudioContent.t_of_yojson json)
475
+
| Some (`String "resource") ->
476
+
Resource (EmbeddedResource.t_of_yojson json)
477
+
| _ -> Util.json_error "Invalid or missing content type" json)
472
478
| j -> Util.json_error "Expected object for ToolsCall.ToolContent.t" j
473
-
474
479
end
475
-
480
+
476
481
module Response = struct
477
-
type t = {
478
-
content: ToolContent.t list;
479
-
is_error: bool;
480
-
}
481
-
482
+
type t = { content : ToolContent.t list; is_error : bool }
483
+
482
484
let yojson_of_t { content; is_error } =
483
-
`Assoc [
484
-
("content", `List (List.map ToolContent.yojson_of_t content));
485
-
("isError", `Bool is_error);
486
-
]
487
-
485
+
`Assoc
486
+
[
487
+
("content", `List (List.map ToolContent.yojson_of_t content));
488
+
("isError", `Bool is_error);
489
+
]
490
+
488
491
let t_of_yojson = function
489
492
| `Assoc fields as json ->
490
-
let content = match List.assoc_opt "content" fields with
491
-
| Some (`List items) -> List.map ToolContent.t_of_yojson items
492
-
| _ -> Util.json_error "Missing or invalid 'content' field" json
493
-
in
494
-
let is_error = match List.assoc_opt "isError" fields with
495
-
| Some (`Bool b) -> b
496
-
| _ -> false
497
-
in
498
-
{ content; is_error }
493
+
let content =
494
+
match List.assoc_opt "content" fields with
495
+
| Some (`List items) -> List.map ToolContent.t_of_yojson items
496
+
| _ -> Util.json_error "Missing or invalid 'content' field" json
497
+
in
498
+
let is_error =
499
+
match List.assoc_opt "isError" fields with
500
+
| Some (`Bool b) -> b
501
+
| _ -> false
502
+
in
503
+
{ content; is_error }
499
504
| j -> Util.json_error "Expected object for ToolsCall.Response.t" j
500
-
501
505
end
502
-
506
+
503
507
(* Request/response creation helpers *)
504
508
let create_request ~name ~arguments ?id () =
505
-
let id = match id with
506
-
| Some i -> i
507
-
| None -> `Int (Random.int 10000)
508
-
in
509
+
let id = match id with Some i -> i | None -> `Int (Random.int 10000) in
509
510
let params = Request.yojson_of_t { name; arguments } in
510
-
JSONRPCMessage.create_request ~id ~meth:Method.ToolsCall ~params:(Some params) ()
511
-
511
+
JSONRPCMessage.create_request ~id ~meth:Method.ToolsCall
512
+
~params:(Some params) ()
513
+
512
514
let create_response ~id ~content ~is_error () =
513
515
let result = Response.yojson_of_t { content; is_error } in
514
516
JSONRPCMessage.create_response ~id ~result
···
517
519
(* Prompts/List *)
518
520
module PromptsList = struct
519
521
module PromptArgument = struct
520
-
type t = {
521
-
name: string;
522
-
description: string option;
523
-
required: bool;
524
-
}
525
-
522
+
type t = { name : string; description : string option; required : bool }
523
+
526
524
let yojson_of_t { name; description; required } =
527
-
let assoc = [
528
-
("name", `String name);
529
-
] in
530
-
let assoc = match description with
525
+
let assoc = [ ("name", `String name) ] in
526
+
let assoc =
527
+
match description with
531
528
| Some desc -> ("description", `String desc) :: assoc
532
529
| None -> assoc
533
530
in
534
-
let assoc = if required then
535
-
("required", `Bool true) :: assoc
536
-
else
537
-
assoc
531
+
let assoc =
532
+
if required then ("required", `Bool true) :: assoc else assoc
538
533
in
539
534
`Assoc assoc
540
-
535
+
541
536
let t_of_yojson = function
542
537
| `Assoc fields as json ->
543
-
let name = match List.assoc_opt "name" fields with
544
-
| Some (`String s) -> s
545
-
| _ -> Util.json_error "Missing or invalid 'name' field" json
546
-
in
547
-
let description = List.assoc_opt "description" fields |> Option.map (function
548
-
| `String s -> s
549
-
| j -> Util.json_error "Expected string for description" j
550
-
) in
551
-
let required = match List.assoc_opt "required" fields with
552
-
| Some (`Bool b) -> b
553
-
| _ -> false
554
-
in
555
-
{ name; description; required }
556
-
| j -> Util.json_error "Expected object for PromptsList.PromptArgument.t" j
557
-
538
+
let name =
539
+
match List.assoc_opt "name" fields with
540
+
| Some (`String s) -> s
541
+
| _ -> Util.json_error "Missing or invalid 'name' field" json
542
+
in
543
+
let description =
544
+
List.assoc_opt "description" fields
545
+
|> Option.map (function
546
+
| `String s -> s
547
+
| j -> Util.json_error "Expected string for description" j)
548
+
in
549
+
let required =
550
+
match List.assoc_opt "required" fields with
551
+
| Some (`Bool b) -> b
552
+
| _ -> false
553
+
in
554
+
{ name; description; required }
555
+
| j ->
556
+
Util.json_error "Expected object for PromptsList.PromptArgument.t" j
558
557
end
559
-
558
+
560
559
module Prompt = struct
561
560
type t = {
562
-
name: string;
563
-
description: string option;
564
-
arguments: PromptArgument.t list;
561
+
name : string;
562
+
description : string option;
563
+
arguments : PromptArgument.t list;
565
564
}
566
-
565
+
567
566
let yojson_of_t { name; description; arguments } =
568
-
let assoc = [
569
-
("name", `String name);
570
-
] in
571
-
let assoc = match description with
567
+
let assoc = [ ("name", `String name) ] in
568
+
let assoc =
569
+
match description with
572
570
| Some desc -> ("description", `String desc) :: assoc
573
571
| None -> assoc
574
572
in
575
-
let assoc = if arguments <> [] then
576
-
("arguments", `List (List.map PromptArgument.yojson_of_t arguments)) :: assoc
577
-
else
578
-
assoc
573
+
let assoc =
574
+
if arguments <> [] then
575
+
("arguments", `List (List.map PromptArgument.yojson_of_t arguments))
576
+
:: assoc
577
+
else assoc
579
578
in
580
579
`Assoc assoc
581
-
580
+
582
581
let t_of_yojson = function
583
582
| `Assoc fields as json ->
584
-
let name = match List.assoc_opt "name" fields with
585
-
| Some (`String s) -> s
586
-
| _ -> Util.json_error "Missing or invalid 'name' field" json
587
-
in
588
-
let description = List.assoc_opt "description" fields |> Option.map (function
589
-
| `String s -> s
590
-
| j -> Util.json_error "Expected string for description" j
591
-
) in
592
-
let arguments = match List.assoc_opt "arguments" fields with
593
-
| Some (`List items) -> List.map PromptArgument.t_of_yojson items
594
-
| _ -> []
595
-
in
596
-
{ name; description; arguments }
583
+
let name =
584
+
match List.assoc_opt "name" fields with
585
+
| Some (`String s) -> s
586
+
| _ -> Util.json_error "Missing or invalid 'name' field" json
587
+
in
588
+
let description =
589
+
List.assoc_opt "description" fields
590
+
|> Option.map (function
591
+
| `String s -> s
592
+
| j -> Util.json_error "Expected string for description" j)
593
+
in
594
+
let arguments =
595
+
match List.assoc_opt "arguments" fields with
596
+
| Some (`List items) -> List.map PromptArgument.t_of_yojson items
597
+
| _ -> []
598
+
in
599
+
{ name; description; arguments }
597
600
| j -> Util.json_error "Expected object for PromptsList.Prompt.t" j
598
-
599
601
end
600
-
602
+
601
603
module Request = struct
602
-
type t = {
603
-
cursor: Cursor.t option;
604
-
}
605
-
604
+
type t = { cursor : Cursor.t option }
605
+
606
606
let yojson_of_t { cursor } =
607
607
let assoc = [] in
608
-
let assoc = match cursor with
608
+
let assoc =
609
+
match cursor with
609
610
| Some c -> ("cursor", Cursor.yojson_of_t c) :: assoc
610
611
| None -> assoc
611
612
in
612
613
`Assoc assoc
613
-
614
+
614
615
let t_of_yojson = function
615
616
| `Assoc fields ->
616
-
let cursor = List.assoc_opt "cursor" fields |> Option.map Cursor.t_of_yojson in
617
-
{ cursor }
617
+
let cursor =
618
+
List.assoc_opt "cursor" fields |> Option.map Cursor.t_of_yojson
619
+
in
620
+
{ cursor }
618
621
| j -> Util.json_error "Expected object for PromptsList.Request.t" j
619
-
620
622
end
621
-
623
+
622
624
module Response = struct
623
-
type t = {
624
-
prompts: Prompt.t list;
625
-
next_cursor: Cursor.t option;
626
-
}
627
-
625
+
type t = { prompts : Prompt.t list; next_cursor : Cursor.t option }
626
+
628
627
let yojson_of_t { prompts; next_cursor } =
629
-
let assoc = [
630
-
("prompts", `List (List.map Prompt.yojson_of_t prompts));
631
-
] in
632
-
let assoc = match next_cursor with
628
+
let assoc =
629
+
[ ("prompts", `List (List.map Prompt.yojson_of_t prompts)) ]
630
+
in
631
+
let assoc =
632
+
match next_cursor with
633
633
| Some c -> ("nextCursor", Cursor.yojson_of_t c) :: assoc
634
634
| None -> assoc
635
635
in
636
636
`Assoc assoc
637
-
637
+
638
638
let t_of_yojson = function
639
639
| `Assoc fields as json ->
640
-
let prompts = match List.assoc_opt "prompts" fields with
641
-
| Some (`List items) -> List.map Prompt.t_of_yojson items
642
-
| _ -> Util.json_error "Missing or invalid 'prompts' field" json
643
-
in
644
-
let next_cursor = List.assoc_opt "nextCursor" fields |> Option.map Cursor.t_of_yojson in
645
-
{ prompts; next_cursor }
640
+
let prompts =
641
+
match List.assoc_opt "prompts" fields with
642
+
| Some (`List items) -> List.map Prompt.t_of_yojson items
643
+
| _ -> Util.json_error "Missing or invalid 'prompts' field" json
644
+
in
645
+
let next_cursor =
646
+
List.assoc_opt "nextCursor" fields |> Option.map Cursor.t_of_yojson
647
+
in
648
+
{ prompts; next_cursor }
646
649
| j -> Util.json_error "Expected object for PromptsList.Response.t" j
647
-
648
650
end
649
-
651
+
650
652
(* Request/response creation helpers *)
651
653
let create_request ?cursor ?id () =
652
-
let id = match id with
653
-
| Some i -> i
654
-
| None -> `Int (Random.int 10000)
655
-
in
654
+
let id = match id with Some i -> i | None -> `Int (Random.int 10000) in
656
655
let params = Request.yojson_of_t { cursor } in
657
-
JSONRPCMessage.create_request ~id ~meth:Method.PromptsList ~params:(Some params) ()
658
-
656
+
JSONRPCMessage.create_request ~id ~meth:Method.PromptsList
657
+
~params:(Some params) ()
658
+
659
659
let create_response ~id ~prompts ?next_cursor () =
660
660
let result = Response.yojson_of_t { prompts; next_cursor } in
661
661
JSONRPCMessage.create_response ~id ~result
···
664
664
(* Prompts/Get *)
665
665
module PromptsGet = struct
666
666
module Request = struct
667
-
type t = {
668
-
name: string;
669
-
arguments: (string * string) list;
670
-
}
671
-
667
+
type t = { name : string; arguments : (string * string) list }
668
+
672
669
let yojson_of_t { name; arguments } =
673
-
let args_json = `Assoc (List.map (fun (k, v) -> (k, `String v)) arguments) in
674
-
`Assoc [
675
-
("name", `String name);
676
-
("arguments", args_json);
677
-
]
678
-
670
+
let args_json =
671
+
`Assoc (List.map (fun (k, v) -> (k, `String v)) arguments)
672
+
in
673
+
`Assoc [ ("name", `String name); ("arguments", args_json) ]
674
+
679
675
let t_of_yojson = function
680
676
| `Assoc fields as json ->
681
-
let name = match List.assoc_opt "name" fields with
682
-
| Some (`String s) -> s
683
-
| _ -> Util.json_error "Missing or invalid 'name' field" json
684
-
in
685
-
let arguments = match List.assoc_opt "arguments" fields with
686
-
| Some (`Assoc args) ->
687
-
List.map (fun (k, v) ->
688
-
match v with
689
-
| `String s -> (k, s)
690
-
| _ -> Util.json_error "Expected string value for argument" v
691
-
) args
692
-
| _ -> []
693
-
in
694
-
{ name; arguments }
677
+
let name =
678
+
match List.assoc_opt "name" fields with
679
+
| Some (`String s) -> s
680
+
| _ -> Util.json_error "Missing or invalid 'name' field" json
681
+
in
682
+
let arguments =
683
+
match List.assoc_opt "arguments" fields with
684
+
| Some (`Assoc args) ->
685
+
List.map
686
+
(fun (k, v) ->
687
+
match v with
688
+
| `String s -> (k, s)
689
+
| _ ->
690
+
Util.json_error "Expected string value for argument" v)
691
+
args
692
+
| _ -> []
693
+
in
694
+
{ name; arguments }
695
695
| j -> Util.json_error "Expected object for PromptsGet.Request.t" j
696
-
697
696
end
698
-
697
+
699
698
module Response = struct
700
-
type t = {
701
-
description: string option;
702
-
messages: PromptMessage.t list;
703
-
}
704
-
699
+
type t = { description : string option; messages : PromptMessage.t list }
700
+
705
701
let yojson_of_t { description; messages } =
706
-
let assoc = [
707
-
("messages", `List (List.map PromptMessage.yojson_of_t messages));
708
-
] in
709
-
let assoc = match description with
702
+
let assoc =
703
+
[ ("messages", `List (List.map PromptMessage.yojson_of_t messages)) ]
704
+
in
705
+
let assoc =
706
+
match description with
710
707
| Some desc -> ("description", `String desc) :: assoc
711
708
| None -> assoc
712
709
in
713
710
`Assoc assoc
714
-
711
+
715
712
let t_of_yojson = function
716
713
| `Assoc fields as json ->
717
-
let messages = match List.assoc_opt "messages" fields with
718
-
| Some (`List items) -> List.map PromptMessage.t_of_yojson items
719
-
| _ -> Util.json_error "Missing or invalid 'messages' field" json
720
-
in
721
-
let description = List.assoc_opt "description" fields |> Option.map (function
722
-
| `String s -> s
723
-
| j -> Util.json_error "Expected string for description" j
724
-
) in
725
-
{ description; messages }
714
+
let messages =
715
+
match List.assoc_opt "messages" fields with
716
+
| Some (`List items) -> List.map PromptMessage.t_of_yojson items
717
+
| _ -> Util.json_error "Missing or invalid 'messages' field" json
718
+
in
719
+
let description =
720
+
List.assoc_opt "description" fields
721
+
|> Option.map (function
722
+
| `String s -> s
723
+
| j -> Util.json_error "Expected string for description" j)
724
+
in
725
+
{ description; messages }
726
726
| j -> Util.json_error "Expected object for PromptsGet.Response.t" j
727
-
728
727
end
729
-
728
+
730
729
(* Request/response creation helpers *)
731
730
let create_request ~name ~arguments ?id () =
732
-
let id = match id with
733
-
| Some i -> i
734
-
| None -> `Int (Random.int 10000)
735
-
in
731
+
let id = match id with Some i -> i | None -> `Int (Random.int 10000) in
736
732
let params = Request.yojson_of_t { name; arguments } in
737
-
JSONRPCMessage.create_request ~id ~meth:Method.PromptsGet ~params:(Some params) ()
738
-
733
+
JSONRPCMessage.create_request ~id ~meth:Method.PromptsGet
734
+
~params:(Some params) ()
735
+
739
736
let create_response ~id ?description ~messages () =
740
737
let result = Response.yojson_of_t { description; messages } in
741
738
JSONRPCMessage.create_response ~id ~result
···
744
741
(* List Changed Notifications *)
745
742
module ListChanged = struct
746
743
(* No parameters for these notifications *)
747
-
744
+
748
745
let create_resources_notification () =
749
746
JSONRPCMessage.create_notification ~meth:Method.ResourcesListChanged ()
750
-
747
+
751
748
let create_tools_notification () =
752
749
JSONRPCMessage.create_notification ~meth:Method.ToolsListChanged ()
753
-
750
+
754
751
let create_prompts_notification () =
755
752
JSONRPCMessage.create_notification ~meth:Method.PromptsListChanged ()
756
753
end
···
758
755
(* Resource Updated Notification *)
759
756
module ResourceUpdated = struct
760
757
module Notification = struct
761
-
type t = {
762
-
uri: string;
763
-
}
764
-
765
-
let yojson_of_t { uri } =
766
-
`Assoc [
767
-
("uri", `String uri);
768
-
]
769
-
758
+
type t = { uri : string }
759
+
760
+
let yojson_of_t { uri } = `Assoc [ ("uri", `String uri) ]
761
+
770
762
let t_of_yojson = function
771
763
| `Assoc fields as json ->
772
-
let uri = match List.assoc_opt "uri" fields with
773
-
| Some (`String s) -> s
774
-
| _ -> Util.json_error "Missing or invalid 'uri' field" json
775
-
in
776
-
{ uri }
777
-
| j -> Util.json_error "Expected object for ResourceUpdated.Notification.t" j
778
-
764
+
let uri =
765
+
match List.assoc_opt "uri" fields with
766
+
| Some (`String s) -> s
767
+
| _ -> Util.json_error "Missing or invalid 'uri' field" json
768
+
in
769
+
{ uri }
770
+
| j ->
771
+
Util.json_error "Expected object for ResourceUpdated.Notification.t" j
779
772
end
780
-
773
+
781
774
let create_notification ~uri () =
782
775
let params = Notification.yojson_of_t { uri } in
783
-
JSONRPCMessage.create_notification ~meth:Method.ResourcesUpdated ~params:(Some params) ()
776
+
JSONRPCMessage.create_notification ~meth:Method.ResourcesUpdated
777
+
~params:(Some params) ()
784
778
end
785
779
786
780
(* Progress Notification *)
787
781
module Progress = struct
788
782
module Notification = struct
789
783
type t = {
790
-
progress: float;
791
-
total: float;
792
-
progress_token: ProgressToken.t;
784
+
progress : float;
785
+
total : float;
786
+
progress_token : ProgressToken.t;
793
787
}
794
-
788
+
795
789
let yojson_of_t { progress; total; progress_token } =
796
-
`Assoc [
797
-
("progress", `Float progress);
798
-
("total", `Float total);
799
-
("progressToken", ProgressToken.yojson_of_t progress_token);
800
-
]
801
-
790
+
`Assoc
791
+
[
792
+
("progress", `Float progress);
793
+
("total", `Float total);
794
+
("progressToken", ProgressToken.yojson_of_t progress_token);
795
+
]
796
+
802
797
let t_of_yojson = function
803
798
| `Assoc fields as json ->
804
-
let progress = match List.assoc_opt "progress" fields with
805
-
| Some (`Float f) -> f
806
-
| _ -> Util.json_error "Missing or invalid 'progress' field" json
807
-
in
808
-
let total = match List.assoc_opt "total" fields with
809
-
| Some (`Float f) -> f
810
-
| _ -> Util.json_error "Missing or invalid 'total' field" json
811
-
in
812
-
let progress_token = match List.assoc_opt "progressToken" fields with
813
-
| Some token -> ProgressToken.t_of_yojson token
814
-
| _ -> Util.json_error "Missing or invalid 'progressToken' field" json
815
-
in
816
-
{ progress; total; progress_token }
799
+
let progress =
800
+
match List.assoc_opt "progress" fields with
801
+
| Some (`Float f) -> f
802
+
| _ -> Util.json_error "Missing or invalid 'progress' field" json
803
+
in
804
+
let total =
805
+
match List.assoc_opt "total" fields with
806
+
| Some (`Float f) -> f
807
+
| _ -> Util.json_error "Missing or invalid 'total' field" json
808
+
in
809
+
let progress_token =
810
+
match List.assoc_opt "progressToken" fields with
811
+
| Some token -> ProgressToken.t_of_yojson token
812
+
| _ ->
813
+
Util.json_error "Missing or invalid 'progressToken' field" json
814
+
in
815
+
{ progress; total; progress_token }
817
816
| j -> Util.json_error "Expected object for Progress.Notification.t" j
818
-
819
817
end
820
-
818
+
821
819
let create_notification ~progress ~total ~progress_token () =
822
820
let params = Notification.yojson_of_t { progress; total; progress_token } in
823
-
JSONRPCMessage.create_notification ~meth:Method.Progress ~params:(Some params) ()
821
+
JSONRPCMessage.create_notification ~meth:Method.Progress
822
+
~params:(Some params) ()
824
823
end
825
824
826
825
(* Type aliases for backward compatibility *)
827
826
type request = ResourcesList.Request.t
828
-
type response = ResourcesList.Response.t
827
+
type response = ResourcesList.Response.t
829
828
type resource = ResourcesList.Resource.t
830
829
type resource_content = ResourcesRead.ResourceContent.t
831
830
type tool = ToolsList.Tool.t
832
831
type tool_content = ToolsCall.ToolContent.t
833
832
type prompt = PromptsList.Prompt.t
834
-
type prompt_argument = PromptsList.PromptArgument.t
833
+
type prompt_argument = PromptsList.PromptArgument.t
+184
-116
lib/mcp_rpc.mli
+184
-116
lib/mcp_rpc.mli
···
1
-
(** Mcp_message - High-level RPC message definitions for Model Context Protocol *)
1
+
(** Mcp_message - High-level RPC message definitions for Model Context Protocol
2
+
*)
2
3
3
4
open Mcp
4
5
open Jsonrpc
···
7
8
module ResourcesList : sig
8
9
(** Request parameters *)
9
10
module Request : sig
10
-
type t = {
11
-
cursor: Cursor.t option; (** Optional pagination cursor *)
12
-
}
11
+
type t = { cursor : Cursor.t option (** Optional pagination cursor *) }
12
+
13
13
include Json.Jsonable.S with type t := t
14
14
end
15
-
15
+
16
16
(** Resource definition *)
17
17
module Resource : sig
18
18
type t = {
19
-
uri: string; (** Unique identifier for the resource *)
20
-
name: string; (** Human-readable name *)
21
-
description: string option; (** Optional description *)
22
-
mime_type: string option; (** Optional MIME type *)
23
-
size: int option; (** Optional size in bytes *)
19
+
uri : string; (** Unique identifier for the resource *)
20
+
name : string; (** Human-readable name *)
21
+
description : string option; (** Optional description *)
22
+
mime_type : string option; (** Optional MIME type *)
23
+
size : int option; (** Optional size in bytes *)
24
24
}
25
+
25
26
include Json.Jsonable.S with type t := t
26
27
end
27
-
28
+
28
29
(** Response result *)
29
30
module Response : sig
30
31
type t = {
31
-
resources: Resource.t list; (** List of available resources *)
32
-
next_cursor: Cursor.t option; (** Optional cursor for the next page *)
32
+
resources : Resource.t list; (** List of available resources *)
33
+
next_cursor : Cursor.t option; (** Optional cursor for the next page *)
33
34
}
35
+
34
36
include Json.Jsonable.S with type t := t
35
37
end
36
-
38
+
39
+
val create_request :
40
+
?cursor:Cursor.t -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
37
41
(** Create a resources/list request *)
38
-
val create_request : ?cursor:Cursor.t -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
39
-
42
+
43
+
val create_response :
44
+
id:RequestId.t ->
45
+
resources:Resource.t list ->
46
+
?next_cursor:Cursor.t ->
47
+
unit ->
48
+
JSONRPCMessage.t
40
49
(** Create a resources/list response *)
41
-
val create_response : id:RequestId.t -> resources:Resource.t list -> ?next_cursor:Cursor.t -> unit -> JSONRPCMessage.t
42
50
end
43
51
44
52
(** Resources/Templates/List - Request to list available resource templates *)
45
53
module ListResourceTemplatesRequest : sig
46
-
type t = {
47
-
cursor: Cursor.t option; (** Optional pagination cursor *)
48
-
}
54
+
type t = { cursor : Cursor.t option (** Optional pagination cursor *) }
55
+
49
56
include Json.Jsonable.S with type t := t
50
57
end
51
58
···
54
61
(** Resource Template definition *)
55
62
module ResourceTemplate : sig
56
63
type t = {
57
-
uri_template: string; (** URI template for the resource *)
58
-
name: string; (** Human-readable name *)
59
-
description: string option; (** Optional description *)
60
-
mime_type: string option; (** Optional MIME type *)
64
+
uri_template : string; (** URI template for the resource *)
65
+
name : string; (** Human-readable name *)
66
+
description : string option; (** Optional description *)
67
+
mime_type : string option; (** Optional MIME type *)
61
68
}
69
+
62
70
include Json.Jsonable.S with type t := t
63
71
end
64
-
72
+
65
73
type t = {
66
-
resource_templates: ResourceTemplate.t list; (** List of available resource templates *)
67
-
next_cursor: Cursor.t option; (** Optional cursor for the next page *)
74
+
resource_templates : ResourceTemplate.t list;
75
+
(** List of available resource templates *)
76
+
next_cursor : Cursor.t option; (** Optional cursor for the next page *)
68
77
}
78
+
69
79
include Json.Jsonable.S with type t := t
70
-
80
+
81
+
val create_request :
82
+
?cursor:Cursor.t -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
71
83
(** Create a resources/templates/list request *)
72
-
val create_request : ?cursor:Cursor.t -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
73
-
84
+
85
+
val create_response :
86
+
id:RequestId.t ->
87
+
resource_templates:ResourceTemplate.t list ->
88
+
?next_cursor:Cursor.t ->
89
+
unit ->
90
+
JSONRPCMessage.t
74
91
(** Create a resources/templates/list response *)
75
-
val create_response : id:RequestId.t -> resource_templates:ResourceTemplate.t list -> ?next_cursor:Cursor.t -> unit -> JSONRPCMessage.t
76
92
end
77
93
78
94
(** Resources/Read - Request to read resource contents *)
79
95
module ResourcesRead : sig
80
96
(** Request parameters *)
81
97
module Request : sig
82
-
type t = {
83
-
uri: string; (** URI of the resource to read *)
84
-
}
98
+
type t = { uri : string (** URI of the resource to read *) }
99
+
85
100
include Json.Jsonable.S with type t := t
86
101
end
87
-
102
+
88
103
(** Resource content *)
89
104
module ResourceContent : sig
90
-
type t =
91
-
| TextResource of TextResourceContents.t (** Text content *)
92
-
| BlobResource of BlobResourceContents.t (** Binary content *)
105
+
type t =
106
+
| TextResource of TextResourceContents.t (** Text content *)
107
+
| BlobResource of BlobResourceContents.t (** Binary content *)
108
+
93
109
include Json.Jsonable.S with type t := t
94
110
end
95
-
111
+
96
112
(** Response result *)
97
113
module Response : sig
98
114
type t = {
99
-
contents: ResourceContent.t list; (** List of resource contents *)
115
+
contents : ResourceContent.t list; (** List of resource contents *)
100
116
}
117
+
101
118
include Json.Jsonable.S with type t := t
102
119
end
103
-
120
+
121
+
val create_request : uri:string -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
104
122
(** Create a resources/read request *)
105
-
val create_request : uri:string -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
106
-
123
+
124
+
val create_response :
125
+
id:RequestId.t ->
126
+
contents:ResourceContent.t list ->
127
+
unit ->
128
+
JSONRPCMessage.t
107
129
(** Create a resources/read response *)
108
-
val create_response : id:RequestId.t -> contents:ResourceContent.t list -> unit -> JSONRPCMessage.t
109
130
end
110
131
111
132
(** Tools/List - Request to list available tools *)
112
133
module ToolsList : sig
113
134
(** Request parameters *)
114
135
module Request : sig
115
-
type t = {
116
-
cursor: Cursor.t option; (** Optional pagination cursor *)
117
-
}
136
+
type t = { cursor : Cursor.t option (** Optional pagination cursor *) }
137
+
118
138
include Json.Jsonable.S with type t := t
119
139
end
120
-
140
+
121
141
(** Tool definition *)
122
142
module Tool : sig
123
143
type t = {
124
-
name: string; (** Unique identifier for the tool *)
125
-
description: string option; (** Human-readable description *)
126
-
input_schema: Json.t; (** JSON Schema defining expected parameters *)
127
-
annotations: Json.t option; (** Optional properties describing tool behavior *)
144
+
name : string; (** Unique identifier for the tool *)
145
+
description : string option; (** Human-readable description *)
146
+
input_schema : Json.t; (** JSON Schema defining expected parameters *)
147
+
annotations : Json.t option;
148
+
(** Optional properties describing tool behavior *)
128
149
}
150
+
129
151
include Json.Jsonable.S with type t := t
130
152
end
131
-
153
+
132
154
(** Response result *)
133
155
module Response : sig
134
156
type t = {
135
-
tools: Tool.t list; (** List of available tools *)
136
-
next_cursor: Cursor.t option; (** Optional cursor for the next page *)
157
+
tools : Tool.t list; (** List of available tools *)
158
+
next_cursor : Cursor.t option; (** Optional cursor for the next page *)
137
159
}
160
+
138
161
include Json.Jsonable.S with type t := t
139
162
end
140
-
163
+
164
+
val create_request :
165
+
?cursor:Cursor.t -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
141
166
(** Create a tools/list request *)
142
-
val create_request : ?cursor:Cursor.t -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
143
-
167
+
168
+
val create_response :
169
+
id:RequestId.t ->
170
+
tools:Tool.t list ->
171
+
?next_cursor:Cursor.t ->
172
+
unit ->
173
+
JSONRPCMessage.t
144
174
(** Create a tools/list response *)
145
-
val create_response : id:RequestId.t -> tools:Tool.t list -> ?next_cursor:Cursor.t -> unit -> JSONRPCMessage.t
146
175
end
147
176
148
177
(** Tools/Call - Request to invoke a tool *)
···
150
179
(** Request parameters *)
151
180
module Request : sig
152
181
type t = {
153
-
name: string; (** Name of the tool to call *)
154
-
arguments: Json.t; (** Arguments for the tool invocation *)
182
+
name : string; (** Name of the tool to call *)
183
+
arguments : Json.t; (** Arguments for the tool invocation *)
155
184
}
185
+
156
186
include Json.Jsonable.S with type t := t
157
187
end
158
-
188
+
159
189
(** Tool content *)
160
190
module ToolContent : sig
161
-
type t =
162
-
| Text of TextContent.t (** Text content *)
163
-
| Image of ImageContent.t (** Image content *)
164
-
| Audio of AudioContent.t (** Audio content *)
165
-
| Resource of EmbeddedResource.t (** Resource content *)
191
+
type t =
192
+
| Text of TextContent.t (** Text content *)
193
+
| Image of ImageContent.t (** Image content *)
194
+
| Audio of AudioContent.t (** Audio content *)
195
+
| Resource of EmbeddedResource.t (** Resource content *)
196
+
166
197
include Json.Jsonable.S with type t := t
167
198
end
168
-
199
+
169
200
(** Response result *)
170
201
module Response : sig
171
202
type t = {
172
-
content: ToolContent.t list; (** List of content items returned by the tool *)
173
-
is_error: bool; (** Whether the result represents an error *)
203
+
content : ToolContent.t list;
204
+
(** List of content items returned by the tool *)
205
+
is_error : bool; (** Whether the result represents an error *)
174
206
}
207
+
175
208
include Json.Jsonable.S with type t := t
176
209
end
177
-
210
+
211
+
val create_request :
212
+
name:string ->
213
+
arguments:Json.t ->
214
+
?id:RequestId.t ->
215
+
unit ->
216
+
JSONRPCMessage.t
178
217
(** Create a tools/call request *)
179
-
val create_request : name:string -> arguments:Json.t -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
180
-
218
+
219
+
val create_response :
220
+
id:RequestId.t ->
221
+
content:ToolContent.t list ->
222
+
is_error:bool ->
223
+
unit ->
224
+
JSONRPCMessage.t
181
225
(** Create a tools/call response *)
182
-
val create_response : id:RequestId.t -> content:ToolContent.t list -> is_error:bool -> unit -> JSONRPCMessage.t
183
226
end
184
227
185
228
(** Prompts/List - Request to list available prompts *)
···
187
230
(** Prompt argument *)
188
231
module PromptArgument : sig
189
232
type t = {
190
-
name: string; (** Name of the argument *)
191
-
description: string option; (** Description of the argument *)
192
-
required: bool; (** Whether the argument is required *)
233
+
name : string; (** Name of the argument *)
234
+
description : string option; (** Description of the argument *)
235
+
required : bool; (** Whether the argument is required *)
193
236
}
237
+
194
238
include Json.Jsonable.S with type t := t
195
239
end
196
-
240
+
197
241
(** Prompt definition *)
198
242
module Prompt : sig
199
243
type t = {
200
-
name: string; (** Unique identifier for the prompt *)
201
-
description: string option; (** Human-readable description *)
202
-
arguments: PromptArgument.t list; (** Arguments for customization *)
244
+
name : string; (** Unique identifier for the prompt *)
245
+
description : string option; (** Human-readable description *)
246
+
arguments : PromptArgument.t list; (** Arguments for customization *)
203
247
}
248
+
204
249
include Json.Jsonable.S with type t := t
205
250
end
206
-
251
+
207
252
(** Request parameters *)
208
253
module Request : sig
209
-
type t = {
210
-
cursor: Cursor.t option; (** Optional pagination cursor *)
211
-
}
254
+
type t = { cursor : Cursor.t option (** Optional pagination cursor *) }
255
+
212
256
include Json.Jsonable.S with type t := t
213
257
end
214
-
258
+
215
259
(** Response result *)
216
260
module Response : sig
217
261
type t = {
218
-
prompts: Prompt.t list; (** List of available prompts *)
219
-
next_cursor: Cursor.t option; (** Optional cursor for the next page *)
262
+
prompts : Prompt.t list; (** List of available prompts *)
263
+
next_cursor : Cursor.t option; (** Optional cursor for the next page *)
220
264
}
265
+
221
266
include Json.Jsonable.S with type t := t
222
267
end
223
-
268
+
269
+
val create_request :
270
+
?cursor:Cursor.t -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
224
271
(** Create a prompts/list request *)
225
-
val create_request : ?cursor:Cursor.t -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
226
-
272
+
273
+
val create_response :
274
+
id:RequestId.t ->
275
+
prompts:Prompt.t list ->
276
+
?next_cursor:Cursor.t ->
277
+
unit ->
278
+
JSONRPCMessage.t
227
279
(** Create a prompts/list response *)
228
-
val create_response : id:RequestId.t -> prompts:Prompt.t list -> ?next_cursor:Cursor.t -> unit -> JSONRPCMessage.t
229
280
end
230
281
231
282
(** Prompts/Get - Request to get a prompt with arguments *)
···
233
284
(** Request parameters *)
234
285
module Request : sig
235
286
type t = {
236
-
name: string; (** Name of the prompt to get *)
237
-
arguments: (string * string) list; (** Arguments for the prompt *)
287
+
name : string; (** Name of the prompt to get *)
288
+
arguments : (string * string) list; (** Arguments for the prompt *)
238
289
}
290
+
239
291
include Json.Jsonable.S with type t := t
240
292
end
241
-
293
+
242
294
(** Response result *)
243
295
module Response : sig
244
296
type t = {
245
-
description: string option; (** Description of the prompt *)
246
-
messages: PromptMessage.t list; (** List of messages in the prompt *)
297
+
description : string option; (** Description of the prompt *)
298
+
messages : PromptMessage.t list; (** List of messages in the prompt *)
247
299
}
300
+
248
301
include Json.Jsonable.S with type t := t
249
302
end
250
-
303
+
304
+
val create_request :
305
+
name:string ->
306
+
arguments:(string * string) list ->
307
+
?id:RequestId.t ->
308
+
unit ->
309
+
JSONRPCMessage.t
251
310
(** Create a prompts/get request *)
252
-
val create_request : name:string -> arguments:(string * string) list -> ?id:RequestId.t -> unit -> JSONRPCMessage.t
253
-
311
+
312
+
val create_response :
313
+
id:RequestId.t ->
314
+
?description:string ->
315
+
messages:PromptMessage.t list ->
316
+
unit ->
317
+
JSONRPCMessage.t
254
318
(** Create a prompts/get response *)
255
-
val create_response : id:RequestId.t -> ?description:string -> messages:PromptMessage.t list -> unit -> JSONRPCMessage.t
256
319
end
257
320
258
321
(** List Changed Notifications *)
259
322
module ListChanged : sig
260
-
(** Create a resources/list_changed notification *)
261
323
val create_resources_notification : unit -> JSONRPCMessage.t
262
-
263
-
(** Create a tools/list_changed notification *)
324
+
(** Create a resources/list_changed notification *)
325
+
264
326
val create_tools_notification : unit -> JSONRPCMessage.t
265
-
327
+
(** Create a tools/list_changed notification *)
328
+
329
+
val create_prompts_notification : unit -> JSONRPCMessage.t
266
330
(** Create a prompts/list_changed notification *)
267
-
val create_prompts_notification : unit -> JSONRPCMessage.t
268
331
end
269
332
270
333
(** Resource Updated Notification *)
271
334
module ResourceUpdated : sig
272
335
(** Notification parameters *)
273
336
module Notification : sig
274
-
type t = {
275
-
uri: string; (** URI of the updated resource *)
276
-
}
337
+
type t = { uri : string (** URI of the updated resource *) }
338
+
277
339
include Json.Jsonable.S with type t := t
278
340
end
279
-
341
+
342
+
val create_notification : uri:string -> unit -> JSONRPCMessage.t
280
343
(** Create a resources/updated notification *)
281
-
val create_notification : uri:string -> unit -> JSONRPCMessage.t
282
344
end
283
345
284
346
(** Progress Notification *)
···
286
348
(** Notification parameters *)
287
349
module Notification : sig
288
350
type t = {
289
-
progress: float; (** Current progress value *)
290
-
total: float; (** Total progress value *)
291
-
progress_token: ProgressToken.t; (** Token identifying the operation *)
351
+
progress : float; (** Current progress value *)
352
+
total : float; (** Total progress value *)
353
+
progress_token : ProgressToken.t; (** Token identifying the operation *)
292
354
}
355
+
293
356
include Json.Jsonable.S with type t := t
294
357
end
295
-
358
+
359
+
val create_notification :
360
+
progress:float ->
361
+
total:float ->
362
+
progress_token:ProgressToken.t ->
363
+
unit ->
364
+
JSONRPCMessage.t
296
365
(** Create a progress notification *)
297
-
val create_notification : progress:float -> total:float -> progress_token:ProgressToken.t -> unit -> JSONRPCMessage.t
298
366
end
+316
-327
lib/mcp_sdk.ml
+316
-327
lib/mcp_sdk.ml
···
16
16
17
17
let logf level fmt =
18
18
Printf.fprintf stderr "[%s] " (string_of_level level);
19
-
Printf.kfprintf (fun oc -> Printf.fprintf oc "\n"; flush oc) stderr fmt
19
+
Printf.kfprintf
20
+
(fun oc ->
21
+
Printf.fprintf oc "\n";
22
+
flush oc)
23
+
stderr fmt
20
24
21
25
let debugf fmt = logf Debug fmt
22
26
let infof fmt = logf Info fmt
23
27
let warningf fmt = logf Warning fmt
24
28
let errorf fmt = logf Error fmt
25
-
29
+
26
30
(* Backward compatibility functions that take a simple string *)
27
31
let log level msg = logf level "%s" msg
28
32
let debug msg = debugf "%s" msg
···
34
38
(* Context for tools and resources *)
35
39
module Context = struct
36
40
type t = {
37
-
request_id: RequestId.t option;
38
-
lifespan_context: (string * Json.t) list;
39
-
progress_token: ProgressToken.t option;
41
+
request_id : RequestId.t option;
42
+
lifespan_context : (string * Json.t) list;
43
+
progress_token : ProgressToken.t option;
40
44
}
41
45
42
-
let create ?request_id ?progress_token ?(lifespan_context=[]) () =
46
+
let create ?request_id ?progress_token ?(lifespan_context = []) () =
43
47
{ request_id; lifespan_context; progress_token }
44
48
45
-
let get_context_value ctx key =
46
-
List.assoc_opt key ctx.lifespan_context
47
-
49
+
let get_context_value ctx key = List.assoc_opt key ctx.lifespan_context
50
+
48
51
let report_progress ctx value total =
49
-
match ctx.progress_token, ctx.request_id with
52
+
match (ctx.progress_token, ctx.request_id) with
50
53
| Some token, Some _id ->
51
-
let params = `Assoc [
52
-
("progress", `Float value);
53
-
("total", `Float total);
54
-
("progressToken", ProgressToken.yojson_of_t token)
55
-
] in
56
-
Some (create_notification ~meth:Method.Progress ~params:(Some params) ())
54
+
let params =
55
+
`Assoc
56
+
[
57
+
("progress", `Float value);
58
+
("total", `Float total);
59
+
("progressToken", ProgressToken.yojson_of_t token);
60
+
]
61
+
in
62
+
Some
63
+
(create_notification ~meth:Method.Progress ~params:(Some params) ())
57
64
| _ -> None
58
65
end
59
66
···
62
69
type handler = Context.t -> Json.t -> (Json.t, string) result
63
70
64
71
type t = {
65
-
name: string;
66
-
description: string option;
67
-
input_schema: Json.t; (* JSON Schema *)
68
-
handler: handler;
72
+
name : string;
73
+
description : string option;
74
+
input_schema : Json.t; (* JSON Schema *)
75
+
handler : handler;
69
76
}
70
77
71
-
let create ~name ?description ~input_schema ~handler () =
78
+
let create ~name ?description ~input_schema ~handler () =
72
79
{ name; description; input_schema; handler }
73
80
74
81
let to_json tool =
75
-
let assoc = [
76
-
("name", `String tool.name);
77
-
("inputSchema", tool.input_schema);
78
-
] in
79
-
let assoc = match tool.description with
82
+
let assoc =
83
+
[ ("name", `String tool.name); ("inputSchema", tool.input_schema) ]
84
+
in
85
+
let assoc =
86
+
match tool.description with
80
87
| Some desc -> ("description", `String desc) :: assoc
81
88
| None -> assoc
82
89
in
83
90
`Assoc assoc
84
-
91
+
85
92
(* Convert to Mcp_rpc.ToolsList.Tool.t *)
86
-
let to_rpc_tool_list_tool (tool:t) =
87
-
Mcp_rpc.ToolsList.Tool.{
88
-
name = tool.name;
89
-
description = tool.description;
90
-
input_schema = tool.input_schema;
91
-
annotations = None; (* Could be extended to support annotations *)
92
-
}
93
+
let to_rpc_tool_list_tool (tool : t) =
94
+
Mcp_rpc.ToolsList.Tool.
95
+
{
96
+
name = tool.name;
97
+
description = tool.description;
98
+
input_schema = tool.input_schema;
99
+
annotations = None;
100
+
(* Could be extended to support annotations *)
101
+
}
93
102
94
103
(* Convert a list of Tool.t to the format needed for tools/list response *)
95
-
let to_rpc_tools_list tools =
96
-
List.map to_rpc_tool_list_tool tools
104
+
let to_rpc_tools_list tools = List.map to_rpc_tool_list_tool tools
97
105
98
106
(* Convert Mcp_rpc.ToolsCall response content to Mcp.content list *)
99
107
let rpc_content_to_mcp_content content =
100
-
List.map (function
101
-
| Mcp_rpc.ToolsCall.ToolContent.Text t ->
102
-
Mcp.Text { TextContent.text = t.text; annotations = None }
103
-
| Mcp_rpc.ToolsCall.ToolContent.Image i ->
104
-
Mcp.Image {
105
-
ImageContent.mime_type = i.mime_type;
106
-
data = i.data;
107
-
annotations = None
108
-
}
109
-
| Mcp_rpc.ToolsCall.ToolContent.Audio a ->
110
-
Mcp.Audio {
111
-
AudioContent.mime_type = a.mime_type;
112
-
data = a.data;
113
-
annotations = None
114
-
}
115
-
| Mcp_rpc.ToolsCall.ToolContent.Resource r ->
116
-
(* Create a simple text resource from the embedded resource *)
117
-
let uri = match r with
118
-
| { EmbeddedResource.resource = `Text tr; _ } -> tr.uri
119
-
| { EmbeddedResource.resource = `Blob br; _ } -> br.uri
120
-
in
121
-
let text_content = match r with
122
-
| { EmbeddedResource.resource = `Text tr; _ } -> tr.text
123
-
| { EmbeddedResource.resource = `Blob br; _ } -> "Binary content"
124
-
in
125
-
let mime_type = match r with
126
-
| { EmbeddedResource.resource = `Text tr; _ } -> tr.mime_type
127
-
| { EmbeddedResource.resource = `Blob br; _ } -> br.mime_type
128
-
in
129
-
let text_resource = {
130
-
TextResourceContents.uri;
131
-
text = text_content;
132
-
mime_type
133
-
} in
134
-
Mcp.Resource {
135
-
EmbeddedResource.resource = `Text text_resource;
136
-
annotations = None
137
-
}
138
-
) content
108
+
List.map
109
+
(function
110
+
| Mcp_rpc.ToolsCall.ToolContent.Text t ->
111
+
Mcp.Text { TextContent.text = t.text; annotations = None }
112
+
| Mcp_rpc.ToolsCall.ToolContent.Image i ->
113
+
Mcp.Image
114
+
{
115
+
ImageContent.mime_type = i.mime_type;
116
+
data = i.data;
117
+
annotations = None;
118
+
}
119
+
| Mcp_rpc.ToolsCall.ToolContent.Audio a ->
120
+
Mcp.Audio
121
+
{
122
+
AudioContent.mime_type = a.mime_type;
123
+
data = a.data;
124
+
annotations = None;
125
+
}
126
+
| Mcp_rpc.ToolsCall.ToolContent.Resource r ->
127
+
(* Create a simple text resource from the embedded resource *)
128
+
let uri =
129
+
match r with
130
+
| { EmbeddedResource.resource = `Text tr; _ } -> tr.uri
131
+
| { EmbeddedResource.resource = `Blob br; _ } -> br.uri
132
+
in
133
+
let text_content =
134
+
match r with
135
+
| { EmbeddedResource.resource = `Text tr; _ } -> tr.text
136
+
| { EmbeddedResource.resource = `Blob br; _ } -> "Binary content"
137
+
in
138
+
let mime_type =
139
+
match r with
140
+
| { EmbeddedResource.resource = `Text tr; _ } -> tr.mime_type
141
+
| { EmbeddedResource.resource = `Blob br; _ } -> br.mime_type
142
+
in
143
+
let text_resource =
144
+
{ TextResourceContents.uri; text = text_content; mime_type }
145
+
in
146
+
Mcp.Resource
147
+
{
148
+
EmbeddedResource.resource = `Text text_resource;
149
+
annotations = None;
150
+
})
151
+
content
139
152
140
153
(* Convert Mcp.content list to Mcp_rpc.ToolsCall.ToolContent.t list *)
141
154
let mcp_content_to_rpc_content content =
142
-
List.map (function
143
-
| Mcp.Text t ->
144
-
Mcp_rpc.ToolsCall.ToolContent.Text t
145
-
| Mcp.Image img ->
146
-
Mcp_rpc.ToolsCall.ToolContent.Image img
147
-
| Mcp.Audio aud ->
148
-
Mcp_rpc.ToolsCall.ToolContent.Audio aud
149
-
| Mcp.Resource res ->
150
-
let resource_data = match res.resource with
151
-
| `Text txt -> `Text txt
152
-
| `Blob blob -> `Blob blob
153
-
in
154
-
let resource = {
155
-
EmbeddedResource.resource = resource_data;
156
-
annotations = res.annotations
157
-
} in
158
-
Mcp_rpc.ToolsCall.ToolContent.Resource resource
159
-
) content
160
-
155
+
List.map
156
+
(function
157
+
| Mcp.Text t -> Mcp_rpc.ToolsCall.ToolContent.Text t
158
+
| Mcp.Image img -> Mcp_rpc.ToolsCall.ToolContent.Image img
159
+
| Mcp.Audio aud -> Mcp_rpc.ToolsCall.ToolContent.Audio aud
160
+
| Mcp.Resource res ->
161
+
let resource_data =
162
+
match res.resource with
163
+
| `Text txt -> `Text txt
164
+
| `Blob blob -> `Blob blob
165
+
in
166
+
let resource =
167
+
{
168
+
EmbeddedResource.resource = resource_data;
169
+
annotations = res.annotations;
170
+
}
171
+
in
172
+
Mcp_rpc.ToolsCall.ToolContent.Resource resource)
173
+
content
174
+
161
175
(* Create a tool result with content *)
162
176
let create_tool_result content ~is_error =
163
-
`Assoc [
164
-
("content", `List (List.map Mcp.yojson_of_content content));
165
-
("isError", `Bool is_error);
166
-
]
177
+
`Assoc
178
+
[
179
+
("content", `List (List.map Mcp.yojson_of_content content));
180
+
("isError", `Bool is_error);
181
+
]
167
182
168
183
(* Create a tool error result with structured content *)
169
184
let create_error_result error =
170
185
Log.errorf "Error result: %s" error;
171
-
create_tool_result [Mcp.make_text_content error] ~is_error:true
172
-
186
+
create_tool_result [ Mcp.make_text_content error ] ~is_error:true
187
+
173
188
(* Handle tool execution errors *)
174
189
let handle_execution_error err =
175
190
create_error_result (Printf.sprintf "Error executing tool: %s" err)
176
-
191
+
177
192
(* Handle unknown tool error *)
178
193
let handle_unknown_tool_error name =
179
194
create_error_result (Printf.sprintf "Unknown tool: %s" name)
180
-
195
+
181
196
(* Handle general tool execution exception *)
182
197
let handle_execution_exception exn =
183
-
create_error_result (Printf.sprintf "Internal error: %s" (Printexc.to_string exn))
198
+
create_error_result
199
+
(Printf.sprintf "Internal error: %s" (Printexc.to_string exn))
184
200
end
185
201
186
202
(* Resources for the MCP server *)
···
188
204
type handler = Context.t -> string list -> (string, string) result
189
205
190
206
type t = {
191
-
uri: string; (* For resources, this is the exact URI (no variables) *)
192
-
name: string;
193
-
description: string option;
194
-
mime_type: string option;
195
-
handler: handler;
207
+
uri : string; (* For resources, this is the exact URI (no variables) *)
208
+
name : string;
209
+
description : string option;
210
+
mime_type : string option;
211
+
handler : handler;
196
212
}
197
213
198
214
let create ~uri ~name ?description ?mime_type ~handler () =
199
215
(* Validate that the URI doesn't contain template variables *)
200
216
if String.contains uri '{' || String.contains uri '}' then
201
-
Log.warningf "Resource '%s' contains template variables. Consider using add_resource_template instead." uri;
217
+
Log.warningf
218
+
"Resource '%s' contains template variables. Consider using \
219
+
add_resource_template instead."
220
+
uri;
202
221
{ uri; name; description; mime_type; handler }
203
222
204
223
let to_json resource =
205
-
let assoc = [
206
-
("uri", `String resource.uri);
207
-
("name", `String resource.name);
208
-
] in
209
-
let assoc = match resource.description with
224
+
let assoc =
225
+
[ ("uri", `String resource.uri); ("name", `String resource.name) ]
226
+
in
227
+
let assoc =
228
+
match resource.description with
210
229
| Some desc -> ("description", `String desc) :: assoc
211
230
| None -> assoc
212
231
in
213
-
let assoc = match resource.mime_type with
232
+
let assoc =
233
+
match resource.mime_type with
214
234
| Some mime -> ("mimeType", `String mime) :: assoc
215
235
| None -> assoc
216
236
in
217
237
`Assoc assoc
218
-
238
+
219
239
(* Convert to Mcp_rpc.ResourcesList.Resource.t *)
220
-
let to_rpc_resource_list_resource (resource:t) =
221
-
Mcp_rpc.ResourcesList.Resource.{
222
-
uri = resource.uri;
223
-
name = resource.name;
224
-
description = resource.description;
225
-
mime_type = resource.mime_type;
226
-
size = None; (* Size can be added when we have actual resource content *)
227
-
}
228
-
240
+
let to_rpc_resource_list_resource (resource : t) =
241
+
Mcp_rpc.ResourcesList.Resource.
242
+
{
243
+
uri = resource.uri;
244
+
name = resource.name;
245
+
description = resource.description;
246
+
mime_type = resource.mime_type;
247
+
size = None;
248
+
(* Size can be added when we have actual resource content *)
249
+
}
250
+
229
251
(* Convert a list of Resource.t to the format needed for resources/list response *)
230
252
let to_rpc_resources_list resources =
231
253
List.map to_rpc_resource_list_resource resources
···
234
256
(* Prompts for the MCP server *)
235
257
module Prompt = struct
236
258
type argument = {
237
-
name: string;
238
-
description: string option;
239
-
required: bool;
259
+
name : string;
260
+
description : string option;
261
+
required : bool;
240
262
}
241
263
242
-
type message = {
243
-
role: Role.t;
244
-
content: content;
245
-
}
264
+
type message = { role : Role.t; content : content }
246
265
247
-
type handler = Context.t -> (string * string) list -> (message list, string) result
266
+
type handler =
267
+
Context.t -> (string * string) list -> (message list, string) result
248
268
249
269
type t = {
250
-
name: string;
251
-
description: string option;
252
-
arguments: argument list;
253
-
handler: handler;
270
+
name : string;
271
+
description : string option;
272
+
arguments : argument list;
273
+
handler : handler;
254
274
}
255
275
256
-
let create ~name ?description ?(arguments=[]) ~handler () =
276
+
let create ~name ?description ?(arguments = []) ~handler () =
257
277
{ name; description; arguments; handler }
258
278
259
-
let create_argument ~name ?description ?(required=false) () =
279
+
let create_argument ~name ?description ?(required = false) () =
260
280
{ name; description; required }
261
281
262
282
let to_json prompt =
263
-
let assoc = [
264
-
("name", `String prompt.name);
265
-
] in
266
-
let assoc = match prompt.description with
283
+
let assoc = [ ("name", `String prompt.name) ] in
284
+
let assoc =
285
+
match prompt.description with
267
286
| Some desc -> ("description", `String desc) :: assoc
268
287
| None -> assoc
269
288
in
270
-
let assoc = if prompt.arguments <> [] then
271
-
let args = List.map (fun (arg: argument) ->
272
-
let arg_assoc = [
273
-
("name", `String arg.name);
274
-
] in
275
-
let arg_assoc = match arg.description with
276
-
| Some desc -> ("description", `String desc) :: arg_assoc
277
-
| None -> arg_assoc
289
+
let assoc =
290
+
if prompt.arguments <> [] then
291
+
let args =
292
+
List.map
293
+
(fun (arg : argument) ->
294
+
let arg_assoc = [ ("name", `String arg.name) ] in
295
+
let arg_assoc =
296
+
match arg.description with
297
+
| Some desc -> ("description", `String desc) :: arg_assoc
298
+
| None -> arg_assoc
299
+
in
300
+
let arg_assoc =
301
+
if arg.required then ("required", `Bool true) :: arg_assoc
302
+
else arg_assoc
303
+
in
304
+
`Assoc arg_assoc)
305
+
prompt.arguments
278
306
in
279
-
let arg_assoc =
280
-
if arg.required then
281
-
("required", `Bool true) :: arg_assoc
282
-
else
283
-
arg_assoc
284
-
in
285
-
`Assoc arg_assoc
286
-
) prompt.arguments in
287
-
("arguments", `List args) :: assoc
288
-
else
289
-
assoc
307
+
("arguments", `List args) :: assoc
308
+
else assoc
290
309
in
291
310
`Assoc assoc
292
-
311
+
293
312
(* Convert argument to Mcp_rpc.PromptsList.PromptArgument.t *)
294
-
let argument_to_rpc_prompt_argument (arg:argument) =
295
-
Mcp_rpc.PromptsList.PromptArgument.{
296
-
name = arg.name;
297
-
description = arg.description;
298
-
required = arg.required;
299
-
}
300
-
313
+
let argument_to_rpc_prompt_argument (arg : argument) =
314
+
Mcp_rpc.PromptsList.PromptArgument.
315
+
{
316
+
name = arg.name;
317
+
description = arg.description;
318
+
required = arg.required;
319
+
}
320
+
301
321
(* Convert to Mcp_rpc.PromptsList.Prompt.t *)
302
-
let to_rpc_prompt_list_prompt (prompt:t) =
303
-
Mcp_rpc.PromptsList.Prompt.{
304
-
name = prompt.name;
305
-
description = prompt.description;
306
-
arguments = List.map argument_to_rpc_prompt_argument prompt.arguments;
307
-
}
308
-
322
+
let to_rpc_prompt_list_prompt (prompt : t) =
323
+
Mcp_rpc.PromptsList.Prompt.
324
+
{
325
+
name = prompt.name;
326
+
description = prompt.description;
327
+
arguments = List.map argument_to_rpc_prompt_argument prompt.arguments;
328
+
}
329
+
309
330
(* Convert a list of Prompt.t to the format needed for prompts/list response *)
310
-
let to_rpc_prompts_list prompts =
311
-
List.map to_rpc_prompt_list_prompt prompts
312
-
331
+
let to_rpc_prompts_list prompts = List.map to_rpc_prompt_list_prompt prompts
332
+
313
333
(* Convert message to Mcp_rpc.PromptMessage.t *)
314
334
let message_to_rpc_prompt_message msg =
315
-
{
316
-
PromptMessage.role = msg.role;
317
-
PromptMessage.content = msg.content;
318
-
}
319
-
335
+
{ PromptMessage.role = msg.role; PromptMessage.content = msg.content }
336
+
320
337
(* Convert a list of messages to the format needed for prompts/get response *)
321
338
let messages_to_rpc_prompt_messages messages =
322
339
List.map message_to_rpc_prompt_message messages
323
340
end
324
341
325
342
let make_tool_schema properties required =
326
-
let props = List.map (fun (name, schema_type, description) ->
327
-
(name, `Assoc [
328
-
("type", `String schema_type);
329
-
("description", `String description)
330
-
])
331
-
) properties in
343
+
let props =
344
+
List.map
345
+
(fun (name, schema_type, description) ->
346
+
( name,
347
+
`Assoc
348
+
[
349
+
("type", `String schema_type); ("description", `String description);
350
+
] ))
351
+
properties
352
+
in
332
353
let required_json = `List (List.map (fun name -> `String name) required) in
333
-
`Assoc [
334
-
("type", `String "object");
335
-
("properties", `Assoc props);
336
-
("required", required_json)
337
-
]
354
+
`Assoc
355
+
[
356
+
("type", `String "object");
357
+
("properties", `Assoc props);
358
+
("required", required_json);
359
+
]
338
360
339
361
(* Resource Templates for the MCP server *)
340
362
module ResourceTemplate = struct
341
363
type handler = Context.t -> string list -> (string, string) result
342
364
343
365
type t = {
344
-
uri_template: string;
345
-
name: string;
346
-
description: string option;
347
-
mime_type: string option;
348
-
handler: handler;
366
+
uri_template : string;
367
+
name : string;
368
+
description : string option;
369
+
mime_type : string option;
370
+
handler : handler;
349
371
}
350
372
351
-
let create ~uri_template ~name ?description ?mime_type ~handler () =
373
+
let create ~uri_template ~name ?description ?mime_type ~handler () =
352
374
{ uri_template; name; description; mime_type; handler }
353
375
354
376
let to_json resource_template =
355
-
let assoc = [
356
-
("uriTemplate", `String resource_template.uri_template);
357
-
("name", `String resource_template.name);
358
-
] in
359
-
let assoc = match resource_template.description with
377
+
let assoc =
378
+
[
379
+
("uriTemplate", `String resource_template.uri_template);
380
+
("name", `String resource_template.name);
381
+
]
382
+
in
383
+
let assoc =
384
+
match resource_template.description with
360
385
| Some desc -> ("description", `String desc) :: assoc
361
386
| None -> assoc
362
387
in
363
-
let assoc = match resource_template.mime_type with
388
+
let assoc =
389
+
match resource_template.mime_type with
364
390
| Some mime -> ("mimeType", `String mime) :: assoc
365
391
| None -> assoc
366
392
in
367
393
`Assoc assoc
368
-
394
+
369
395
(* Convert to Mcp_rpc.ResourceTemplatesList.ResourceTemplate.t *)
370
-
let to_rpc_resource_template (template:t) =
371
-
Mcp_rpc.ListResourceTemplatesResult.ResourceTemplate.{
372
-
uri_template = template.uri_template;
373
-
name = template.name;
374
-
description = template.description;
375
-
mime_type = template.mime_type;
376
-
}
377
-
396
+
let to_rpc_resource_template (template : t) =
397
+
Mcp_rpc.ListResourceTemplatesResult.ResourceTemplate.
398
+
{
399
+
uri_template = template.uri_template;
400
+
name = template.name;
401
+
description = template.description;
402
+
mime_type = template.mime_type;
403
+
}
404
+
378
405
(* Convert a list of ResourceTemplate.t to the format needed for resources/templates/list response *)
379
406
let to_rpc_resource_templates_list templates =
380
407
List.map to_rpc_resource_template templates
···
382
409
383
410
(* Main server type *)
384
411
type server = {
385
-
name: string;
386
-
version: string;
387
-
protocol_version: string;
388
-
lifespan_context: (string * Json.t) list;
389
-
mutable capabilities: Json.t;
390
-
mutable tools: Tool.t list;
391
-
mutable resources: Resource.t list;
392
-
mutable resource_templates: ResourceTemplate.t list;
393
-
mutable prompts: Prompt.t list;
394
-
}
412
+
name : string;
413
+
version : string;
414
+
protocol_version : string;
415
+
lifespan_context : (string * Json.t) list;
416
+
mutable capabilities : Json.t;
417
+
mutable tools : Tool.t list;
418
+
mutable resources : Resource.t list;
419
+
mutable resource_templates : ResourceTemplate.t list;
420
+
mutable prompts : Prompt.t list;
421
+
}
395
422
396
423
let name { name; _ } = name
397
424
let version { version; _ } = version
···
404
431
let prompts { prompts; _ } = prompts
405
432
406
433
(* Create a new server *)
407
-
let create_server ~name ?(version="0.1.0") ?(protocol_version="2024-11-05") () =
408
-
{
434
+
let create_server ~name ?(version = "0.1.0") ?(protocol_version = "2024-11-05")
435
+
() =
436
+
{
409
437
name;
410
438
version;
411
439
protocol_version;
···
418
446
}
419
447
420
448
(* Default capabilities for the server *)
421
-
let default_capabilities ?(with_tools=true) ?(with_resources=false) ?(with_resource_templates=false) ?(with_prompts=false) () =
449
+
let default_capabilities ?(with_tools = true) ?(with_resources = false)
450
+
?(with_resource_templates = false) ?(with_prompts = false) () =
422
451
let caps = [] in
423
-
let caps =
424
-
if with_tools then
425
-
("tools", `Assoc [
426
-
("listChanged", `Bool true)
427
-
]) :: caps
428
-
else
429
-
caps
452
+
let caps =
453
+
if with_tools then ("tools", `Assoc [ ("listChanged", `Bool true) ]) :: caps
454
+
else caps
430
455
in
431
-
let caps =
456
+
let caps =
432
457
if with_resources then
433
-
("resources", `Assoc [
434
-
("listChanged", `Bool true);
435
-
("subscribe", `Bool false)
436
-
]) :: caps
458
+
( "resources",
459
+
`Assoc [ ("listChanged", `Bool true); ("subscribe", `Bool false) ] )
460
+
:: caps
437
461
else if not with_resources then
438
-
("resources", `Assoc [
439
-
("listChanged", `Bool false);
440
-
("subscribe", `Bool false)
441
-
]) :: caps
442
-
else
443
-
caps
462
+
( "resources",
463
+
`Assoc [ ("listChanged", `Bool false); ("subscribe", `Bool false) ] )
464
+
:: caps
465
+
else caps
444
466
in
445
467
let caps =
446
468
if with_resource_templates then
447
-
("resourceTemplates", `Assoc [
448
-
("listChanged", `Bool true)
449
-
]) :: caps
469
+
("resourceTemplates", `Assoc [ ("listChanged", `Bool true) ]) :: caps
450
470
else if not with_resource_templates then
451
-
("resourceTemplates", `Assoc [
452
-
("listChanged", `Bool false)
453
-
]) :: caps
454
-
else
455
-
caps
471
+
("resourceTemplates", `Assoc [ ("listChanged", `Bool false) ]) :: caps
472
+
else caps
456
473
in
457
-
let caps =
474
+
let caps =
458
475
if with_prompts then
459
-
("prompts", `Assoc [
460
-
("listChanged", `Bool true)
461
-
]) :: caps
476
+
("prompts", `Assoc [ ("listChanged", `Bool true) ]) :: caps
462
477
else if not with_prompts then
463
-
("prompts", `Assoc [
464
-
("listChanged", `Bool false)
465
-
]) :: caps
466
-
else
467
-
caps
478
+
("prompts", `Assoc [ ("listChanged", `Bool false) ]) :: caps
479
+
else caps
468
480
in
469
481
`Assoc caps
470
482
···
474
486
tool
475
487
476
488
(* Create and register a tool in one step *)
477
-
let add_tool server ~name ?description ?(schema_properties=[]) ?(schema_required=[]) handler =
489
+
let add_tool server ~name ?description ?(schema_properties = [])
490
+
?(schema_required = []) handler =
478
491
let input_schema = make_tool_schema schema_properties schema_required in
479
492
let handler' ctx args =
480
-
try
481
-
Ok (handler args)
482
-
with exn ->
483
-
Error (Printexc.to_string exn)
493
+
try Ok (handler args) with exn -> Error (Printexc.to_string exn)
484
494
in
485
-
let tool = Tool.create
486
-
~name
487
-
?description
488
-
~input_schema
489
-
~handler:handler'
490
-
()
495
+
let tool =
496
+
Tool.create ~name ?description ~input_schema ~handler:handler' ()
491
497
in
492
498
register_tool server tool
493
499
···
499
505
(* Create and register a resource in one step *)
500
506
let add_resource server ~uri ~name ?description ?mime_type handler =
501
507
let handler' _ctx params =
502
-
try
503
-
Ok (handler params)
504
-
with exn ->
505
-
Error (Printexc.to_string exn)
508
+
try Ok (handler params) with exn -> Error (Printexc.to_string exn)
506
509
in
507
-
let resource = Resource.create
508
-
~uri
509
-
~name
510
-
?description
511
-
?mime_type
512
-
~handler:handler'
513
-
()
510
+
let resource =
511
+
Resource.create ~uri ~name ?description ?mime_type ~handler:handler' ()
514
512
in
515
513
register_resource server resource
516
514
···
520
518
template
521
519
522
520
(* Create and register a resource template in one step *)
523
-
let add_resource_template server ~uri_template ~name ?description ?mime_type handler =
521
+
let add_resource_template server ~uri_template ~name ?description ?mime_type
522
+
handler =
524
523
let handler' _ctx params =
525
-
try
526
-
Ok (handler params)
527
-
with exn ->
528
-
Error (Printexc.to_string exn)
524
+
try Ok (handler params) with exn -> Error (Printexc.to_string exn)
529
525
in
530
-
let template = ResourceTemplate.create
531
-
~uri_template
532
-
~name
533
-
?description
534
-
?mime_type
535
-
~handler:handler'
536
-
()
526
+
let template =
527
+
ResourceTemplate.create ~uri_template ~name ?description ?mime_type
528
+
~handler:handler' ()
537
529
in
538
530
register_resource_template server template
539
531
···
543
535
prompt
544
536
545
537
(* Create and register a prompt in one step *)
546
-
let add_prompt server ~name ?description ?(arguments=[]) handler =
547
-
let prompt_args = List.map (fun (name, desc, required) ->
548
-
Prompt.create_argument ~name ?description:desc ~required ()
549
-
) arguments in
538
+
let add_prompt server ~name ?description ?(arguments = []) handler =
539
+
let prompt_args =
540
+
List.map
541
+
(fun (name, desc, required) ->
542
+
Prompt.create_argument ~name ?description:desc ~required ())
543
+
arguments
544
+
in
550
545
let handler' _ctx args =
551
-
try
552
-
Ok (handler args)
553
-
with exn ->
554
-
Error (Printexc.to_string exn)
546
+
try Ok (handler args) with exn -> Error (Printexc.to_string exn)
555
547
in
556
-
let prompt = Prompt.create
557
-
~name
558
-
?description
559
-
~arguments:prompt_args
560
-
~handler:handler'
561
-
()
548
+
let prompt =
549
+
Prompt.create ~name ?description ~arguments:prompt_args ~handler:handler' ()
562
550
in
563
551
register_prompt server prompt
564
552
565
553
(* Set server capabilities *)
566
-
let set_capabilities server capabilities =
567
-
server.capabilities <- capabilities
554
+
let set_capabilities server capabilities = server.capabilities <- capabilities
568
555
569
556
(* Configure server with default capabilities based on registered components *)
570
-
let configure_server server ?with_tools ?with_resources ?with_resource_templates ?with_prompts () =
571
-
let with_tools = match with_tools with
572
-
| Some b -> b
573
-
| None -> server.tools <> []
557
+
let configure_server server ?with_tools ?with_resources ?with_resource_templates
558
+
?with_prompts () =
559
+
let with_tools =
560
+
match with_tools with Some b -> b | None -> server.tools <> []
574
561
in
575
-
let with_resources = match with_resources with
576
-
| Some b -> b
577
-
| None -> server.resources <> []
562
+
let with_resources =
563
+
match with_resources with Some b -> b | None -> server.resources <> []
578
564
in
579
-
let with_resource_templates = match with_resource_templates with
565
+
let with_resource_templates =
566
+
match with_resource_templates with
580
567
| Some b -> b
581
568
| None -> server.resource_templates <> []
582
569
in
583
-
let with_prompts = match with_prompts with
584
-
| Some b -> b
585
-
| None -> server.prompts <> []
570
+
let with_prompts =
571
+
match with_prompts with Some b -> b | None -> server.prompts <> []
586
572
in
587
-
let capabilities = default_capabilities ~with_tools ~with_resources ~with_resource_templates ~with_prompts () in
573
+
let capabilities =
574
+
default_capabilities ~with_tools ~with_resources ~with_resource_templates
575
+
~with_prompts ()
576
+
in
588
577
set_capabilities server capabilities;
589
578
server
+168
-80
lib/mcp_sdk.mli
+168
-80
lib/mcp_sdk.mli
···
3
3
open Mcp
4
4
open Jsonrpc
5
5
6
-
(** SDK version *)
7
6
val version : string
7
+
(** SDK version *)
8
8
9
9
(** Logging utilities *)
10
10
module Log : sig
···
12
12
13
13
val string_of_level : level -> string
14
14
15
-
(** Format-string based logging functions *)
16
15
val logf : level -> ('a, out_channel, unit) format -> 'a
16
+
(** Format-string based logging functions *)
17
+
17
18
val debugf : ('a, out_channel, unit) format -> 'a
18
19
val infof : ('a, out_channel, unit) format -> 'a
19
20
val warningf : ('a, out_channel, unit) format -> 'a
20
21
val errorf : ('a, out_channel, unit) format -> 'a
21
22
23
+
val log : level -> string -> unit
22
24
(** Simple string logging functions (for backward compatibility) *)
23
-
val log : level -> string -> unit
25
+
24
26
val debug : string -> unit
25
27
val info : string -> unit
26
28
val warning : string -> unit
···
31
33
module Context : sig
32
34
type t
33
35
34
-
val create : ?request_id:RequestId.t -> ?progress_token:ProgressToken.t -> ?lifespan_context:(string * Json.t) list -> unit -> t
36
+
val create :
37
+
?request_id:RequestId.t ->
38
+
?progress_token:ProgressToken.t ->
39
+
?lifespan_context:(string * Json.t) list ->
40
+
unit ->
41
+
t
42
+
35
43
val get_context_value : t -> string -> Json.t option
36
44
val report_progress : t -> float -> float -> JSONRPCMessage.t option
37
45
end
···
41
49
type handler = Context.t -> Json.t -> (Json.t, string) result
42
50
43
51
type t = {
44
-
name: string;
45
-
description: string option;
46
-
input_schema: Json.t;
47
-
handler: handler;
52
+
name : string;
53
+
description : string option;
54
+
input_schema : Json.t;
55
+
handler : handler;
48
56
}
49
57
50
-
val create : name:string -> ?description:string -> input_schema:Json.t -> handler:handler -> unit -> t
58
+
val create :
59
+
name:string ->
60
+
?description:string ->
61
+
input_schema:Json.t ->
62
+
handler:handler ->
63
+
unit ->
64
+
t
65
+
51
66
val to_json : t -> Json.t
52
-
53
-
(** Convert to Mcp_rpc.ToolsList.Tool.t *)
67
+
54
68
val to_rpc_tool_list_tool : t -> Mcp_rpc.ToolsList.Tool.t
55
-
56
-
(** Convert a list of Tool.t to the format needed for tools/list response *)
69
+
(** Convert to Mcp_rpc.ToolsList.Tool.t *)
70
+
57
71
val to_rpc_tools_list : t list -> Mcp_rpc.ToolsList.Tool.t list
58
-
72
+
(** Convert a list of Tool.t to the format needed for tools/list response *)
73
+
74
+
val rpc_content_to_mcp_content :
75
+
Mcp_rpc.ToolsCall.ToolContent.t list -> Mcp.content list
59
76
(** Convert Mcp_rpc.ToolsCall response content to Mcp.content list *)
60
-
val rpc_content_to_mcp_content : Mcp_rpc.ToolsCall.ToolContent.t list -> Mcp.content list
61
-
77
+
78
+
val mcp_content_to_rpc_content :
79
+
Mcp.content list -> Mcp_rpc.ToolsCall.ToolContent.t list
62
80
(** Convert Mcp.content list to Mcp_rpc.ToolsCall.ToolContent.t list *)
63
-
val mcp_content_to_rpc_content : Mcp.content list -> Mcp_rpc.ToolsCall.ToolContent.t list
64
-
81
+
82
+
val create_tool_result : Mcp.content list -> is_error:bool -> Json.t
65
83
(** Create a tool result with content *)
66
-
val create_tool_result : Mcp.content list -> is_error:bool -> Json.t
67
-
84
+
85
+
val create_error_result : string -> Json.t
68
86
(** Create a tool error result with structured content *)
69
-
val create_error_result : string -> Json.t
70
-
71
-
(** Handle tool execution errors *)
87
+
72
88
val handle_execution_error : string -> Json.t
73
-
74
-
(** Handle unknown tool error *)
89
+
(** Handle tool execution errors *)
90
+
75
91
val handle_unknown_tool_error : string -> Json.t
76
-
77
-
(** Handle general tool execution exception *)
92
+
(** Handle unknown tool error *)
93
+
78
94
val handle_execution_exception : exn -> Json.t
95
+
(** Handle general tool execution exception *)
79
96
end
80
97
81
98
(** Resources for the MCP server *)
···
83
100
type handler = Context.t -> string list -> (string, string) result
84
101
85
102
type t = {
86
-
uri: string;
87
-
name: string;
88
-
description: string option;
89
-
mime_type: string option;
90
-
handler: handler;
103
+
uri : string;
104
+
name : string;
105
+
description : string option;
106
+
mime_type : string option;
107
+
handler : handler;
91
108
}
92
109
93
-
val create : uri:string -> name:string -> ?description:string -> ?mime_type:string -> handler:handler -> unit -> t
110
+
val create :
111
+
uri:string ->
112
+
name:string ->
113
+
?description:string ->
114
+
?mime_type:string ->
115
+
handler:handler ->
116
+
unit ->
117
+
t
118
+
94
119
val to_json : t -> Json.t
95
-
96
-
(** Convert to Mcp_rpc.ResourcesList.Resource.t *)
120
+
97
121
val to_rpc_resource_list_resource : t -> Mcp_rpc.ResourcesList.Resource.t
98
-
99
-
(** Convert a list of Resource.t to the format needed for resources/list response *)
122
+
(** Convert to Mcp_rpc.ResourcesList.Resource.t *)
123
+
100
124
val to_rpc_resources_list : t list -> Mcp_rpc.ResourcesList.Resource.t list
125
+
(** Convert a list of Resource.t to the format needed for resources/list
126
+
response *)
101
127
end
102
128
103
129
(** Resource Templates for the MCP server *)
···
105
131
type handler = Context.t -> string list -> (string, string) result
106
132
107
133
type t = {
108
-
uri_template: string;
109
-
name: string;
110
-
description: string option;
111
-
mime_type: string option;
112
-
handler: handler;
134
+
uri_template : string;
135
+
name : string;
136
+
description : string option;
137
+
mime_type : string option;
138
+
handler : handler;
113
139
}
114
140
115
-
val create : uri_template:string -> name:string -> ?description:string -> ?mime_type:string -> handler:handler -> unit -> t
141
+
val create :
142
+
uri_template:string ->
143
+
name:string ->
144
+
?description:string ->
145
+
?mime_type:string ->
146
+
handler:handler ->
147
+
unit ->
148
+
t
149
+
116
150
val to_json : t -> Json.t
117
-
151
+
152
+
val to_rpc_resource_template :
153
+
t -> Mcp_rpc.ListResourceTemplatesResult.ResourceTemplate.t
118
154
(** Convert to Mcp_rpc.ResourceTemplatesList.ResourceTemplate.t *)
119
-
val to_rpc_resource_template : t -> Mcp_rpc.ListResourceTemplatesResult.ResourceTemplate.t
120
-
121
-
(** Convert a list of ResourceTemplate.t to the format needed for resources/templates/list response *)
122
-
val to_rpc_resource_templates_list : t list -> Mcp_rpc.ListResourceTemplatesResult.ResourceTemplate.t list
155
+
156
+
val to_rpc_resource_templates_list :
157
+
t list -> Mcp_rpc.ListResourceTemplatesResult.ResourceTemplate.t list
158
+
(** Convert a list of ResourceTemplate.t to the format needed for
159
+
resources/templates/list response *)
123
160
end
124
161
125
162
(** Prompts for the MCP server *)
126
163
module Prompt : sig
127
164
type argument = {
128
-
name: string;
129
-
description: string option;
130
-
required: bool;
165
+
name : string;
166
+
description : string option;
167
+
required : bool;
131
168
}
132
169
133
-
type message = {
134
-
role: Role.t;
135
-
content: content;
136
-
}
170
+
type message = { role : Role.t; content : content }
137
171
138
-
type handler = Context.t -> (string * string) list -> (message list, string) result
172
+
type handler =
173
+
Context.t -> (string * string) list -> (message list, string) result
139
174
140
175
type t = {
141
-
name: string;
142
-
description: string option;
143
-
arguments: argument list;
144
-
handler: handler;
176
+
name : string;
177
+
description : string option;
178
+
arguments : argument list;
179
+
handler : handler;
145
180
}
146
181
147
-
val create : name:string -> ?description:string -> ?arguments:argument list -> handler:handler -> unit -> t
148
-
val create_argument : name:string -> ?description:string -> ?required:bool -> unit -> argument
182
+
val create :
183
+
name:string ->
184
+
?description:string ->
185
+
?arguments:argument list ->
186
+
handler:handler ->
187
+
unit ->
188
+
t
189
+
190
+
val create_argument :
191
+
name:string -> ?description:string -> ?required:bool -> unit -> argument
192
+
149
193
val to_json : t -> Json.t
150
-
194
+
195
+
val argument_to_rpc_prompt_argument :
196
+
argument -> Mcp_rpc.PromptsList.PromptArgument.t
151
197
(** Convert argument to Mcp_rpc.PromptsList.PromptArgument.t *)
152
-
val argument_to_rpc_prompt_argument : argument -> Mcp_rpc.PromptsList.PromptArgument.t
153
-
154
-
(** Convert to Mcp_rpc.PromptsList.Prompt.t *)
198
+
155
199
val to_rpc_prompt_list_prompt : t -> Mcp_rpc.PromptsList.Prompt.t
156
-
157
-
(** Convert a list of Prompt.t to the format needed for prompts/list response *)
200
+
(** Convert to Mcp_rpc.PromptsList.Prompt.t *)
201
+
158
202
val to_rpc_prompts_list : t list -> Mcp_rpc.PromptsList.Prompt.t list
159
-
160
-
(** Convert message to Mcp_rpc.PromptMessage.t *)
203
+
(** Convert a list of Prompt.t to the format needed for prompts/list response
204
+
*)
205
+
161
206
val message_to_rpc_prompt_message : message -> PromptMessage.t
162
-
163
-
(** Convert a list of messages to the format needed for prompts/get response *)
207
+
(** Convert message to Mcp_rpc.PromptMessage.t *)
208
+
164
209
val messages_to_rpc_prompt_messages : message list -> PromptMessage.t list
210
+
(** Convert a list of messages to the format needed for prompts/get response
211
+
*)
165
212
end
166
213
214
+
type server
167
215
(** Main server type *)
168
-
type server
169
216
170
217
val name : server -> string
171
218
val version : server -> string
···
176
223
val resource_templates : server -> ResourceTemplate.t list
177
224
val prompts : server -> Prompt.t list
178
225
226
+
val create_server :
227
+
name:string -> ?version:string -> ?protocol_version:string -> unit -> server
179
228
(** Create a new server *)
180
-
val create_server : name:string -> ?version:string -> ?protocol_version:string -> unit -> server
181
229
230
+
val default_capabilities :
231
+
?with_tools:bool ->
232
+
?with_resources:bool ->
233
+
?with_resource_templates:bool ->
234
+
?with_prompts:bool ->
235
+
unit ->
236
+
Json.t
182
237
(** Default capabilities for the server *)
183
-
val default_capabilities : ?with_tools:bool -> ?with_resources:bool -> ?with_resource_templates:bool -> ?with_prompts:bool -> unit -> Json.t
184
238
239
+
val add_tool :
240
+
server ->
241
+
name:string ->
242
+
?description:string ->
243
+
?schema_properties:(string * string * string) list ->
244
+
?schema_required:string list ->
245
+
(Json.t -> Json.t) ->
246
+
Tool.t
185
247
(** Create and register a tool in one step *)
186
-
val add_tool : server -> name:string -> ?description:string -> ?schema_properties:(string * string * string) list -> ?schema_required:string list -> (Json.t -> Json.t) -> Tool.t
187
248
249
+
val add_resource :
250
+
server ->
251
+
uri:string ->
252
+
name:string ->
253
+
?description:string ->
254
+
?mime_type:string ->
255
+
(string list -> string) ->
256
+
Resource.t
188
257
(** Create and register a resource in one step *)
189
-
val add_resource : server -> uri:string -> name:string -> ?description:string -> ?mime_type:string -> (string list -> string) -> Resource.t
190
258
259
+
val add_resource_template :
260
+
server ->
261
+
uri_template:string ->
262
+
name:string ->
263
+
?description:string ->
264
+
?mime_type:string ->
265
+
(string list -> string) ->
266
+
ResourceTemplate.t
191
267
(** Create and register a resource template in one step *)
192
-
val add_resource_template : server -> uri_template:string -> name:string -> ?description:string -> ?mime_type:string -> (string list -> string) -> ResourceTemplate.t
193
268
269
+
val add_prompt :
270
+
server ->
271
+
name:string ->
272
+
?description:string ->
273
+
?arguments:(string * string option * bool) list ->
274
+
((string * string) list -> Prompt.message list) ->
275
+
Prompt.t
194
276
(** Create and register a prompt in one step *)
195
-
val add_prompt : server -> name:string -> ?description:string -> ?arguments:(string * string option * bool) list -> ((string * string) list -> Prompt.message list) -> Prompt.t
196
277
278
+
val configure_server :
279
+
server ->
280
+
?with_tools:bool ->
281
+
?with_resources:bool ->
282
+
?with_resource_templates:bool ->
283
+
?with_prompts:bool ->
284
+
unit ->
285
+
server
197
286
(** Configure server with default capabilities based on registered components *)
198
-
val configure_server : server -> ?with_tools:bool -> ?with_resources:bool -> ?with_resource_templates:bool -> ?with_prompts:bool -> unit -> server
199
287
200
288
val make_tool_schema : (string * string * string) list -> string list -> Json.t
+280
-227
lib/mcp_server.ml
+280
-227
lib/mcp_server.ml
···
5
5
(* Create a proper JSONRPC error with code and data *)
6
6
let create_jsonrpc_error id code message ?data () =
7
7
let error_code = ErrorCode.to_int code in
8
-
let error_data = match data with
9
-
| Some d -> d
10
-
| None -> `Null
11
-
in
8
+
let error_data = match data with Some d -> d | None -> `Null in
12
9
create_error ~id ~code:error_code ~message ~data:(Some error_data) ()
13
10
14
11
(* Process initialize request *)
15
12
let handle_initialize server req =
16
13
Log.debug "Processing initialize request";
17
-
let result = match req.JSONRPCMessage.params with
18
-
| Some params ->
14
+
let result =
15
+
match req.JSONRPCMessage.params with
16
+
| Some params ->
19
17
let req_data = Initialize.Request.t_of_yojson params in
20
-
Log.debugf "Client info: %s v%s"
21
-
req_data.client_info.name req_data.client_info.version;
18
+
Log.debugf "Client info: %s v%s" req_data.client_info.name
19
+
req_data.client_info.version;
22
20
Log.debugf "Client protocol version: %s" req_data.protocol_version;
23
-
21
+
24
22
(* Create initialize response *)
25
-
let result = Initialize.Result.create
26
-
~capabilities:(capabilities server)
27
-
~server_info:Implementation.{
28
-
name = name server;
29
-
version = version server
30
-
}
31
-
~protocol_version:(protocol_version server)
32
-
~instructions:(Printf.sprintf "This server provides tools for %s." (name server))
33
-
()
23
+
let result =
24
+
Initialize.Result.create ~capabilities:(capabilities server)
25
+
~server_info:
26
+
Implementation.{ name = name server; version = version server }
27
+
~protocol_version:(protocol_version server)
28
+
~instructions:
29
+
(Printf.sprintf "This server provides tools for %s." (name server))
30
+
()
34
31
in
35
32
Initialize.Result.yojson_of_t result
36
-
| None ->
33
+
| None ->
37
34
Log.error "Missing params for initialize request";
38
-
`Assoc [("error", `String "Missing params for initialize request")]
35
+
`Assoc [ ("error", `String "Missing params for initialize request") ]
39
36
in
40
37
Some (create_response ~id:req.id ~result)
41
38
42
39
(* Process tools/list request *)
43
-
let handle_tools_list server (req:JSONRPCMessage.request) =
40
+
let handle_tools_list server (req : JSONRPCMessage.request) =
44
41
Log.debug "Processing tools/list request";
45
42
let tools_list = Tool.to_rpc_tools_list (tools server) in
46
-
let response = Mcp_rpc.ToolsList.create_response ~id:req.id ~tools:tools_list () in
43
+
let response =
44
+
Mcp_rpc.ToolsList.create_response ~id:req.id ~tools:tools_list ()
45
+
in
47
46
Some response
48
47
49
48
(* Process prompts/list request *)
50
-
let handle_prompts_list server (req:JSONRPCMessage.request) =
49
+
let handle_prompts_list server (req : JSONRPCMessage.request) =
51
50
Log.debug "Processing prompts/list request";
52
51
let prompts_list = Prompt.to_rpc_prompts_list (prompts server) in
53
-
let response = Mcp_rpc.PromptsList.create_response ~id:req.id ~prompts:prompts_list () in
52
+
let response =
53
+
Mcp_rpc.PromptsList.create_response ~id:req.id ~prompts:prompts_list ()
54
+
in
54
55
Some response
55
56
56
57
(* Process resources/list request *)
57
-
let handle_resources_list server (req:JSONRPCMessage.request) =
58
+
let handle_resources_list server (req : JSONRPCMessage.request) =
58
59
Log.debug "Processing resources/list request";
59
60
let resources_list = Resource.to_rpc_resources_list (resources server) in
60
-
let response = Mcp_rpc.ResourcesList.create_response ~id:req.id ~resources:resources_list () in
61
+
let response =
62
+
Mcp_rpc.ResourcesList.create_response ~id:req.id ~resources:resources_list
63
+
()
64
+
in
61
65
Some response
62
66
63
67
(* Process resources/templates/list request *)
64
-
let handle_resource_templates_list server (req:JSONRPCMessage.request) =
68
+
let handle_resource_templates_list server (req : JSONRPCMessage.request) =
65
69
Log.debug "Processing resources/templates/list request";
66
-
let templates_list = ResourceTemplate.to_rpc_resource_templates_list (resource_templates server) in
67
-
let response = Mcp_rpc.ListResourceTemplatesResult.create_response ~id:req.id ~resource_templates:templates_list () in
70
+
let templates_list =
71
+
ResourceTemplate.to_rpc_resource_templates_list (resource_templates server)
72
+
in
73
+
let response =
74
+
Mcp_rpc.ListResourceTemplatesResult.create_response ~id:req.id
75
+
~resource_templates:templates_list ()
76
+
in
68
77
Some response
69
78
70
79
(* Utility module for resource template matching *)
···
80
89
(* Simple template variable extraction - could be enhanced with regex *)
81
90
let template_parts = String.split_on_char '/' template_uri in
82
91
let uri_parts = String.split_on_char '/' uri in
83
-
84
-
if List.length template_parts <> List.length uri_parts then
85
-
None
92
+
93
+
if List.length template_parts <> List.length uri_parts then None
86
94
else
87
95
(* Match parts and extract variables *)
88
96
let rec match_parts tparts uparts acc =
89
-
match tparts, uparts with
97
+
match (tparts, uparts) with
90
98
| [], [] -> Some (List.rev acc)
91
-
| th::tt, uh::ut ->
99
+
| th :: tt, uh :: ut ->
92
100
(* Check if this part is a template variable *)
93
-
if String.length th > 2 &&
94
-
String.get th 0 = '{' &&
95
-
String.get th (String.length th - 1) = '}' then
101
+
if
102
+
String.length th > 2
103
+
&& String.get th 0 = '{'
104
+
&& String.get th (String.length th - 1) = '}'
105
+
then
96
106
(* Extract variable value and continue *)
97
-
match_parts tt ut (uh::acc)
107
+
match_parts tt ut (uh :: acc)
98
108
else if th = uh then
99
109
(* Fixed part matches, continue *)
100
110
match_parts tt ut acc
···
108
118
(* Find a matching resource or template for a URI *)
109
119
let find_match server uri =
110
120
(* Try direct resource match first *)
111
-
match List.find_opt (fun resource -> resource.Resource.uri = uri) (resources server) with
121
+
match
122
+
List.find_opt
123
+
(fun resource -> resource.Resource.uri = uri)
124
+
(resources server)
125
+
with
112
126
| Some resource -> DirectResource (resource, [])
113
127
| None ->
114
128
(* Try template match next *)
115
129
let templates = resource_templates server in
116
-
130
+
117
131
(* Try each template to see if it matches *)
118
132
let rec try_templates templates =
119
133
match templates with
120
134
| [] -> NoMatch
121
-
| template::rest ->
122
-
match extract_template_vars template.ResourceTemplate.uri_template uri with
135
+
| template :: rest -> (
136
+
match
137
+
extract_template_vars template.ResourceTemplate.uri_template uri
138
+
with
123
139
| Some params -> TemplateResource (template, params)
124
-
| None -> try_templates rest
140
+
| None -> try_templates rest)
125
141
in
126
142
try_templates templates
127
143
end
128
144
129
145
(* Process resources/read request *)
130
-
let handle_resources_read server (req:JSONRPCMessage.request) =
146
+
let handle_resources_read server (req : JSONRPCMessage.request) =
131
147
Log.debug "Processing resources/read request";
132
148
match req.JSONRPCMessage.params with
133
149
| None ->
134
150
Log.error "Missing params for resources/read request";
135
-
Some (create_jsonrpc_error req.id ErrorCode.InvalidParams "Missing params for resources/read request" ())
136
-
| Some params ->
151
+
Some
152
+
(create_jsonrpc_error req.id ErrorCode.InvalidParams
153
+
"Missing params for resources/read request" ())
154
+
| Some params -> (
137
155
let req_data = Mcp_rpc.ResourcesRead.Request.t_of_yojson params in
138
156
let uri = req_data.uri in
139
157
Log.debugf "Resource URI: %s" uri;
140
-
158
+
141
159
(* Find matching resource or template *)
142
160
match Resource_matcher.find_match server uri with
143
-
| Resource_matcher.DirectResource (resource, params) ->
161
+
| Resource_matcher.DirectResource (resource, params) -> (
144
162
(* Create context for this request *)
145
-
let ctx = Context.create
146
-
?request_id:(Some req.id)
147
-
?progress_token:req.progress_token
148
-
~lifespan_context:[("resources/read", `Assoc [("uri", `String uri)])]
149
-
()
163
+
let ctx =
164
+
Context.create ?request_id:(Some req.id)
165
+
?progress_token:req.progress_token
166
+
~lifespan_context:
167
+
[ ("resources/read", `Assoc [ ("uri", `String uri) ]) ]
168
+
()
150
169
in
151
-
170
+
152
171
Log.debugf "Handling direct resource: %s" resource.name;
153
-
172
+
154
173
(* Call the resource handler *)
155
-
(match resource.handler ctx params with
156
-
| Ok content ->
157
-
(* Create text resource content *)
158
-
let mime_type = match resource.mime_type with
159
-
| Some mime -> mime
160
-
| None -> "text/plain"
161
-
in
162
-
let text_resource = {
163
-
TextResourceContents.uri;
164
-
text = content;
165
-
mime_type = Some mime_type
166
-
} in
167
-
let resource_content = Mcp_rpc.ResourcesRead.ResourceContent.TextResource text_resource in
168
-
let response = Mcp_rpc.ResourcesRead.create_response ~id:req.id ~contents:[resource_content] () in
169
-
Some response
170
-
| Error err ->
171
-
Log.errorf "Error reading resource: %s" err;
172
-
Some (create_jsonrpc_error req.id ErrorCode.InternalError ("Error reading resource: " ^ err) ()))
173
-
174
-
| Resource_matcher.TemplateResource (template, params) ->
174
+
match resource.handler ctx params with
175
+
| Ok content ->
176
+
(* Create text resource content *)
177
+
let mime_type =
178
+
match resource.mime_type with
179
+
| Some mime -> mime
180
+
| None -> "text/plain"
181
+
in
182
+
let text_resource =
183
+
{
184
+
TextResourceContents.uri;
185
+
text = content;
186
+
mime_type = Some mime_type;
187
+
}
188
+
in
189
+
let resource_content =
190
+
Mcp_rpc.ResourcesRead.ResourceContent.TextResource text_resource
191
+
in
192
+
let response =
193
+
Mcp_rpc.ResourcesRead.create_response ~id:req.id
194
+
~contents:[ resource_content ] ()
195
+
in
196
+
Some response
197
+
| Error err ->
198
+
Log.errorf "Error reading resource: %s" err;
199
+
Some
200
+
(create_jsonrpc_error req.id ErrorCode.InternalError
201
+
("Error reading resource: " ^ err)
202
+
()))
203
+
| Resource_matcher.TemplateResource (template, params) -> (
175
204
(* Create context for this request *)
176
-
let ctx = Context.create
177
-
?request_id:(Some req.id)
178
-
?progress_token:req.progress_token
179
-
~lifespan_context:[("resources/read", `Assoc [("uri", `String uri)])]
180
-
()
205
+
let ctx =
206
+
Context.create ?request_id:(Some req.id)
207
+
?progress_token:req.progress_token
208
+
~lifespan_context:
209
+
[ ("resources/read", `Assoc [ ("uri", `String uri) ]) ]
210
+
()
181
211
in
182
-
183
-
Log.debugf "Handling resource template: %s with params: [%s]"
184
-
template.name
212
+
213
+
Log.debugf "Handling resource template: %s with params: [%s]"
214
+
template.name
185
215
(String.concat ", " params);
186
-
216
+
187
217
(* Call the template handler *)
188
-
(match template.handler ctx params with
189
-
| Ok content ->
190
-
(* Create text resource content *)
191
-
let mime_type = match template.mime_type with
192
-
| Some mime -> mime
193
-
| None -> "text/plain"
194
-
in
195
-
let text_resource = {
196
-
TextResourceContents.uri;
197
-
text = content;
198
-
mime_type = Some mime_type
199
-
} in
200
-
let resource_content = Mcp_rpc.ResourcesRead.ResourceContent.TextResource text_resource in
201
-
let response = Mcp_rpc.ResourcesRead.create_response ~id:req.id ~contents:[resource_content] () in
202
-
Some response
203
-
| Error err ->
204
-
Log.errorf "Error reading resource template: %s" err;
205
-
Some (create_jsonrpc_error req.id ErrorCode.InternalError ("Error reading resource template: " ^ err) ()))
206
-
218
+
match template.handler ctx params with
219
+
| Ok content ->
220
+
(* Create text resource content *)
221
+
let mime_type =
222
+
match template.mime_type with
223
+
| Some mime -> mime
224
+
| None -> "text/plain"
225
+
in
226
+
let text_resource =
227
+
{
228
+
TextResourceContents.uri;
229
+
text = content;
230
+
mime_type = Some mime_type;
231
+
}
232
+
in
233
+
let resource_content =
234
+
Mcp_rpc.ResourcesRead.ResourceContent.TextResource text_resource
235
+
in
236
+
let response =
237
+
Mcp_rpc.ResourcesRead.create_response ~id:req.id
238
+
~contents:[ resource_content ] ()
239
+
in
240
+
Some response
241
+
| Error err ->
242
+
Log.errorf "Error reading resource template: %s" err;
243
+
Some
244
+
(create_jsonrpc_error req.id ErrorCode.InternalError
245
+
("Error reading resource template: " ^ err)
246
+
()))
207
247
| Resource_matcher.NoMatch ->
208
248
Log.errorf "Resource not found: %s" uri;
209
-
Some (create_jsonrpc_error req.id ErrorCode.InvalidParams ("Resource not found: " ^ uri) ())
249
+
Some
250
+
(create_jsonrpc_error req.id ErrorCode.InvalidParams
251
+
("Resource not found: " ^ uri)
252
+
()))
210
253
211
254
(* Extract the tool name from params *)
212
255
let extract_tool_name params =
213
256
match List.assoc_opt "name" params with
214
-
| Some (`String name) ->
215
-
Log.debugf "Tool name: %s" name;
216
-
Some name
217
-
| _ ->
218
-
Log.error "Missing or invalid 'name' parameter in tool call";
219
-
None
257
+
| Some (`String name) ->
258
+
Log.debugf "Tool name: %s" name;
259
+
Some name
260
+
| _ ->
261
+
Log.error "Missing or invalid 'name' parameter in tool call";
262
+
None
220
263
221
264
(* Extract the tool arguments from params *)
222
265
let extract_tool_arguments params =
223
266
match List.assoc_opt "arguments" params with
224
-
| Some (args) ->
225
-
Log.debugf "Tool arguments: %s" (Yojson.Safe.to_string args);
226
-
args
227
-
| _ ->
228
-
Log.debug "No arguments provided for tool call, using empty object";
229
-
`Assoc [] (* Empty arguments is valid *)
267
+
| Some args ->
268
+
Log.debugf "Tool arguments: %s" (Yojson.Safe.to_string args);
269
+
args
270
+
| _ ->
271
+
Log.debug "No arguments provided for tool call, using empty object";
272
+
`Assoc [] (* Empty arguments is valid *)
230
273
231
274
(* Execute a tool *)
232
275
let execute_tool server ctx name args =
233
276
try
234
277
let tool = List.find (fun t -> t.Tool.name = name) (tools server) in
235
278
Log.debugf "Found tool: %s" name;
236
-
279
+
237
280
(* Call the tool handler *)
238
281
match tool.handler ctx args with
239
-
| Ok result ->
282
+
| Ok result ->
240
283
Log.debug "Tool execution succeeded";
241
284
result
242
285
| Error err -> Tool.handle_execution_error err
···
247
290
(* Convert JSON tool result to RPC content format *)
248
291
let json_to_rpc_content json =
249
292
match json with
250
-
| `Assoc fields ->
251
-
(match List.assoc_opt "content" fields, List.assoc_opt "isError" fields with
252
-
| Some (`List content_items), Some (`Bool is_error) ->
253
-
let mcp_content = List.map Mcp.content_of_yojson content_items in
254
-
let rpc_content = Tool.mcp_content_to_rpc_content mcp_content in
255
-
(rpc_content, is_error)
256
-
| _ ->
257
-
(* Fallback for compatibility with older formats *)
258
-
let text = Yojson.Safe.to_string json in
259
-
let text_content = { TextContent.text = text; annotations = None } in
260
-
([Mcp_rpc.ToolsCall.ToolContent.Text text_content], false))
293
+
| `Assoc fields -> (
294
+
match
295
+
(List.assoc_opt "content" fields, List.assoc_opt "isError" fields)
296
+
with
297
+
| Some (`List content_items), Some (`Bool is_error) ->
298
+
let mcp_content = List.map Mcp.content_of_yojson content_items in
299
+
let rpc_content = Tool.mcp_content_to_rpc_content mcp_content in
300
+
(rpc_content, is_error)
301
+
| _ ->
302
+
(* Fallback for compatibility with older formats *)
303
+
let text = Yojson.Safe.to_string json in
304
+
let text_content = { TextContent.text; annotations = None } in
305
+
([ Mcp_rpc.ToolsCall.ToolContent.Text text_content ], false))
261
306
| _ ->
262
-
(* Simple fallback for non-object results *)
263
-
let text = Yojson.Safe.to_string json in
264
-
let text_content = { TextContent.text = text; annotations = None } in
265
-
([Mcp_rpc.ToolsCall.ToolContent.Text text_content], false)
307
+
(* Simple fallback for non-object results *)
308
+
let text = Yojson.Safe.to_string json in
309
+
let text_content = { TextContent.text; annotations = None } in
310
+
([ Mcp_rpc.ToolsCall.ToolContent.Text text_content ], false)
266
311
267
312
(* Process tools/call request *)
268
313
let handle_tools_call server req =
269
314
Log.debug "Processing tools/call request";
270
315
match req.JSONRPCMessage.params with
271
-
| Some (`Assoc params) ->
272
-
(match extract_tool_name params with
273
-
| Some name ->
274
-
let args = extract_tool_arguments params in
275
-
276
-
(* Create context for this request *)
277
-
let ctx = Context.create
278
-
?request_id:(Some req.id)
279
-
?progress_token:req.progress_token
280
-
~lifespan_context:[("tools/call", `Assoc params)]
281
-
()
282
-
in
283
-
284
-
(* Execute the tool *)
285
-
let result_json = execute_tool server ctx name args in
286
-
287
-
(* Convert JSON result to RPC format *)
288
-
let content, is_error = json_to_rpc_content result_json in
289
-
290
-
(* Create the RPC response *)
291
-
let response = Mcp_rpc.ToolsCall.create_response
292
-
~id:req.id
293
-
~content
294
-
~is_error
295
-
()
296
-
in
297
-
298
-
Some response
299
-
| None ->
300
-
Some (create_jsonrpc_error req.id InvalidParams "Missing tool name parameter" ()))
316
+
| Some (`Assoc params) -> (
317
+
match extract_tool_name params with
318
+
| Some name ->
319
+
let args = extract_tool_arguments params in
320
+
321
+
(* Create context for this request *)
322
+
let ctx =
323
+
Context.create ?request_id:(Some req.id)
324
+
?progress_token:req.progress_token
325
+
~lifespan_context:[ ("tools/call", `Assoc params) ]
326
+
()
327
+
in
328
+
329
+
(* Execute the tool *)
330
+
let result_json = execute_tool server ctx name args in
331
+
332
+
(* Convert JSON result to RPC format *)
333
+
let content, is_error = json_to_rpc_content result_json in
334
+
335
+
(* Create the RPC response *)
336
+
let response =
337
+
Mcp_rpc.ToolsCall.create_response ~id:req.id ~content ~is_error ()
338
+
in
339
+
340
+
Some response
341
+
| None ->
342
+
Some
343
+
(create_jsonrpc_error req.id InvalidParams
344
+
"Missing tool name parameter" ()))
301
345
| _ ->
302
-
Log.error "Invalid params format for tools/call";
303
-
Some (create_jsonrpc_error req.id InvalidParams "Invalid params format for tools/call" ())
346
+
Log.error "Invalid params format for tools/call";
347
+
Some
348
+
(create_jsonrpc_error req.id InvalidParams
349
+
"Invalid params format for tools/call" ())
304
350
305
351
(* Process ping request *)
306
-
let handle_ping (req:JSONRPCMessage.request) =
352
+
let handle_ping (req : JSONRPCMessage.request) =
307
353
Log.debug "Processing ping request";
308
354
Some (create_response ~id:req.JSONRPCMessage.id ~result:(`Assoc []))
309
355
310
356
(* Handle notifications/initialized *)
311
-
let handle_initialized (notif:JSONRPCMessage.notification) =
312
-
Log.debug "Client initialization complete - Server is now ready to receive requests";
313
-
Log.debugf "Notification params: %s"
357
+
let handle_initialized (notif : JSONRPCMessage.notification) =
358
+
Log.debug
359
+
"Client initialization complete - Server is now ready to receive requests";
360
+
Log.debugf "Notification params: %s"
314
361
(match notif.JSONRPCMessage.params with
315
-
| Some p -> Yojson.Safe.to_string p
316
-
| None -> "null");
362
+
| Some p -> Yojson.Safe.to_string p
363
+
| None -> "null");
317
364
None
318
365
319
366
(* Process a single message using the MCP SDK *)
···
321
368
try
322
369
Log.debugf "Processing message: %s" (Yojson.Safe.to_string message);
323
370
match JSONRPCMessage.t_of_yojson message with
324
-
| JSONRPCMessage.Request req ->
325
-
Log.debugf "Received request with method: %s" (Method.to_string req.meth);
326
-
(match req.meth with
327
-
| Method.Initialize -> handle_initialize server req
328
-
| Method.ToolsList -> handle_tools_list server req
329
-
| Method.ToolsCall -> handle_tools_call server req
330
-
| Method.PromptsList -> handle_prompts_list server req
331
-
| Method.ResourcesList -> handle_resources_list server req
332
-
| Method.ResourcesRead -> handle_resources_read server req
333
-
| Method.ResourceTemplatesList -> handle_resource_templates_list server req
334
-
| _ ->
335
-
Log.errorf "Unknown method received: %s" (Method.to_string req.meth);
336
-
Some (create_jsonrpc_error req.id ErrorCode.MethodNotFound ("Method not found: " ^ (Method.to_string req.meth)) ()))
337
-
| JSONRPCMessage.Notification notif ->
338
-
Log.debugf "Received notification with method: %s" (Method.to_string notif.meth);
339
-
(match notif.meth with
340
-
| Method.Initialized -> handle_initialized notif
341
-
| _ ->
342
-
Log.debugf "Ignoring notification: %s" (Method.to_string notif.meth);
343
-
None)
371
+
| JSONRPCMessage.Request req -> (
372
+
Log.debugf "Received request with method: %s"
373
+
(Method.to_string req.meth);
374
+
match req.meth with
375
+
| Method.Initialize -> handle_initialize server req
376
+
| Method.ToolsList -> handle_tools_list server req
377
+
| Method.ToolsCall -> handle_tools_call server req
378
+
| Method.PromptsList -> handle_prompts_list server req
379
+
| Method.ResourcesList -> handle_resources_list server req
380
+
| Method.ResourcesRead -> handle_resources_read server req
381
+
| Method.ResourceTemplatesList ->
382
+
handle_resource_templates_list server req
383
+
| _ ->
384
+
Log.errorf "Unknown method received: %s" (Method.to_string req.meth);
385
+
Some
386
+
(create_jsonrpc_error req.id ErrorCode.MethodNotFound
387
+
("Method not found: " ^ Method.to_string req.meth)
388
+
()))
389
+
| JSONRPCMessage.Notification notif -> (
390
+
Log.debugf "Received notification with method: %s"
391
+
(Method.to_string notif.meth);
392
+
match notif.meth with
393
+
| Method.Initialized -> handle_initialized notif
394
+
| _ ->
395
+
Log.debugf "Ignoring notification: %s" (Method.to_string notif.meth);
396
+
None)
344
397
| JSONRPCMessage.Response _ ->
345
-
Log.error "Unexpected response message received";
346
-
None
398
+
Log.error "Unexpected response message received";
399
+
None
347
400
| JSONRPCMessage.Error _ ->
348
-
Log.error "Unexpected error message received";
349
-
None
401
+
Log.error "Unexpected error message received";
402
+
None
350
403
with
351
404
| Json.Of_json (msg, _) ->
352
-
Log.errorf "JSON error: %s" msg;
353
-
(* Can't respond with error because we don't have a request ID *)
354
-
None
355
-
| Yojson.Json_error msg ->
356
-
Log.errorf "JSON parse error: %s" msg;
357
-
(* Can't respond with error because we don't have a request ID *)
358
-
None
405
+
Log.errorf "JSON error: %s" msg;
406
+
(* Can't respond with error because we don't have a request ID *)
407
+
None
408
+
| Yojson.Json_error msg ->
409
+
Log.errorf "JSON parse error: %s" msg;
410
+
(* Can't respond with error because we don't have a request ID *)
411
+
None
359
412
| exc ->
360
-
Log.errorf "Exception during message processing: %s" (Printexc.to_string exc);
361
-
Log.errorf "Backtrace: %s" (Printexc.get_backtrace());
362
-
Log.errorf "Message was: %s" (Yojson.Safe.to_string message);
363
-
None
413
+
Log.errorf "Exception during message processing: %s"
414
+
(Printexc.to_string exc);
415
+
Log.errorf "Backtrace: %s" (Printexc.get_backtrace ());
416
+
Log.errorf "Message was: %s" (Yojson.Safe.to_string message);
417
+
None
364
418
365
419
(* Extract a request ID from a potentially malformed message *)
366
420
let extract_request_id json =
367
421
try
368
422
match json with
369
-
| `Assoc fields ->
370
-
(match List.assoc_opt "id" fields with
371
-
| Some (`Int id) -> Some (`Int id)
372
-
| Some (`String id) -> Some (`String id)
373
-
| _ -> None)
423
+
| `Assoc fields -> (
424
+
match List.assoc_opt "id" fields with
425
+
| Some (`Int id) -> Some (`Int id)
426
+
| Some (`String id) -> Some (`String id)
427
+
| _ -> None)
374
428
| _ -> None
375
429
with _ -> None
376
430
···
378
432
let process_input_line server line =
379
433
if line = "" then (
380
434
Log.debug "Empty line received, ignoring";
381
-
None
382
-
) else (
435
+
None)
436
+
else (
383
437
Log.debugf "Raw input: %s" line;
384
438
try
385
439
let json = Yojson.Safe.from_string line in
386
440
Log.debug "Successfully parsed JSON";
387
-
441
+
388
442
(* Process the message *)
389
443
process_message server json
390
-
with
391
-
| Yojson.Json_error msg -> begin
392
-
Log.errorf "Error parsing JSON: %s" msg;
393
-
Log.errorf "Input was: %s" line;
394
-
None
395
-
end
396
-
)
444
+
with Yojson.Json_error msg ->
445
+
Log.errorf "Error parsing JSON: %s" msg;
446
+
Log.errorf "Input was: %s" line;
447
+
None)
397
448
398
449
(* Send a response to the client *)
399
450
let send_response stdout response =
400
451
let response_json = JSONRPCMessage.yojson_of_t response in
401
452
let response_str = Yojson.Safe.to_string response_json in
402
453
Log.debugf "Sending response: %s" response_str;
403
-
454
+
404
455
(* Write the response followed by a newline *)
405
456
Eio.Flow.copy_string response_str stdout;
406
457
Eio.Flow.copy_string "\n" stdout
···
426
477
()
427
478
| None ->
428
479
Log.debug "No MCP response needed";
429
-
Cohttp_eio.Server.respond ~status:`No_content ~body:(Cohttp_eio.Body.of_string "") ())
480
+
Cohttp_eio.Server.respond ~status:`No_content
481
+
~body:(Cohttp_eio.Body.of_string "")
482
+
())
430
483
| _ ->
431
484
Log.infof "Unsupported method: %s" (Http.Method.to_string request.meth);
432
485
Cohttp_eio.Server.respond ~status:`Method_not_allowed
···
463
516
464
517
(* Enable exception backtraces *)
465
518
Printexc.record_backtrace true;
466
-
519
+
467
520
let buf = Eio.Buf_read.of_flow stdin ~initial_size:100 ~max_size:1_000_000 in
468
-
521
+
469
522
(* Main processing loop *)
470
523
try
471
524
while true do
472
525
Log.debug "Waiting for message...";
473
526
let line = Eio.Buf_read.line buf in
474
-
527
+
475
528
(* Process the input and send response if needed *)
476
529
match process_input_line server line with
477
530
| Some response -> send_response stdout response
478
531
| None -> Log.debug "No response needed for this message"
479
532
done
480
533
with
481
-
| End_of_file ->
534
+
| End_of_file ->
482
535
Log.debug "End of file received on stdin";
483
536
()
484
537
| Eio.Exn.Io _ as exn ->