futur.blue
objective categorical abstract machine language personal data server
1module String_map = Map.Make (String)
2
3(* sort map keys by length first, then lexicographically *)
4let dag_cbor_key_compare a b =
5 let la = String.length a in
6 let lb = String.length b in
7 if la = lb then String.compare a b else compare la lb
8
9let ordered_map_keys (m : 'a String_map.t) : string list =
10 let keys = String_map.bindings m |> List.map fst in
11 List.sort dag_cbor_key_compare keys
12
13(* returns bindings sorted in dag-cbor canonical order *)
14let ordered_map_bindings (m : 'a String_map.t) : (string * 'a) list =
15 String_map.bindings m
16 |> List.sort (fun (a, _) (b, _) -> dag_cbor_key_compare a b)
17
18let type_info_length len =
19 if len < 24 then 1
20 else if len < 0x100 then 2
21 else if len < 0x10000 then 3
22 else if len < 0x100000000 then 5
23 else 9
24
25type value =
26 [ `Null
27 | `Boolean of bool
28 | `Integer of int64
29 | `Float of float
30 | `Bytes of bytes
31 | `String of string
32 | `Array of value Array.t
33 | `Map of value String_map.t
34 | `Link of Cid.t ]
35
36let rec of_yojson (json : Yojson.Safe.t) : value =
37 match json with
38 | `Assoc [("$bytes", `String s)] ->
39 `Bytes (Bytes.of_string (Base64.decode_exn ~pad:false s))
40 | `Assoc [("$link", `String s)] ->
41 `Link (Result.get_ok (Cid.of_string s))
42 | `Assoc assoc_list ->
43 `Map
44 (String_map.of_list
45 (List.map (fun (k, v) -> (k, of_yojson v)) assoc_list) )
46 | `List lst ->
47 `Array (Array.of_list (List.map of_yojson lst))
48 | `Bool b ->
49 `Boolean b
50 | `Int i ->
51 `Integer (Int64.of_int i)
52 | `Intlit s ->
53 `Integer (Int64.of_string s)
54 | `Float f ->
55 `Float f
56 | `String s ->
57 `String s
58 | `Null ->
59 `Null
60
61let rec to_yojson (value : value) : Yojson.Safe.t =
62 match value with
63 | `Map map ->
64 `Assoc
65 (String_map.to_list map |> List.map (fun (k, v) -> (k, to_yojson v)))
66 | `Array arr ->
67 `List (Array.to_list arr |> List.map to_yojson)
68 | `Bytes bytes ->
69 `Assoc
70 [ ( "$bytes"
71 , `String (Base64.encode_exn ~pad:false (Bytes.to_string bytes)) ) ]
72 | `Link cid ->
73 `Assoc [("$link", `String (Cid.to_string cid))]
74 | `Boolean b ->
75 `Bool b
76 | `Integer i ->
77 `Int (Int64.to_int i)
78 | `Float f ->
79 `Float f
80 | `String s ->
81 `String s
82 | `Null ->
83 `Null
84
85module Encoder = struct
86 type t = {mutable buf: Buffer.t; mutable pos: int}
87
88 let create () = {buf= Buffer.create 1024; pos= 0}
89
90 let write_float_64 t f =
91 let i64 = Int64.bits_of_float f in
92 let bytes = Bytes.create 8 in
93 Bytes.set_int64_be bytes 0 i64 ;
94 Buffer.add_bytes t.buf bytes ;
95 t.pos <- t.pos + 8
96
97 let write_uint_8 t i =
98 if i < 0 || i > 255 then
99 invalid_arg "write_uint_8: value out of range ([0, 255])" ;
100 Buffer.add_uint8 t.buf i ;
101 t.pos <- t.pos + 1
102
103 let write_uint_16 t i =
104 if i < 0 || i > 65535 then
105 invalid_arg "write_uint_16: value out of range ([0, 65535])" ;
106 Buffer.add_uint16_be t.buf i ;
107 t.pos <- t.pos + 2
108
109 let write_uint_32 t (i : int32) =
110 Buffer.add_int32_be t.buf i ;
111 t.pos <- t.pos + 4
112
113 let write_uint_53 t (i : int64) =
114 if i < 0L || i > 9007199254740991L then
115 invalid_arg "write_uint_53: value out of range ([0, 9007199254740991])" ;
116 Buffer.add_int64_be t.buf i ;
117 t.pos <- t.pos + 8
118
119 let write_type_and_argument t major (arg : int64) =
120 let type_code =
121 match major with
122 | 0 ->
123 0x00 (* unsigned integer *)
124 | 1 ->
125 0x20 (* negative integer *)
126 | 2 ->
127 0x40 (* byte string *)
128 | 3 ->
129 0x60 (* text string *)
130 | 4 ->
131 0x80 (* array *)
132 | 5 ->
133 0xa0 (* map *)
134 | 6 ->
135 0xc0 (* tag *)
136 | _ ->
137 invalid_arg "write_type_and_argument: invalid major type"
138 in
139 if arg < 24L then write_uint_8 t (type_code lor Int64.to_int arg)
140 else if arg < 0x100L then (
141 write_uint_8 t (type_code lor 24) ;
142 write_uint_8 t (Int64.to_int arg) )
143 else if arg < 0x10000L then (
144 write_uint_8 t (type_code lor 25) ;
145 write_uint_16 t (Int64.to_int arg) )
146 else if arg < 0x100000000L then (
147 write_uint_8 t (type_code lor 26) ;
148 write_uint_32 t (Int64.to_int32 arg) )
149 else (
150 write_uint_8 t (type_code lor 27) ;
151 write_uint_53 t arg )
152
153 let write_integer t (i : int64) =
154 if i < -9007199254740991L || i > 9007199254740991L then
155 invalid_arg
156 "write_integer: value out of range ([-9007199254740991, \
157 9007199254740991])"
158 else if i >= 0L then write_type_and_argument t 0 i
159 else write_type_and_argument t 1 (Int64.sub (Int64.neg i) 1L)
160
161 let write_float t (f : float) = write_uint_8 t 0xfb ; write_float_64 t f
162
163 let write_string t (s : string) =
164 let len = String.length s in
165 write_type_and_argument t 3 (Int64.of_int len) ;
166 Buffer.add_string t.buf s ;
167 t.pos <- t.pos + len
168
169 let write_bytes t (b : bytes) =
170 let len = Bytes.length b in
171 write_type_and_argument t 2 (Int64.of_int len) ;
172 Buffer.add_bytes t.buf b ;
173 t.pos <- t.pos + len
174
175 let write_cid t (cid : Cid.t) =
176 let cid_bytes = Cid.to_bytes cid in
177 let bytes_len = Bytes.length cid_bytes in
178 write_type_and_argument t 6 42L ;
179 write_type_and_argument t 2 (Int64.of_int bytes_len) ;
180 Buffer.add_bytes t.buf cid_bytes ;
181 t.pos <- t.pos + bytes_len
182
183 let rec write_value t (v : value) =
184 match v with
185 | `Null ->
186 write_uint_8 t 0xf6 (* null *)
187 | `Boolean b ->
188 write_uint_8 t (if b then 0xf5 else 0xf4) (* true/false *)
189 | `Integer i ->
190 write_integer t i
191 | `Float f ->
192 write_float t f
193 | `Bytes b ->
194 write_bytes t b
195 | `String s ->
196 write_string t s
197 | `Array lst ->
198 let len = Array.length lst in
199 write_type_and_argument t 4 (Int64.of_int len) ;
200 Array.iter (write_value t) lst
201 | `Map m ->
202 let len = String_map.cardinal m in
203 write_type_and_argument t 5 (Int64.of_int len) ;
204 ordered_map_bindings m
205 |> List.iter (fun (k, v) -> write_string t k ; write_value t v)
206 | `Link cid ->
207 write_cid t cid
208
209 let encode (v : value) : bytes =
210 let encoder = create () in
211 write_value encoder v ;
212 if encoder.pos < Buffer.length encoder.buf then
213 Buffer.truncate encoder.buf encoder.pos ;
214 Buffer.to_bytes encoder.buf
215
216 let encode_yojson (v : Yojson.Safe.t) : bytes = of_yojson v |> encode
217end
218
219module Decoder = struct
220 type t = {mutable buf: bytes; mutable pos: int}
221
222 let read_float_64 t =
223 if t.pos + 8 > Bytes.length t.buf then
224 invalid_arg "read_float_64: not enough bytes in buffer" ;
225 let bytes = Bytes.sub t.buf t.pos 8 in
226 let f = Int64.float_of_bits (Bytes.get_int64_be bytes 0) in
227 t.pos <- t.pos + 8 ;
228 f
229
230 let read_uint_8 t =
231 if t.pos + 1 > Bytes.length t.buf then
232 invalid_arg "read_uint_8: not enough bytes in buffer" ;
233 let i = Bytes.get_uint8 t.buf t.pos in
234 t.pos <- t.pos + 1 ;
235 i
236
237 let read_uint_16 t =
238 if t.pos + 2 > Bytes.length t.buf then
239 invalid_arg "read_uint_16: not enough bytes in buffer" ;
240 let i = Bytes.get_uint16_be t.buf t.pos in
241 t.pos <- t.pos + 2 ;
242 i
243
244 let read_uint_32 t =
245 if t.pos + 4 > Bytes.length t.buf then
246 invalid_arg "read_uint_32: not enough bytes in buffer" ;
247 let i = Bytes.get_int32_be t.buf t.pos in
248 t.pos <- t.pos + 4 ;
249 i
250
251 let read_uint_53 t =
252 if t.pos + 8 > Bytes.length t.buf then
253 invalid_arg "read_uint_53: not enough bytes in buffer" ;
254 let i = Bytes.get_int64_be t.buf t.pos in
255 t.pos <- t.pos + 8 ;
256 if i < 0L || i > 9007199254740991L then
257 invalid_arg "read_uint_53: value out of range (0-9007199254740991)" ;
258 i
259
260 let read_argument t info =
261 if info < 24L then info
262 else
263 let len : int64 =
264 match info with
265 | 24L ->
266 Int64.of_int (read_uint_8 t)
267 | 25L ->
268 Int64.of_int (read_uint_16 t)
269 | 26L ->
270 Int64.of_int32 (read_uint_32 t)
271 | 27L ->
272 read_uint_53 t
273 | _ ->
274 invalid_arg "read_argument: invalid info value"
275 in
276 if len < 0L then invalid_arg "read_argument: negative length" ;
277 len
278
279 let read_string t len =
280 if t.pos + len > Bytes.length t.buf then
281 invalid_arg "read_string: not enough bytes in buffer" ;
282 let str = Bytes.sub_string t.buf t.pos len in
283 t.pos <- t.pos + len ;
284 str
285
286 let read_bytes t len =
287 if t.pos + len > Bytes.length t.buf then
288 invalid_arg "read_bytes: not enough bytes in buffer" ;
289 let bytes = Bytes.sub t.buf t.pos len in
290 t.pos <- t.pos + len ;
291 bytes
292
293 let read_cid t len =
294 if t.pos + len > Bytes.length t.buf then
295 invalid_arg "read_cid: not enough bytes in buffer" ;
296 let cid_bytes = Bytes.sub t.buf t.pos len in
297 t.pos <- t.pos + len ;
298 Cid.of_bytes cid_bytes
299
300 let decode_string_key t =
301 let prelude = read_uint_8 t in
302 let type_code = prelude lsr 5 in
303 if type_code <> 3 then
304 invalid_arg
305 ( "decode_string_key: expected text string type; got "
306 ^ string_of_int type_code ) ;
307 let info = Int64.of_int (prelude land 0x1f) in
308 let len = read_argument t info in
309 if len < 0L then invalid_arg "decode_string_key: negative length" ;
310 read_string t (Int64.to_int len)
311
312 let decode_first buf =
313 let t = {buf; pos= 0} in
314 let rec decode_first' () =
315 if t.pos >= Bytes.length t.buf then
316 invalid_arg "decode_first: no more bytes to decode" ;
317 let prelude = read_uint_8 t in
318 let major_type = prelude lsr 5 in
319 let info = Int64.of_int (prelude land 0x1f) in
320 match major_type with
321 | 0 ->
322 (* unsigned integer *)
323 let value = read_argument t info in
324 if value < 0L then
325 invalid_arg "decode_first: negative unsigned integer" ;
326 `Integer value
327 | 1 ->
328 (* negative integer *)
329 let value = read_argument t info in
330 if value < 0L then
331 invalid_arg "decode_first: negative negative integer" ;
332 `Integer (Int64.neg (Int64.add value 1L))
333 | 2 ->
334 (* byte string *)
335 let len = read_argument t info in
336 if len < 0L then
337 invalid_arg "decode_first: negative byte string length" ;
338 `Bytes (read_bytes t (Int64.to_int len))
339 | 3 ->
340 (* text string *)
341 let len = read_argument t info in
342 if len < 0L then
343 invalid_arg "decode_first: negative text string length" ;
344 `String (read_string t (Int64.to_int len))
345 | 4 ->
346 (* array *)
347 let len = read_argument t info in
348 if len < 0L then invalid_arg "decode_first: negative array length" ;
349 let rec decode_array acc n =
350 if n <= 0 then Array.of_list (List.rev acc)
351 else
352 let item = decode_first' () in
353 decode_array (item :: acc) (n - 1)
354 in
355 `Array (decode_array [] (Int64.to_int len))
356 | 5 ->
357 (* map *)
358 let len = read_argument t info in
359 if len < 0L then invalid_arg "decode_first: negative map length" ;
360 let rec decode_map acc n =
361 if n <= 0 then String_map.of_seq (List.to_seq acc)
362 else
363 let key = decode_string_key t in
364 let value = decode_first' () in
365 decode_map ((key, value) :: acc) (n - 1)
366 in
367 `Map (decode_map [] (Int64.to_int len))
368 | 6 ->
369 (* tag *)
370 let tag = read_uint_8 t in
371 if tag = 42 then (
372 let prelude = read_uint_8 t in
373 let type_code = prelude lsr 5 in
374 if type_code <> 2 then
375 invalid_arg
376 ( "decode_first: expected type 2 for CID; got "
377 ^ string_of_int type_code ) ;
378 let info = Int64.of_int (prelude land 0x1f) in
379 let len = read_argument t info in
380 if len < 0L then invalid_arg "decode_first: negative CID length" ;
381 match read_cid t (Int64.to_int len) with
382 | Ok cid ->
383 `Link cid
384 | Error msg ->
385 invalid_arg ("decode_first: CID decode error: " ^ msg) )
386 else invalid_arg ("decode_first: unsupported tag " ^ string_of_int tag)
387 | 7 -> (
388 (* boolean, null, or float *)
389 match info with
390 | 20L | 21L ->
391 `Boolean (info = 21L) (* true/false *)
392 | 22L ->
393 `Null
394 | 27L ->
395 `Float (read_float_64 t)
396 | _ ->
397 invalid_arg
398 ( "decode_first: unsupported info value for major type 7: "
399 ^ Int64.to_string info ) )
400 | _ ->
401 invalid_arg
402 ("decode_first: unsupported major type " ^ string_of_int major_type)
403 in
404 let result : value = decode_first' () in
405 let remainder = Bytes.sub t.buf t.pos (Bytes.length t.buf - t.pos) in
406 (result, remainder)
407
408 let decode buf =
409 let value, remainder = decode_first buf in
410 if Bytes.length remainder > 0 then
411 invalid_arg
412 (Printf.sprintf "decode: extra bytes after valid CBOR data (%d)"
413 (Bytes.length remainder) ) ;
414 value
415
416 let decode_to_yojson buf =
417 let value = decode buf in
418 to_yojson value
419end
420
421let encode = Encoder.encode
422
423let decode = Decoder.decode
424
425let encode_yojson = Encoder.encode_yojson
426
427let decode_to_yojson = Decoder.decode_to_yojson