Declarative JSON data manipulation for OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2024 The jsont programmers. All rights reserved.
3 SPDX-License-Identifier: CC0-1.0
4 ---------------------------------------------------------------------------*)
5
6(** JSON-RPC codec https://www.jsonrpc.org/ *)
7
8(* JSON-RPC version *)
9
10type jsonrpc = [ `V2 ]
11
12let jsonrpc_codec = Json.Codec.enum [ ("2.0", `V2) ]
13
14(* JSON-RPC identifiers *)
15
16type id = [ `String of string | `Number of float | `Null ]
17
18let id_codec : id Json.Codec.t =
19 let null = Json.Codec.null `Null in
20 let string =
21 let dec s = `String s in
22 let enc = function `String s -> s | _ -> assert false in
23 Json.Codec.map ~dec ~enc Json.Codec.string
24 in
25 let number =
26 let dec n = `Number n in
27 let enc = function `Number n -> n | _ -> assert false in
28 Json.Codec.map ~dec ~enc Json.Codec.number
29 in
30 let enc = function
31 | `Null -> null
32 | `String _ -> string
33 | `Number _ -> number
34 in
35 Json.Codec.any ~dec_null:null ~dec_string:string ~dec_number:number ~enc ()
36
37(* JSON-RPC request object *)
38
39type params = Json.t (* An array or object *)
40
41let params_codec =
42 let enc = function
43 | Json.Value.Object _ | Json.Value.Array _ -> Json.Codec.Value.t
44 | j ->
45 let meta = Json.Meta.none in
46 let fnd = Json.Sort.to_string (Json.Value.sort j) in
47 Json.Error.fail_expected meta "object or array" ~fnd
48 in
49 let kind = "JSON-RPC params" in
50 Json.Codec.any ~kind ~dec_array:Json.Codec.Value.t
51 ~dec_object:Json.Codec.Value.t ~enc ()
52
53type request = {
54 jsonrpc : jsonrpc;
55 method' : string;
56 params : params option;
57 id : id option;
58}
59
60let request jsonrpc method' params id = { jsonrpc; method'; params; id }
61
62let request_codec : request Json.Codec.t =
63 Json.Codec.Object.map request
64 |> Json.Codec.Object.member "jsonrpc" jsonrpc_codec ~enc:(fun r -> r.jsonrpc)
65 |> Json.Codec.Object.member "method" Json.Codec.string ~enc:(fun r ->
66 r.method')
67 |> Json.Codec.Object.opt_member "params" params_codec ~enc:(fun r -> r.params)
68 |> Json.Codec.Object.opt_member "id" id_codec ~enc:(fun r -> r.id)
69 |> Json.Codec.Object.seal
70
71(* JSON-RPC error objects *)
72
73type error = { code : int; message : string; data : Json.t option }
74
75let error code message data = { code; message; data }
76
77let error_codec =
78 Json.Codec.Object.map error
79 |> Json.Codec.Object.member "code" Json.Codec.int ~enc:(fun e -> e.code)
80 |> Json.Codec.Object.member "message" Json.Codec.string ~enc:(fun e ->
81 e.message)
82 |> Json.Codec.Object.opt_member "data" Json.Codec.Value.t ~enc:(fun e ->
83 e.data)
84 |> Json.Codec.Object.seal
85
86(* JSON-RPC response object *)
87
88type response = { jsonrpc : jsonrpc; value : (Json.t, error) result; id : id }
89
90let response jsonrpc result error id : response =
91 let err_both () =
92 Json.Error.msgf Json.Meta.none "Both %a and %a members are defined"
93 Format.pp_print_string "result" Format.pp_print_string "error"
94 in
95 let err_none () =
96 Json.Error.msgf Json.Meta.none "Missing either %a or %a member"
97 Format.pp_print_string "result" Format.pp_print_string "error"
98 in
99 match (result, error) with
100 | Some result, None -> { jsonrpc; value = Ok result; id }
101 | None, Some error -> { jsonrpc; value = Error error; id }
102 | Some _, Some _ -> err_both ()
103 | None, None -> err_none ()
104
105let response_result r = match r.value with Ok v -> Some v | Error _ -> None
106let response_error r = match r.value with Ok _ -> None | Error e -> Some e
107
108let response_codec : response Json.Codec.t =
109 Json.Codec.Object.map response
110 |> Json.Codec.Object.member "jsonrpc" jsonrpc_codec ~enc:(fun r -> r.jsonrpc)
111 |> Json.Codec.Object.opt_member "result" Json.Codec.Value.t
112 ~enc:response_result
113 |> Json.Codec.Object.opt_member "error" error_codec ~enc:response_error
114 |> Json.Codec.Object.member "id" id_codec ~enc:(fun r -> r.id)
115 |> Json.Codec.Object.seal