My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1(** JSON-RPC 2.0 protocol implementation *)
2
3(* Protocol Version *)
4
5type jsonrpc = [ `V2 ]
6
7let jsonrpc_jsont = Jsont.enum ["2.0", `V2]
8
9(* Request/Response Identifiers *)
10
11module Id = struct
12 type t = [ `String of string | `Number of float | `Null ]
13
14 let jsont : t Jsont.t =
15 let null = Jsont.null `Null in
16 let string =
17 let dec s = `String s in
18 let enc = function `String s -> s | _ -> assert false in
19 Jsont.map ~dec ~enc Jsont.string
20 in
21 let number =
22 let dec n = `Number n in
23 let enc = function `Number n -> n | _ -> assert false in
24 Jsont.map ~dec ~enc Jsont.number
25 in
26 let enc = function
27 | `Null -> null | `String _ -> string | `Number _ -> number
28 in
29 Jsont.any ~dec_null:null ~dec_string:string ~dec_number:number ~enc ()
30
31 let to_string = function
32 | `String s -> s
33 | `Number n -> string_of_float n
34 | `Null -> "null"
35
36 let compare a b = match a, b with
37 | `Null, `Null -> 0
38 | `Null, _ -> -1
39 | _, `Null -> 1
40 | `String s1, `String s2 -> String.compare s1 s2
41 | `String _, _ -> -1
42 | _, `String _ -> 1
43 | `Number n1, `Number n2 -> Float.compare n1 n2
44
45 let pp fmt = function
46 | `String s -> Format.fprintf fmt "%S" s
47 | `Number n -> Format.fprintf fmt "%g" n
48 | `Null -> Format.fprintf fmt "null"
49end
50
51(* Error Codes *)
52
53module Error_code = struct
54 type t =
55 | Parse_error
56 | Invalid_request
57 | Method_not_found
58 | Invalid_params
59 | Internal_error
60 | Connection_closed
61 | Server_error of int
62 | Other of int
63
64 let to_int = function
65 | Parse_error -> -32700
66 | Invalid_request -> -32600
67 | Method_not_found -> -32601
68 | Invalid_params -> -32602
69 | Internal_error -> -32603
70 | Connection_closed -> -32000
71 | Server_error n -> n
72 | Other n -> n
73
74 let of_int = function
75 | -32700 -> Parse_error
76 | -32600 -> Invalid_request
77 | -32601 -> Method_not_found
78 | -32602 -> Invalid_params
79 | -32603 -> Internal_error
80 | -32000 -> Connection_closed
81 | n when n >= -32099 && n <= -32001 -> Server_error n
82 | n -> Other n
83
84 let jsont : t Jsont.t =
85 let dec n = of_int n in
86 let enc code = to_int code in
87 Jsont.map ~dec ~enc Jsont.int
88
89 let pp fmt code =
90 Format.fprintf fmt "%d" (to_int code)
91end
92
93(* Error Data *)
94
95module Error_data = struct
96 type t = {
97 code : Error_code.t;
98 message : string;
99 data : Jsont.json option;
100 unknown : Jsont.json;
101 }
102
103 let make ~code ~message ?data () =
104 let unknown = Jsont.Object ([], Jsont.Meta.none) in
105 { code; message; data; unknown }
106
107 let jsont : t Jsont.t =
108 let make code message data unknown = { code; message; data; unknown } in
109 Jsont.Object.map ~kind:"ErrorData" make
110 |> Jsont.Object.mem "code" Error_code.jsont ~enc:(fun e -> e.code)
111 |> Jsont.Object.mem "message" Jsont.string ~enc:(fun e -> e.message)
112 |> Jsont.Object.opt_mem "data" Jsont.json ~enc:(fun e -> e.data)
113 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun e -> e.unknown)
114 |> Jsont.Object.finish
115
116 let pp fmt err =
117 Format.fprintf fmt "{code=%a, message=%S}" Error_code.pp err.code err.message
118end
119
120(* Params *)
121
122type params = Jsont.json
123
124let params_jsont =
125 let enc = function
126 | Jsont.Object _ | Jsont.Array _ -> Jsont.json
127 | j ->
128 let meta = Jsont.Meta.none in
129 let fnd = Jsont.Sort.to_string (Jsont.Json.sort j) in
130 Jsont.Error.expected meta "object or array" ~fnd
131 in
132 let kind = "JSON-RPC params" in
133 Jsont.any ~kind ~dec_array:Jsont.json ~dec_object:Jsont.json ~enc ()
134
135(* Request Message *)
136
137module Request = struct
138 type t = {
139 jsonrpc : jsonrpc;
140 method_ : string;
141 params : params option;
142 id : Id.t option;
143 unknown : Jsont.json;
144 }
145
146 let make ~method_ ?params ?id () =
147 let unknown = Jsont.Object ([], Jsont.Meta.none) in
148 { jsonrpc = `V2; method_; params; id; unknown }
149
150 let jsont : t Jsont.t =
151 let make jsonrpc method_ params id unknown =
152 { jsonrpc; method_; params; id; unknown }
153 in
154 Jsont.Object.map ~kind:"JSONRPCRequest" make
155 |> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
156 |> Jsont.Object.mem "method" Jsont.string ~enc:(fun r -> r.method_)
157 |> Jsont.Object.opt_mem "params" params_jsont ~enc:(fun r -> r.params)
158 |> Jsont.Object.opt_mem "id" Id.jsont ~enc:(fun r -> r.id)
159 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
160 |> Jsont.Object.finish
161
162 let pp fmt req =
163 let id_str = match req.id with
164 | Some id -> Id.to_string id
165 | None -> "none"
166 in
167 Format.fprintf fmt "{method=%S, id=%s}" req.method_ id_str
168end
169
170(* Response Message *)
171
172module Response = struct
173 type t = {
174 jsonrpc : jsonrpc;
175 value : (Jsont.json, Error_data.t) result;
176 id : Id.t;
177 unknown : Jsont.json;
178 }
179
180 let make_result ~id ~result =
181 let unknown = Jsont.Object ([], Jsont.Meta.none) in
182 { jsonrpc = `V2; value = Ok result; id; unknown }
183
184 let make_error ~id ~error =
185 let unknown = Jsont.Object ([], Jsont.Meta.none) in
186 { jsonrpc = `V2; value = Error error; id; unknown }
187
188 let response_result r = match r.value with Ok v -> Some v | Error _ -> None
189 let response_error r = match r.value with Ok _ -> None | Error e -> Some e
190
191 let response jsonrpc result error id : t =
192 let unknown = Jsont.Object ([], Jsont.Meta.none) in
193 let err_both () =
194 Jsont.Error.msgf Jsont.Meta.none "Both %a and %a members are defined"
195 Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error"
196 in
197 let err_none () =
198 Jsont.Error.msgf Jsont.Meta.none "Missing either %a or %a member"
199 Jsont.Repr.pp_code "result" Jsont.Repr.pp_code "error"
200 in
201 match result, error with
202 | Some result, None -> { jsonrpc; value = Ok result; id; unknown }
203 | None, Some error -> { jsonrpc; value = Error error; id; unknown }
204 | Some _ , Some _ -> err_both ()
205 | None, None -> err_none ()
206
207 let jsont : t Jsont.t =
208 let make jsonrpc result error id unknown =
209 let resp = response jsonrpc result error id in
210 { resp with unknown }
211 in
212 Jsont.Object.map ~kind:"JSONRPCResponse" make
213 |> Jsont.Object.mem "jsonrpc" jsonrpc_jsont ~enc:(fun r -> r.jsonrpc)
214 |> Jsont.Object.opt_mem "result" Jsont.json ~enc:response_result
215 |> Jsont.Object.opt_mem "error" Error_data.jsont ~enc:response_error
216 |> Jsont.Object.mem "id" Id.jsont ~enc:(fun r -> r.id)
217 |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:(fun r -> r.unknown)
218 |> Jsont.Object.finish
219
220 let pp fmt resp =
221 let result_str = match resp.value with
222 | Ok _ -> "Ok(...)"
223 | Error err -> Format.asprintf "Error(%a)" Error_data.pp err
224 in
225 Format.fprintf fmt "{id=%a, %s}" Id.pp resp.id result_str
226end
227
228(* Message Union *)
229
230module Message = struct
231 type t =
232 | Request of Request.t
233 | Response of Response.t
234
235 let classify json =
236 (* Detect message type by presence of fields:
237 - "method" -> Request
238 - "result" or "error" -> Response *)
239 match json with
240 | Jsont.Object (members, _) ->
241 let has_method = List.exists (fun ((name, _), _) -> name = "method") members in
242 let has_result_or_error =
243 List.exists (fun ((name, _), _) ->
244 name = "result" || name = "error"
245 ) members
246 in
247 if has_method then
248 match Jsont.Json.decode Request.jsont json with
249 | Ok req -> Request req
250 | Error msg -> failwith ("Failed to decode request: " ^ msg)
251 else if has_result_or_error then
252 match Jsont.Json.decode Response.jsont json with
253 | Ok resp -> Response resp
254 | Error msg -> failwith ("Failed to decode response: " ^ msg)
255 else
256 failwith "Invalid JSON-RPC message: missing method or result/error"
257 | _ ->
258 failwith "Invalid JSON-RPC message: not an object"
259
260 let jsont : t Jsont.t =
261 let enc = function
262 | Request req ->
263 (match Jsont.Json.encode Request.jsont req with
264 | Ok json -> json
265 | Error msg -> failwith ("Failed to encode request: " ^ msg))
266 | Response resp ->
267 (match Jsont.Json.encode Response.jsont resp with
268 | Ok json -> json
269 | Error msg -> failwith ("Failed to encode response: " ^ msg))
270 in
271 let dec json =
272 classify json
273 in
274 Jsont.map ~kind:"JSONRPCMessage" ~dec ~enc Jsont.json
275
276 let pp fmt = function
277 | Request req -> Format.fprintf fmt "Request(%a)" Request.pp req
278 | Response resp -> Format.fprintf fmt "Response(%a)" Response.pp resp
279end