crdt library in ocaml implementing json-joy
gdiazlo.tngl.sh
1(** JSON codec for CRDT operations.
2
3 Encodes/decodes operations in the json-joy verbose JSON format. *)
4
5module J = Simdjsont.Json
6
7(** {1 Timestamp Codec} *)
8
9(** Encode a timestamp as [sid, time] JSON array *)
10let encode_timestamp (ts : Clock.timestamp) : J.t =
11 J.Array [ J.Float (Float.of_int ts.sid); J.Float (Float.of_int ts.time) ]
12
13(** Decode a timestamp from JSON *)
14let decode_timestamp (json : J.t) : Clock.timestamp option =
15 match json with
16 | J.Array [ J.Float sid; J.Float time ] ->
17 Some { sid = Float.to_int sid; time = Float.to_int time }
18 | J.Array [ J.Int sid; J.Int time ] ->
19 Some { sid = Int64.to_int sid; time = Int64.to_int time }
20 | J.Array [ J.Int sid; J.Float time ] ->
21 Some { sid = Int64.to_int sid; time = Float.to_int time }
22 | J.Array [ J.Float sid; J.Int time ] ->
23 Some { sid = Float.to_int sid; time = Int64.to_int time }
24 | _ -> None
25
26(** {1 Timespan Codec} *)
27
28(** Encode a timespan as [sid, time, span] JSON array *)
29let encode_timespan (ts : Clock.timespan) : J.t =
30 J.Array
31 [
32 J.Float (Float.of_int ts.sid);
33 J.Float (Float.of_int ts.time);
34 J.Float (Float.of_int ts.span);
35 ]
36
37(** Decode a timespan from JSON *)
38let decode_timespan (json : J.t) : Clock.timespan option =
39 match json with
40 | J.Array [ J.Float sid; J.Float time; J.Float span ] ->
41 Some
42 {
43 sid = Float.to_int sid;
44 time = Float.to_int time;
45 span = Float.to_int span;
46 }
47 | J.Array [ J.Int sid; J.Int time; J.Int span ] ->
48 Some
49 {
50 sid = Int64.to_int sid;
51 time = Int64.to_int time;
52 span = Int64.to_int span;
53 }
54 | _ -> None
55
56(** {1 Object Entry Codec} *)
57
58(** Encode an object entry as ["key", [sid, time]] *)
59let encode_obj_entry ((key, ts) : Op.obj_entry) : J.t =
60 J.Array [ J.String key; encode_timestamp ts ]
61
62(** Decode an object entry from ["key", [sid, time]] *)
63let decode_obj_entry (json : J.t) : Op.obj_entry option =
64 match json with
65 | J.Array [ J.String key; ts_json ] -> (
66 match decode_timestamp ts_json with
67 | Some ts -> Some (key, ts)
68 | None -> None)
69 | _ -> None
70
71(** {1 Value Codec for new_con} *)
72
73(** Encode a Value.t for new_con (only primitives: null, bool, number, string)
74*)
75let encode_con_value (v : Value.t) : J.t =
76 match v with
77 | Value.Null -> J.Null
78 | Value.Bool b -> J.Bool b
79 | Value.Int n -> J.Float (Float.of_int n)
80 | Value.Float f -> J.Float f
81 | Value.String s -> J.String s
82 | _ -> J.Null
83(* Unsupported values become null *)
84
85(** Decode a Value.t from JSON for new_con *)
86let decode_con_value (json : J.t) : Value.t =
87 match json with
88 | J.Null -> Value.Null
89 | J.Bool b -> Value.Bool b
90 | J.Float f ->
91 (* Check if it's an integer *)
92 if Float.is_integer f then Value.Int (Float.to_int f) else Value.Float f
93 | J.Int i -> Value.Int (Int64.to_int i)
94 | J.String s -> Value.String s
95 | _ -> Value.Null
96
97(** {1 Operation Encoding} *)
98
99(** Make a JSON object with the given members *)
100let make_obj members : J.t = J.Object members
101
102(** Encode an operation to JSON (verbose format) *)
103let encode_op (op : Op.op_data) : J.t =
104 let op_name = Op.op_name op in
105 let op_str = J.String op_name in
106 match op with
107 | Op_new_con { con_value } ->
108 make_obj [ ("op", op_str); ("value", encode_con_value con_value) ]
109 | Op_new_val | Op_new_obj | Op_new_vec | Op_new_str | Op_new_bin | Op_new_arr
110 ->
111 make_obj [ ("op", op_str) ]
112 | Op_ins_val { ins_val_obj; ins_val_value } ->
113 make_obj
114 [
115 ("op", op_str);
116 ("obj", encode_timestamp ins_val_obj);
117 ("value", encode_timestamp ins_val_value);
118 ]
119 | Op_ins_obj { ins_obj_obj; ins_obj_value } ->
120 make_obj
121 [
122 ("op", op_str);
123 ("obj", encode_timestamp ins_obj_obj);
124 ("value", J.Array (List.map encode_obj_entry ins_obj_value));
125 ]
126 | Op_ins_vec { ins_vec_obj; ins_vec_idx; ins_vec_value } ->
127 make_obj
128 [
129 ("op", op_str);
130 ("obj", encode_timestamp ins_vec_obj);
131 ("idx", J.Float (Float.of_int ins_vec_idx));
132 ("value", encode_timestamp ins_vec_value);
133 ]
134 | Op_ins_str { ins_str_obj; ins_str_after; ins_str_value } ->
135 make_obj
136 [
137 ("op", op_str);
138 ("obj", encode_timestamp ins_str_obj);
139 ("after", encode_timestamp ins_str_after);
140 ("value", J.String ins_str_value);
141 ]
142 | Op_ins_bin { ins_bin_obj; ins_bin_after; ins_bin_value } ->
143 (* Binary is base64 encoded *)
144 make_obj
145 [
146 ("op", op_str);
147 ("obj", encode_timestamp ins_bin_obj);
148 ("after", encode_timestamp ins_bin_after);
149 ( "value",
150 J.String (Base64.encode_string (Bytes.to_string ins_bin_value)) );
151 ]
152 | Op_ins_arr { ins_arr_obj; ins_arr_after; ins_arr_value } ->
153 make_obj
154 [
155 ("op", op_str);
156 ("obj", encode_timestamp ins_arr_obj);
157 ("after", encode_timestamp ins_arr_after);
158 ("value", encode_timestamp ins_arr_value);
159 ]
160 | Op_upd_arr { upd_arr_obj; upd_arr_pos; upd_arr_value } ->
161 make_obj
162 [
163 ("op", op_str);
164 ("obj", encode_timestamp upd_arr_obj);
165 ("pos", encode_timestamp upd_arr_pos);
166 ("value", encode_timestamp upd_arr_value);
167 ]
168 | Op_del { del_obj; del_what } ->
169 make_obj
170 [
171 ("op", op_str);
172 ("obj", encode_timestamp del_obj);
173 ("what", J.Array (List.map encode_timespan del_what));
174 ]
175 | Op_nop { nop_len } ->
176 make_obj [ ("op", op_str); ("len", J.Float (Float.of_int nop_len)) ]
177
178(** {1 Operation Decoding} *)
179
180(** Get a member from a JSON object members list *)
181let get_member key (mems : (string * J.t) list) : J.t option =
182 List.find_map (fun (k, v) -> if k = key then Some v else None) mems
183
184(** Get a string field from a JSON object *)
185let get_string key mems =
186 match get_member key mems with Some (J.String s) -> Some s | _ -> None
187
188(** Get a timestamp field from a JSON object *)
189let get_timestamp key mems =
190 match get_member key mems with
191 | Some json -> decode_timestamp json
192 | None -> None
193
194(** Get an int field from a JSON object *)
195let get_int key mems =
196 match get_member key mems with
197 | Some (J.Float f) -> Some (Float.to_int f)
198 | Some (J.Int i) -> Some (Int64.to_int i)
199 | _ -> None
200
201(** Decode an operation from JSON (verbose format) *)
202let decode_op (json : J.t) : (Op.op_data, string) result =
203 match json with
204 | J.Object mems -> (
205 match get_string "op" mems with
206 | None -> Error "missing 'op' field"
207 | Some op_name -> (
208 match Op.opcode_of_name op_name with
209 | None -> Error (Printf.sprintf "unknown operation: %s" op_name)
210 | Some opcode -> (
211 match opcode with
212 | Op.New_con -> (
213 match get_member "value" mems with
214 | Some v ->
215 Ok (Op.Op_new_con { con_value = decode_con_value v })
216 | None -> Error "new_con: missing 'value' field")
217 | Op.New_val -> Ok Op.Op_new_val
218 | Op.New_obj -> Ok Op.Op_new_obj
219 | Op.New_vec -> Ok Op.Op_new_vec
220 | Op.New_str -> Ok Op.Op_new_str
221 | Op.New_bin -> Ok Op.Op_new_bin
222 | Op.New_arr -> Ok Op.Op_new_arr
223 | Op.Ins_val -> (
224 match
225 (get_timestamp "obj" mems, get_timestamp "value" mems)
226 with
227 | Some obj, Some value ->
228 Ok
229 (Op.Op_ins_val
230 { ins_val_obj = obj; ins_val_value = value })
231 | _ -> Error "ins_val: missing 'obj' or 'value' field")
232 | Op.Ins_obj -> (
233 match (get_timestamp "obj" mems, get_member "value" mems) with
234 | Some obj, Some (J.Array entries) ->
235 let decoded = List.filter_map decode_obj_entry entries in
236 if List.length decoded = List.length entries then
237 Ok
238 (Op.Op_ins_obj
239 { ins_obj_obj = obj; ins_obj_value = decoded })
240 else Error "ins_obj: invalid entry format"
241 | _ -> Error "ins_obj: missing 'obj' or 'value' field")
242 | Op.Ins_vec -> (
243 match
244 ( get_timestamp "obj" mems,
245 get_int "idx" mems,
246 get_timestamp "value" mems )
247 with
248 | Some obj, Some idx, Some value ->
249 Ok
250 (Op.Op_ins_vec
251 {
252 ins_vec_obj = obj;
253 ins_vec_idx = idx;
254 ins_vec_value = value;
255 })
256 | _ -> Error "ins_vec: missing 'obj', 'idx', or 'value' field"
257 )
258 | Op.Ins_str -> (
259 match
260 ( get_timestamp "obj" mems,
261 get_timestamp "after" mems,
262 get_string "value" mems )
263 with
264 | Some obj, Some after, Some value ->
265 Ok
266 (Op.Op_ins_str
267 {
268 ins_str_obj = obj;
269 ins_str_after = after;
270 ins_str_value = value;
271 })
272 | _ ->
273 Error "ins_str: missing 'obj', 'after', or 'value' field")
274 | Op.Ins_bin -> (
275 match
276 ( get_timestamp "obj" mems,
277 get_timestamp "after" mems,
278 get_string "value" mems )
279 with
280 | Some obj, Some after, Some b64_value -> (
281 match Base64.decode b64_value with
282 | Ok decoded ->
283 Ok
284 (Op.Op_ins_bin
285 {
286 ins_bin_obj = obj;
287 ins_bin_after = after;
288 ins_bin_value = Bytes.of_string decoded;
289 })
290 | Error _ -> Error "ins_bin: invalid base64 value")
291 | _ ->
292 Error "ins_bin: missing 'obj', 'after', or 'value' field")
293 | Op.Ins_arr -> (
294 match
295 ( get_timestamp "obj" mems,
296 get_timestamp "after" mems,
297 get_timestamp "value" mems )
298 with
299 | Some obj, Some after, Some value ->
300 Ok
301 (Op.Op_ins_arr
302 {
303 ins_arr_obj = obj;
304 ins_arr_after = after;
305 ins_arr_value = value;
306 })
307 | _ ->
308 Error "ins_arr: missing 'obj', 'after', or 'value' field")
309 | Op.Upd_arr -> (
310 match
311 ( get_timestamp "obj" mems,
312 get_timestamp "pos" mems,
313 get_timestamp "value" mems )
314 with
315 | Some obj, Some pos, Some value ->
316 Ok
317 (Op.Op_upd_arr
318 {
319 upd_arr_obj = obj;
320 upd_arr_pos = pos;
321 upd_arr_value = value;
322 })
323 | _ -> Error "upd_arr: missing 'obj', 'pos', or 'value' field"
324 )
325 | Op.Del -> (
326 match (get_timestamp "obj" mems, get_member "what" mems) with
327 | Some obj, Some (J.Array spans) ->
328 let decoded = List.filter_map decode_timespan spans in
329 if List.length decoded = List.length spans then
330 Ok (Op.Op_del { del_obj = obj; del_what = decoded })
331 else Error "del: invalid timespan format"
332 | _ -> Error "del: missing 'obj' or 'what' field")
333 | Op.Nop -> (
334 match get_int "len" mems with
335 | Some len -> Ok (Op.Op_nop { nop_len = len })
336 | None ->
337 (* Default to 1 if no len specified *)
338 Ok (Op.Op_nop { nop_len = 1 })))))
339 | _ -> Error "expected JSON object"
340
341(** {1 String Encoding/Decoding} *)
342
343(** Encode an operation to a JSON string *)
344let encode (op : Op.op_data) : string =
345 let json = encode_op op in
346 J.to_string json
347
348(** Decode an operation from a JSON string *)
349let decode (s : string) : (Op.op_data, string) result =
350 match Simdjsont.Decode.decode_string Simdjsont.Decode.value s with
351 | Ok json -> decode_op json
352 | Error e -> Error (Printf.sprintf "JSON parse error: %s" e)