crdt library in ocaml implementing json-joy
gdiazlo.tngl.sh
1(** JSON-Rx message codecs.
2
3 This module provides encode/decode functions for JSON-Rx messages in two
4 formats:
5 - JSON (verbose, human-readable)
6 - Compact (array-based, more efficient)
7
8 @see <https://jsonjoy.com/specs/json-rx> JSON-Rx specification *)
9
10module J = Simdjsont.Json
11
12module Json = struct
13 let to_json (msg : Rx.message) : J.t =
14 let str s = J.String s in
15 let int i = J.Float (Float.of_int i) in
16 let obj fields = J.Object fields in
17 let opt_field k v =
18 match v with Some data -> [ (k, Value_codec.to_json data) ] | None -> []
19 in
20 match msg with
21 | Rx.Request { id; method_; data } ->
22 obj
23 ([ ("type", str "request"); ("id", int id); ("method", str method_) ]
24 @ opt_field "data" data)
25 | Rx.Response { id; data } ->
26 obj
27 [
28 ("type", str "response");
29 ("id", int id);
30 ("data", Value_codec.to_json data);
31 ]
32 | Rx.Error { id; error } ->
33 obj
34 [
35 ("type", str "error");
36 ("id", int id);
37 ("error", Value_codec.to_json error);
38 ]
39 | Rx.Notification { method_; data } ->
40 obj
41 ([ ("type", str "notification"); ("method", str method_) ]
42 @ opt_field "data" data)
43 | Rx.Subscribe { id; channel } ->
44 obj
45 [
46 ("type", str "subscribe"); ("id", int id); ("channel", str channel);
47 ]
48 | Rx.Unsubscribe { id } ->
49 obj [ ("type", str "unsubscribe"); ("id", int id) ]
50 | Rx.Data { id; data } ->
51 obj
52 [
53 ("type", str "data");
54 ("id", int id);
55 ("data", Value_codec.to_json data);
56 ]
57 | Rx.Complete { id } -> obj [ ("type", str "complete"); ("id", int id) ]
58
59 let of_json (json : J.t) : (Rx.message, string) result =
60 let get_string key mems =
61 match List.find_opt (fun (k, _) -> k = key) mems with
62 | Some (_, J.String s) -> Ok s
63 | Some _ -> Error (Printf.sprintf "expected string for %s" key)
64 | None -> Error (Printf.sprintf "missing field: %s" key)
65 in
66 let get_int key mems =
67 match List.find_opt (fun (k, _) -> k = key) mems with
68 | Some (_, J.Float n) ->
69 if Float.is_integer n then Ok (Float.to_int n)
70 else Error (Printf.sprintf "expected integer for %s" key)
71 | Some (_, J.Int i) -> Ok (Int64.to_int i)
72 | Some _ -> Error (Printf.sprintf "expected number for %s" key)
73 | None -> Error (Printf.sprintf "missing field: %s" key)
74 in
75 let get_value key mems =
76 match List.find_opt (fun (k, _) -> k = key) mems with
77 | Some (_, j) -> Ok (Value_codec.of_json j)
78 | None -> Error (Printf.sprintf "missing field: %s" key)
79 in
80 let get_value_opt key mems =
81 match List.find_opt (fun (k, _) -> k = key) mems with
82 | Some (_, j) -> Some (Value_codec.of_json j)
83 | None -> None
84 in
85 match json with
86 | J.Object mems -> (
87 match get_string "type" mems with
88 | Error e -> Error e
89 | Ok type_str -> (
90 match type_str with
91 | "request" -> (
92 match (get_int "id" mems, get_string "method" mems) with
93 | Ok id, Ok method_ ->
94 let data = get_value_opt "data" mems in
95 Ok (Rx.Request { id; method_; data })
96 | Error e, _ | _, Error e -> Error e)
97 | "response" -> (
98 match (get_int "id" mems, get_value "data" mems) with
99 | Ok id, Ok data -> Ok (Rx.Response { id; data })
100 | Error e, _ | _, Error e -> Error e)
101 | "error" -> (
102 match (get_int "id" mems, get_value "error" mems) with
103 | Ok id, Ok error -> Ok (Rx.Error { id; error })
104 | Error e, _ | _, Error e -> Error e)
105 | "notification" -> (
106 match get_string "method" mems with
107 | Ok method_ ->
108 let data = get_value_opt "data" mems in
109 Ok (Rx.Notification { method_; data })
110 | Error e -> Error e)
111 | "subscribe" -> (
112 match (get_int "id" mems, get_string "channel" mems) with
113 | Ok id, Ok channel -> Ok (Rx.Subscribe { id; channel })
114 | Error e, _ | _, Error e -> Error e)
115 | "unsubscribe" -> (
116 match get_int "id" mems with
117 | Ok id -> Ok (Rx.Unsubscribe { id })
118 | Error e -> Error e)
119 | "data" -> (
120 match (get_int "id" mems, get_value "data" mems) with
121 | Ok id, Ok data -> Ok (Rx.Data { id; data })
122 | Error e, _ | _, Error e -> Error e)
123 | "complete" -> (
124 match get_int "id" mems with
125 | Ok id -> Ok (Rx.Complete { id })
126 | Error e -> Error e)
127 | t -> Error (Printf.sprintf "unknown message type: %s" t)))
128 | _ -> Error "expected JSON object"
129
130 let encode (msg : Rx.message) : string =
131 let json = to_json msg in
132 J.to_string json
133
134 let encode_pretty (msg : Rx.message) : string =
135 let json = to_json msg in
136 J.to_string json
137
138 let decode (s : string) : (Rx.message, string) result =
139 match Simdjsont.Decode.decode_string Simdjsont.Decode.value s with
140 | Ok json -> of_json json
141 | Error e -> Error e
142end
143
144module Compact = struct
145 let to_json (msg : Rx.message) : J.t =
146 let int i = J.Float (Float.of_int i) in
147 let str s = J.String s in
148 let arr items = J.Array items in
149
150 match msg with
151 | Rx.Request { id; method_; data } ->
152 let base = [ int Rx.Type_code.request; int id; str method_ ] in
153 arr
154 (match data with
155 | Some d -> base @ [ Value_codec.to_json d ]
156 | None -> base)
157 | Rx.Response { id; data } ->
158 arr [ int Rx.Type_code.response; int id; Value_codec.to_json data ]
159 | Rx.Error { id; error } ->
160 arr [ int Rx.Type_code.error; int id; Value_codec.to_json error ]
161 | Rx.Notification { method_; data } ->
162 let base = [ int Rx.Type_code.notification; str method_ ] in
163 arr
164 (match data with
165 | Some d -> base @ [ Value_codec.to_json d ]
166 | None -> base)
167 | Rx.Subscribe { id; channel } ->
168 arr [ int Rx.Type_code.subscribe; int id; str channel ]
169 | Rx.Unsubscribe { id } -> arr [ int Rx.Type_code.unsubscribe; int id ]
170 | Rx.Data { id; data } ->
171 arr [ int Rx.Type_code.data; int id; Value_codec.to_json data ]
172 | Rx.Complete { id } -> arr [ int Rx.Type_code.complete; int id ]
173
174 let of_json (json : J.t) : (Rx.message, string) result =
175 let get_int = function
176 | J.Float n when Float.is_integer n -> Ok (Float.to_int n)
177 | J.Int i -> Ok (Int64.to_int i)
178 | _ -> Error "expected integer"
179 in
180 let get_string = function
181 | J.String s -> Ok s
182 | _ -> Error "expected string"
183 in
184 let get_value j = Ok (Value_codec.of_json j) in
185 match json with
186 | J.Array items -> (
187 match items with
188 | [] -> Error "empty array"
189 | type_code :: rest -> (
190 match get_int type_code with
191 | Error e -> Error e
192 | Ok code -> (
193 match (code, rest) with
194 | 0, id_j :: method_j :: rest -> (
195 match (get_int id_j, get_string method_j) with
196 | Ok id, Ok method_ ->
197 let data =
198 match rest with
199 | [] -> None
200 | [ d ] -> Some (Value_codec.of_json d)
201 | _ -> None
202 in
203 Ok (Rx.Request { id; method_; data })
204 | Error e, _ | _, Error e -> Error e)
205 | 0, _ -> Error "request requires at least id and method"
206 | 1, [ id_j; data_j ] -> (
207 match (get_int id_j, get_value data_j) with
208 | Ok id, Ok data -> Ok (Rx.Response { id; data })
209 | Error e, _ | _, Error e -> Error e)
210 | 1, _ -> Error "response requires id and data"
211 | 2, [ id_j; error_j ] -> (
212 match (get_int id_j, get_value error_j) with
213 | Ok id, Ok error -> Ok (Rx.Error { id; error })
214 | Error e, _ | _, Error e -> Error e)
215 | 2, _ -> Error "error requires id and error"
216 | 3, method_j :: rest -> (
217 match get_string method_j with
218 | Ok method_ ->
219 let data =
220 match rest with
221 | [] -> None
222 | [ d ] -> Some (Value_codec.of_json d)
223 | _ -> None
224 in
225 Ok (Rx.Notification { method_; data })
226 | Error e -> Error e)
227 | 3, _ -> Error "notification requires method"
228 | 4, [ id_j; channel_j ] -> (
229 match (get_int id_j, get_string channel_j) with
230 | Ok id, Ok channel -> Ok (Rx.Subscribe { id; channel })
231 | Error e, _ | _, Error e -> Error e)
232 | 4, _ -> Error "subscribe requires id and channel"
233 | 5, [ id_j ] -> (
234 match get_int id_j with
235 | Ok id -> Ok (Rx.Unsubscribe { id })
236 | Error e -> Error e)
237 | 5, _ -> Error "unsubscribe requires id"
238 | 6, [ id_j; data_j ] -> (
239 match (get_int id_j, get_value data_j) with
240 | Ok id, Ok data -> Ok (Rx.Data { id; data })
241 | Error e, _ | _, Error e -> Error e)
242 | 6, _ -> Error "data requires id and data"
243 | 7, [ id_j ] -> (
244 match get_int id_j with
245 | Ok id -> Ok (Rx.Complete { id })
246 | Error e -> Error e)
247 | 7, _ -> Error "complete requires id"
248 | code, _ -> Error (Printf.sprintf "unknown type code: %d" code)
249 )))
250 | _ -> Error "expected JSON array"
251
252 let encode (msg : Rx.message) : string =
253 let json = to_json msg in
254 J.to_string json
255
256 let decode (s : string) : (Rx.message, string) result =
257 match Simdjsont.Decode.decode_string Simdjsont.Decode.value s with
258 | Ok json -> of_json json
259 | Error e -> Error e
260end
261
262module Framing = struct
263 let frame (data : string) : string =
264 let len = String.length data in
265 let buf = Bytes.create (4 + len) in
266 Bytes.set buf 0 (Char.chr ((len lsr 24) land 0xff));
267 Bytes.set buf 1 (Char.chr ((len lsr 16) land 0xff));
268 Bytes.set buf 2 (Char.chr ((len lsr 8) land 0xff));
269 Bytes.set buf 3 (Char.chr (len land 0xff));
270 Bytes.blit_string data 0 buf 4 len;
271 Bytes.to_string buf
272
273 let read_length (buf : bytes) (offset : int) : int option =
274 if Bytes.length buf < offset + 4 then None
275 else
276 let b0 = Char.code (Bytes.get buf offset) in
277 let b1 = Char.code (Bytes.get buf (offset + 1)) in
278 let b2 = Char.code (Bytes.get buf (offset + 2)) in
279 let b3 = Char.code (Bytes.get buf (offset + 3)) in
280 Some ((b0 lsl 24) lor (b1 lsl 16) lor (b2 lsl 8) lor b3)
281
282 let unframe (data : string) : (string * string) option =
283 if String.length data < 4 then None
284 else
285 match read_length (Bytes.of_string data) 0 with
286 | None -> None
287 | Some len ->
288 if String.length data < 4 + len then None
289 else
290 let msg = String.sub data 4 len in
291 let rest =
292 String.sub data (4 + len) (String.length data - 4 - len)
293 in
294 Some (msg, rest)
295
296 let unframe_all (data : string) : string list * string =
297 let rec loop acc remaining =
298 match unframe remaining with
299 | None -> (List.rev acc, remaining)
300 | Some (msg, rest) -> loop (msg :: acc) rest
301 in
302 loop [] data
303
304 let frame_json (msg : Rx.message) : string = frame (Json.encode msg)
305 let frame_compact (msg : Rx.message) : string = frame (Compact.encode msg)
306
307 let unframe_json (data : string) : (Rx.message * string, string) result =
308 match unframe data with
309 | None -> Error "incomplete frame"
310 | Some (msg_str, rest) -> (
311 match Json.decode msg_str with
312 | Ok msg -> Ok (msg, rest)
313 | Error e -> Error e)
314
315 let unframe_compact (data : string) : (Rx.message * string, string) result =
316 match unframe data with
317 | None -> Error "incomplete frame"
318 | Some (msg_str, rest) -> (
319 match Compact.decode msg_str with
320 | Ok msg -> Ok (msg, rest)
321 | Error e -> Error e)
322end