My working unpac space for OCaml projects in development
Add cbort library for CBOR serialization of jsont codecs
Cbort directly serializes jsont codecs to/from CBOR (RFC 8949) by walking
the Repr.t GADT, similar to how jsont_bytesrw does for JSON. This enables
using the same codec definition for both JSON and CBOR serialization.
Data model mapping:
- JSON null → CBOR simple value 22
- JSON bool → CBOR simple values 20/21
- JSON number → CBOR int (types 0/1) or float (type 7)
- JSON string → CBOR text string (type 3)
- JSON array → CBOR array (type 4)
- JSON object → CBOR map with text keys (type 5)
🤖 Generated with [Claude Code](https://claude.com/claude-code)
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+776
+678
lib/cbort.ml
+678
lib/cbort.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
4
+
SPDX-License-Identifier: ISC
5
+
---------------------------------------------------------------------------*)
6
+
7
+
(* CBOR encoder/decoder for jsont codecs.
8
+
9
+
This module replicates the pattern from jsont_bytesrw but emits/parses
10
+
CBOR (RFC 8949) instead of JSON. The codec walking logic is derived from
11
+
jsont's Repr module. *)
12
+
13
+
[@@@warning "-32-69"] (* Allow unused values and fields - reserved for future *)
14
+
15
+
open Bytesrw
16
+
open Jsont.Repr
17
+
18
+
(* CBOR major types *)
19
+
let major_uint = 0
20
+
let major_nint = 1
21
+
let major_bytes = 2
22
+
let major_text = 3
23
+
let major_array = 4
24
+
let major_map = 5
25
+
let major_tag = 6
26
+
let major_simple = 7
27
+
28
+
(* CBOR simple values *)
29
+
let simple_false = 20
30
+
let simple_true = 21
31
+
let simple_null = 22
32
+
let simple_undefined = 23
33
+
34
+
(* CBOR additional info *)
35
+
let ai_1byte = 24
36
+
let ai_2byte = 25
37
+
let ai_4byte = 26
38
+
let ai_8byte = 27
39
+
let ai_indefinite = 31
40
+
41
+
(* Encoder *)
42
+
43
+
type encoder = {
44
+
writer : Bytes.Writer.t;
45
+
mutable buf : bytes;
46
+
mutable buf_pos : int;
47
+
}
48
+
49
+
let encoder_buf_size = 4096
50
+
51
+
let make_encoder writer =
52
+
{ writer;
53
+
buf = Stdlib.Bytes.create encoder_buf_size;
54
+
buf_pos = 0 }
55
+
56
+
let flush_encoder e =
57
+
if e.buf_pos > 0 then begin
58
+
let slice = Bytes.Slice.make e.buf ~first:0 ~length:e.buf_pos in
59
+
Bytes.Writer.write e.writer slice;
60
+
e.buf_pos <- 0
61
+
end
62
+
63
+
let ensure_space e n =
64
+
if e.buf_pos + n > Stdlib.Bytes.length e.buf then flush_encoder e
65
+
66
+
let write_byte e b =
67
+
ensure_space e 1;
68
+
Stdlib.Bytes.set_uint8 e.buf e.buf_pos b;
69
+
e.buf_pos <- e.buf_pos + 1
70
+
71
+
let write_bytes e bs =
72
+
let len = String.length bs in
73
+
ensure_space e len;
74
+
Stdlib.Bytes.blit_string bs 0 e.buf e.buf_pos len;
75
+
e.buf_pos <- e.buf_pos + len
76
+
77
+
let write_u16_be e v =
78
+
ensure_space e 2;
79
+
Stdlib.Bytes.set_uint16_be e.buf e.buf_pos v;
80
+
e.buf_pos <- e.buf_pos + 2
81
+
82
+
let write_u32_be e v =
83
+
ensure_space e 4;
84
+
Stdlib.Bytes.set_int32_be e.buf e.buf_pos v;
85
+
e.buf_pos <- e.buf_pos + 4
86
+
87
+
let write_u64_be e v =
88
+
ensure_space e 8;
89
+
Stdlib.Bytes.set_int64_be e.buf e.buf_pos v;
90
+
e.buf_pos <- e.buf_pos + 8
91
+
92
+
(* Write CBOR type header *)
93
+
let write_type_arg e major arg =
94
+
let h = major lsl 5 in
95
+
if arg <= 23 then
96
+
write_byte e (h lor arg)
97
+
else if arg <= 0xff then begin
98
+
write_byte e (h lor ai_1byte);
99
+
write_byte e arg
100
+
end else if arg <= 0xffff then begin
101
+
write_byte e (h lor ai_2byte);
102
+
write_u16_be e arg
103
+
end else if arg <= 0x7fffffff then begin (* OCaml int is 63-bit on 64-bit *)
104
+
write_byte e (h lor ai_4byte);
105
+
write_u32_be e (Int32.of_int arg)
106
+
end else begin
107
+
write_byte e (h lor ai_8byte);
108
+
write_u64_be e (Int64.of_int arg)
109
+
end
110
+
111
+
let write_type_arg64 e major arg =
112
+
let h = major lsl 5 in
113
+
if arg <= 23L then
114
+
write_byte e (h lor Int64.to_int arg)
115
+
else if arg <= 0xffL then begin
116
+
write_byte e (h lor ai_1byte);
117
+
write_byte e (Int64.to_int arg)
118
+
end else if arg <= 0xffffL then begin
119
+
write_byte e (h lor ai_2byte);
120
+
write_u16_be e (Int64.to_int arg)
121
+
end else if arg <= 0xffffffffL then begin
122
+
write_byte e (h lor ai_4byte);
123
+
write_u32_be e (Int64.to_int32 arg)
124
+
end else begin
125
+
write_byte e (h lor ai_8byte);
126
+
write_u64_be e arg
127
+
end
128
+
129
+
let write_null e =
130
+
write_byte e ((major_simple lsl 5) lor simple_null)
131
+
132
+
let write_bool e b =
133
+
let v = if b then simple_true else simple_false in
134
+
write_byte e ((major_simple lsl 5) lor v)
135
+
136
+
let write_float e f =
137
+
(* Always write as 64-bit double for simplicity *)
138
+
write_byte e ((major_simple lsl 5) lor ai_8byte);
139
+
write_u64_be e (Int64.bits_of_float f)
140
+
141
+
let write_int e n =
142
+
if n >= 0 then
143
+
write_type_arg e major_uint n
144
+
else
145
+
write_type_arg e major_nint (-(n + 1))
146
+
147
+
let write_int64 e n =
148
+
if n >= 0L then
149
+
write_type_arg64 e major_uint n
150
+
else
151
+
write_type_arg64 e major_nint (Int64.neg (Int64.add n 1L))
152
+
153
+
(* Encode a JSON number to CBOR.
154
+
If it's an integer that fits, encode as integer, otherwise as float *)
155
+
let write_number e f =
156
+
let i = Float.to_int f in
157
+
if Float.equal (Float.of_int i) f &&
158
+
i >= Int.min_int && i <= Int.max_int then
159
+
write_int e i
160
+
else
161
+
write_float e f
162
+
163
+
let write_text e s =
164
+
write_type_arg e major_text (String.length s);
165
+
write_bytes e s
166
+
167
+
let write_array_start e len =
168
+
write_type_arg e major_array len
169
+
170
+
let write_map_start e len =
171
+
write_type_arg e major_map len
172
+
173
+
(* Encode using jsont codec *)
174
+
175
+
let encode_null (map : (unit, 'a) base_map) e v =
176
+
ignore (map.enc v);
177
+
write_null e
178
+
179
+
let encode_bool (map : (bool, 'a) base_map) e v =
180
+
write_bool e (map.enc v)
181
+
182
+
let encode_number (map : (float, 'a) base_map) e v =
183
+
write_number e (map.enc v)
184
+
185
+
let encode_string (map : (string, 'a) base_map) e v =
186
+
write_text e (map.enc v)
187
+
188
+
let rec encode : type a. a t -> encoder -> a -> unit =
189
+
fun t e v -> match t with
190
+
| Null map -> encode_null map e v
191
+
| Bool map -> encode_bool map e v
192
+
| Number map -> encode_number map e v
193
+
| String map -> encode_string map e v
194
+
| Array map -> encode_array map e v
195
+
| Object map -> encode_object map e v
196
+
| Any map -> encode (map.enc v) e v
197
+
| Map map -> encode map.dom e (map.enc v)
198
+
| Rec t -> encode (Lazy.force t) e v
199
+
200
+
and encode_array : type a elt b.
201
+
(a, elt, b) array_map -> encoder -> a -> unit
202
+
=
203
+
fun map e v ->
204
+
(* Count elements first *)
205
+
let count = ref 0 in
206
+
let counter _ _ _ = incr count; () in
207
+
ignore (map.enc counter () v);
208
+
write_array_start e !count;
209
+
let encode_element map e i elt =
210
+
(try encode map.elt e elt with
211
+
| Jsont.Error err ->
212
+
error_push_array Jsont.Meta.none map (i, Jsont.Meta.none) err);
213
+
e
214
+
in
215
+
ignore (map.enc (encode_element map) e v)
216
+
217
+
and encode_object : type o.
218
+
(o, o) object_map -> encoder -> o -> unit
219
+
=
220
+
fun map e o ->
221
+
(* Count members first *)
222
+
let count = ref 0 in
223
+
let counter _map o (Mem_enc mmap) =
224
+
let v = mmap.enc o in
225
+
if not (mmap.enc_omit v) then incr count
226
+
in
227
+
List.iter (counter map o) map.mem_encs;
228
+
(match map.shape with
229
+
| Object_basic (Unknown_keep (umap, enc)) ->
230
+
let counter _ _ _ _ = incr count; () in
231
+
umap.enc counter (enc o) ()
232
+
| _ -> ());
233
+
(match map.shape with
234
+
| Object_cases (_, cases) ->
235
+
let Case_value (case, c) = cases.enc_case (cases.enc o) in
236
+
if not (cases.tag.enc_omit case.tag) then incr count;
237
+
List.iter (counter case.object_map c) case.object_map.mem_encs
238
+
| _ -> ());
239
+
write_map_start e !count;
240
+
encode_object_members map e ~do_unknown:true o
241
+
242
+
and encode_object_members : type o.
243
+
(o, o) object_map -> encoder -> do_unknown:bool -> o -> unit
244
+
=
245
+
fun map e ~do_unknown o ->
246
+
let encode_mem map e o (Mem_enc mmap) =
247
+
try
248
+
let v = mmap.enc o in
249
+
if not (mmap.enc_omit v) then begin
250
+
write_text e mmap.name;
251
+
encode mmap.type' e v
252
+
end
253
+
with
254
+
| Jsont.Error err ->
255
+
error_push_object Jsont.Meta.none map
256
+
(mmap.name, Jsont.Meta.none) err
257
+
in
258
+
(match map.shape with
259
+
| Object_cases (umap, cases) ->
260
+
let Case_value (case, c) = cases.enc_case (cases.enc o) in
261
+
if not (cases.tag.enc_omit case.tag) then begin
262
+
write_text e cases.tag.name;
263
+
encode cases.tag.type' e case.tag
264
+
end;
265
+
List.iter (encode_mem map e o) map.mem_encs;
266
+
(match umap with
267
+
| Some (Unknown_keep (umap, enc)) ->
268
+
encode_object_members case.object_map e ~do_unknown:false c;
269
+
encode_unknown_mems map umap e (enc o)
270
+
| _ ->
271
+
encode_object_members case.object_map e ~do_unknown c)
272
+
| Object_basic u ->
273
+
List.iter (encode_mem map e o) map.mem_encs;
274
+
(match u with
275
+
| Unknown_keep (umap, enc) when do_unknown ->
276
+
encode_unknown_mems map umap e (enc o)
277
+
| _ -> ()))
278
+
279
+
and encode_unknown_mems : type o mems a builder.
280
+
(o, o) object_map -> (mems, a, builder) mems_map ->
281
+
encoder -> mems -> unit
282
+
=
283
+
fun map umap e mems ->
284
+
let encode_unknown_mem map umap e _meta n v () =
285
+
try
286
+
write_text e n;
287
+
encode umap.mems_type e v
288
+
with
289
+
| Jsont.Error err ->
290
+
error_push_object Jsont.Meta.none map (n, Jsont.Meta.none) err
291
+
in
292
+
umap.enc (encode_unknown_mem map umap e) mems ()
293
+
294
+
let encode' t v ~eod w =
295
+
let e = make_encoder w in
296
+
let t = of_t t in
297
+
try
298
+
encode t e v;
299
+
flush_encoder e;
300
+
if eod then Bytes.Writer.write w Bytes.Slice.eod;
301
+
Ok ()
302
+
with
303
+
| Jsont.Error err -> Error err
304
+
305
+
let encode ?buf:_ t v ~eod w =
306
+
Result.map_error Jsont.Error.to_string (encode' t v ~eod w)
307
+
308
+
let encode_string' t v =
309
+
let b = Buffer.create 255 in
310
+
let w = Bytes.Writer.of_buffer b in
311
+
match encode' t v ~eod:true w with
312
+
| Ok () -> Ok (Buffer.contents b)
313
+
| Error _ as e -> e
314
+
315
+
let encode_string t v =
316
+
Result.map_error Jsont.Error.to_string (encode_string' t v)
317
+
318
+
(* Decoder *)
319
+
320
+
type decoder = {
321
+
reader : Bytes.Reader.t;
322
+
mutable slice : Bytes.Slice.t;
323
+
mutable pos : int; (* position within current slice *)
324
+
mutable byte_count : int; (* global byte count for errors *)
325
+
}
326
+
327
+
let make_decoder reader =
328
+
{ reader;
329
+
slice = Bytes.Slice.make (Stdlib.Bytes.create 0) ~first:0 ~length:0;
330
+
pos = 0;
331
+
byte_count = 0 }
332
+
333
+
let decoder_refill d =
334
+
d.slice <- Bytes.Reader.read d.reader;
335
+
d.pos <- Bytes.Slice.first d.slice
336
+
337
+
let available d = Bytes.Slice.length d.slice - (d.pos - Bytes.Slice.first d.slice)
338
+
339
+
let ensure_bytes d n =
340
+
if available d < n then begin
341
+
(* Need to buffer across slices *)
342
+
let buf = Stdlib.Bytes.create n in
343
+
let rec fill offset remaining =
344
+
if remaining <= 0 then ()
345
+
else begin
346
+
if available d = 0 then decoder_refill d;
347
+
let avail = available d in
348
+
if avail = 0 then
349
+
Jsont.Error.msg Jsont.Meta.none "Unexpected end of CBOR data";
350
+
let take = min avail remaining in
351
+
let src = Bytes.Slice.bytes d.slice in
352
+
Stdlib.Bytes.blit src d.pos buf offset take;
353
+
d.pos <- d.pos + take;
354
+
d.byte_count <- d.byte_count + take;
355
+
fill (offset + take) (remaining - take)
356
+
end
357
+
in
358
+
fill 0 n;
359
+
d.slice <- Bytes.Slice.make buf ~first:0 ~length:n;
360
+
d.pos <- 0
361
+
end
362
+
363
+
let read_byte d =
364
+
ensure_bytes d 1;
365
+
let b = Stdlib.Bytes.get_uint8 (Bytes.Slice.bytes d.slice) d.pos in
366
+
d.pos <- d.pos + 1;
367
+
d.byte_count <- d.byte_count + 1;
368
+
b
369
+
370
+
let read_u16_be d =
371
+
ensure_bytes d 2;
372
+
let v = Stdlib.Bytes.get_uint16_be (Bytes.Slice.bytes d.slice) d.pos in
373
+
d.pos <- d.pos + 2;
374
+
d.byte_count <- d.byte_count + 2;
375
+
v
376
+
377
+
let read_u32_be d =
378
+
ensure_bytes d 4;
379
+
let v = Stdlib.Bytes.get_int32_be (Bytes.Slice.bytes d.slice) d.pos in
380
+
d.pos <- d.pos + 4;
381
+
d.byte_count <- d.byte_count + 4;
382
+
Int32.to_int v (* may truncate on 32-bit, but that's a limitation *)
383
+
384
+
let read_u64_be d =
385
+
ensure_bytes d 8;
386
+
let v = Stdlib.Bytes.get_int64_be (Bytes.Slice.bytes d.slice) d.pos in
387
+
d.pos <- d.pos + 8;
388
+
d.byte_count <- d.byte_count + 8;
389
+
v
390
+
391
+
let read_bytes_to_string d len =
392
+
let buf = Stdlib.Bytes.create len in
393
+
let rec fill offset remaining =
394
+
if remaining <= 0 then ()
395
+
else begin
396
+
if available d = 0 then decoder_refill d;
397
+
let avail = available d in
398
+
if avail = 0 then
399
+
Jsont.Error.msg Jsont.Meta.none "Unexpected end of CBOR data";
400
+
let take = min avail remaining in
401
+
Stdlib.Bytes.blit (Bytes.Slice.bytes d.slice) d.pos buf offset take;
402
+
d.pos <- d.pos + take;
403
+
d.byte_count <- d.byte_count + take;
404
+
fill (offset + take) (remaining - take)
405
+
end
406
+
in
407
+
fill 0 len;
408
+
Stdlib.Bytes.unsafe_to_string buf
409
+
410
+
(* Read CBOR argument value *)
411
+
let read_arg d ai =
412
+
if ai <= 23 then ai
413
+
else if ai = ai_1byte then read_byte d
414
+
else if ai = ai_2byte then read_u16_be d
415
+
else if ai = ai_4byte then read_u32_be d
416
+
else if ai = ai_8byte then Int64.to_int (read_u64_be d)
417
+
else Jsont.Error.msgf Jsont.Meta.none "Invalid CBOR additional info: %d" ai
418
+
419
+
let read_arg64 d ai =
420
+
if ai <= 23 then Int64.of_int ai
421
+
else if ai = ai_1byte then Int64.of_int (read_byte d)
422
+
else if ai = ai_2byte then Int64.of_int (read_u16_be d)
423
+
else if ai = ai_4byte then Int64.of_int32 (Int32.of_int (read_u32_be d))
424
+
else if ai = ai_8byte then read_u64_be d
425
+
else Jsont.Error.msgf Jsont.Meta.none "Invalid CBOR additional info: %d" ai
426
+
427
+
(* Peek at CBOR type without consuming *)
428
+
let peek_type d =
429
+
ensure_bytes d 1;
430
+
let b = Stdlib.Bytes.get_uint8 (Bytes.Slice.bytes d.slice) d.pos in
431
+
let major = b lsr 5 in
432
+
let ai = b land 0x1f in
433
+
(major, ai)
434
+
435
+
(* Error helpers *)
436
+
let dec_type_error (type a) (t : a t) ~fnd =
437
+
let sort = match fnd with
438
+
| 0 | 1 -> Jsont.Sort.Number
439
+
| 2 -> Jsont.Sort.String (* bytes treated as string for error *)
440
+
| 3 -> Jsont.Sort.String
441
+
| 4 -> Jsont.Sort.Array
442
+
| 5 -> Jsont.Sort.Object
443
+
| 7 -> Jsont.Sort.Null (* could be bool/null *)
444
+
| _ -> Jsont.Sort.Null
445
+
in
446
+
type_error Jsont.Meta.none t ~fnd:sort
447
+
448
+
(* Decode using jsont codec *)
449
+
450
+
let rec decode : type a. a t -> decoder -> a =
451
+
fun t d ->
452
+
let major, ai = peek_type d in
453
+
match t with
454
+
| Null map -> decode_null map d major ai
455
+
| Bool map -> decode_bool map d major ai
456
+
| Number map -> decode_number map d major ai
457
+
| String map -> decode_string map d major ai
458
+
| Array map -> decode_array map d major ai
459
+
| Object map -> decode_object map d major ai
460
+
| Any map -> decode_any t map d major ai
461
+
| Map map -> map.dec (decode map.dom d)
462
+
| Rec t -> decode (Lazy.force t) d
463
+
464
+
and decode_null : type a.
465
+
(unit, a) base_map -> decoder -> int -> int -> a
466
+
=
467
+
fun map d major ai ->
468
+
if major = major_simple && (ai = simple_null || ai = simple_undefined) then begin
469
+
ignore (read_byte d);
470
+
map.dec Jsont.Meta.none ()
471
+
end else
472
+
dec_type_error (Null map) ~fnd:major
473
+
474
+
and decode_bool : type a.
475
+
(bool, a) base_map -> decoder -> int -> int -> a
476
+
=
477
+
fun map d major ai ->
478
+
if major = major_simple && (ai = simple_false || ai = simple_true) then begin
479
+
ignore (read_byte d);
480
+
map.dec Jsont.Meta.none (ai = simple_true)
481
+
end else
482
+
dec_type_error (Bool map) ~fnd:major
483
+
484
+
and decode_number : type a.
485
+
(float, a) base_map -> decoder -> int -> int -> a
486
+
=
487
+
fun map d major ai ->
488
+
let f = match major with
489
+
| 0 -> (* unsigned int *)
490
+
ignore (read_byte d);
491
+
let v = read_arg64 d ai in
492
+
Int64.to_float v
493
+
| 1 -> (* negative int *)
494
+
ignore (read_byte d);
495
+
let v = read_arg64 d ai in
496
+
Float.neg (Int64.to_float (Int64.add v 1L))
497
+
| 7 when ai = 25 -> (* half-precision float *)
498
+
ignore (read_byte d);
499
+
let bits = read_u16_be d in
500
+
(* Decode IEEE 754 half-precision *)
501
+
let sign = if bits land 0x8000 <> 0 then -1.0 else 1.0 in
502
+
let exp = (bits lsr 10) land 0x1f in
503
+
let mant = bits land 0x3ff in
504
+
if exp = 0 then
505
+
sign *. (Float.ldexp (float_of_int mant) (-24))
506
+
else if exp = 31 then
507
+
if mant = 0 then sign *. Float.infinity else Float.nan
508
+
else
509
+
sign *. (Float.ldexp (float_of_int (mant + 1024)) (exp - 25))
510
+
| 7 when ai = 26 -> (* single-precision float *)
511
+
ignore (read_byte d);
512
+
let bits = Int32.of_int (read_u32_be d) in
513
+
Int32.float_of_bits bits
514
+
| 7 when ai = 27 -> (* double-precision float *)
515
+
ignore (read_byte d);
516
+
let bits = read_u64_be d in
517
+
Int64.float_of_bits bits
518
+
| 7 when ai = simple_null ->
519
+
(* JSON treats null as NaN in numbers *)
520
+
ignore (read_byte d);
521
+
Float.nan
522
+
| _ ->
523
+
dec_type_error (Number map) ~fnd:major
524
+
in
525
+
map.dec Jsont.Meta.none f
526
+
527
+
and decode_string : type a.
528
+
(string, a) base_map -> decoder -> int -> int -> a
529
+
=
530
+
fun map d major ai ->
531
+
if major = major_text then begin
532
+
ignore (read_byte d);
533
+
let len = read_arg d ai in
534
+
let s = read_bytes_to_string d len in
535
+
map.dec Jsont.Meta.none s
536
+
end else if major = major_bytes then begin
537
+
(* Accept byte strings as strings (decoded as latin-1) *)
538
+
ignore (read_byte d);
539
+
let len = read_arg d ai in
540
+
let s = read_bytes_to_string d len in
541
+
map.dec Jsont.Meta.none s
542
+
end else
543
+
dec_type_error (String map) ~fnd:major
544
+
545
+
and decode_array : type a elt b.
546
+
(a, elt, b) array_map -> decoder -> int -> int -> a
547
+
=
548
+
fun map d major ai ->
549
+
if major <> major_array then dec_type_error (Array map) ~fnd:major;
550
+
ignore (read_byte d);
551
+
let len = read_arg d ai in
552
+
let builder = map.dec_empty () in
553
+
let rec loop builder i =
554
+
if i >= len then builder
555
+
else begin
556
+
let builder =
557
+
if map.dec_skip i builder then begin
558
+
(* Skip this element - need to consume it *)
559
+
skip_value d;
560
+
builder
561
+
end else begin
562
+
try map.dec_add i (decode map.elt d) builder
563
+
with Jsont.Error e ->
564
+
error_push_array Jsont.Meta.none map (i, Jsont.Meta.none) e
565
+
end
566
+
in
567
+
loop builder (i + 1)
568
+
end
569
+
in
570
+
let builder = loop builder 0 in
571
+
map.dec_finish Jsont.Meta.none len builder
572
+
573
+
and skip_value d =
574
+
let major, ai = peek_type d in
575
+
ignore (read_byte d);
576
+
match major with
577
+
| 0 | 1 -> ignore (read_arg64 d ai)
578
+
| 2 | 3 ->
579
+
let len = read_arg d ai in
580
+
ignore (read_bytes_to_string d len)
581
+
| 4 ->
582
+
let len = read_arg d ai in
583
+
for _ = 0 to len - 1 do skip_value d done
584
+
| 5 ->
585
+
let len = read_arg d ai in
586
+
for _ = 0 to len - 1 do skip_value d; skip_value d done
587
+
| 6 ->
588
+
ignore (read_arg64 d ai);
589
+
skip_value d
590
+
| 7 ->
591
+
if ai >= 25 && ai <= 27 then
592
+
let bytes = if ai = 25 then 2 else if ai = 26 then 4 else 8 in
593
+
ignore (read_bytes_to_string d bytes)
594
+
| _ ->
595
+
Jsont.Error.msgf Jsont.Meta.none "Unknown CBOR major type: %d" major
596
+
597
+
and decode_object : type o.
598
+
(o, o) object_map -> decoder -> int -> int -> o
599
+
=
600
+
fun map d major ai ->
601
+
if major <> major_map then dec_type_error (Object map) ~fnd:major;
602
+
ignore (read_byte d);
603
+
let len = read_arg d ai in
604
+
(* Read all members into an association list *)
605
+
let dict = Dict.empty in
606
+
let mem_miss = map.mem_decs in
607
+
decode_object_members map d len String_map.empty mem_miss dict
608
+
609
+
and decode_object_members : type o.
610
+
(o, o) object_map -> decoder -> int ->
611
+
mem_dec String_map.t ->
612
+
mem_dec String_map.t ->
613
+
Dict.t -> o
614
+
=
615
+
fun map d remaining found mem_miss dict ->
616
+
if remaining <= 0 then begin
617
+
(* Check for missing required members *)
618
+
finish_object_decode map Jsont.Meta.none
619
+
Unknown_skip () mem_miss dict
620
+
|> apply_dict map.dec
621
+
end else begin
622
+
(* Read key *)
623
+
let key_major, key_ai = peek_type d in
624
+
if key_major <> major_text then
625
+
Jsont.Error.msgf Jsont.Meta.none "CBOR map key must be text string";
626
+
ignore (read_byte d);
627
+
let key_len = read_arg d key_ai in
628
+
let key = read_bytes_to_string d key_len in
629
+
(* Find member decoder *)
630
+
match String_map.find_opt key map.mem_decs with
631
+
| Some (Mem_dec m) ->
632
+
let dict =
633
+
try Dict.add m.id (decode m.type' d) dict
634
+
with Jsont.Error e ->
635
+
error_push_object Jsont.Meta.none map
636
+
(key, Jsont.Meta.none) e
637
+
in
638
+
let mem_miss = String_map.remove key mem_miss in
639
+
decode_object_members map d (remaining - 1) found mem_miss dict
640
+
| None ->
641
+
(* Unknown member - skip it *)
642
+
skip_value d;
643
+
decode_object_members map d (remaining - 1) found mem_miss dict
644
+
end
645
+
646
+
and decode_any : type a.
647
+
a t -> a any_map -> decoder -> int -> int -> a
648
+
=
649
+
fun t map d major ai ->
650
+
let dec opt = match opt with
651
+
| Some t' -> decode t' d
652
+
| None -> dec_type_error t ~fnd:major
653
+
in
654
+
match major with
655
+
| 7 when ai = simple_null || ai = simple_undefined -> dec map.dec_null
656
+
| 7 when ai = simple_false || ai = simple_true -> dec map.dec_bool
657
+
| 0 | 1 -> dec map.dec_number
658
+
| 7 when ai >= 25 && ai <= 27 -> dec map.dec_number
659
+
| 2 | 3 -> dec map.dec_string
660
+
| 4 -> dec map.dec_array
661
+
| 5 -> dec map.dec_object
662
+
| _ -> dec_type_error t ~fnd:major
663
+
664
+
let decode' t r =
665
+
let d = make_decoder r in
666
+
decoder_refill d;
667
+
try Ok (decode (of_t t) d) with
668
+
| Jsont.Error e -> Error e
669
+
670
+
let decode t r =
671
+
Result.map_error Jsont.Error.to_string (decode' t r)
672
+
673
+
let decode_string' t s =
674
+
let r = Bytes.Reader.of_string s in
675
+
decode' t r
676
+
677
+
let decode_string t s =
678
+
Result.map_error Jsont.Error.to_string (decode_string' t s)
+95
lib/cbort.mli
+95
lib/cbort.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The jsont programmers. All rights reserved.
3
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
4
+
SPDX-License-Identifier: ISC
5
+
---------------------------------------------------------------------------*)
6
+
7
+
(** CBOR codec for jsont types.
8
+
9
+
This module provides CBOR ({{:https://www.rfc-editor.org/rfc/rfc8949}RFC 8949})
10
+
encoding and decoding for values described by {{:https://erratique.ch/software/jsont}jsont}
11
+
codecs.
12
+
13
+
Since CBOR and JSON share the same underlying data model (null, booleans,
14
+
numbers, strings, arrays, and objects/maps), jsont codecs can be used
15
+
directly for CBOR serialization without modification.
16
+
17
+
{2 Quick Start}
18
+
19
+
{[
20
+
(* Define a codec using jsont *)
21
+
type person = { name : string; age : int }
22
+
23
+
let person_codec = Jsont.(
24
+
Object.(map (fun name age -> { name; age })
25
+
|> mem "name" string ~enc:(fun p -> p.name)
26
+
|> mem "age" int ~enc:(fun p -> p.age)
27
+
|> finish))
28
+
29
+
(* Encode to CBOR *)
30
+
let cbor_bytes = Cbort.encode_string person_codec { name = "Alice"; age = 30 }
31
+
32
+
(* Decode from CBOR *)
33
+
let person = Cbort.decode_string person_codec cbor_bytes
34
+
]}
35
+
36
+
{2 Data Model Mapping}
37
+
38
+
| JSON Type | CBOR Type |
39
+
|------------|-----------|
40
+
| null | Simple value 22 (null) |
41
+
| boolean | Simple values 20/21 (false/true) |
42
+
| number | Integer (types 0/1) or float (type 7) |
43
+
| string | Text string (type 3) |
44
+
| array | Array (type 4) |
45
+
| object | Map with text string keys (type 5) |
46
+
47
+
{2 Notes}
48
+
49
+
- JSON numbers that are integers are encoded as CBOR integers for compactness
50
+
- CBOR byte strings (type 2) are accepted when decoding strings
51
+
- CBOR tags are ignored on decode
52
+
- CBOR indefinite-length encoding is not currently supported *)
53
+
54
+
open Bytesrw
55
+
56
+
(** {1:decode Decode} *)
57
+
58
+
val decode : 'a Jsont.t -> Bytes.Reader.t -> ('a, string) result
59
+
(** [decode t r] decodes a value from CBOR reader [r] according to codec [t]. *)
60
+
61
+
val decode' : 'a Jsont.t -> Bytes.Reader.t -> ('a, Jsont.Error.t) result
62
+
(** [decode'] is like {!val-decode} but preserves the error structure. *)
63
+
64
+
val decode_string : 'a Jsont.t -> string -> ('a, string) result
65
+
(** [decode_string t s] decodes a value from CBOR string [s] according to
66
+
codec [t]. *)
67
+
68
+
val decode_string' : 'a Jsont.t -> string -> ('a, Jsont.Error.t) result
69
+
(** [decode_string'] is like {!decode_string} but preserves the error
70
+
structure. *)
71
+
72
+
(** {1:encode Encode} *)
73
+
74
+
val encode :
75
+
?buf:Bytes.t -> 'a Jsont.t -> 'a -> eod:bool -> Bytes.Writer.t ->
76
+
(unit, string) result
77
+
(** [encode t v w] encodes value [v] according to codec [t] as CBOR on
78
+
writer [w].
79
+
{ul
80
+
{- [buf] is currently unused (reserved for future buffer configuration)}
81
+
{- [eod] indicates whether {!Bytesrw.Bytes.Slice.eod} should be written
82
+
on [w] after encoding.}} *)
83
+
84
+
val encode' :
85
+
'a Jsont.t -> 'a -> eod:bool -> Bytes.Writer.t ->
86
+
(unit, Jsont.Error.t) result
87
+
(** [encode'] is like {!val-encode} but preserves the error structure. *)
88
+
89
+
val encode_string : 'a Jsont.t -> 'a -> (string, string) result
90
+
(** [encode_string t v] encodes value [v] according to codec [t] as a CBOR
91
+
byte string. *)
92
+
93
+
val encode_string' : 'a Jsont.t -> 'a -> (string, Jsont.Error.t) result
94
+
(** [encode_string'] is like {!encode_string} but preserves the error
95
+
structure. *)