Model Context Protocol in OCaml
anil.recoil.org
1open Jsonrpc
2
3(* Utility functions for JSON parsing *)
4module Util = struct
5 (* Helper to raise a Json.Of_json exception with formatted message *)
6 let json_error fmt json =
7 Printf.ksprintf (fun msg -> raise (Json.Of_json (msg, json))) fmt
8
9 (* Extract a string field from JSON object or raise an error *)
10 let get_string_field fields name json =
11 match List.assoc_opt name fields with
12 | Some (`String s) -> s
13 | _ -> json_error "Missing or invalid '%s' field" json name
14
15 (* Extract an optional string field from JSON object *)
16 let get_optional_string_field fields name =
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 (* Extract an int field from JSON object or raise an error *)
23 let get_int_field fields name json =
24 match List.assoc_opt name fields with
25 | Some (`Int i) -> i
26 | _ -> json_error "Missing or invalid '%s' field" json name
27
28 (* Extract a float field from JSON object or raise an error *)
29 let get_float_field fields name json =
30 match List.assoc_opt name fields with
31 | Some (`Float f) -> f
32 | _ -> json_error "Missing or invalid '%s' field" json name
33
34 (* Extract a boolean field from JSON object or raise an error *)
35 let get_bool_field fields name json =
36 match List.assoc_opt name fields with
37 | Some (`Bool b) -> b
38 | _ -> json_error "Missing or invalid '%s' field" json name
39
40 (* Extract an object field from JSON object or raise an error *)
41 let get_object_field fields name json =
42 match List.assoc_opt name fields with
43 | Some (`Assoc obj) -> obj
44 | _ -> json_error "Missing or invalid '%s' field" json name
45
46 (* Extract a list field from JSON object or raise an error *)
47 let get_list_field fields name json =
48 match List.assoc_opt name fields with
49 | Some (`List items) -> items
50 | _ -> json_error "Missing or invalid '%s' field" json name
51
52 (* Verify a specific string value in a field *)
53 let verify_string_field fields name expected_value json =
54 match List.assoc_opt name fields with
55 | Some (`String s) when s = expected_value -> ()
56 | _ ->
57 json_error "Field '%s' missing or not equal to '%s'" json name
58 expected_value
59end
60
61(* Error codes for JSON-RPC *)
62module ErrorCode = struct
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 *)
72 | CustomError of int (* For any other error codes *)
73
74 (* Convert the error code to its integer representation *)
75 let to_int = function
76 | ParseError -> -32700
77 | InvalidRequest -> -32600
78 | MethodNotFound -> -32601
79 | InvalidParams -> -32602
80 | InternalError -> -32603
81 | ResourceNotFound -> -32002
82 | AuthRequired -> -32001
83 | CustomError code -> code
84
85 (* Get error message for standard error codes *)
86 let to_message = function
87 | ParseError -> "Parse error"
88 | InvalidRequest -> "Invalid Request"
89 | MethodNotFound -> "Method not found"
90 | InvalidParams -> "Invalid params"
91 | InternalError -> "Internal error"
92 | ResourceNotFound -> "Resource not found"
93 | AuthRequired -> "Authentication required"
94 | CustomError _ -> "Error"
95end
96
97(* Protocol method types *)
98module Method = struct
99 (* Method type representing all MCP protocol methods *)
100 type t =
101 (* Initialization and lifecycle methods *)
102 | Initialize
103 | Initialized
104 (* Resource methods *)
105 | ResourcesList
106 | ResourcesRead
107 | ResourceTemplatesList
108 | ResourcesSubscribe
109 | ResourcesListChanged
110 | ResourcesUpdated
111 (* Tool methods *)
112 | ToolsList
113 | ToolsCall
114 | ToolsListChanged
115 (* Prompt methods *)
116 | PromptsList
117 | PromptsGet
118 | PromptsListChanged
119 (* Progress notifications *)
120 | Progress
121
122 (* Convert method type to string representation *)
123 let to_string = function
124 | Initialize -> "initialize"
125 | Initialized -> "notifications/initialized"
126 | ResourcesList -> "resources/list"
127 | ResourcesRead -> "resources/read"
128 | ResourceTemplatesList -> "resources/templates/list"
129 | ResourcesSubscribe -> "resources/subscribe"
130 | ResourcesListChanged -> "notifications/resources/list_changed"
131 | ResourcesUpdated -> "notifications/resources/updated"
132 | ToolsList -> "tools/list"
133 | ToolsCall -> "tools/call"
134 | ToolsListChanged -> "notifications/tools/list_changed"
135 | PromptsList -> "prompts/list"
136 | PromptsGet -> "prompts/get"
137 | PromptsListChanged -> "notifications/prompts/list_changed"
138 | Progress -> "notifications/progress"
139
140 (* Convert string to method type *)
141 let of_string = function
142 | "initialize" -> Initialize
143 | "notifications/initialized" -> Initialized
144 | "resources/list" -> ResourcesList
145 | "resources/read" -> ResourcesRead
146 | "resources/templates/list" -> ResourceTemplatesList
147 | "resources/subscribe" -> ResourcesSubscribe
148 | "notifications/resources/list_changed" -> ResourcesListChanged
149 | "notifications/resources/updated" -> ResourcesUpdated
150 | "tools/list" -> ToolsList
151 | "tools/call" -> ToolsCall
152 | "notifications/tools/list_changed" -> ToolsListChanged
153 | "prompts/list" -> PromptsList
154 | "prompts/get" -> PromptsGet
155 | "notifications/prompts/list_changed" -> PromptsListChanged
156 | "notifications/progress" -> Progress
157 | s -> failwith ("Unknown MCP method: " ^ s)
158end
159
160(* Common types *)
161
162module Role = struct
163 type t = [ `User | `Assistant ]
164
165 let to_string = function `User -> "user" | `Assistant -> "assistant"
166
167 let of_string = function
168 | "user" -> `User
169 | "assistant" -> `Assistant
170 | s -> Util.json_error "Unknown role: %s" (`String s) s
171
172 let yojson_of_t t = `String (to_string t)
173
174 let t_of_yojson = function
175 | `String s -> of_string s
176 | j -> Util.json_error "Expected string for Role" j
177end
178
179module ProgressToken = struct
180 type t = [ `String of string | `Int of int ]
181
182 include (Id : Json.Jsonable.S with type t := t)
183end
184
185module RequestId = Id
186
187module Cursor = struct
188 type t = string
189
190 let yojson_of_t t = `String t
191
192 let t_of_yojson = function
193 | `String s -> s
194 | j -> Util.json_error "Expected string for Cursor" j
195end
196
197(* Annotations *)
198
199module Annotated = struct
200 type t = { annotations : annotation option }
201 and annotation = { audience : Role.t list option; priority : float option }
202
203 let yojson_of_annotation { audience; priority } =
204 let assoc = [] in
205 let assoc =
206 match audience with
207 | Some audience ->
208 ("audience", `List (List.map Role.yojson_of_t audience)) :: assoc
209 | None -> assoc
210 in
211 let assoc =
212 match priority with
213 | Some priority -> ("priority", `Float priority) :: assoc
214 | None -> assoc
215 in
216 `Assoc assoc
217
218 let annotation_of_yojson = function
219 | `Assoc fields ->
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 }
233 | j -> Util.json_error "Expected object for annotation" j
234
235 let yojson_of_t { annotations } =
236 match annotations with
237 | Some annotations ->
238 `Assoc [ ("annotations", yojson_of_annotation annotations) ]
239 | None -> `Assoc []
240
241 let t_of_yojson = function
242 | `Assoc fields ->
243 let annotations =
244 List.assoc_opt "annotations" fields |> Option.map annotation_of_yojson
245 in
246 { annotations }
247 | j -> Util.json_error "Expected object for Annotated" j
248end
249
250(* Content types *)
251
252module TextContent = struct
253 type t = { text : string; annotations : Annotated.annotation option }
254
255 let yojson_of_t { text; annotations } =
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 | None -> assoc
262 in
263 `Assoc assoc
264
265 let t_of_yojson = function
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 =
270 List.assoc_opt "annotations" fields
271 |> Option.map Annotated.annotation_of_yojson
272 in
273 { text; annotations }
274 | j -> Util.json_error "Expected object for TextContent" j
275end
276
277module ImageContent = struct
278 type t = {
279 data : string;
280 mime_type : string;
281 annotations : Annotated.annotation option;
282 }
283
284 let yojson_of_t { data; mime_type; annotations } =
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
296 | None -> assoc
297 in
298 `Assoc assoc
299
300 let t_of_yojson = function
301 | `Assoc fields as json ->
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 }
310 | j -> Util.json_error "Expected object for ImageContent" j
311end
312
313module AudioContent = struct
314 type t = {
315 data : string;
316 mime_type : string;
317 annotations : Annotated.annotation option;
318 }
319
320 let yojson_of_t { data; mime_type; annotations } =
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
332 | None -> assoc
333 in
334 `Assoc assoc
335
336 let t_of_yojson = function
337 | `Assoc fields as json ->
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 }
346 | j -> Util.json_error "Expected object for AudioContent" j
347end
348
349module ResourceContents = struct
350 type t = { uri : string; mime_type : string option }
351
352 let yojson_of_t { uri; mime_type } =
353 let assoc = [ ("uri", `String uri) ] in
354 let assoc =
355 match mime_type with
356 | Some mime_type -> ("mimeType", `String mime_type) :: assoc
357 | None -> assoc
358 in
359 `Assoc assoc
360
361 let t_of_yojson = function
362 | `Assoc fields as json ->
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 }
366 | j -> Util.json_error "Expected object for ResourceContents" j
367end
368
369module TextResourceContents = struct
370 type t = { uri : string; text : string; mime_type : string option }
371
372 let yojson_of_t { uri; text; mime_type } =
373 let assoc = [ ("uri", `String uri); ("text", `String text) ] in
374 let assoc =
375 match mime_type with
376 | Some mime_type -> ("mimeType", `String mime_type) :: assoc
377 | None -> assoc
378 in
379 `Assoc assoc
380
381 let t_of_yojson = function
382 | `Assoc fields as json ->
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 }
387 | j -> Util.json_error "Expected object for TextResourceContents" j
388end
389
390module BlobResourceContents = struct
391 type t = { uri : string; blob : string; mime_type : string option }
392
393 let yojson_of_t { uri; blob; mime_type } =
394 let assoc = [ ("uri", `String uri); ("blob", `String blob) ] in
395 let assoc =
396 match mime_type with
397 | Some mime_type -> ("mimeType", `String mime_type) :: assoc
398 | None -> assoc
399 in
400 `Assoc assoc
401
402 let t_of_yojson = function
403 | `Assoc fields as json ->
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 }
408 | j -> Util.json_error "Expected object for BlobResourceContents" j
409end
410
411module EmbeddedResource = struct
412 type t = {
413 resource :
414 [ `Text of TextResourceContents.t | `Blob of BlobResourceContents.t ];
415 annotations : Annotated.annotation option;
416 }
417
418 let yojson_of_t { resource; annotations } =
419 let resource_json =
420 match resource with
421 | `Text txt -> TextResourceContents.yojson_of_t txt
422 | `Blob blob -> BlobResourceContents.yojson_of_t blob
423 in
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
429 | None -> assoc
430 in
431 `Assoc assoc
432
433 let t_of_yojson = function
434 | `Assoc fields as json ->
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 }
454 | j -> Util.json_error "Expected object for EmbeddedResource" j
455end
456
457type content =
458 | Text of TextContent.t
459 | Image of ImageContent.t
460 | Audio of AudioContent.t
461 | Resource of EmbeddedResource.t
462
463let yojson_of_content = function
464 | Text t -> TextContent.yojson_of_t t
465 | Image i -> ImageContent.yojson_of_t i
466 | Audio a -> AudioContent.yojson_of_t a
467 | Resource r -> EmbeddedResource.yojson_of_t r
468
469let content_of_yojson = function
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)
478 | j -> Util.json_error "Expected object for content" j
479
480(* Message types *)
481
482module PromptMessage = struct
483 type t = { role : Role.t; content : content }
484
485 let yojson_of_t { role; content } =
486 `Assoc
487 [
488 ("role", Role.yojson_of_t role); ("content", yojson_of_content content);
489 ]
490
491 let t_of_yojson = function
492 | `Assoc fields as json ->
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 }
504 | j -> Util.json_error "Expected object for PromptMessage" j
505end
506
507module SamplingMessage = struct
508 type t = {
509 role : Role.t;
510 content :
511 [ `Text of TextContent.t
512 | `Image of ImageContent.t
513 | `Audio of AudioContent.t ];
514 }
515
516 let yojson_of_t { role; content } =
517 let content_json =
518 match content with
519 | `Text t -> TextContent.yojson_of_t t
520 | `Image i -> ImageContent.yojson_of_t i
521 | `Audio a -> AudioContent.yojson_of_t a
522 in
523 `Assoc [ ("role", Role.yojson_of_t role); ("content", content_json) ]
524
525 let t_of_yojson = function
526 | `Assoc fields as json ->
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 }
554 | j -> Util.json_error "Expected object for SamplingMessage" j
555end
556
557(* Implementation info *)
558
559module Implementation = struct
560 type t = { name : string; version : string }
561
562 let yojson_of_t { name; version } =
563 `Assoc [ ("name", `String name); ("version", `String version) ]
564
565 let t_of_yojson = function
566 | `Assoc fields as json ->
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 }
570 | j -> Util.json_error "Expected object for Implementation" j
571end
572
573(* JSONRPC Message types *)
574
575module JSONRPCMessage = struct
576 type notification = { meth : Method.t; params : Json.t option }
577
578 type request = {
579 id : RequestId.t;
580 meth : Method.t;
581 params : Json.t option;
582 progress_token : ProgressToken.t option;
583 }
584
585 type response = { id : RequestId.t; result : Json.t }
586
587 type error = {
588 id : RequestId.t;
589 code : int;
590 message : string;
591 data : Json.t option;
592 }
593
594 type t =
595 | Notification of notification
596 | Request of request
597 | Response of response
598 | Error of error
599
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
608 | Some params -> ("params", params) :: assoc
609 | None -> assoc
610 in
611 `Assoc assoc
612
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
623 | Some params ->
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
641 | None -> assoc
642 in
643 `Assoc assoc
644
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 ]
652
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
659 | Some data -> ("data", data) :: error_assoc
660 | None -> error_assoc
661 in
662 `Assoc
663 [
664 ("jsonrpc", `String "2.0");
665 ("id", Id.yojson_of_t e.id);
666 ("error", `Assoc error_assoc);
667 ]
668
669 let yojson_of_t = function
670 | Notification n -> yojson_of_notification n
671 | Request r -> yojson_of_request r
672 | Response r -> yojson_of_response r
673 | Error e -> yojson_of_error e
674
675 let notification_of_yojson = function
676 | `Assoc fields ->
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 }
688 | j -> Util.json_error "Expected object for notification" j
689
690 let request_of_yojson = function
691 | `Assoc fields ->
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 }
720 | j -> Util.json_error "Expected object for request" j
721
722 let response_of_yojson = function
723 | `Assoc fields ->
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 }
735 | j -> Util.json_error "Expected object for response" j
736
737 let error_of_yojson = function
738 | `Assoc fields as json ->
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 }
765 | j -> Util.json_error "Expected object for error" j
766
767 let t_of_yojson json =
768 match json with
769 | `Assoc fields ->
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
782 | j -> Util.json_error "Expected object for JSONRPC message" j
783
784 let create_notification ?(params = None) ~meth () =
785 Notification { meth; params }
786
787 let create_request ?(params = None) ?(progress_token = None) ~id ~meth () =
788 Request { id; meth; params; progress_token }
789
790 let create_response ~id ~result = Response { id; result }
791
792 let create_error ~id ~code ~message ?(data = None) () =
793 Error { id; code; message; data }
794end
795
796(* MCP-specific request/response types *)
797
798module Initialize = struct
799 module Request = struct
800 type t = {
801 capabilities : Json.t; (* ClientCapabilities *)
802 client_info : Implementation.t;
803 protocol_version : string;
804 }
805
806 let yojson_of_t { capabilities; client_info; protocol_version } =
807 `Assoc
808 [
809 ("capabilities", capabilities);
810 ("clientInfo", Implementation.yojson_of_t client_info);
811 ("protocolVersion", `String protocol_version);
812 ]
813
814 let t_of_yojson = function
815 | `Assoc fields as json ->
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 }
830 | j -> Util.json_error "Expected object for InitializeRequest" j
831
832 let create ~capabilities ~client_info ~protocol_version =
833 { capabilities; client_info; protocol_version }
834
835 let to_jsonrpc ~id t =
836 let params = yojson_of_t t in
837 JSONRPCMessage.create_request ~id ~meth:Method.Initialize
838 ~params:(Some params) ()
839 end
840
841 module Result = struct
842 type t = {
843 capabilities : Json.t; (* ServerCapabilities *)
844 server_info : Implementation.t;
845 protocol_version : string;
846 instructions : string option;
847 meta : Json.t option;
848 }
849
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
861 | Some instr -> ("instructions", `String instr) :: assoc
862 | None -> assoc
863 in
864 let assoc =
865 match meta with Some meta -> ("_meta", meta) :: assoc | None -> assoc
866 in
867 `Assoc assoc
868
869 let t_of_yojson = function
870 | `Assoc fields as json ->
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 }
889 | j -> Util.json_error "Expected object for InitializeResult" j
890
891 let create ~capabilities ~server_info ~protocol_version ?instructions ?meta
892 () =
893 { capabilities; server_info; protocol_version; instructions; meta }
894
895 let to_jsonrpc ~id t =
896 JSONRPCMessage.create_response ~id ~result:(yojson_of_t t)
897 end
898end
899
900module Initialized = struct
901 module Notification = struct
902 type t = { meta : Json.t option }
903
904 let yojson_of_t { meta } =
905 let assoc = [] in
906 let assoc =
907 match meta with Some meta -> ("_meta", meta) :: assoc | None -> assoc
908 in
909 `Assoc assoc
910
911 let t_of_yojson = function
912 | `Assoc fields ->
913 let meta = List.assoc_opt "_meta" fields in
914 { meta }
915 | j -> Util.json_error "Expected object for InitializedNotification" j
916
917 let create ?meta () = { meta }
918
919 let to_jsonrpc t =
920 let params =
921 match yojson_of_t t with `Assoc [] -> None | json -> Some json
922 in
923 JSONRPCMessage.create_notification ~meth:Method.Initialized ~params ()
924 end
925end
926
927(* Export the main interface for using the MCP protocol *)
928
929let parse_message json = JSONRPCMessage.t_of_yojson json
930
931let create_notification ?(params = None) ~meth () =
932 JSONRPCMessage.create_notification ~params ~meth ()
933
934let create_request ?(params = None) ?(progress_token = None) ~id ~meth () =
935 JSONRPCMessage.create_request ~params ~progress_token ~id ~meth ()
936
937let create_response = JSONRPCMessage.create_response
938let create_error = JSONRPCMessage.create_error
939
940(* Content type constructors *)
941let make_text_content text = Text TextContent.{ text; annotations = None }
942
943let make_image_content data mime_type =
944 Image ImageContent.{ data; mime_type; annotations = None }
945
946let make_audio_content data mime_type =
947 Audio AudioContent.{ data; mime_type; annotations = None }
948
949let make_resource_text_content uri text mime_type =
950 Resource
951 EmbeddedResource.
952 {
953 resource = `Text TextResourceContents.{ uri; text; mime_type };
954 annotations = None;
955 }
956
957let make_resource_blob_content uri blob mime_type =
958 Resource
959 EmbeddedResource.
960 {
961 resource = `Blob BlobResourceContents.{ uri; blob; mime_type };
962 annotations = None;
963 }