Native CBOR codec with type-safe combinators
ocaml-cbor: decouple Codec from Value, namespace under Cbor.Codec, rename IO verbs
The codec record drops its Value.t-based [encode] / [decode] fields, leaving
[{ kind; encode_rw; decode_rw }] — codecs now write to a Binary.encoder and
read from a Binary.decoder directly, building 'a from bytes without an
intermediate Value.t. This satisfies the ocaml-encodings skill's "codec.ml
does not depend on value.ml" rule; only cbor.ml bridges the two via
[Binary.read_cbor] / [write_cbor].
Surface follows RFC 8949 spec order: cbor.mli sections walk major types 0-7,
then simple values (3.3) and tags (3.4), each linking to the relevant clause.
Combinators move under [Cbor.Codec] (was top-level on [Cbor]); naming tracks
CDDL: [Cbor.Obj] -> [Cbor.Codec.Map], [Cbor.Obj_int] -> [Cbor.Codec.Map_int],
[Cbor.string] -> [Cbor.Codec.text], [Cbor.string_map] -> [Cbor.Codec.text_map].
Top-level IO verbs follow the parallel naming convention used elsewhere in the
monorepo: [encode_string] / [decode_string] -> [to_string] / [of_string];
[Cbor.Private.{decode,encode}_cbor] collapse into [Cbor.{decode,encode}].
[update_mem] and [delete_mem] move out of [Codec] into [Cbor] as Value.t
patch helpers (they cannot be pure-stream codecs).
Includes a fix to [Binary.skip] for definite-length text/bytes (it was
unconditionally calling [skip_break], which fired on the next item's header).
297 cbor tests + mdx pass; 16 downstream callers (cose, jwt/cwt, mst, scitt,
irmin/cbor) migrated and pass tests.
+2280
-2372
+34
-23
README.md
+34
-23
README.md
···
43
43
type person = { name : string; age : int }
44
44
45
45
let person_codec =
46
-
let open Obj in
47
-
seal
48
-
(let* name = mem "name" (fun p -> p.name) string in
49
-
let* age = mem "age" (fun p -> p.age) int in
50
-
return { name; age })
46
+
Codec.Map.(
47
+
map (fun name age -> { name; age })
48
+
|> mem "name" (fun p -> p.name) Codec.text
49
+
|> mem "age" (fun p -> p.age) Codec.int
50
+
|> seal)
51
51
52
52
(* Encode to CBOR bytes *)
53
-
let encoded = encode_string person_codec { name = "Alice"; age = 30 }
53
+
let encoded = Cbor.to_string person_codec { name = "Alice"; age = 30 }
54
54
55
55
(* Decode from CBOR bytes *)
56
56
let () =
57
-
match decode_string person_codec encoded with
57
+
match Cbor.of_string person_codec encoded with
58
58
| Ok p -> Printf.printf "%s is %d\n" p.name p.age
59
59
| Error e -> prerr_endline (Error.to_string e)
60
60
61
61
(* Streaming decode from a bytesrw reader *)
62
62
let stream_decode encoded =
63
63
let reader = Bytesrw.Bytes.Reader.of_string encoded in
64
-
match decode person_codec reader with
64
+
match Cbor.of_reader person_codec reader with
65
65
| Ok p -> Printf.printf "%s\n" p.name
66
66
| Error e -> prerr_endline (Error.to_string e)
67
67
```
···
74
74
type shape = Circle of float | Rect of float * float
75
75
76
76
let shape_codec =
77
-
Variant.(variant [
78
-
case 0 float (fun r -> Circle r)
77
+
Codec.Variant.(variant [
78
+
case 0 Codec.float (fun r -> Circle r)
79
79
(function Circle r -> Some r | _ -> None);
80
-
case 1 (tuple2 float float) (fun (w, h) -> Rect (w, h))
80
+
case 1 (Codec.tuple2 Codec.float Codec.float) (fun (w, h) -> Rect (w, h))
81
81
(function Rect (w, h) -> Some (w, h) | _ -> None);
82
82
])
83
83
```
84
84
85
85
## API Overview
86
86
87
-
- **Base codecs** -- `null`, `bool`, `int`, `int32`, `int64`, `float`, `string`, `bytes`, `any`
88
-
- **`nullable`**, **`option`** -- Optional values
89
-
- **`array`**, **`array_of`**, **`tuple2`**--**`tuple4`** -- Array codecs
90
-
- **`assoc`**, **`string_map`**, **`int_map`** -- Map codecs
91
-
- **`Obj`** module -- Record builder with string keys: `mem`, `mem_opt`, `mem_default`, `return`, `seal`
92
-
- **`Obj_int`** module -- Record builder with integer keys (COSE/CWT style)
93
-
- **`Variant`**, **`Variant_key`** -- Sum types via CBOR tags or string-keyed maps
94
-
- **`tag`**, **`tag_opt`** -- CBOR semantic tags
95
-
- **`map`**, **`conv`**, **`const`**, **`fix`** -- Transformations and recursion
96
-
- **`mem`**, **`int_mem`**, **`nth`** -- Query combinators
97
-
- **`decode`**, **`decode_string`** -- Decoding (streaming and string)
98
-
- **`encode`**, **`encode_string`** -- Encoding (streaming and string)
87
+
The combinator surface lives under `Cbor.Codec`, organized by RFC 8949 major
88
+
type:
89
+
90
+
- **Major 0/1 — integers** -- `int`, `int32`, `int64`, `uint`, `uint32`, `uint64`
91
+
- **Major 2 — byte string** -- `bytes`
92
+
- **Major 3 — text string** -- `text`
93
+
- **Major 4 — array** -- `array`, `array_of`, `tuple2`, `tuple3`, `tuple4`
94
+
- **Major 5 — map** -- `assoc`, `text_map`, `int_map`, `Map` (records by text
95
+
key), `Map_int` (records by int key, COSE / CWT style)
96
+
- **Major 6 — tag** -- `tag`, `tag_opt`
97
+
- **Major 7 — simple / float** -- `null`, `bool`, `float`
98
+
- **Sum types** -- `Variant` (tag-discriminated), `Variant_key` (singleton-map)
99
+
- **Transformations** -- `map`, `conv`, `const`, `nullable`, `option`, `number`,
100
+
`fix`
101
+
- **Queries** -- `mem`, `int_mem`, `nth`
102
+
103
+
Top-level I/O lives in `Cbor`:
104
+
105
+
- **`Cbor.of_string`**, **`Cbor.of_string_exn`** — decode from CBOR bytes
106
+
- **`Cbor.to_string`** — encode to CBOR bytes
107
+
- **`Cbor.of_reader`**, **`Cbor.to_writer`** — bytesrw streaming
108
+
- **`Cbor.decode`**, **`Cbor.encode`** — bridges to `Value.t`
109
+
- **`Cbor.update_mem`**, **`Cbor.delete_mem`** — patch operations on maps
99
110
100
111
## References
101
112
+3
-2
lib/binary.ml
+3
-2
lib/binary.ml
···
579
579
| 2 | 3 ->
580
580
let arg = read_argument dec hdr in
581
581
if arg >= 0L then ignore (read_bytes dec (Int64.to_int arg))
582
-
else
582
+
else begin
583
583
while not (is_break dec) do
584
584
skip dec
585
585
done;
586
-
skip_break dec
586
+
skip_break dec
587
+
end
587
588
| 4 ->
588
589
let arg = read_argument dec hdr in
589
590
if arg >= 0L then
+100
-1823
lib/cbor.ml
+100
-1823
lib/cbor.ml
···
8
8
module Value = Value
9
9
module Sort = Sort
10
10
module Error = Error
11
-
12
-
type 'a t = {
13
-
kind : string;
14
-
encode : 'a -> Value.t;
15
-
decode : Loc.Context.t -> Value.t -> ('a, Error.t) result;
16
-
decode_rw : Loc.Context.t -> Binary.decoder -> ('a, Error.t) result;
17
-
}
11
+
module Codec = Codec
18
12
19
-
let kind c = c.kind
20
-
let pp ppf c = Fmt.pf ppf "<codec:%s>" c.kind
13
+
type t = Value.t
14
+
type 'a codec = 'a Codec.t
21
15
22
-
let type_name (v : Value.t) =
23
-
match v with
24
-
| Int _ -> "integer"
25
-
| Bytes _ -> "bytes"
26
-
| Text _ -> "text"
27
-
| Array _ -> "array"
28
-
| Map _ -> "map"
29
-
| Tag _ -> "tag"
30
-
| Bool _ -> "boolean"
31
-
| Null -> "null"
32
-
| Undefined -> "undefined"
33
-
| Simple _ -> "simple"
34
-
| Float _ -> "float"
35
-
36
-
let type_error path expected v =
37
-
Error.type_mismatch_result path ~expected ~got:(type_name v)
38
-
39
-
(* Major type name for stream decoding errors *)
40
-
let major_type_name = function
41
-
| 0 -> "integer"
42
-
| 1 -> "integer"
43
-
| 2 -> "bytes"
44
-
| 3 -> "text"
45
-
| 4 -> "array"
46
-
| 5 -> "map"
47
-
| 6 -> "tag"
48
-
| 7 -> "simple/float"
49
-
| _ -> "unknown"
50
-
51
-
let stream_type_error path expected (hdr : Binary.header) =
52
-
Error.type_mismatch_result path ~expected ~got:(major_type_name hdr.major)
53
-
54
-
(* Fallback: read a Value.t from the stream, then use the Value.t decoder *)
55
-
let decode_rw_via_cbor decode path dec =
56
-
let v = Binary.read_cbor dec in
57
-
decode path v
58
-
59
-
(* Stream-level: read text string (major type 3) handling both definite
60
-
and indefinite lengths, given an already-read header *)
61
-
let read_text_with_hdr dec (hdr : Binary.header) =
62
-
let arg = Binary.read_argument dec hdr in
63
-
if arg >= 0L then Binary.read_bytes dec (Int64.to_int arg)
64
-
else begin
65
-
let buf = Buffer.create 64 in
66
-
while
67
-
match Binary.peek_byte dec with
68
-
| Some 0xff ->
69
-
ignore (Binary.read_byte dec);
70
-
false
71
-
| _ -> true
72
-
do
73
-
let hdr = Binary.read_header dec in
74
-
if hdr.major <> Binary.major_text then failwith "Expected text chunk";
75
-
let len = Binary.read_argument dec hdr in
76
-
if len < 0L then failwith "Nested indefinite text";
77
-
Buffer.add_string buf (Binary.read_bytes dec (Int64.to_int len))
78
-
done;
79
-
Buffer.contents buf
80
-
end
81
-
82
-
(* Stream-level: read bytes string (major type 2) given an already-read header *)
83
-
let read_bytes_with_hdr dec (hdr : Binary.header) =
84
-
let arg = Binary.read_argument dec hdr in
85
-
if arg >= 0L then Binary.read_bytes dec (Int64.to_int arg)
86
-
else begin
87
-
let buf = Buffer.create 64 in
88
-
while
89
-
match Binary.peek_byte dec with
90
-
| Some 0xff ->
91
-
ignore (Binary.read_byte dec);
92
-
false
93
-
| _ -> true
94
-
do
95
-
let hdr = Binary.read_header dec in
96
-
if hdr.major <> Binary.major_bytes then failwith "Expected bytes chunk";
97
-
let len = Binary.read_argument dec hdr in
98
-
if len < 0L then failwith "Nested indefinite bytes";
99
-
Buffer.add_string buf (Binary.read_bytes dec (Int64.to_int len))
100
-
done;
101
-
Buffer.contents buf
102
-
end
103
-
104
-
(* Stream-level: read a float from major type 7 header *)
105
-
let read_float_with_hdr dec (hdr : Binary.header) =
106
-
if hdr.info = Binary.ai_2byte then Binary.decode_half (Binary.read_u16_be dec)
107
-
else if hdr.info = Binary.ai_4byte then
108
-
Int32.float_of_bits (Binary.read_u32_be dec)
109
-
else if hdr.info = Binary.ai_8byte then
110
-
Int64.float_of_bits (Binary.read_u64_be dec)
111
-
else failwith "Expected float"
112
-
113
-
(* Base codecs *)
114
-
115
-
let null =
16
+
(* Generic codec for any CBOR data item — passes the streaming bytes straight
17
+
through {!Binary.read_cbor} / {!Binary.write_cbor}. Lives here (not in
18
+
{!Codec}) because it bridges to {!Value.t}. *)
19
+
let any : Value.t codec =
116
20
{
117
-
kind = "null";
118
-
encode = (fun () -> Value.Null);
119
-
decode =
120
-
(fun path v ->
121
-
match v with Value.Null -> Ok () | _ -> type_error path "null" v);
122
-
decode_rw =
123
-
(fun path dec ->
124
-
let hdr = Binary.read_header dec in
125
-
if hdr.major = Binary.major_simple && hdr.info = Binary.simple_null then
126
-
Ok ()
127
-
else stream_type_error path "null" hdr);
128
-
}
129
-
130
-
let bool =
131
-
{
132
-
kind = "bool";
133
-
encode = (fun b -> Value.Bool b);
134
-
decode =
135
-
(fun path v ->
136
-
match v with Value.Bool b -> Ok b | _ -> type_error path "boolean" v);
137
-
decode_rw =
138
-
(fun path dec ->
139
-
let hdr = Binary.read_header dec in
140
-
if hdr.major = Binary.major_simple && hdr.info = Binary.simple_false
141
-
then Ok false
142
-
else if hdr.major = Binary.major_simple && hdr.info = Binary.simple_true
143
-
then Ok true
144
-
else stream_type_error path "boolean" hdr);
145
-
}
146
-
147
-
let int =
148
-
{
149
-
kind = "int";
150
-
encode = (fun n -> Value.Int (Z.of_int n));
151
-
decode =
152
-
(fun path v ->
153
-
match v with
154
-
| Value.Int n ->
155
-
if Z.fits_int n then Ok (Z.to_int n)
156
-
else
157
-
Error
158
-
(Error.v ~ctx:path
159
-
(Error.Out_of_range
160
-
{
161
-
value = Z.to_string n;
162
-
range = Fmt.str "[%d, %d]" min_int max_int;
163
-
}))
164
-
| _ -> type_error path "integer" v);
165
-
decode_rw =
166
-
(fun path dec ->
167
-
let hdr = Binary.read_header dec in
168
-
match hdr.major with
169
-
| 0 ->
170
-
let n = Binary.read_argument_z dec hdr in
171
-
if Z.fits_int n then Ok (Z.to_int n)
172
-
else
173
-
Error
174
-
(Error.v ~ctx:path
175
-
(Error.Out_of_range
176
-
{
177
-
value = Z.to_string n;
178
-
range = Fmt.str "[%d, %d]" min_int max_int;
179
-
}))
180
-
| 1 ->
181
-
let n = Z.neg (Z.succ (Binary.read_argument_z dec hdr)) in
182
-
if Z.fits_int n then Ok (Z.to_int n)
183
-
else
184
-
Error
185
-
(Error.v ~ctx:path
186
-
(Error.Out_of_range
187
-
{
188
-
value = Z.to_string n;
189
-
range = Fmt.str "[%d, %d]" min_int max_int;
190
-
}))
191
-
| _ -> stream_type_error path "integer" hdr);
192
-
}
193
-
194
-
let int32 =
195
-
{
196
-
kind = "int32";
197
-
encode = (fun n -> Value.Int (Z.of_int32 n));
198
-
decode =
199
-
(fun path v ->
200
-
match v with
201
-
| Value.Int n ->
202
-
if
203
-
Z.geq n (Z.of_int32 Int32.min_int)
204
-
&& Z.leq n (Z.of_int32 Int32.max_int)
205
-
then Ok (Z.to_int32 n)
206
-
else
207
-
Error
208
-
(Error.v ~ctx:path
209
-
(Error.Out_of_range
210
-
{
211
-
value = Z.to_string n;
212
-
range = Fmt.str "[%ld, %ld]" Int32.min_int Int32.max_int;
213
-
}))
214
-
| _ -> type_error path "integer" v);
215
-
decode_rw =
216
-
(fun path dec ->
217
-
let hdr = Binary.read_header dec in
218
-
match hdr.major with
219
-
| 0 | 1 ->
220
-
let n =
221
-
if hdr.major = 0 then Binary.read_argument_z dec hdr
222
-
else Z.neg (Z.succ (Binary.read_argument_z dec hdr))
223
-
in
224
-
if
225
-
Z.geq n (Z.of_int32 Int32.min_int)
226
-
&& Z.leq n (Z.of_int32 Int32.max_int)
227
-
then Ok (Z.to_int32 n)
228
-
else
229
-
Error
230
-
(Error.v ~ctx:path
231
-
(Error.Out_of_range
232
-
{
233
-
value = Z.to_string n;
234
-
range = Fmt.str "[%ld, %ld]" Int32.min_int Int32.max_int;
235
-
}))
236
-
| _ -> stream_type_error path "integer" hdr);
237
-
}
238
-
239
-
let int64 =
240
-
{
241
-
kind = "int64";
242
-
encode = (fun n -> Value.Int (Z.of_int64 n));
243
-
decode =
244
-
(fun path v ->
245
-
match v with
246
-
| Value.Int n ->
247
-
if Z.fits_int64 n then Ok (Z.to_int64 n)
248
-
else
249
-
Error
250
-
(Error.v ~ctx:path
251
-
(Error.Out_of_range
252
-
{
253
-
value = Z.to_string n;
254
-
range = Fmt.str "[%Ld, %Ld]" Int64.min_int Int64.max_int;
255
-
}))
256
-
| _ -> type_error path "integer" v);
257
-
decode_rw =
258
-
(fun path dec ->
259
-
let hdr = Binary.read_header dec in
260
-
match hdr.major with
261
-
| 0 | 1 ->
262
-
let n =
263
-
if hdr.major = 0 then Binary.read_argument_z dec hdr
264
-
else Z.neg (Z.succ (Binary.read_argument_z dec hdr))
265
-
in
266
-
if Z.fits_int64 n then Ok (Z.to_int64 n)
267
-
else
268
-
Error
269
-
(Error.v ~ctx:path
270
-
(Error.Out_of_range
271
-
{
272
-
value = Z.to_string n;
273
-
range = Fmt.str "[%Ld, %Ld]" Int64.min_int Int64.max_int;
274
-
}))
275
-
| _ -> stream_type_error path "integer" hdr);
276
-
}
277
-
278
-
let float =
279
-
{
280
-
kind = "float";
281
-
encode = (fun f -> Value.Float f);
282
-
decode =
283
-
(fun path v ->
284
-
match v with
285
-
| Value.Float f -> Ok f
286
-
| Value.Int n -> Ok (Z.to_float n)
287
-
| _ -> type_error path "float" v);
288
-
decode_rw =
289
-
(fun path dec ->
290
-
let hdr = Binary.read_header dec in
291
-
match hdr.major with
292
-
| 7 -> Ok (read_float_with_hdr dec hdr)
293
-
| 0 -> Ok (Z.to_float (Binary.read_argument_z dec hdr))
294
-
| 1 -> Ok (Z.to_float (Z.neg (Z.succ (Binary.read_argument_z dec hdr))))
295
-
| _ -> stream_type_error path "float" hdr);
296
-
}
297
-
298
-
let string =
299
-
{
300
-
kind = "string";
301
-
encode = (fun s -> Value.Text s);
302
-
decode =
303
-
(fun path v ->
304
-
match v with Value.Text s -> Ok s | _ -> type_error path "text" v);
305
-
decode_rw =
306
-
(fun path dec ->
307
-
let hdr = Binary.read_header dec in
308
-
if hdr.major = Binary.major_text then Ok (read_text_with_hdr dec hdr)
309
-
else stream_type_error path "text" hdr);
310
-
}
311
-
312
-
let bytes =
313
-
{
314
-
kind = "bytes";
315
-
encode = (fun s -> Value.Bytes s);
316
-
decode =
317
-
(fun path v ->
318
-
match v with Value.Bytes s -> Ok s | _ -> type_error path "bytes" v);
319
-
decode_rw =
320
-
(fun path dec ->
321
-
let hdr = Binary.read_header dec in
322
-
if hdr.major = Binary.major_bytes then Ok (read_bytes_with_hdr dec hdr)
323
-
else stream_type_error path "bytes" hdr);
324
-
}
325
-
326
-
let any =
327
-
{
328
-
kind = "any";
329
-
encode = Fun.id;
330
-
decode = (fun _path v -> Ok v);
21
+
Codec.kind = "any";
22
+
encode_rw = (fun enc v -> Binary.write_cbor enc v);
331
23
decode_rw = (fun _path dec -> Ok (Binary.read_cbor dec));
332
24
}
333
25
334
-
(* Nullable *)
335
-
336
-
let nullable c =
337
-
{
338
-
kind = Fmt.str "nullable(%s)" c.kind;
339
-
encode =
340
-
(fun opt -> match opt with None -> Value.Null | Some x -> c.encode x);
341
-
decode =
342
-
(fun path v ->
343
-
match v with
344
-
| Value.Null -> Ok None
345
-
| _ -> Result.map Option.some (c.decode path v));
346
-
decode_rw =
347
-
(fun path dec ->
348
-
match Binary.peek_byte dec with
349
-
| Some b
350
-
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
351
-
->
352
-
ignore (Binary.read_byte dec);
353
-
Ok None
354
-
| _ -> Result.map Option.some (c.decode_rw path dec));
355
-
}
356
-
357
-
let option ~default c =
358
-
{
359
-
kind = Fmt.str "option(%s)" c.kind;
360
-
encode = c.encode;
361
-
decode =
362
-
(fun path v ->
363
-
match v with Value.Null -> Ok default | _ -> c.decode path v);
364
-
decode_rw =
365
-
(fun path dec ->
366
-
match Binary.peek_byte dec with
367
-
| Some b
368
-
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
369
-
->
370
-
ignore (Binary.read_byte dec);
371
-
Ok default
372
-
| _ -> c.decode_rw path dec);
373
-
}
374
-
375
-
(* Numeric variants *)
376
-
377
-
let uint =
378
-
{
379
-
kind = "uint";
380
-
encode = (fun n -> Value.Int (Z.of_int n));
381
-
decode =
382
-
(fun path v ->
383
-
match v with
384
-
| Value.Int n ->
385
-
if Z.sign n >= 0 && Z.fits_int n then Ok (Z.to_int n)
386
-
else
387
-
Error
388
-
(Error.v ~ctx:path
389
-
(Error.Out_of_range
390
-
{
391
-
value = Z.to_string n;
392
-
range = Fmt.str "[0, %d]" max_int;
393
-
}))
394
-
| _ -> type_error path "integer" v);
395
-
decode_rw =
396
-
(fun path dec ->
397
-
let hdr = Binary.read_header dec in
398
-
match hdr.major with
399
-
| 0 ->
400
-
let n = Binary.read_argument_z dec hdr in
401
-
if Z.fits_int n then Ok (Z.to_int n)
402
-
else
403
-
Error
404
-
(Error.v ~ctx:path
405
-
(Error.Out_of_range
406
-
{
407
-
value = Z.to_string n;
408
-
range = Fmt.str "[0, %d]" max_int;
409
-
}))
410
-
| 1 ->
411
-
let n = Z.neg (Z.succ (Binary.read_argument_z dec hdr)) in
412
-
Error
413
-
(Error.v ~ctx:path
414
-
(Error.Out_of_range
415
-
{ value = Z.to_string n; range = Fmt.str "[0, %d]" max_int }))
416
-
| _ -> stream_type_error path "integer" hdr);
417
-
}
418
-
419
-
let uint32 =
420
-
{
421
-
kind = "uint32";
422
-
encode = (fun n -> Value.Int (Z.of_int32 n));
423
-
decode =
424
-
(fun path v ->
425
-
match v with
426
-
| Value.Int n ->
427
-
if Z.sign n >= 0 && Z.leq n (Z.of_string "4294967295") then
428
-
Ok (Z.to_int32 n)
429
-
else
430
-
Error
431
-
(Error.v ~ctx:path
432
-
(Error.Out_of_range
433
-
{ value = Z.to_string n; range = "[0, 4294967295]" }))
434
-
| _ -> type_error path "integer" v);
435
-
decode_rw =
436
-
(fun path dec ->
437
-
let hdr = Binary.read_header dec in
438
-
match hdr.major with
439
-
| 0 | 1 ->
440
-
let n =
441
-
if hdr.major = 0 then Binary.read_argument_z dec hdr
442
-
else Z.neg (Z.succ (Binary.read_argument_z dec hdr))
443
-
in
444
-
if Z.sign n >= 0 && Z.leq n (Z.of_string "4294967295") then
445
-
Ok (Z.to_int32 n)
446
-
else
447
-
Error
448
-
(Error.v ~ctx:path
449
-
(Error.Out_of_range
450
-
{ value = Z.to_string n; range = "[0, 4294967295]" }))
451
-
| _ -> stream_type_error path "integer" hdr);
452
-
}
453
-
454
-
let uint64 =
455
-
{
456
-
kind = "uint64";
457
-
encode = (fun n -> Value.Int (Z.of_int64 n));
458
-
decode =
459
-
(fun path v ->
460
-
match v with
461
-
| Value.Int n ->
462
-
if Z.sign n >= 0 && Z.fits_int64 n then Ok (Z.to_int64 n)
463
-
else
464
-
Error
465
-
(Error.v ~ctx:path
466
-
(Error.Out_of_range
467
-
{ value = Z.to_string n; range = "[0, 2^63-1]" }))
468
-
| _ -> type_error path "integer" v);
469
-
decode_rw =
470
-
(fun path dec ->
471
-
let hdr = Binary.read_header dec in
472
-
match hdr.major with
473
-
| 0 | 1 ->
474
-
let n =
475
-
if hdr.major = 0 then Binary.read_argument_z dec hdr
476
-
else Z.neg (Z.succ (Binary.read_argument_z dec hdr))
477
-
in
478
-
if Z.sign n >= 0 && Z.fits_int64 n then Ok (Z.to_int64 n)
479
-
else
480
-
Error
481
-
(Error.v ~ctx:path
482
-
(Error.Out_of_range
483
-
{ value = Z.to_string n; range = "[0, 2^63-1]" }))
484
-
| _ -> stream_type_error path "integer" hdr);
485
-
}
486
-
487
-
let number = float
488
-
489
-
(* Arrays *)
490
-
491
-
(* Helper: read array length from stream, returning count or None for indefinite *)
492
-
let read_array_length_rw path dec =
493
-
let hdr = Binary.read_header dec in
494
-
if hdr.major <> Binary.major_array then
495
-
Error (stream_type_error path "array" hdr)
496
-
else
497
-
let arg = Binary.read_argument dec hdr in
498
-
if arg < 0L then Ok None else Ok (Some (Int64.to_int arg))
26
+
(* {1 Reading and writing CBOR (RFC 8949 §5)} *)
499
27
500
-
(* Helper: decode n elements from stream using element codec *)
501
-
let decode_array_elements_rw c path dec n =
502
-
let rec loop i acc =
503
-
if i >= n then Ok (List.rev acc)
504
-
else
505
-
let path' = Error.ctx_with_index i path in
506
-
match c.decode_rw path' dec with
507
-
| Ok v -> loop (i + 1) (v :: acc)
508
-
| Error e -> Error e
509
-
in
510
-
loop 0 []
511
-
512
-
(* Helper: decode indefinite-length array elements from stream *)
513
-
let decode_array_indef_rw c path dec =
514
-
let rec loop i acc =
515
-
if Binary.is_break dec then (
516
-
Binary.skip_break dec;
517
-
Ok (List.rev acc))
518
-
else
519
-
let path' = Error.ctx_with_index i path in
520
-
match c.decode_rw path' dec with
521
-
| Ok v -> loop (i + 1) (v :: acc)
522
-
| Error e -> Error e
523
-
in
524
-
loop 0 []
525
-
526
-
let array c =
527
-
{
528
-
kind = Fmt.str "array(%s)" c.kind;
529
-
encode = (fun items -> Value.Array (List.map c.encode items));
530
-
decode =
531
-
(fun path v ->
532
-
match v with
533
-
| Value.Array items ->
534
-
let rec loop i acc = function
535
-
| [] -> Ok (List.rev acc)
536
-
| x :: xs -> (
537
-
let path' = Error.ctx_with_index i path in
538
-
match c.decode path' x with
539
-
| Ok v -> loop (i + 1) (v :: acc) xs
540
-
| Error e -> Error e)
541
-
in
542
-
loop 0 [] items
543
-
| _ -> type_error path "array" v);
544
-
decode_rw =
545
-
(fun path dec ->
546
-
match read_array_length_rw path dec with
547
-
| Error e -> e
548
-
| Ok (Some n) -> decode_array_elements_rw c path dec n
549
-
| Ok None -> decode_array_indef_rw c path dec);
550
-
}
551
-
552
-
let array_of ~len c =
553
-
{
554
-
kind = Fmt.str "array_of(%d, %s)" len c.kind;
555
-
encode =
556
-
(fun items ->
557
-
if List.length items <> len then
558
-
Fmt.failwith "Expected array of length %d" len;
559
-
Value.Array (List.map c.encode items));
560
-
decode =
561
-
(fun path v ->
562
-
match v with
563
-
| Value.Array items when List.length items = len ->
564
-
let rec loop i acc = function
565
-
| [] -> Ok (List.rev acc)
566
-
| x :: xs -> (
567
-
let path' = Error.ctx_with_index i path in
568
-
match c.decode path' x with
569
-
| Ok v -> loop (i + 1) (v :: acc) xs
570
-
| Error e -> Error e)
571
-
in
572
-
loop 0 [] items
573
-
| Value.Array items ->
574
-
Error
575
-
(Error.v ~ctx:path
576
-
(Error.Invalid_value
577
-
(Fmt.str "expected array of length %d, got %d" len
578
-
(List.length items))))
579
-
| _ -> type_error path "array" v);
580
-
decode_rw =
581
-
(fun path dec ->
582
-
match read_array_length_rw path dec with
583
-
| Error e -> e
584
-
| Ok (Some n) when n = len -> decode_array_elements_rw c path dec n
585
-
| Ok (Some n) ->
586
-
(* Skip the remaining elements to leave the stream in a valid state *)
587
-
for _ = 1 to n do
588
-
Binary.skip dec
589
-
done;
590
-
Error
591
-
(Error.v ~ctx:path
592
-
(Error.Invalid_value
593
-
(Fmt.str "expected array of length %d, got %d" len n)))
594
-
| Ok None -> (
595
-
(* Indefinite array: read all elements to find the break *)
596
-
match decode_array_indef_rw c path dec with
597
-
| Ok items when List.length items = len -> Ok items
598
-
| Ok items ->
599
-
Error
600
-
(Error.v ~ctx:path
601
-
(Error.Invalid_value
602
-
(Fmt.str "expected array of length %d, got %d" len
603
-
(List.length items))))
604
-
| Error e -> Error e));
605
-
}
606
-
607
-
let tuple2 ca cb =
608
-
{
609
-
kind = Fmt.str "tuple2(%s, %s)" ca.kind cb.kind;
610
-
encode = (fun (a, b) -> Value.Array [ ca.encode a; cb.encode b ]);
611
-
decode =
612
-
(fun path v ->
613
-
match v with
614
-
| Value.Array [ va; vb ] -> (
615
-
match ca.decode (Error.ctx_with_index 0 path) va with
616
-
| Error e -> Error e
617
-
| Ok a -> (
618
-
match cb.decode (Error.ctx_with_index 1 path) vb with
619
-
| Error e -> Error e
620
-
| Ok b -> Ok (a, b)))
621
-
| Value.Array _ ->
622
-
Error
623
-
(Error.v ~ctx:path
624
-
(Error.Invalid_value "expected 2-element array"))
625
-
| _ -> type_error path "array" v);
626
-
decode_rw =
627
-
(fun path dec ->
628
-
match read_array_length_rw path dec with
629
-
| Error e -> e
630
-
| Ok (Some 2) -> (
631
-
match ca.decode_rw (Error.ctx_with_index 0 path) dec with
632
-
| Error e -> Error e
633
-
| Ok a -> (
634
-
match cb.decode_rw (Error.ctx_with_index 1 path) dec with
635
-
| Error e -> Error e
636
-
| Ok b -> Ok (a, b)))
637
-
| Ok (Some _n) ->
638
-
Error
639
-
(Error.v ~ctx:path
640
-
(Error.Invalid_value "expected 2-element array"))
641
-
| Ok None ->
642
-
Error
643
-
(Error.v ~ctx:path
644
-
(Error.Invalid_value "expected 2-element array")));
645
-
}
646
-
647
-
let tuple3 ca cb cc =
648
-
{
649
-
kind = Fmt.str "tuple3(%s, %s, %s)" ca.kind cb.kind cc.kind;
650
-
encode =
651
-
(fun (a, b, c) -> Value.Array [ ca.encode a; cb.encode b; cc.encode c ]);
652
-
decode =
653
-
(fun path v ->
654
-
match v with
655
-
| Value.Array [ va; vb; vc ] -> (
656
-
match ca.decode (Error.ctx_with_index 0 path) va with
657
-
| Error e -> Error e
658
-
| Ok a -> (
659
-
match cb.decode (Error.ctx_with_index 1 path) vb with
660
-
| Error e -> Error e
661
-
| Ok b -> (
662
-
match cc.decode (Error.ctx_with_index 2 path) vc with
663
-
| Error e -> Error e
664
-
| Ok c -> Ok (a, b, c))))
665
-
| Value.Array _ ->
666
-
Error
667
-
(Error.v ~ctx:path
668
-
(Error.Invalid_value "expected 3-element array"))
669
-
| _ -> type_error path "array" v);
670
-
decode_rw =
671
-
(fun path dec ->
672
-
match read_array_length_rw path dec with
673
-
| Error e -> e
674
-
| Ok (Some 3) -> (
675
-
match ca.decode_rw (Error.ctx_with_index 0 path) dec with
676
-
| Error e -> Error e
677
-
| Ok a -> (
678
-
match cb.decode_rw (Error.ctx_with_index 1 path) dec with
679
-
| Error e -> Error e
680
-
| Ok b -> (
681
-
match cc.decode_rw (Error.ctx_with_index 2 path) dec with
682
-
| Error e -> Error e
683
-
| Ok c -> Ok (a, b, c))))
684
-
| Ok (Some _n) ->
685
-
Error
686
-
(Error.v ~ctx:path
687
-
(Error.Invalid_value "expected 3-element array"))
688
-
| Ok None ->
689
-
Error
690
-
(Error.v ~ctx:path
691
-
(Error.Invalid_value "expected 3-element array")));
692
-
}
693
-
694
-
let tuple4 ca cb cc cd =
695
-
let bad_arity path =
696
-
Error (Error.v ~ctx:path (Error.Invalid_value "expected 4-element array"))
697
-
in
698
-
{
699
-
kind = Fmt.str "tuple4(%s, %s, %s, %s)" ca.kind cb.kind cc.kind cd.kind;
700
-
encode =
701
-
(fun (a, b, c, d) ->
702
-
Value.Array [ ca.encode a; cb.encode b; cc.encode c; cd.encode d ]);
703
-
decode =
704
-
(fun path v ->
705
-
match v with
706
-
| Value.Array [ va; vb; vc; vd ] -> (
707
-
match ca.decode (Error.ctx_with_index 0 path) va with
708
-
| Error e -> Error e
709
-
| Ok a -> (
710
-
match cb.decode (Error.ctx_with_index 1 path) vb with
711
-
| Error e -> Error e
712
-
| Ok b -> (
713
-
match cc.decode (Error.ctx_with_index 2 path) vc with
714
-
| Error e -> Error e
715
-
| Ok c -> (
716
-
match cd.decode (Error.ctx_with_index 3 path) vd with
717
-
| Error e -> Error e
718
-
| Ok d -> Ok (a, b, c, d)))))
719
-
| Value.Array _ -> bad_arity path
720
-
| _ -> type_error path "array" v);
721
-
decode_rw =
722
-
(fun path dec ->
723
-
match read_array_length_rw path dec with
724
-
| Error e -> e
725
-
| Ok (Some 4) -> (
726
-
match ca.decode_rw (Error.ctx_with_index 0 path) dec with
727
-
| Error e -> Error e
728
-
| Ok a -> (
729
-
match cb.decode_rw (Error.ctx_with_index 1 path) dec with
730
-
| Error e -> Error e
731
-
| Ok b -> (
732
-
match cc.decode_rw (Error.ctx_with_index 2 path) dec with
733
-
| Error e -> Error e
734
-
| Ok c -> (
735
-
match
736
-
cd.decode_rw (Error.ctx_with_index 3 path) dec
737
-
with
738
-
| Error e -> Error e
739
-
| Ok d -> Ok (a, b, c, d)))))
740
-
| Ok (Some _) | Ok None -> bad_arity path);
741
-
}
742
-
743
-
(* Maps *)
744
-
745
-
(* Helper: read map length from stream *)
746
-
let read_map_length_rw path dec =
747
-
let hdr = Binary.read_header dec in
748
-
if hdr.major <> Binary.major_map then Error (stream_type_error path "map" hdr)
749
-
else
750
-
let arg = Binary.read_argument dec hdr in
751
-
if arg < 0L then Ok None else Ok (Some (Int64.to_int arg))
752
-
753
-
let assoc kc vc =
754
-
{
755
-
kind = Fmt.str "assoc(%s, %s)" kc.kind vc.kind;
756
-
encode =
757
-
(fun pairs ->
758
-
Value.Map (List.map (fun (k, v) -> (kc.encode k, vc.encode v)) pairs));
759
-
decode =
760
-
(fun path v ->
761
-
match v with
762
-
| Value.Map pairs ->
763
-
let rec loop acc = function
764
-
| [] -> Ok (List.rev acc)
765
-
| (ck, cv) :: rest -> (
766
-
let path_k = Error.ctx_with_cbor_key ck path in
767
-
match kc.decode path_k ck with
768
-
| Error e -> Error e
769
-
| Ok k -> (
770
-
match vc.decode path_k cv with
771
-
| Error e -> Error e
772
-
| Ok v -> loop ((k, v) :: acc) rest))
773
-
in
774
-
loop [] pairs
775
-
| _ -> type_error path "map" v);
776
-
decode_rw =
777
-
(fun path dec ->
778
-
match read_map_length_rw path dec with
779
-
| Error e -> e
780
-
| Ok len_opt ->
781
-
let n = match len_opt with Some n -> n | None -> max_int in
782
-
let rec loop i acc =
783
-
if i >= n then Ok (List.rev acc)
784
-
else if len_opt = None && Binary.is_break dec then (
785
-
Binary.skip_break dec;
786
-
Ok (List.rev acc))
787
-
else
788
-
match kc.decode_rw path dec with
789
-
| Error e -> Error e
790
-
| Ok k -> (
791
-
match vc.decode_rw path dec with
792
-
| Error e -> Error e
793
-
| Ok v -> loop (i + 1) ((k, v) :: acc))
794
-
in
795
-
loop 0 []);
796
-
}
797
-
798
-
let string_map vc = assoc string vc
799
-
let int_map vc = assoc int vc
800
-
801
-
(* Object codec module.
802
-
803
-
Records are described as a curried constructor [map ctor] threaded through a
804
-
sequence of [mem] / [mem_opt] / [mem_default] applications and closed by
805
-
[seal] — the same applicative pipeline shape used by [Json.Codec.Object].
806
-
Each [mem] reifies a field as an [_ field] record carrying its name plus a
807
-
typed encode/decode pair, and applies one argument of the curried [ctor].
808
-
Assembly of the final record happens after decoding through a per-instance
809
-
lookup, so the codec never has to walk the structure with a fake value
810
-
(which is what the previous monadic GADT did via [Obj.magic ()]). *)
811
-
812
-
module Obj = struct
813
-
type 'o field = {
814
-
name : string;
815
-
encode : 'o -> Value.t option;
816
-
(** [None] means the field is omitted from the encoded map. *)
817
-
decode_value :
818
-
Loc.Context.t -> Value.t option -> (Stdlib.Obj.t, Error.t) result;
819
-
(** [decode_value ctx v] takes the value found for this field ([None]
820
-
when the field was absent in the input map). The result is
821
-
type-erased into [Stdlib.Obj.t] for storage in the per-decode value
822
-
table; the matching {!field_lookup} reverses the erasure via the
823
-
field's known static type. *)
824
-
decode_rw :
825
-
Loc.Context.t -> Binary.decoder -> (Stdlib.Obj.t, Error.t) result;
826
-
(** Streaming decode entry point. The peek-and-skip-on-null behaviour of
827
-
{!mem_opt} / {!mem_default} lives here. *)
828
-
decode_missing : (Stdlib.Obj.t, string) result;
829
-
(** Default value used when the field is absent in the streaming decode
830
-
path. [Error name] is returned for required fields. *)
831
-
}
832
-
833
-
type ('o, 'dec) mem = {
834
-
fields : 'o field list;
835
-
build : (string -> Stdlib.Obj.t) -> 'dec;
836
-
(** Always called with a [lookup] that maps every field's name to a real
837
-
decoded value (already type-erased into [Stdlib.Obj.t]). The static
838
-
type of each lookup result is fixed by the field that produced it,
839
-
so [Stdlib.Obj.obj] in the field-specific reader is the same kind of
840
-
contract that drives [Hmap]. *)
841
-
}
842
-
843
-
let map ctor = { fields = []; build = (fun _ -> ctor) }
844
-
845
-
let mem (type o a b) name (get : o -> a) (codec : a t) (m : (o, a -> b) mem) :
846
-
(o, b) mem =
847
-
let encode o = Some (codec.encode (get o)) in
848
-
let decode_value ctx v =
849
-
let path' = Error.ctx_with_key name ctx in
850
-
match v with
851
-
| None -> Error (Error.v ~ctx:path' (Error.Missing_member name))
852
-
| Some v -> (
853
-
match codec.decode path' v with
854
-
| Ok x -> Ok (Stdlib.Obj.repr x)
855
-
| Error e -> Error e)
856
-
in
857
-
let decode_rw ctx dec =
858
-
let path' = Error.ctx_with_key name ctx in
859
-
match codec.decode_rw path' dec with
860
-
| Ok x -> Ok (Stdlib.Obj.repr x)
861
-
| Error e -> Error e
862
-
in
863
-
let field =
864
-
{ name; encode; decode_value; decode_rw; decode_missing = Error name }
865
-
in
866
-
{
867
-
fields = m.fields @ [ field ];
868
-
build =
869
-
(fun lookup ->
870
-
let f = m.build lookup in
871
-
let v : a = Stdlib.Obj.obj (lookup name) in
872
-
f v);
873
-
}
874
-
875
-
let mem_opt (type o a b) name (get : o -> a option) (codec : a t)
876
-
(m : (o, a option -> b) mem) : (o, b) mem =
877
-
let none_obj : Stdlib.Obj.t = Stdlib.Obj.repr (None : a option) in
878
-
let encode o =
879
-
match get o with None -> None | Some x -> Some (codec.encode x)
880
-
in
881
-
let decode_value ctx v =
882
-
match v with
883
-
| None | Some Value.Null -> Ok none_obj
884
-
| Some v -> (
885
-
let path' = Error.ctx_with_key name ctx in
886
-
match codec.decode path' v with
887
-
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
888
-
| Error e -> Error e)
889
-
in
890
-
let decode_rw ctx dec =
891
-
match Binary.peek_byte dec with
892
-
| Some b
893
-
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
894
-
->
895
-
ignore (Binary.read_byte dec);
896
-
Ok none_obj
897
-
| _ -> (
898
-
let path' = Error.ctx_with_key name ctx in
899
-
match codec.decode_rw path' dec with
900
-
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
901
-
| Error e -> Error e)
902
-
in
903
-
let field =
904
-
{ name; encode; decode_value; decode_rw; decode_missing = Ok none_obj }
905
-
in
906
-
{
907
-
fields = m.fields @ [ field ];
908
-
build =
909
-
(fun lookup ->
910
-
let f = m.build lookup in
911
-
let v : a option = Stdlib.Obj.obj (lookup name) in
912
-
f v);
913
-
}
914
-
915
-
let mem_default (type o a b) name (get : o -> a) ~(default : a) (codec : a t)
916
-
(m : (o, a -> b) mem) : (o, b) mem =
917
-
let default_obj : Stdlib.Obj.t = Stdlib.Obj.repr default in
918
-
let encode o = Some (codec.encode (get o)) in
919
-
let decode_value ctx v =
920
-
match v with
921
-
| None | Some Value.Null -> Ok default_obj
922
-
| Some v -> (
923
-
let path' = Error.ctx_with_key name ctx in
924
-
match codec.decode path' v with
925
-
| Ok x -> Ok (Stdlib.Obj.repr x)
926
-
| Error e -> Error e)
927
-
in
928
-
let decode_rw ctx dec =
929
-
match Binary.peek_byte dec with
930
-
| Some b
931
-
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
932
-
->
933
-
ignore (Binary.read_byte dec);
934
-
Ok default_obj
935
-
| _ -> (
936
-
let path' = Error.ctx_with_key name ctx in
937
-
match codec.decode_rw path' dec with
938
-
| Ok x -> Ok (Stdlib.Obj.repr x)
939
-
| Error e -> Error e)
940
-
in
941
-
let field =
942
-
{ name; encode; decode_value; decode_rw; decode_missing = Ok default_obj }
943
-
in
944
-
{
945
-
fields = m.fields @ [ field ];
946
-
build =
947
-
(fun lookup ->
948
-
let f = m.build lookup in
949
-
let v : a = Stdlib.Obj.obj (lookup name) in
950
-
f v);
951
-
}
952
-
953
-
let seal (type o) (m : (o, o) mem) : o t =
954
-
let names = List.map (fun (f : o field) -> f.name) m.fields in
955
-
let kind = Fmt.str "obj({%s})" (String.concat ", " names) in
956
-
let by_name : (string, o field) Hashtbl.t =
957
-
Hashtbl.create (List.length m.fields)
958
-
in
959
-
List.iter (fun (f : o field) -> Hashtbl.replace by_name f.name f) m.fields;
960
-
let lookup_or_fail path tbl =
961
-
let lookup name =
962
-
match Hashtbl.find_opt tbl name with
963
-
| Some v -> v
964
-
| None ->
965
-
(* Decoding never reaches assembly without populating every field
966
-
(or its default), so this only fires on a programmer bug in
967
-
the codec itself. *)
968
-
Stdlib.invalid_arg
969
-
(Fmt.str "Cbor.Obj.seal: missing %s for %a" name Loc.Context.pp
970
-
path)
971
-
in
972
-
lookup
973
-
in
974
-
let decode_value path values =
975
-
let pairs =
976
-
List.filter_map
977
-
(fun (k, v) -> match k with Value.Text s -> Some (s, v) | _ -> None)
978
-
values
979
-
in
980
-
let pairs_tbl = Hashtbl.create (List.length pairs) in
981
-
List.iter (fun (k, v) -> Hashtbl.replace pairs_tbl k v) pairs;
982
-
let results = Hashtbl.create (List.length m.fields) in
983
-
let rec fill = function
984
-
| [] -> Ok ()
985
-
| (f : o field) :: rest -> (
986
-
let v_opt = Hashtbl.find_opt pairs_tbl f.name in
987
-
match f.decode_value path v_opt with
988
-
| Error e -> Error e
989
-
| Ok obj ->
990
-
Hashtbl.replace results f.name obj;
991
-
fill rest)
992
-
in
993
-
match fill m.fields with
994
-
| Error e -> Error e
995
-
| Ok () -> Ok (m.build (lookup_or_fail path results))
996
-
in
997
-
let decode_rw path dec =
998
-
match read_map_length_rw path dec with
999
-
| Error e -> e
1000
-
| Ok len_opt -> (
1001
-
let results = Hashtbl.create (List.length m.fields) in
1002
-
let n = match len_opt with Some n -> n | None -> max_int in
1003
-
let rec read i =
1004
-
if i >= n then Ok ()
1005
-
else if len_opt = None && Binary.is_break dec then (
1006
-
Binary.skip_break dec;
1007
-
Ok ())
1008
-
else
1009
-
match Binary.peek_byte dec with
1010
-
| Some b when b lsr 5 = Binary.major_text -> (
1011
-
let key = Binary.read_text dec in
1012
-
match Hashtbl.find_opt by_name key with
1013
-
| Some f -> (
1014
-
match f.decode_rw path dec with
1015
-
| Error e -> Error e
1016
-
| Ok obj ->
1017
-
Hashtbl.replace results key obj;
1018
-
read (i + 1))
1019
-
| None ->
1020
-
Binary.skip dec;
1021
-
read (i + 1))
1022
-
| _ ->
1023
-
Binary.skip dec;
1024
-
Binary.skip dec;
1025
-
read (i + 1)
1026
-
in
1027
-
match read 0 with
1028
-
| Error e -> Error e
1029
-
| Ok () -> (
1030
-
(* Fill in defaults / report missing required fields. *)
1031
-
let missing =
1032
-
List.find_map
1033
-
(fun (f : o field) ->
1034
-
if Hashtbl.mem results f.name then None
1035
-
else
1036
-
match f.decode_missing with
1037
-
| Ok obj ->
1038
-
Hashtbl.replace results f.name obj;
1039
-
None
1040
-
| Error name -> Some name)
1041
-
m.fields
1042
-
in
1043
-
match missing with
1044
-
| Some name ->
1045
-
Error (Error.v ~ctx:path (Error.Missing_member name))
1046
-
| None -> Ok (m.build (lookup_or_fail path results))))
1047
-
in
1048
-
{
1049
-
kind;
1050
-
encode =
1051
-
(fun v ->
1052
-
let pairs =
1053
-
List.filter_map
1054
-
(fun (f : o field) ->
1055
-
match f.encode v with
1056
-
| None -> None
1057
-
| Some value -> Some (Value.Text f.name, value))
1058
-
m.fields
1059
-
in
1060
-
Value.Map pairs);
1061
-
decode =
1062
-
(fun path v ->
1063
-
match v with
1064
-
| Value.Map pairs -> decode_value path pairs
1065
-
| _ -> type_error path "map" v);
1066
-
decode_rw;
1067
-
}
1068
-
end
1069
-
1070
-
(* Integer-keyed object codec module *)
1071
-
1072
-
(* Integer-keyed object codec module. Mirrors {!Obj} but indexes fields by
1073
-
integer keys instead of text strings (the COSE/CWT layout). Same
1074
-
applicative shape; same Obj.magic-free assembly. *)
1075
-
1076
-
module Obj_int = struct
1077
-
type 'o field = {
1078
-
key : int;
1079
-
encode : 'o -> Value.t option;
1080
-
decode_value :
1081
-
Loc.Context.t -> Value.t option -> (Stdlib.Obj.t, Error.t) result;
1082
-
decode_rw :
1083
-
Loc.Context.t -> Binary.decoder -> (Stdlib.Obj.t, Error.t) result;
1084
-
decode_missing : (Stdlib.Obj.t, int) result;
1085
-
}
1086
-
1087
-
type ('o, 'dec) mem = {
1088
-
fields : 'o field list;
1089
-
build : (int -> Stdlib.Obj.t) -> 'dec;
1090
-
}
1091
-
1092
-
let map ctor = { fields = []; build = (fun _ -> ctor) }
1093
-
1094
-
let mem (type o a b) key (get : o -> a) (codec : a t) (m : (o, a -> b) mem) :
1095
-
(o, b) mem =
1096
-
let key_str = string_of_int key in
1097
-
let encode o = Some (codec.encode (get o)) in
1098
-
let decode_value ctx v =
1099
-
let path' = Error.ctx_with_key key_str ctx in
1100
-
match v with
1101
-
| None -> Error (Error.v ~ctx:path' (Error.Missing_member key_str))
1102
-
| Some v -> (
1103
-
match codec.decode path' v with
1104
-
| Ok x -> Ok (Stdlib.Obj.repr x)
1105
-
| Error e -> Error e)
1106
-
in
1107
-
let decode_rw ctx dec =
1108
-
let path' = Error.ctx_with_key key_str ctx in
1109
-
match codec.decode_rw path' dec with
1110
-
| Ok x -> Ok (Stdlib.Obj.repr x)
1111
-
| Error e -> Error e
1112
-
in
1113
-
let field =
1114
-
{ key; encode; decode_value; decode_rw; decode_missing = Error key }
1115
-
in
1116
-
{
1117
-
fields = m.fields @ [ field ];
1118
-
build =
1119
-
(fun lookup ->
1120
-
let f = m.build lookup in
1121
-
let v : a = Stdlib.Obj.obj (lookup key) in
1122
-
f v);
1123
-
}
1124
-
1125
-
let mem_opt (type o a b) key (get : o -> a option) (codec : a t)
1126
-
(m : (o, a option -> b) mem) : (o, b) mem =
1127
-
let key_str = string_of_int key in
1128
-
let none_obj : Stdlib.Obj.t = Stdlib.Obj.repr (None : a option) in
1129
-
let encode o =
1130
-
match get o with None -> None | Some x -> Some (codec.encode x)
1131
-
in
1132
-
let decode_value ctx v =
1133
-
match v with
1134
-
| None | Some Value.Null -> Ok none_obj
1135
-
| Some v -> (
1136
-
let path' = Error.ctx_with_key key_str ctx in
1137
-
match codec.decode path' v with
1138
-
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
1139
-
| Error e -> Error e)
1140
-
in
1141
-
let decode_rw ctx dec =
1142
-
match Binary.peek_byte dec with
1143
-
| Some b
1144
-
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
1145
-
->
1146
-
ignore (Binary.read_byte dec);
1147
-
Ok none_obj
1148
-
| _ -> (
1149
-
let path' = Error.ctx_with_key key_str ctx in
1150
-
match codec.decode_rw path' dec with
1151
-
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
1152
-
| Error e -> Error e)
1153
-
in
1154
-
let field =
1155
-
{ key; encode; decode_value; decode_rw; decode_missing = Ok none_obj }
1156
-
in
1157
-
{
1158
-
fields = m.fields @ [ field ];
1159
-
build =
1160
-
(fun lookup ->
1161
-
let f = m.build lookup in
1162
-
let v : a option = Stdlib.Obj.obj (lookup key) in
1163
-
f v);
1164
-
}
1165
-
1166
-
let mem_default (type o a b) key (get : o -> a) ~(default : a) (codec : a t)
1167
-
(m : (o, a -> b) mem) : (o, b) mem =
1168
-
let key_str = string_of_int key in
1169
-
let default_obj : Stdlib.Obj.t = Stdlib.Obj.repr default in
1170
-
let encode o = Some (codec.encode (get o)) in
1171
-
let decode_value ctx v =
1172
-
match v with
1173
-
| None | Some Value.Null -> Ok default_obj
1174
-
| Some v -> (
1175
-
let path' = Error.ctx_with_key key_str ctx in
1176
-
match codec.decode path' v with
1177
-
| Ok x -> Ok (Stdlib.Obj.repr x)
1178
-
| Error e -> Error e)
1179
-
in
1180
-
let decode_rw ctx dec =
1181
-
match Binary.peek_byte dec with
1182
-
| Some b
1183
-
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
1184
-
->
1185
-
ignore (Binary.read_byte dec);
1186
-
Ok default_obj
1187
-
| _ -> (
1188
-
let path' = Error.ctx_with_key key_str ctx in
1189
-
match codec.decode_rw path' dec with
1190
-
| Ok x -> Ok (Stdlib.Obj.repr x)
1191
-
| Error e -> Error e)
1192
-
in
1193
-
let field =
1194
-
{ key; encode; decode_value; decode_rw; decode_missing = Ok default_obj }
1195
-
in
1196
-
{
1197
-
fields = m.fields @ [ field ];
1198
-
build =
1199
-
(fun lookup ->
1200
-
let f = m.build lookup in
1201
-
let v : a = Stdlib.Obj.obj (lookup key) in
1202
-
f v);
1203
-
}
1204
-
1205
-
let read_int_key dec =
1206
-
let key_hdr = Binary.read_header dec in
1207
-
if key_hdr.major = 0 || key_hdr.major = 1 then
1208
-
let kz =
1209
-
if key_hdr.major = 0 then Binary.read_argument_z dec key_hdr
1210
-
else Z.neg (Z.succ (Binary.read_argument_z dec key_hdr))
1211
-
in
1212
-
if Z.fits_int kz then Some (Z.to_int kz) else None
1213
-
else None
1214
-
1215
-
let seal (type o) (m : (o, o) mem) : o t =
1216
-
let keys = List.map (fun (f : o field) -> f.key) m.fields in
1217
-
let kind =
1218
-
Fmt.str "obj_int({%s})" (String.concat ", " (List.map string_of_int keys))
1219
-
in
1220
-
let by_key : (int, o field) Hashtbl.t =
1221
-
Hashtbl.create (List.length m.fields)
1222
-
in
1223
-
List.iter (fun (f : o field) -> Hashtbl.replace by_key f.key f) m.fields;
1224
-
let lookup_or_fail path tbl =
1225
-
let lookup key =
1226
-
match Hashtbl.find_opt tbl key with
1227
-
| Some v -> v
1228
-
| None ->
1229
-
Stdlib.invalid_arg
1230
-
(Fmt.str "Cbor.Obj_int.seal: missing %d for %a" key Loc.Context.pp
1231
-
path)
1232
-
in
1233
-
lookup
1234
-
in
1235
-
let decode_value path values =
1236
-
let pairs =
1237
-
List.filter_map
1238
-
(fun (k, v) ->
1239
-
match k with
1240
-
| Value.Int n when Z.fits_int n -> Some (Z.to_int n, v)
1241
-
| _ -> None)
1242
-
values
1243
-
in
1244
-
let pairs_tbl = Hashtbl.create (List.length pairs) in
1245
-
List.iter (fun (k, v) -> Hashtbl.replace pairs_tbl k v) pairs;
1246
-
let results = Hashtbl.create (List.length m.fields) in
1247
-
let rec fill = function
1248
-
| [] -> Ok ()
1249
-
| (f : o field) :: rest -> (
1250
-
let v_opt = Hashtbl.find_opt pairs_tbl f.key in
1251
-
match f.decode_value path v_opt with
1252
-
| Error e -> Error e
1253
-
| Ok obj ->
1254
-
Hashtbl.replace results f.key obj;
1255
-
fill rest)
1256
-
in
1257
-
match fill m.fields with
1258
-
| Error e -> Error e
1259
-
| Ok () -> Ok (m.build (lookup_or_fail path results))
1260
-
in
1261
-
let decode_rw path dec =
1262
-
match read_map_length_rw path dec with
1263
-
| Error e -> e
1264
-
| Ok len_opt -> (
1265
-
let results = Hashtbl.create (List.length m.fields) in
1266
-
let n = match len_opt with Some n -> n | None -> max_int in
1267
-
let rec read i =
1268
-
if i >= n then Ok ()
1269
-
else if len_opt = None && Binary.is_break dec then (
1270
-
Binary.skip_break dec;
1271
-
Ok ())
1272
-
else
1273
-
match Binary.peek_byte dec with
1274
-
| Some b
1275
-
when b lsr 5 = Binary.major_uint || b lsr 5 = Binary.major_nint
1276
-
-> (
1277
-
match read_int_key dec with
1278
-
| Some key -> (
1279
-
match Hashtbl.find_opt by_key key with
1280
-
| Some f -> (
1281
-
match f.decode_rw path dec with
1282
-
| Error e -> Error e
1283
-
| Ok obj ->
1284
-
Hashtbl.replace results key obj;
1285
-
read (i + 1))
1286
-
| None ->
1287
-
Binary.skip dec;
1288
-
read (i + 1))
1289
-
| None ->
1290
-
Binary.skip dec;
1291
-
read (i + 1))
1292
-
| _ ->
1293
-
Binary.skip dec;
1294
-
Binary.skip dec;
1295
-
read (i + 1)
1296
-
in
1297
-
match read 0 with
1298
-
| Error e -> Error e
1299
-
| Ok () -> (
1300
-
let missing =
1301
-
List.find_map
1302
-
(fun (f : o field) ->
1303
-
if Hashtbl.mem results f.key then None
1304
-
else
1305
-
match f.decode_missing with
1306
-
| Ok obj ->
1307
-
Hashtbl.replace results f.key obj;
1308
-
None
1309
-
| Error key -> Some key)
1310
-
m.fields
1311
-
in
1312
-
match missing with
1313
-
| Some key ->
1314
-
Error
1315
-
(Error.v ~ctx:path
1316
-
(Error.Missing_member (string_of_int key)))
1317
-
| None -> Ok (m.build (lookup_or_fail path results))))
1318
-
in
1319
-
{
1320
-
kind;
1321
-
encode =
1322
-
(fun v ->
1323
-
let pairs =
1324
-
List.filter_map
1325
-
(fun (f : o field) ->
1326
-
match f.encode v with
1327
-
| None -> None
1328
-
| Some value -> Some (Value.Int (Z.of_int f.key), value))
1329
-
m.fields
1330
-
in
1331
-
Value.Map pairs);
1332
-
decode =
1333
-
(fun path v ->
1334
-
match v with
1335
-
| Value.Map pairs -> decode_value path pairs
1336
-
| _ -> type_error path "map" v);
1337
-
decode_rw;
1338
-
}
1339
-
end
1340
-
1341
-
(* Tags *)
1342
-
1343
-
let tag n c =
1344
-
{
1345
-
kind = Fmt.str "tag(%d, %s)" n c.kind;
1346
-
encode = (fun v -> Value.Tag (n, c.encode v));
1347
-
decode =
1348
-
(fun path v ->
1349
-
match v with
1350
-
| Value.Tag (m, content) when m = n ->
1351
-
c.decode (Error.ctx_with_tag n path) content
1352
-
| Value.Tag (m, _) ->
1353
-
Error
1354
-
(Error.v ~ctx:path
1355
-
(Error.Invalid_value
1356
-
(Fmt.str "expected tag %d, got tag %d" n m)))
1357
-
| _ -> type_error path (Fmt.str "tag(%d)" n) v);
1358
-
decode_rw =
1359
-
(fun path dec ->
1360
-
let hdr = Binary.read_header dec in
1361
-
if hdr.major = Binary.major_tag then
1362
-
let m = Int64.to_int (Binary.read_argument dec hdr) in
1363
-
if m = n then c.decode_rw (Error.ctx_with_tag n path) dec
1364
-
else
1365
-
Error
1366
-
(Error.v ~ctx:path
1367
-
(Error.Invalid_value
1368
-
(Fmt.str "expected tag %d, got tag %d" n m)))
1369
-
else stream_type_error path (Fmt.str "tag(%d)" n) hdr);
1370
-
}
1371
-
1372
-
let tag_opt n c =
1373
-
{
1374
-
kind = Fmt.str "tag_opt(%d, %s)" n c.kind;
1375
-
encode = (fun v -> Value.Tag (n, c.encode v));
1376
-
decode =
1377
-
(fun path v ->
1378
-
match v with
1379
-
| Value.Tag (m, content) when m = n ->
1380
-
c.decode (Error.ctx_with_tag n path) content
1381
-
| _ -> c.decode path v);
1382
-
decode_rw =
1383
-
(fun path dec ->
1384
-
match Binary.peek_byte dec with
1385
-
| Some b when b lsr 5 = Binary.major_tag ->
1386
-
let hdr = Binary.read_header dec in
1387
-
let m = Int64.to_int (Binary.read_argument dec hdr) in
1388
-
if m = n then c.decode_rw (Error.ctx_with_tag n path) dec
1389
-
else
1390
-
(* Not our tag; read the content as Value.t and use the Value.t
1391
-
decoder with the tag wrapper *)
1392
-
let content = Binary.read_cbor dec in
1393
-
c.decode path (Value.Tag (m, content))
1394
-
| _ -> c.decode_rw path dec);
1395
-
}
1396
-
1397
-
(* Transformations *)
1398
-
1399
-
let map decode_f encode_f c =
1400
-
{
1401
-
kind = Fmt.str "map(%s)" c.kind;
1402
-
encode = (fun v -> c.encode (encode_f v));
1403
-
decode =
1404
-
(fun path v ->
1405
-
match c.decode path v with
1406
-
| Error e -> Error e
1407
-
| Ok x -> Ok (decode_f x));
1408
-
decode_rw =
1409
-
(fun path dec ->
1410
-
match c.decode_rw path dec with
1411
-
| Error e -> Error e
1412
-
| Ok x -> Ok (decode_f x));
1413
-
}
1414
-
1415
-
let conv decode_f encode_f c =
1416
-
{
1417
-
kind = Fmt.str "conv(%s)" c.kind;
1418
-
encode = (fun v -> c.encode (encode_f v));
1419
-
decode =
1420
-
(fun path v ->
1421
-
match c.decode path v with
1422
-
| Error e -> Error e
1423
-
| Ok x -> (
1424
-
match decode_f x with
1425
-
| Ok y -> Ok y
1426
-
| Error msg -> Error (Error.v ~ctx:path (Error.Custom msg))));
1427
-
decode_rw =
1428
-
(fun path dec ->
1429
-
match c.decode_rw path dec with
1430
-
| Error e -> Error e
1431
-
| Ok x -> (
1432
-
match decode_f x with
1433
-
| Ok y -> Ok y
1434
-
| Error msg -> Error (Error.v ~ctx:path (Error.Custom msg))));
1435
-
}
1436
-
1437
-
let const v c =
1438
-
{
1439
-
kind = Fmt.str "const(%s)" c.kind;
1440
-
encode = (fun _ -> c.encode ());
1441
-
decode =
1442
-
(fun path cbor ->
1443
-
match c.decode path cbor with Error e -> Error e | Ok () -> Ok v);
1444
-
decode_rw =
1445
-
(fun path dec ->
1446
-
match c.decode_rw path dec with Error e -> Error e | Ok () -> Ok v);
1447
-
}
1448
-
1449
-
(* Variants *)
1450
-
1451
-
module Variant = struct
1452
-
type 'a case =
1453
-
| Case : int * 'b t * ('b -> 'a) * ('a -> 'b option) -> 'a case
1454
-
| Case0 : int * 'a * ('a -> bool) -> 'a case
1455
-
1456
-
let case tag c inject project = Case (tag, c, inject, project)
1457
-
let case0 tag v is_v = Case0 (tag, v, is_v)
1458
-
1459
-
let variant cases =
1460
-
{
1461
-
kind = "variant";
1462
-
encode =
1463
-
(fun v ->
1464
-
let rec find = function
1465
-
| [] -> failwith "No matching variant case for encoding"
1466
-
| Case (tag, c, _, project) :: rest -> (
1467
-
match project v with
1468
-
| Some x -> Value.Tag (tag, c.encode x)
1469
-
| None -> find rest)
1470
-
| Case0 (tag, _, is_v) :: rest ->
1471
-
if is_v v then Value.Tag (tag, Value.Null) else find rest
1472
-
in
1473
-
find cases);
1474
-
decode =
1475
-
(fun path v ->
1476
-
match v with
1477
-
| Value.Tag (tag, content) ->
1478
-
let rec try_cases = function
1479
-
| [] ->
1480
-
Error
1481
-
(Error.v ~ctx:path
1482
-
(Error.Invalid_value
1483
-
(Fmt.str "unknown tag %d in variant" tag)))
1484
-
| Case (t, c, inject, _) :: _rest when t = tag -> (
1485
-
match c.decode (Error.ctx_with_tag t path) content with
1486
-
| Error e -> Error e
1487
-
| Ok x -> Ok (inject x))
1488
-
| Case0 (t, v, _) :: _ when t = tag -> Ok v
1489
-
| _ :: rest -> try_cases rest
1490
-
in
1491
-
try_cases cases
1492
-
| _ -> type_error path "tag" v);
1493
-
decode_rw =
1494
-
(fun path dec ->
1495
-
let hdr = Binary.read_header dec in
1496
-
if hdr.major <> Binary.major_tag then stream_type_error path "tag" hdr
1497
-
else
1498
-
let tag = Int64.to_int (Binary.read_argument dec hdr) in
1499
-
let rec try_cases = function
1500
-
| [] ->
1501
-
Binary.skip dec;
1502
-
Error
1503
-
(Error.v ~ctx:path
1504
-
(Error.Invalid_value
1505
-
(Fmt.str "unknown tag %d in variant" tag)))
1506
-
| Case (t, c, inject, _) :: _rest when t = tag -> (
1507
-
match c.decode_rw (Error.ctx_with_tag t path) dec with
1508
-
| Error e -> Error e
1509
-
| Ok x -> Ok (inject x))
1510
-
| Case0 (t, v, _) :: _ when t = tag ->
1511
-
Binary.skip dec;
1512
-
Ok v
1513
-
| _ :: rest -> try_cases rest
1514
-
in
1515
-
try_cases cases);
1516
-
}
1517
-
end
1518
-
1519
-
module Variant_key = struct
1520
-
type 'a case =
1521
-
| Case : string * 'b t * ('b -> 'a) * ('a -> 'b option) -> 'a case
1522
-
| Case0 : string * 'a * ('a -> bool) -> 'a case
1523
-
1524
-
let case key c inject project = Case (key, c, inject, project)
1525
-
let case0 key v is_v = Case0 (key, v, is_v)
1526
-
1527
-
let variant cases =
1528
-
{
1529
-
kind = "variant_key";
1530
-
encode =
1531
-
(fun v ->
1532
-
let rec find = function
1533
-
| [] -> failwith "No matching variant case for encoding"
1534
-
| Case (key, c, _, project) :: rest -> (
1535
-
match project v with
1536
-
| Some x -> Value.Map [ (Value.Text key, c.encode x) ]
1537
-
| None -> find rest)
1538
-
| Case0 (key, _, is_v) :: rest ->
1539
-
if is_v v then Value.Map [ (Value.Text key, Value.Null) ]
1540
-
else find rest
1541
-
in
1542
-
find cases);
1543
-
decode =
1544
-
(fun path v ->
1545
-
match v with
1546
-
| Value.Map [ (Value.Text key, content) ] ->
1547
-
let rec try_cases = function
1548
-
| [] ->
1549
-
Error
1550
-
(Error.v ~ctx:path
1551
-
(Error.Invalid_value
1552
-
(Fmt.str "unknown key %S in variant" key)))
1553
-
| Case (k, c, inject, _) :: _rest when k = key -> (
1554
-
match c.decode (Error.ctx_with_key k path) content with
1555
-
| Error e -> Error e
1556
-
| Ok x -> Ok (inject x))
1557
-
| Case0 (k, v, _) :: _ when k = key -> Ok v
1558
-
| _ :: rest -> try_cases rest
1559
-
in
1560
-
try_cases cases
1561
-
| Value.Map _ ->
1562
-
Error
1563
-
(Error.v ~ctx:path
1564
-
(Error.Invalid_value "variant map must have exactly one key"))
1565
-
| _ -> type_error path "map" v);
1566
-
decode_rw =
1567
-
(fun path dec ->
1568
-
match read_map_length_rw path dec with
1569
-
| Error e -> e
1570
-
| Ok (Some 1) -> (
1571
-
(* Peek at key type without consuming *)
1572
-
match Binary.peek_byte dec with
1573
-
| Some b when b lsr 5 <> Binary.major_text ->
1574
-
(* Non-text key: skip key and value *)
1575
-
Binary.skip dec;
1576
-
Binary.skip dec;
1577
-
Error
1578
-
(Error.v ~ctx:path
1579
-
(Error.Invalid_value "variant map key must be text"))
1580
-
| _ ->
1581
-
let key = Binary.read_text dec in
1582
-
let rec try_cases = function
1583
-
| [] ->
1584
-
Binary.skip dec;
1585
-
Error
1586
-
(Error.v ~ctx:path
1587
-
(Error.Invalid_value
1588
-
(Fmt.str "unknown key %S in variant" key)))
1589
-
| Case (k, c, inject, _) :: _rest when k = key -> (
1590
-
match c.decode_rw (Error.ctx_with_key k path) dec with
1591
-
| Error e -> Error e
1592
-
| Ok x -> Ok (inject x))
1593
-
| Case0 (k, v, _) :: _ when k = key ->
1594
-
Binary.skip dec;
1595
-
Ok v
1596
-
| _ :: rest -> try_cases rest
1597
-
in
1598
-
try_cases cases)
1599
-
| Ok (Some n) ->
1600
-
(* Skip all map entries *)
1601
-
for _ = 1 to n do
1602
-
Binary.skip dec;
1603
-
Binary.skip dec
1604
-
done;
1605
-
Error
1606
-
(Error.v ~ctx:path
1607
-
(Error.Invalid_value "variant map must have exactly one key"))
1608
-
| Ok None -> (
1609
-
if
1610
-
(* Indefinite map: must have exactly one entry *)
1611
-
Binary.is_break dec
1612
-
then (
1613
-
Binary.skip_break dec;
1614
-
Error
1615
-
(Error.v ~ctx:path
1616
-
(Error.Invalid_value
1617
-
"variant map must have exactly one key")))
1618
-
else
1619
-
(* Read the first (and hopefully only) key *)
1620
-
match Binary.peek_byte dec with
1621
-
| Some b when b lsr 5 <> Binary.major_text ->
1622
-
(* Non-text key: skip key and value, then drain rest *)
1623
-
Binary.skip dec;
1624
-
Binary.skip dec;
1625
-
while not (Binary.is_break dec) do
1626
-
Binary.skip dec;
1627
-
Binary.skip dec
1628
-
done;
1629
-
Binary.skip_break dec;
1630
-
Error
1631
-
(Error.v ~ctx:path
1632
-
(Error.Invalid_value "variant map key must be text"))
1633
-
| _ ->
1634
-
let key = Binary.read_text dec in
1635
-
let result =
1636
-
let rec try_cases = function
1637
-
| [] ->
1638
-
Binary.skip dec;
1639
-
Error
1640
-
(Error.v ~ctx:path
1641
-
(Error.Invalid_value
1642
-
(Fmt.str "unknown key %S in variant" key)))
1643
-
| Case (k, c, inject, _) :: _rest when k = key -> (
1644
-
match
1645
-
c.decode_rw (Error.ctx_with_key k path) dec
1646
-
with
1647
-
| Error e -> Error e
1648
-
| Ok x -> Ok (inject x))
1649
-
| Case0 (k, v, _) :: _ when k = key ->
1650
-
Binary.skip dec;
1651
-
Ok v
1652
-
| _ :: rest -> try_cases rest
1653
-
in
1654
-
try_cases cases
1655
-
in
1656
-
(* Check that no more entries follow *)
1657
-
let extra = ref 0 in
1658
-
while not (Binary.is_break dec) do
1659
-
incr extra;
1660
-
Binary.skip dec;
1661
-
Binary.skip dec
1662
-
done;
1663
-
Binary.skip_break dec;
1664
-
if !extra > 0 then
1665
-
Error
1666
-
(Error.v ~ctx:path
1667
-
(Error.Invalid_value
1668
-
"variant map must have exactly one key"))
1669
-
else result));
1670
-
}
1671
-
end
1672
-
1673
-
(* Recursive types *)
1674
-
1675
-
let fix f =
1676
-
let rec self =
1677
-
lazy
1678
-
(f
1679
-
{
1680
-
kind = "fix";
1681
-
encode = (fun v -> (Lazy.force self).encode v);
1682
-
decode = (fun path v -> (Lazy.force self).decode path v);
1683
-
decode_rw = (fun path dec -> (Lazy.force self).decode_rw path dec);
1684
-
})
1685
-
in
1686
-
Lazy.force self
1687
-
1688
-
(* Queries *)
1689
-
1690
-
let mem name c =
1691
-
let decode =
1692
-
fun path v ->
1693
-
match v with
1694
-
| Value.Map pairs ->
1695
-
let rec find = function
1696
-
| [] -> Error (Error.v ~ctx:path (Error.Missing_member name))
1697
-
| (Value.Text k, value) :: _ when k = name ->
1698
-
c.decode (Error.ctx_with_key name path) value
1699
-
| _ :: rest -> find rest
1700
-
in
1701
-
find pairs
1702
-
| _ -> type_error path "map" v
1703
-
in
1704
-
{
1705
-
kind = Fmt.str "mem(%s, %s)" name c.kind;
1706
-
encode = (fun v -> Value.Map [ (Value.Text name, c.encode v) ]);
1707
-
decode;
1708
-
decode_rw = decode_rw_via_cbor decode;
1709
-
}
1710
-
1711
-
let int_mem key c =
1712
-
let decode =
1713
-
fun path v ->
1714
-
match v with
1715
-
| Value.Map pairs ->
1716
-
let key_cbor = Value.Int (Z.of_int key) in
1717
-
let rec find = function
1718
-
| [] ->
1719
-
Error
1720
-
(Error.v ~ctx:path (Error.Missing_member (string_of_int key)))
1721
-
| (k, value) :: _ when Value.equal k key_cbor ->
1722
-
c.decode (Error.ctx_with_key (string_of_int key) path) value
1723
-
| _ :: rest -> find rest
1724
-
in
1725
-
find pairs
1726
-
| _ -> type_error path "map" v
1727
-
in
1728
-
{
1729
-
kind = Fmt.str "int_mem(%d, %s)" key c.kind;
1730
-
encode = (fun v -> Value.Map [ (Value.Int (Z.of_int key), c.encode v) ]);
1731
-
decode;
1732
-
decode_rw = decode_rw_via_cbor decode;
1733
-
}
1734
-
1735
-
let nth n c =
1736
-
let decode =
1737
-
fun path v ->
1738
-
match v with
1739
-
| Value.Array items -> (
1740
-
match List.nth_opt items n with
1741
-
| None ->
1742
-
Error
1743
-
(Error.v ~ctx:path
1744
-
(Error.Out_of_range
1745
-
{
1746
-
value = string_of_int n;
1747
-
range = Fmt.str "[0, %d)" (List.length items);
1748
-
}))
1749
-
| Some item -> c.decode (Error.ctx_with_index n path) item)
1750
-
| _ -> type_error path "array" v
1751
-
in
1752
-
{
1753
-
kind = Fmt.str "nth(%d, %s)" n c.kind;
1754
-
encode =
1755
-
(fun v ->
1756
-
let items =
1757
-
List.init (n + 1) (fun i -> if i = n then c.encode v else Value.Null)
1758
-
in
1759
-
Value.Array items);
1760
-
decode;
1761
-
decode_rw = decode_rw_via_cbor decode;
1762
-
}
1763
-
1764
-
(* Updates *)
1765
-
1766
-
let update_mem name c =
1767
-
let decode =
1768
-
fun path v ->
1769
-
match v with
1770
-
| Value.Map pairs ->
1771
-
let rec find found acc = function
1772
-
| [] ->
1773
-
if found then Ok (Value.Map (List.rev acc))
1774
-
else Error (Error.v ~ctx:path (Error.Missing_member name))
1775
-
| (Value.Text k, value) :: rest when k = name -> (
1776
-
match c.decode (Error.ctx_with_key name path) value with
1777
-
| Error e -> Error e
1778
-
| Ok new_value ->
1779
-
let new_pair = (Value.Text name, c.encode new_value) in
1780
-
find true (new_pair :: acc) rest)
1781
-
| pair :: rest -> find found (pair :: acc) rest
1782
-
in
1783
-
find false [] pairs
1784
-
| _ -> type_error path "map" v
1785
-
in
1786
-
{
1787
-
kind = Fmt.str "update_mem(%s, %s)" name c.kind;
1788
-
encode = (fun v -> Value.Map [ (Value.Text name, v) ]);
1789
-
decode;
1790
-
decode_rw = decode_rw_via_cbor decode;
1791
-
}
1792
-
1793
-
let delete_mem name =
1794
-
let decode =
1795
-
fun path v ->
1796
-
match v with
1797
-
| Value.Map pairs ->
1798
-
let filtered =
1799
-
List.filter
1800
-
(fun (k, _) -> match k with Value.Text k -> k <> name | _ -> true)
1801
-
pairs
1802
-
in
1803
-
Ok (Value.Map filtered)
1804
-
| _ -> type_error path "map" v
1805
-
in
1806
-
{
1807
-
kind = Fmt.str "delete_mem(%s)" name;
1808
-
encode = (fun v -> v);
1809
-
decode;
1810
-
decode_rw = decode_rw_via_cbor decode;
1811
-
}
1812
-
1813
-
(* Decoding *)
1814
-
1815
-
let decode_cbor c v = c.decode Loc.Context.empty v
1816
-
1817
-
let decode_cbor_exn c v =
1818
-
match decode_cbor c v with Ok x -> x | Error e -> raise (Loc.Error e)
1819
-
1820
-
let decode c reader =
28
+
let of_reader (c : 'a codec) reader =
1821
29
let dec = Binary.decoder reader in
1822
30
try
1823
31
let result = c.decode_rw Loc.Context.empty dec in
···
1842
50
(Error.v ~ctx:Loc.Context.empty
1843
51
(Error.Parse_error "unexpected end of input"))
1844
52
1845
-
let decode_exn c reader =
1846
-
match decode c reader with Ok x -> x | Error e -> raise (Loc.Error e)
53
+
let of_reader_exn c reader =
54
+
match of_reader c reader with Ok x -> x | Error e -> raise (Loc.Error e)
1847
55
1848
-
let decode_string c s =
56
+
let of_string c s =
1849
57
let reader = Bytes.Reader.of_string s in
1850
-
decode c reader
58
+
of_reader c reader
1851
59
1852
-
let decode_string_exn c s =
1853
-
match decode_string c s with Ok x -> x | Error e -> raise (Loc.Error e)
60
+
let of_string_exn c s =
61
+
match of_string c s with Ok x -> x | Error e -> raise (Loc.Error e)
1854
62
1855
-
(* Encoding *)
1856
-
1857
-
let encode_cbor c v = c.encode v
1858
-
1859
-
let encode c v ~eod writer =
63
+
let to_writer (c : 'a codec) v ~eod writer =
1860
64
let enc = Binary.encoder writer in
1861
-
let cbor = c.encode v in
1862
-
Binary.write_cbor enc cbor;
65
+
c.encode_rw enc v;
1863
66
Binary.flush_encoder enc;
1864
67
if eod then Bytes.Writer.write writer Bytes.Slice.eod
1865
68
1866
-
let encode_string c v =
69
+
let to_string c v =
1867
70
let buf = Buffer.create 256 in
1868
71
let writer = Bytes.Writer.of_buffer buf in
1869
-
encode c v ~eod:false writer;
72
+
to_writer c v ~eod:false writer;
1870
73
Buffer.contents buf
1871
74
1872
-
module Private = struct
1873
-
let decode_cbor = decode_cbor
1874
-
let decode_cbor_exn = decode_cbor_exn
1875
-
let encode_cbor = encode_cbor
1876
-
end
75
+
(* {1 Pure operations over Value.t}
76
+
77
+
Bridges between codecs and {!Value.t}: serialize the value to bytes via
78
+
{!Binary.write_cbor}, then drive the codec's streaming decoder; or run the
79
+
codec's streaming encoder into a buffer and parse it back with
80
+
{!Binary.read_cbor}. The codec itself never sees a {!Value.t}. *)
81
+
82
+
let decode (c : 'a codec) v =
83
+
let buf = Buffer.create 256 in
84
+
let writer = Bytes.Writer.of_buffer buf in
85
+
let enc = Binary.encoder writer in
86
+
Binary.write_cbor enc v;
87
+
Binary.flush_encoder enc;
88
+
let s = Buffer.contents buf in
89
+
of_string c s
90
+
91
+
let decode_exn c v =
92
+
match decode c v with Ok x -> x | Error e -> raise (Loc.Error e)
93
+
94
+
let encode (c : 'a codec) x =
95
+
let s = to_string c x in
96
+
let reader = Bytes.Reader.of_string s in
97
+
let dec = Binary.decoder reader in
98
+
Binary.read_cbor dec
99
+
100
+
(* {1 Patch operations on {!Value.t} maps} *)
101
+
102
+
let map_type_error v =
103
+
let got =
104
+
match v with
105
+
| Value.Null -> "null"
106
+
| Value.Bool _ -> "bool"
107
+
| Value.Int _ -> "integer"
108
+
| Value.Bytes _ -> "bytes"
109
+
| Value.Text _ -> "text"
110
+
| Value.Array _ -> "array"
111
+
| Value.Map _ -> "map"
112
+
| Value.Tag _ -> "tag"
113
+
| Value.Float _ -> "float"
114
+
| Value.Simple _ -> "simple"
115
+
| Value.Undefined -> "undefined"
116
+
in
117
+
Error.type_mismatch_result Loc.Context.empty ~expected:"map" ~got
118
+
119
+
let update_mem name (c : 'a codec) v =
120
+
match v with
121
+
| Value.Map pairs ->
122
+
let rec loop found acc = function
123
+
| [] ->
124
+
if found then Ok (Value.Map (List.rev acc))
125
+
else
126
+
Error (Error.v ~ctx:Loc.Context.empty (Error.Missing_member name))
127
+
| (Value.Text k, value) :: rest when k = name -> (
128
+
match decode c value with
129
+
| Error e -> Error e
130
+
| Ok decoded ->
131
+
let new_value = encode c decoded in
132
+
loop true ((Value.Text name, new_value) :: acc) rest)
133
+
| pair :: rest -> loop found (pair :: acc) rest
134
+
in
135
+
loop false [] pairs
136
+
| _ -> map_type_error v
137
+
138
+
let update_mem_exn name c v =
139
+
match update_mem name c v with Ok x -> x | Error e -> raise (Loc.Error e)
140
+
141
+
let delete_mem name v =
142
+
match v with
143
+
| Value.Map pairs ->
144
+
let filtered =
145
+
List.filter
146
+
(fun (k, _) -> match k with Value.Text k -> k <> name | _ -> true)
147
+
pairs
148
+
in
149
+
Ok (Value.Map filtered)
150
+
| _ -> map_type_error v
151
+
152
+
let delete_mem_exn name v =
153
+
match delete_mem name v with Ok x -> x | Error e -> raise (Loc.Error e)
+308
-316
lib/cbor.mli
+308
-316
lib/cbor.mli
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
(** CBOR codecs.
7
-
8
-
This module provides type-safe CBOR encoding and decoding using a
9
-
combinator-based approach. Define codecs once and use them for both encoding
10
-
and decoding.
6
+
(** CBOR codecs (RFC 8949).
11
7
12
-
The design follows the jsont pattern: codecs are values of type ['a t] that
13
-
describe how to convert between OCaml values of type ['a] and CBOR data
14
-
items.
8
+
Type-safe CBOR encoding and decoding via combinators. Codecs are
9
+
bidirectional: the same value drives encode and decode. The combinator
10
+
vocabulary mirrors the format described by the specification — major types
11
+
per RFC 8949 §3.1, simple values per §3.3, tags per §3.4 — not OCaml's.
12
+
Users describe their OCaml type by composing the CBOR alphabet from {!Codec}
13
+
via {!Codec.map}, {!Codec.Map}, {!Codec.Variant}, etc. Each section header
14
+
below cites the RFC 8949 clause it implements.
15
15
16
16
{2 Quick Start}
17
17
18
18
{[
19
19
type person = { name : string; age : int }
20
20
21
-
let person_codec : person Cbor.t =
22
-
Cbor.Obj.map (fun name age -> { name; age })
23
-
|> Cbor.Obj.mem "name" (fun p -> p.name) Cbor.string
24
-
|> Cbor.Obj.mem "age" (fun p -> p.age) Cbor.int
25
-
|> Cbor.Obj.seal
21
+
let person_codec : person Cbor.codec =
22
+
let open Cbor.Codec in
23
+
Map.map (fun name age -> { name; age })
24
+
|> Map.mem "name" (fun p -> p.name) text
25
+
|> Map.mem "age" (fun p -> p.age) int
26
+
|> Map.seal
26
27
27
28
let alice = { name = "Alice"; age = 30 }
28
-
let cbor_bytes = Cbor.encode_string person_codec alice
29
+
let cbor_bytes = Cbor.to_string person_codec alice
29
30
30
31
let () =
31
-
match Cbor.decode_string person_codec cbor_bytes with
32
+
match Cbor.of_string person_codec cbor_bytes with
32
33
| Ok p -> assert (p = alice)
33
34
| Error e -> Fmt.failwith "decode: %a" Cbor.Error.pp e
34
-
]}
35
+
]} *)
35
36
36
-
{2 Data Model}
37
+
open Bytesrw
37
38
38
-
This codec library maps OCaml types to CBOR types:
39
-
40
-
| OCaml type | CBOR type | |------------|-----------| | [unit] | null
41
-
(simple value 22) | | [bool] | true/false (simple values 21/20) | | [int],
42
-
[int32], [int64] | integer (major types 0/1) | | [float] | float (major type
43
-
7) | | [string] | text string (major type 3) | | [bytes] | byte string
44
-
(major type 2) | | ['a list] | array (major type 4) | | [('k, 'v) list] |
45
-
map (major type 5) | | records | map with text keys | | variants | tagged or
46
-
keyed encoding | *)
39
+
(** {1:layers Modules} *)
47
40
48
-
open Bytesrw
49
41
module Binary = Binary
50
-
module Value = Value
51
-
52
-
(** {1:sort Sorts} *)
42
+
(** Low-level wire reader/writer (RFC 8949 §3). Used by the codec interpreter
43
+
and exposed for sibling libraries that need stream-level access. *)
53
44
54
45
module Sort = Sort
55
-
(** Sorts of CBOR values, one per RFC 8949 major type (with major type 7 split
56
-
into {!Sort.Bool} / {!Sort.Null} / {!Sort.Undefined} / {!Sort.Simple} /
57
-
{!Sort.Float} by the simple-value sub-tag). Labels used in structured error
58
-
contexts and {!Loc.Path} frames. *)
59
-
60
-
(** {1:errors Errors} *)
46
+
(** Closed enumeration of CBOR value sorts, one per RFC 8949 §3.1 major type
47
+
(with major type 7 split into {!Sort.Bool} / {!Sort.Null} /
48
+
{!Sort.Undefined} / {!Sort.Simple} / {!Sort.Float} by the simple-value
49
+
sub-tag from §3.3). *)
61
50
62
51
module Error = Error
63
52
(** CBOR error facade. Extends {!Loc.Error.kind} with typed CBOR kinds
64
53
({!Error.Type_mismatch}, {!Error.Missing_member}, ...), registers printers,
65
-
and re-exports {!Loc.Error} verbs. See {!module:Error}. *)
54
+
and re-exports {!Loc.Error} verbs. *)
66
55
67
-
(** {1:codec Codecs} *)
56
+
module Value = Value
57
+
(** Concrete CBOR AST. {!Value.t} is the universal "any CBOR value" type and
58
+
matches {!t} below. *)
68
59
69
-
type 'a t
70
-
(** The type of codecs for values of type ['a]. A codec knows how to both encode
71
-
['a] to CBOR and decode CBOR to ['a]. *)
60
+
(** {1:types Types} *)
72
61
73
-
val pp : Format.formatter -> _ t -> unit
74
-
(** [pp ppf t] pretty-prints the codec as [<codec>]. *)
62
+
type t = Value.t
63
+
(** A CBOR value. Alias for {!Value.t}. *)
75
64
76
-
(** {1:base Base Codecs}
65
+
(** {1:codec Codecs}
77
66
78
-
Codecs for primitive types. *)
67
+
A {!codec} is an opaque description of how an OCaml type maps to a CBOR
68
+
value. {!Codec}'s sections follow RFC 8949 §3.1 in spec order (major type 0
69
+
→ 7), then simple values (§3.3), then tags (§3.4), then the OCaml-side
70
+
helpers that don't correspond to a CBOR major type. Pass codecs to the IO
71
+
verbs below ({!of_string}, {!to_writer}, ...) or the pure {!encode} /
72
+
{!decode} pair over {!Value.t}. *)
79
73
80
-
val null : unit t
81
-
(** [null] is a codec for the CBOR null value. Encodes [()] as null. *)
74
+
(** Codec combinators. Sections track RFC 8949 §3.1 in spec order. *)
75
+
module Codec : sig
76
+
type 'a t
77
+
(** A CBOR codec for OCaml values of type ['a]. *)
82
78
83
-
val bool : bool t
84
-
(** [bool] is a codec for CBOR booleans. *)
79
+
val pp : Format.formatter -> _ t -> unit
80
+
(** [pp ppf c] pretty-prints [c] as [<codec:...>]. *)
85
81
86
-
val int : int t
87
-
(** [int] is a codec for OCaml [int] as CBOR integer.
88
-
@raise Loc.Error if the CBOR integer is out of [int] range. *)
82
+
val kind : 'a t -> string
83
+
(** [kind c] is a human-readable description of [c]'s shape, e.g. ["int"],
84
+
["text"], ["map({name, age})"], ["mem(name, text)"]. *)
89
85
90
-
val int32 : int32 t
91
-
(** [int32] is a codec for [int32] as CBOR integer.
92
-
@raise Loc.Error if the CBOR integer is out of [int32] range. *)
86
+
(** {2:major0 Major type 0 — Unsigned integer (RFC 8949 §3.1)}
93
87
94
-
val int64 : int64 t
95
-
(** [int64] is a codec for [int64] as CBOR integer. *)
88
+
Direct values from 0 to 2^64 - 1; CBOR tag 0 in the wire encoding. *)
96
89
97
-
val float : float t
98
-
(** [float] is a codec for CBOR floating-point numbers. Also accepts CBOR
99
-
integers, converting them to float. *)
90
+
val uint : int t
91
+
(** Codec for OCaml [int] restricted to non-negative integers. Encodes via
92
+
major type 0; decoding rejects major type 1. *)
100
93
101
-
val string : string t
102
-
(** [string] is a codec for CBOR text strings (UTF-8). *)
94
+
val uint32 : int32 t
95
+
(** As {!uint} but for [int32]. *)
103
96
104
-
val bytes : string t
105
-
(** [bytes] is a codec for CBOR byte strings. The OCaml [string] type is used
106
-
since it can hold arbitrary bytes. *)
97
+
val uint64 : int64 t
98
+
(** As {!uint} but for [int64]. *)
107
99
108
-
val any : Value.t t
109
-
(** [any] is a codec that accepts any CBOR value. Useful for dynamic content or
110
-
when preserving unknown fields. *)
100
+
(** {2:major1 Major type 1 — Negative integer (RFC 8949 §3.1)}
111
101
112
-
(** {1:nullable Nullable Values} *)
102
+
Negative values in [-2^64, -1]; the wire encoding stores [-1 - n] where
103
+
[n] is the magnitude minus one (RFC 8949 §3, Table 3). The [int] codecs
104
+
below decode either major type 0 or 1, matching CDDL's [int] type. *)
113
105
114
-
val nullable : 'a t -> 'a option t
115
-
(** [nullable c] creates a codec for optional values. Encodes [None] as null,
116
-
[Some x] as [c] would encode [x]. *)
106
+
val int : int t
107
+
(** Codec for OCaml [int]. Decodes either a CBOR Unsigned (major 0) or
108
+
Negative integer (major 1).
109
+
@raise Loc.Error if the CBOR integer is outside the OCaml [int] range. *)
117
110
118
-
val option : default:'a -> 'a t -> 'a t
119
-
(** [option ~default c] creates a codec that uses [default] when decoding null
120
-
instead of failing. *)
111
+
val int32 : int32 t
112
+
(** As {!int} but for [int32]. *)
121
113
122
-
(** {1:numbers Numeric Variants} *)
114
+
val int64 : int64 t
115
+
(** As {!int} but for [int64]. *)
123
116
124
-
val uint : int t
125
-
(** [uint] is like {!int} but only accepts non-negative integers. *)
117
+
(** {2:major2 Major type 2 — Byte string (RFC 8949 §3.1)}
126
118
127
-
val uint32 : int32 t
128
-
(** [uint32] is like {!int32} but only accepts non-negative integers. *)
119
+
Sequence of bytes with no encoding constraints. CDDL [bstr] / [bytes]. *)
129
120
130
-
val uint64 : int64 t
131
-
(** [uint64] is like {!int64} but only accepts non-negative integers. *)
121
+
val bytes : string t
122
+
(** Codec for CBOR byte strings. The OCaml [string] type carries arbitrary
123
+
bytes. *)
132
124
133
-
val number : float t
134
-
(** [number] accepts both integers and floats, converting to float. Alias for
135
-
{!float}. *)
125
+
(** {2:major3 Major type 3 — Text string (RFC 8949 §3.1)}
136
126
137
-
(** {1:arrays Arrays} *)
127
+
Sequence of bytes that must be valid UTF-8 (RFC 8949 §3.1, Major Type 3).
128
+
CDDL [tstr] / [text]. *)
138
129
139
-
val array : 'a t -> 'a list t
140
-
(** [array c] is a codec for arrays where each element uses codec [c]. *)
130
+
val text : string t
131
+
(** Codec for CBOR UTF-8 text strings. *)
141
132
142
-
val array_of : len:int -> 'a t -> 'a list t
143
-
(** [array_of ~len c] is like {!array} but requires exactly [len] elements. *)
133
+
(** {2:major4 Major type 4 — Array (RFC 8949 §3.1)}
144
134
145
-
val tuple2 : 'a t -> 'b t -> ('a * 'b) t
146
-
(** [tuple2 ca cb] is a codec for 2-element arrays as pairs. *)
135
+
Ordered sequence of data items; CDDL [[ … ]]. *)
147
136
148
-
val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
149
-
(** [tuple3 ca cb cc] is a codec for 3-element arrays as triples. *)
137
+
val array : 'a t -> 'a list t
138
+
(** [array c] is a codec for arrays of arbitrary length. *)
150
139
151
-
val tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
152
-
(** [tuple4 ca cb cc cd] is a codec for 4-element arrays as quadruples. *)
140
+
val array_of : len:int -> 'a t -> 'a list t
141
+
(** [array_of ~len c] requires exactly [len] elements. *)
153
142
154
-
(** {1:maps Maps}
143
+
val tuple2 : 'a t -> 'b t -> ('a * 'b) t
144
+
(** Codec for 2-element arrays as pairs. *)
155
145
156
-
Codecs for CBOR maps with uniform key and value types. For records and
157
-
heterogeneous maps, see {!module:Obj}. *)
146
+
val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
147
+
(** Codec for 3-element arrays as triples. *)
158
148
159
-
val assoc : 'k t -> 'v t -> ('k * 'v) list t
160
-
(** [assoc kc vc] is a codec for maps as association lists. Keys are decoded
161
-
using [kc], values using [vc]. *)
149
+
val tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
150
+
(** Codec for 4-element arrays as quadruples. *)
162
151
163
-
val string_map : 'v t -> (string * 'v) list t
164
-
(** [string_map vc] is a codec for maps with text string keys. Equivalent to
165
-
[assoc string vc]. *)
152
+
(** {2:major5 Major type 5 — Map (RFC 8949 §3.1)}
166
153
167
-
val int_map : 'v t -> (int * 'v) list t
168
-
(** [int_map vc] is a codec for maps with integer keys. Common in COSE and other
169
-
binary protocols. *)
154
+
Set of key/value pairs; CDDL [{ … }]. Three views:
155
+
- {!assoc} / {!text_map} / {!int_map} — uniform key/value type, decode
156
+
into an association list.
157
+
- {!Map} — text-keyed map as a curried-constructor record builder.
158
+
- {!Map_int} — same shape, integer-keyed (COSE / CWT, RFC 9052 / 8392). *)
170
159
171
-
(** {1:objects Object Codecs}
160
+
val assoc : 'k t -> 'v t -> ('k * 'v) list t
161
+
(** [assoc kc vc] decodes a CBOR map into a list of [(key, value)] pairs. *)
172
162
173
-
Build codecs for records and objects from CBOR maps with text string keys.
174
-
The shape mirrors [Json.Codec.Object]: start with {!map} and a curried
175
-
record constructor, thread the constructor through {!mem} / {!mem_opt} /
176
-
{!mem_default} (one application per field), and close with {!seal}.
163
+
val text_map : 'v t -> (string * 'v) list t
164
+
(** [text_map vc] is [assoc text vc]. *)
177
165
178
-
{[
179
-
type person = { name : string; age : int; email : string option }
166
+
val int_map : 'v t -> (int * 'v) list t
167
+
(** [int_map vc] is [assoc int vc]. Common in COSE / CWT. *)
180
168
181
-
let person_codec : person Cbor.t =
182
-
Cbor.Obj.map (fun name age email -> { name; age; email })
183
-
|> Cbor.Obj.mem "name" (fun p -> p.name) Cbor.string
184
-
|> Cbor.Obj.mem "age" (fun p -> p.age) Cbor.int
185
-
|> Cbor.Obj.mem_opt "email" (fun p -> p.email) Cbor.string
186
-
|> Cbor.Obj.seal
187
-
]}
169
+
(** Records as text-keyed maps. Build a record codec as a curried-constructor
170
+
pipeline:
188
171
189
-
The pipeline never inspects a synthetic value to walk its own shape, so the
190
-
implementation is free of [Obj.magic]. *)
191
-
module Obj : sig
192
-
type ('o, 'dec) mem
193
-
(** A partially-applied curried constructor for an object of type ['o]. The
194
-
['dec] parameter is the constructor's remaining arrow type — every {!mem}
195
-
application consumes one argument; {!seal} fires when ['dec] equals ['o].
196
-
*)
172
+
{[
173
+
type person = { name : string; age : int; email : string option }
197
174
198
-
val map : 'dec -> ('o, 'dec) mem
199
-
(** [map ctor] starts a member chain with [ctor] as the unsaturated
200
-
constructor (e.g. [fun a b c -> { a; b; c }]). *)
175
+
let person_codec =
176
+
let open Cbor.Codec in
177
+
Map.map (fun name age email -> { name; age; email })
178
+
|> Map.mem "name" (fun p -> p.name) text
179
+
|> Map.mem "age" (fun p -> p.age) int
180
+
|> Map.mem_opt "email" (fun p -> p.email) text
181
+
|> Map.seal
182
+
]}
201
183
202
-
val mem : string -> ('o -> 'a) -> 'a t -> ('o, 'a -> 'b) mem -> ('o, 'b) mem
203
-
(** [mem name get c m] declares a required member at key [name] decoded by
204
-
[c]. [get] extracts the field for encoding. Consumes one argument of the
205
-
curried constructor in [m]. *)
184
+
The pipeline never inspects a synthetic value to walk its own shape, so
185
+
the implementation is free of {!Stdlib.Obj.magic}. *)
186
+
module Map : sig
187
+
type ('o, 'dec) mem
188
+
(** A partially-applied curried constructor for an object of type ['o].
189
+
['dec] tracks the constructor's remaining arrow type — every {!mem}
190
+
application consumes one argument; {!seal} fires when ['dec] equals
191
+
['o]. *)
206
192
207
-
val mem_opt :
208
-
string ->
209
-
('o -> 'a option) ->
210
-
'a t ->
211
-
('o, 'a option -> 'b) mem ->
212
-
('o, 'b) mem
213
-
(** [mem_opt name get c m] declares an optional member. The constructor
214
-
receives the field's value as an [option]; absent / null both decode to
215
-
[None]. *)
193
+
val map : 'dec -> ('o, 'dec) mem
194
+
(** [map ctor] starts a member chain with [ctor] as the unsaturated
195
+
constructor (e.g. [fun a b c -> { a; b; c }]). *)
216
196
217
-
val mem_default :
218
-
string ->
219
-
('o -> 'a) ->
220
-
default:'a ->
221
-
'a t ->
222
-
('o, 'a -> 'b) mem ->
223
-
('o, 'b) mem
224
-
(** [mem_default name get ~default c m] declares a member that falls back to
225
-
[default] when the key is absent or the value is null. *)
197
+
val mem : string -> ('o -> 'a) -> 'a t -> ('o, 'a -> 'b) mem -> ('o, 'b) mem
198
+
(** [mem name get c m] declares a required member at key [name] decoded by
199
+
[c]. [get] extracts the field for encoding. *)
226
200
227
-
val seal : ('o, 'o) mem -> 'o t
228
-
(** [seal m] converts the saturated member chain into a codec. *)
229
-
end
201
+
val mem_opt :
202
+
string ->
203
+
('o -> 'a option) ->
204
+
'a t ->
205
+
('o, 'a option -> 'b) mem ->
206
+
('o, 'b) mem
207
+
(** [mem_opt name get c m] declares an optional member: absent / null both
208
+
decode to [None]. *)
230
209
231
-
(** {1:int_objects Integer-Keyed Objects}
210
+
val mem_default :
211
+
string ->
212
+
('o -> 'a) ->
213
+
default:'a ->
214
+
'a t ->
215
+
('o, 'a -> 'b) mem ->
216
+
('o, 'b) mem
217
+
(** [mem_default name get ~default c m] falls back to [default] when the key
218
+
is absent or the value is null. *)
232
219
233
-
Same pipeline as {!Obj}, but indexes fields by integer keys (the COSE / CWT
234
-
layout). *)
235
-
module Obj_int : sig
236
-
type ('o, 'dec) mem
237
-
(** As in {!Obj.mem} but keyed by integer. *)
220
+
val seal : ('o, 'o) mem -> 'o t
221
+
(** [seal m] converts the saturated chain into a codec. *)
222
+
end
238
223
239
-
val map : 'dec -> ('o, 'dec) mem
240
-
(** [map ctor] starts a member chain with [ctor] as the unsaturated
241
-
constructor. *)
224
+
(** Records as integer-keyed maps. Same pipeline as {!Map}, used by COSE (RFC
225
+
9052) and CWT (RFC 8392). *)
226
+
module Map_int : sig
227
+
type ('o, 'dec) mem
228
+
(** As in {!Map.mem} but keyed by integer. *)
242
229
243
-
val mem : int -> ('o -> 'a) -> 'a t -> ('o, 'a -> 'b) mem -> ('o, 'b) mem
244
-
(** [mem key get c m] declares a required member at integer key [key]. *)
230
+
val map : 'dec -> ('o, 'dec) mem
231
+
(** [map ctor] starts a member chain. *)
245
232
246
-
val mem_opt :
247
-
int ->
248
-
('o -> 'a option) ->
249
-
'a t ->
250
-
('o, 'a option -> 'b) mem ->
251
-
('o, 'b) mem
252
-
(** [mem_opt key get c m] declares an optional member with integer key. *)
233
+
val mem : int -> ('o -> 'a) -> 'a t -> ('o, 'a -> 'b) mem -> ('o, 'b) mem
234
+
(** [mem key get c m] declares a required integer-keyed member. *)
253
235
254
-
val mem_default :
255
-
int ->
256
-
('o -> 'a) ->
257
-
default:'a ->
258
-
'a t ->
259
-
('o, 'a -> 'b) mem ->
260
-
('o, 'b) mem
261
-
(** [mem_default key get ~default c m] declares a member that falls back to
262
-
[default] when the key is absent or the value is null. *)
236
+
val mem_opt :
237
+
int ->
238
+
('o -> 'a option) ->
239
+
'a t ->
240
+
('o, 'a option -> 'b) mem ->
241
+
('o, 'b) mem
242
+
(** [mem_opt key get c m] declares an optional integer-keyed member. *)
263
243
264
-
val seal : ('o, 'o) mem -> 'o t
265
-
(** [seal m] converts the saturated member chain into a codec. *)
266
-
end
244
+
val mem_default :
245
+
int ->
246
+
('o -> 'a) ->
247
+
default:'a ->
248
+
'a t ->
249
+
('o, 'a -> 'b) mem ->
250
+
('o, 'b) mem
251
+
(** [mem_default key get ~default c m] falls back to [default] when the key
252
+
is absent or the value is null. *)
267
253
268
-
(** {1:tags Tagged Values}
254
+
val seal : ('o, 'o) mem -> 'o t
255
+
(** [seal m] converts the saturated chain into a codec. *)
256
+
end
269
257
270
-
CBOR tags provide semantic information about data items. *)
258
+
(** {2:major6 Major type 6 — Tagged data item (RFC 8949 §3.1, §3.4)}
271
259
272
-
val tag : int -> 'a t -> 'a t
273
-
(** [tag n c] wraps codec [c] with tag number [n]. On encoding, outputs the tag;
274
-
on decoding, expects and strips the tag. *)
260
+
A tag attaches semantic information to a single enclosed data item,
261
+
identified by an unsigned integer tag number. *)
275
262
276
-
val tag_opt : int -> 'a t -> 'a t
277
-
(** [tag_opt n c] is like {!tag} but the tag is optional when decoding. Useful
278
-
for accepting both tagged and untagged input. *)
263
+
val tag : int -> 'a t -> 'a t
264
+
(** [tag n c] wraps [c] with tag number [n]. On encoding, outputs the tag; on
265
+
decoding, expects and strips it. *)
279
266
280
-
(** {1:transforms Transformations}
267
+
val tag_opt : int -> 'a t -> 'a t
268
+
(** [tag_opt n c] is like {!tag} but the tag is optional when decoding. *)
281
269
282
-
Convert between types using codecs. *)
270
+
(** {2:major7 Major type 7 — Floating-point and simple values (RFC 8949 §3.3)}
283
271
284
-
val map : ('a -> 'b) -> ('b -> 'a) -> 'a t -> 'b t
285
-
(** [map decode encode c] transforms codec [c]. The [decode] function is applied
286
-
after decoding, [encode] before encoding. *)
272
+
Major type 7 carries floating-point numbers (sub-tags 25 / 26 / 27) and
273
+
simple values from §3.3 Table 4, including the standard simple values
274
+
[false] (20), [true] (21), [null] (22), and [undefined] (23). *)
287
275
288
-
val conv : ('a -> ('b, string) result) -> ('b -> 'a) -> 'a t -> 'b t
289
-
(** [conv decode encode c] is like {!map} but [decode] may fail. *)
276
+
val null : unit t
277
+
(** Codec for the CBOR null simple value (sub-tag 22). *)
290
278
291
-
val const : 'a -> unit t -> 'a t
292
-
(** [const v c] is a codec that always decodes to [v] and encodes [v] using [c].
293
-
*)
279
+
val bool : bool t
280
+
(** Codec for CBOR booleans (simple values 20 / 21). *)
294
281
295
-
(** {1:variants Variants}
282
+
val float : float t
283
+
(** Codec for CBOR floats (RFC 8949 §3.3, sub-tags 25 / 26 / 27). Decoding
284
+
accepts CBOR integers and converts them to [float]. *)
296
285
297
-
Encode sum types using either tags or key-based discrimination. *)
286
+
(** {1:transforms Codec transformations}
298
287
299
-
(** Tag-based variant encoding. Each constructor is assigned a unique CBOR tag
300
-
number. *)
301
-
module Variant : sig
302
-
type 'a case
303
-
(** A variant case specification. *)
288
+
The combinators in this section don't correspond to any CBOR major type;
289
+
they shape the OCaml-side type the GADT carries. *)
304
290
305
-
val case : int -> 'a t -> ('a -> 'b) -> ('b -> 'a option) -> 'b case
306
-
(** [case tag c inject project] defines a case:
307
-
- [tag] is the CBOR tag number for this case
308
-
- [c] is the codec for the payload
309
-
- [inject] wraps decoded payload into the variant type
310
-
- [project] extracts payload if this case matches *)
291
+
val map : ('a -> 'b) -> ('b -> 'a) -> 'a t -> 'b t
292
+
(** [map dec enc c] is the codec morphism: post-process [c]'s decoded value
293
+
with [dec], pre-process the encoded value with [enc]. *)
311
294
312
-
val case0 : int -> 'a -> ('a -> bool) -> 'a case
313
-
(** [case0 tag v is_v] defines a case with no payload. Encodes as an empty
314
-
tag. [is_v x] should return [true] iff [x] equals [v]. *)
295
+
val conv : ('a -> ('b, string) result) -> ('b -> 'a) -> 'a t -> 'b t
296
+
(** [conv dec enc c] is like {!map} but [dec] may fail. *)
315
297
316
-
val variant : 'a case list -> 'a t
317
-
(** [variant cases] builds a codec from a list of cases. Cases are tried in
318
-
order during decoding. *)
319
-
end
298
+
val const : 'a -> unit t -> 'a t
299
+
(** [const v c] always decodes to [v] and encodes [v] using [c]. *)
320
300
321
-
(** Key-based variant encoding. Each constructor is identified by a string key
322
-
in a singleton map. *)
323
-
module Variant_key : sig
324
-
type 'a case
325
-
(** A variant case specification. *)
301
+
val nullable : 'a t -> 'a option t
302
+
(** [nullable c] encodes [None] as null, [Some x] as [c] would encode [x]. *)
326
303
327
-
val case : string -> 'a t -> ('a -> 'b) -> ('b -> 'a option) -> 'b case
328
-
(** [case key c inject project] defines a case identified by text key [key].
329
-
*)
304
+
val option : default:'a -> 'a t -> 'a t
305
+
(** [option ~default c] decodes a null as [default] instead of failing. *)
330
306
331
-
val case0 : string -> 'a -> ('a -> bool) -> 'a case
332
-
(** [case0 key v is_v] defines a case with no payload. Encodes as
333
-
[{key: null}]. *)
307
+
val number : float t
308
+
(** Decoder accepts both CBOR integers and floats, returning a [float].
309
+
Encodes via {!float}. *)
334
310
335
-
val variant : 'a case list -> 'a t
336
-
(** [variant cases] builds a codec from cases. *)
337
-
end
311
+
val fix : ('a t -> 'a t) -> 'a t
312
+
(** [fix f] creates a recursive codec. [f] receives a codec for
313
+
self-reference. *)
338
314
339
-
(** {1:recursive Recursive Types} *)
315
+
(** {1:variants Sum types}
340
316
341
-
val fix : ('a t -> 'a t) -> 'a t
342
-
(** [fix f] creates a recursive codec. The function [f] receives a codec that
343
-
can be used for self-reference.
317
+
Two CBOR-native shapes for sum types, each a different major-type choice
318
+
for the discriminator. *)
344
319
345
-
{[
346
-
type tree = Leaf of int | Node of tree * tree
320
+
(** Tag-discriminated variants (RFC 8949 §3.4, major type 6). Each constructor
321
+
gets a unique CBOR tag number. *)
322
+
module Variant : sig
323
+
type 'a case
324
+
(** A variant case. *)
347
325
348
-
let tree_codec : tree Cbor.t =
349
-
Cbor.fix @@ fun self ->
350
-
Cbor.Variant.(
351
-
variant
352
-
[
353
-
case 0 Cbor.int
354
-
(fun x -> Leaf x)
355
-
(function Leaf x -> Some x | _ -> None);
356
-
case 1 (Cbor.tuple2 self self)
357
-
(fun (l, r) -> Node (l, r))
358
-
(function Node (l, r) -> Some (l, r) | _ -> None);
359
-
])
360
-
]} *)
326
+
val case : int -> 'a t -> ('a -> 'b) -> ('b -> 'a option) -> 'b case
327
+
(** [case tag c inject project] defines a case:
328
+
- [tag] is the CBOR tag number for this case
329
+
- [c] is the codec for the payload
330
+
- [inject] wraps decoded payload into the variant type
331
+
- [project] extracts payload if this case matches *)
361
332
362
-
(** {1:queries Queries}
333
+
val case0 : int -> 'a -> ('a -> bool) -> 'a case
334
+
(** [case0 tag v is_v] defines a payload-less case encoded as an empty tag.
335
+
*)
363
336
364
-
Queries navigate into CBOR structures. Following the soup paper approach,
365
-
each query builds a new codec that knows how to find and decode a specific
366
-
part of a CBOR data structure. *)
337
+
val variant : 'a case list -> 'a t
338
+
(** [variant cases] builds a codec from [cases]. Cases are tried in order
339
+
during decoding. *)
340
+
end
367
341
368
-
val mem : string -> 'a t -> 'a t
369
-
(** [mem name c] queries a map member by text key [name], decoding the value
370
-
with codec [c]. Returns a codec that expects a CBOR map and extracts the
371
-
member named [name]. *)
342
+
(** Singleton-map variants (RFC 8949 §3.1, major type 5). Each constructor is
343
+
identified by a text key in a one-element map. *)
344
+
module Variant_key : sig
345
+
type 'a case
346
+
(** A variant case. *)
372
347
373
-
val int_mem : int -> 'a t -> 'a t
374
-
(** [int_mem key c] queries a map member by integer key [key], decoding the
375
-
value with codec [c]. Useful for COSE/CWT style integer-keyed maps. *)
348
+
val case : string -> 'a t -> ('a -> 'b) -> ('b -> 'a option) -> 'b case
349
+
(** [case key c inject project] defines a case identified by text [key]. *)
376
350
377
-
val nth : int -> 'a t -> 'a t
378
-
(** [nth n c] queries the [n]th element of an array, decoding the element with
379
-
codec [c]. Zero-indexed. *)
351
+
val case0 : string -> 'a -> ('a -> bool) -> 'a case
352
+
(** [case0 key v is_v] defines a payload-less case encoded as [{key: null}].
353
+
*)
380
354
381
-
(** {1:updates Updates}
355
+
val variant : 'a case list -> 'a t
356
+
(** [variant cases] builds a codec from [cases]. *)
357
+
end
382
358
383
-
Updates modify parts of a CBOR structure, returning new CBOR values. Like
384
-
queries, updates are built as codecs. *)
359
+
(** {1:queries Queries and updates}
385
360
386
-
val update_mem : string -> 'a t -> Value.t t
387
-
(** [update_mem name c] creates a codec that decodes a map, finds the member
388
-
named [name], decodes it with [c], re-encodes the decoded value, and returns
389
-
the whole map with the member replaced. This is an identity transform
390
-
through codec [c] -- useful when [c] normalizes or transforms values. *)
361
+
These build a codec that descends into a CBOR structure to read or replace
362
+
one element, leaving the surrounding structure untouched. *)
391
363
392
-
val delete_mem : string -> Value.t t
393
-
(** [delete_mem name] creates a codec that decodes a map and returns it with the
394
-
member named [name] removed. If the member is absent the map is returned
395
-
unchanged. *)
364
+
val mem : string -> 'a t -> 'a t
365
+
(** [mem name c] queries a map member by text key [name]. *)
396
366
397
-
(** {1:introspection Introspection} *)
367
+
val int_mem : int -> 'a t -> 'a t
368
+
(** [int_mem key c] queries a map member by integer key. *)
398
369
399
-
val kind : 'a t -> string
400
-
(** [kind c] returns a human-readable description of the codec kind (e.g.,
401
-
["int"], ["string"], ["obj({name, age})"], ["mem(name, string)"]). *)
370
+
val nth : int -> 'a t -> 'a t
371
+
(** [nth n c] queries the [n]-th element of an array (zero-indexed). *)
372
+
end
402
373
403
-
(** {1:decode Decoding} *)
374
+
type 'a codec = 'a Codec.t
375
+
(** A CBOR codec for values of type ['a]. Alias for {!Codec.t}. *)
404
376
405
-
val decode : 'a t -> Bytes.Reader.t -> ('a, Error.t) result
406
-
(** [decode c r] decodes a value from CBOR reader [r] using codec [c]. *)
377
+
val any : Value.t codec
378
+
(** Identity codec: streams a {!Value.t} through {!Binary.read_cbor} /
379
+
{!Binary.write_cbor} without rewriting it. Useful as a sub-codec for parts
380
+
of a document whose schema isn't known statically. *)
407
381
408
-
val decode_string : 'a t -> string -> ('a, Error.t) result
409
-
(** [decode_string c s] decodes from CBOR bytes [s]. *)
382
+
(** {1:io Reading and writing CBOR (RFC 8949 §5)} *)
410
383
411
-
val decode_exn : 'a t -> Bytes.Reader.t -> 'a
412
-
(** [decode_exn c r] is like {!val-decode} but raises {!Loc.Error}. *)
384
+
val of_string : 'a codec -> string -> ('a, Error.t) result
385
+
(** [of_string c s] decodes CBOR bytes [s] using codec [c]. *)
413
386
414
-
val decode_string_exn : 'a t -> string -> 'a
415
-
(** [decode_string_exn c s] is like {!decode_string} but raises. *)
387
+
val of_string_exn : 'a codec -> string -> 'a
388
+
(** [of_string_exn c s] is like {!of_string} but raises {!Loc.Error.Error}. *)
416
389
417
-
(** {1:encode Encoding} *)
390
+
val to_string : 'a codec -> 'a -> string
391
+
(** [to_string c v] encodes [v] to CBOR bytes. *)
418
392
419
-
val encode : 'a t -> 'a -> eod:bool -> Bytes.Writer.t -> unit
420
-
(** [encode c v ~eod w] encodes [v] to writer [w] using codec [c]. If [eod] is
421
-
true, signals end-of-data after encoding. *)
393
+
val of_reader : 'a codec -> Bytes.Reader.t -> ('a, Error.t) result
394
+
(** [of_reader c r] decodes a value from CBOR reader [r]. *)
422
395
423
-
val encode_string : 'a t -> 'a -> string
424
-
(** [encode_string c v] encodes [v] to a CBOR byte string. *)
396
+
val of_reader_exn : 'a codec -> Bytes.Reader.t -> 'a
397
+
(** [of_reader_exn c r] is like {!of_reader} but raises {!Loc.Error.Error}. *)
425
398
426
-
(** {1:private_ Private}
399
+
val to_writer : 'a codec -> 'a -> eod:bool -> Bytes.Writer.t -> unit
400
+
(** [to_writer c v ~eod w] encodes [v] to writer [w]. If [eod] is [true],
401
+
signals end-of-data after encoding. *)
427
402
428
-
{b For internal use by sibling libraries and tests only.} These functions
429
-
expose the intermediate [Value.t] type and are not part of the public codec
430
-
API. *)
431
-
module Private : sig
432
-
val decode_cbor : 'a t -> Value.t -> ('a, Error.t) result
433
-
(** [decode_cbor c v] decodes from a CBOR value [v]. *)
403
+
(** {1:value Pure codec operations over Value.t} *)
404
+
405
+
val decode : 'a codec -> Value.t -> ('a, Error.t) result
406
+
(** [decode c v] interprets a CBOR {!Value.t} through codec [c]. *)
407
+
408
+
val decode_exn : 'a codec -> Value.t -> 'a
409
+
(** [decode_exn c v] is like {!decode} but raises {!Loc.Error.Error}. *)
410
+
411
+
val encode : 'a codec -> 'a -> Value.t
412
+
(** [encode c v] reflects [v] through codec [c] into a CBOR {!Value.t}. *)
413
+
414
+
(** {1:patches Patch operations on {!Value.t} maps}
415
+
416
+
These operate directly on a {!Value.t} tree (they are not codecs). The codec
417
+
argument to {!update_mem} drives the round-trip on the targeted member. *)
418
+
419
+
val update_mem : string -> 'a codec -> Value.t -> (Value.t, Error.t) result
420
+
(** [update_mem name c v] decodes member [name] of map [v] through [c],
421
+
re-encodes it through [c], and returns the map with that member replaced.
422
+
Errors if [v] is not a map or if [name] is absent. *)
423
+
424
+
val update_mem_exn : string -> 'a codec -> Value.t -> Value.t
425
+
(** [update_mem_exn name c v] is {!update_mem} raising {!Loc.Error}. *)
434
426
435
-
val decode_cbor_exn : 'a t -> Value.t -> 'a
436
-
(** [decode_cbor_exn c v] is like [decode_cbor] but raises. *)
427
+
val delete_mem : string -> Value.t -> (Value.t, Error.t) result
428
+
(** [delete_mem name v] returns map [v] with member [name] removed (or unchanged
429
+
if absent). Errors if [v] is not a map. *)
437
430
438
-
val encode_cbor : 'a t -> 'a -> Value.t
439
-
(** [encode_cbor c v] encodes [v] to a [Value.t] value. *)
440
-
end
431
+
val delete_mem_exn : string -> Value.t -> Value.t
432
+
(** [delete_mem_exn name v] is {!delete_mem} raising {!Loc.Error}. *)
+1361
lib/codec.ml
+1361
lib/codec.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type 'a t = {
7
+
kind : string;
8
+
encode_rw : Binary.encoder -> 'a -> unit;
9
+
decode_rw : Loc.Context.t -> Binary.decoder -> ('a, Error.t) result;
10
+
}
11
+
12
+
let kind c = c.kind
13
+
let pp ppf c = Fmt.pf ppf "<codec:%s>" c.kind
14
+
15
+
let major_type_name = function
16
+
| 0 -> "integer"
17
+
| 1 -> "integer"
18
+
| 2 -> "bytes"
19
+
| 3 -> "text"
20
+
| 4 -> "array"
21
+
| 5 -> "map"
22
+
| 6 -> "tag"
23
+
| 7 -> "simple/float"
24
+
| _ -> "unknown"
25
+
26
+
let stream_type_error path expected (hdr : Binary.header) =
27
+
Error.type_mismatch_result path ~expected ~got:(major_type_name hdr.major)
28
+
29
+
let read_text_with_hdr dec (hdr : Binary.header) =
30
+
let arg = Binary.read_argument dec hdr in
31
+
if arg >= 0L then Binary.read_bytes dec (Int64.to_int arg)
32
+
else begin
33
+
let buf = Buffer.create 64 in
34
+
while
35
+
match Binary.peek_byte dec with
36
+
| Some 0xff ->
37
+
ignore (Binary.read_byte dec);
38
+
false
39
+
| _ -> true
40
+
do
41
+
let hdr = Binary.read_header dec in
42
+
if hdr.major <> Binary.major_text then failwith "Expected text chunk";
43
+
let len = Binary.read_argument dec hdr in
44
+
if len < 0L then failwith "Nested indefinite text";
45
+
Buffer.add_string buf (Binary.read_bytes dec (Int64.to_int len))
46
+
done;
47
+
Buffer.contents buf
48
+
end
49
+
50
+
let read_bytes_with_hdr dec (hdr : Binary.header) =
51
+
let arg = Binary.read_argument dec hdr in
52
+
if arg >= 0L then Binary.read_bytes dec (Int64.to_int arg)
53
+
else begin
54
+
let buf = Buffer.create 64 in
55
+
while
56
+
match Binary.peek_byte dec with
57
+
| Some 0xff ->
58
+
ignore (Binary.read_byte dec);
59
+
false
60
+
| _ -> true
61
+
do
62
+
let hdr = Binary.read_header dec in
63
+
if hdr.major <> Binary.major_bytes then failwith "Expected bytes chunk";
64
+
let len = Binary.read_argument dec hdr in
65
+
if len < 0L then failwith "Nested indefinite bytes";
66
+
Buffer.add_string buf (Binary.read_bytes dec (Int64.to_int len))
67
+
done;
68
+
Buffer.contents buf
69
+
end
70
+
71
+
let read_float_with_hdr dec (hdr : Binary.header) =
72
+
if hdr.info = Binary.ai_2byte then Binary.decode_half (Binary.read_u16_be dec)
73
+
else if hdr.info = Binary.ai_4byte then
74
+
Int32.float_of_bits (Binary.read_u32_be dec)
75
+
else if hdr.info = Binary.ai_8byte then
76
+
Int64.float_of_bits (Binary.read_u64_be dec)
77
+
else failwith "Expected float"
78
+
79
+
let read_int_signed_z dec (hdr : Binary.header) =
80
+
if hdr.major = 0 then Binary.read_argument_z dec hdr
81
+
else Z.neg (Z.succ (Binary.read_argument_z dec hdr))
82
+
83
+
let out_of_range path z range =
84
+
Error
85
+
(Error.v ~ctx:path (Error.Out_of_range { value = Z.to_string z; range }))
86
+
87
+
(* {1 Major type 0/1 - Integers} *)
88
+
89
+
let int =
90
+
let range = Fmt.str "[%d, %d]" min_int max_int in
91
+
{
92
+
kind = "int";
93
+
encode_rw = (fun enc n -> Binary.write_int enc n);
94
+
decode_rw =
95
+
(fun path dec ->
96
+
let hdr = Binary.read_header dec in
97
+
match hdr.major with
98
+
| 0 | 1 ->
99
+
let n = read_int_signed_z dec hdr in
100
+
if Z.fits_int n then Ok (Z.to_int n) else out_of_range path n range
101
+
| _ -> stream_type_error path "integer" hdr);
102
+
}
103
+
104
+
let int32 =
105
+
let range = Fmt.str "[%ld, %ld]" Int32.min_int Int32.max_int in
106
+
{
107
+
kind = "int32";
108
+
encode_rw = (fun enc n -> Binary.write_int64 enc (Int64.of_int32 n));
109
+
decode_rw =
110
+
(fun path dec ->
111
+
let hdr = Binary.read_header dec in
112
+
match hdr.major with
113
+
| 0 | 1 ->
114
+
let n = read_int_signed_z dec hdr in
115
+
if
116
+
Z.geq n (Z.of_int32 Int32.min_int)
117
+
&& Z.leq n (Z.of_int32 Int32.max_int)
118
+
then Ok (Z.to_int32 n)
119
+
else out_of_range path n range
120
+
| _ -> stream_type_error path "integer" hdr);
121
+
}
122
+
123
+
let int64 =
124
+
let range = Fmt.str "[%Ld, %Ld]" Int64.min_int Int64.max_int in
125
+
{
126
+
kind = "int64";
127
+
encode_rw = (fun enc n -> Binary.write_int64 enc n);
128
+
decode_rw =
129
+
(fun path dec ->
130
+
let hdr = Binary.read_header dec in
131
+
match hdr.major with
132
+
| 0 | 1 ->
133
+
let n = read_int_signed_z dec hdr in
134
+
if Z.fits_int64 n then Ok (Z.to_int64 n)
135
+
else out_of_range path n range
136
+
| _ -> stream_type_error path "integer" hdr);
137
+
}
138
+
139
+
let uint =
140
+
let range = Fmt.str "[0, %d]" max_int in
141
+
{
142
+
kind = "uint";
143
+
encode_rw =
144
+
(fun enc n ->
145
+
if n < 0 then Fmt.invalid_arg "uint encode: negative value %d" n;
146
+
Binary.write_int enc n);
147
+
decode_rw =
148
+
(fun path dec ->
149
+
let hdr = Binary.read_header dec in
150
+
match hdr.major with
151
+
| 0 ->
152
+
let n = Binary.read_argument_z dec hdr in
153
+
if Z.fits_int n then Ok (Z.to_int n) else out_of_range path n range
154
+
| 1 ->
155
+
let n = Z.neg (Z.succ (Binary.read_argument_z dec hdr)) in
156
+
out_of_range path n range
157
+
| _ -> stream_type_error path "integer" hdr);
158
+
}
159
+
160
+
let uint32 =
161
+
let range = "[0, 4294967295]" in
162
+
let max_uint32 = Z.of_string "4294967295" in
163
+
{
164
+
kind = "uint32";
165
+
encode_rw =
166
+
(fun enc n ->
167
+
if Int32.compare n 0l < 0 then
168
+
Fmt.invalid_arg "uint32 encode: negative value %ld" n;
169
+
Binary.write_int64 enc (Int64.of_int32 n));
170
+
decode_rw =
171
+
(fun path dec ->
172
+
let hdr = Binary.read_header dec in
173
+
match hdr.major with
174
+
| 0 | 1 ->
175
+
let n = read_int_signed_z dec hdr in
176
+
if Z.sign n >= 0 && Z.leq n max_uint32 then Ok (Z.to_int32 n)
177
+
else out_of_range path n range
178
+
| _ -> stream_type_error path "integer" hdr);
179
+
}
180
+
181
+
let uint64 =
182
+
let range = "[0, 2^63-1]" in
183
+
{
184
+
kind = "uint64";
185
+
encode_rw =
186
+
(fun enc n ->
187
+
if Int64.compare n 0L < 0 then
188
+
Fmt.invalid_arg "uint64 encode: negative value %Ld" n;
189
+
Binary.write_int64 enc n);
190
+
decode_rw =
191
+
(fun path dec ->
192
+
let hdr = Binary.read_header dec in
193
+
match hdr.major with
194
+
| 0 | 1 ->
195
+
let n = read_int_signed_z dec hdr in
196
+
if Z.sign n >= 0 && Z.fits_int64 n then Ok (Z.to_int64 n)
197
+
else out_of_range path n range
198
+
| _ -> stream_type_error path "integer" hdr);
199
+
}
200
+
201
+
(* {1 Major type 2 - Byte string} *)
202
+
203
+
let bytes =
204
+
{
205
+
kind = "bytes";
206
+
encode_rw = (fun enc s -> Binary.write_bytes_data enc s);
207
+
decode_rw =
208
+
(fun path dec ->
209
+
let hdr = Binary.read_header dec in
210
+
if hdr.major = Binary.major_bytes then Ok (read_bytes_with_hdr dec hdr)
211
+
else stream_type_error path "bytes" hdr);
212
+
}
213
+
214
+
(* {1 Major type 3 - Text string} *)
215
+
216
+
let text =
217
+
{
218
+
kind = "text";
219
+
encode_rw = (fun enc s -> Binary.write_text enc s);
220
+
decode_rw =
221
+
(fun path dec ->
222
+
let hdr = Binary.read_header dec in
223
+
if hdr.major = Binary.major_text then Ok (read_text_with_hdr dec hdr)
224
+
else stream_type_error path "text" hdr);
225
+
}
226
+
227
+
(* {1 Major type 4 - Array} *)
228
+
229
+
let read_array_length_rw path dec =
230
+
let hdr = Binary.read_header dec in
231
+
if hdr.major <> Binary.major_array then
232
+
Error (stream_type_error path "array" hdr)
233
+
else
234
+
let arg = Binary.read_argument dec hdr in
235
+
if arg < 0L then Ok None else Ok (Some (Int64.to_int arg))
236
+
237
+
let decode_array_elements_rw c path dec n =
238
+
let rec loop i acc =
239
+
if i >= n then Ok (List.rev acc)
240
+
else
241
+
let path' = Error.ctx_with_index i path in
242
+
match c.decode_rw path' dec with
243
+
| Ok v -> loop (i + 1) (v :: acc)
244
+
| Error e -> Error e
245
+
in
246
+
loop 0 []
247
+
248
+
let decode_array_indef_rw c path dec =
249
+
let rec loop i acc =
250
+
if Binary.is_break dec then (
251
+
Binary.skip_break dec;
252
+
Ok (List.rev acc))
253
+
else
254
+
let path' = Error.ctx_with_index i path in
255
+
match c.decode_rw path' dec with
256
+
| Ok v -> loop (i + 1) (v :: acc)
257
+
| Error e -> Error e
258
+
in
259
+
loop 0 []
260
+
261
+
let array c =
262
+
{
263
+
kind = Fmt.str "array(%s)" c.kind;
264
+
encode_rw =
265
+
(fun enc items ->
266
+
Binary.write_array_start enc (List.length items);
267
+
List.iter (fun x -> c.encode_rw enc x) items);
268
+
decode_rw =
269
+
(fun path dec ->
270
+
match read_array_length_rw path dec with
271
+
| Error e -> e
272
+
| Ok (Some n) -> decode_array_elements_rw c path dec n
273
+
| Ok None -> decode_array_indef_rw c path dec);
274
+
}
275
+
276
+
let array_of ~len c =
277
+
{
278
+
kind = Fmt.str "array_of(%d, %s)" len c.kind;
279
+
encode_rw =
280
+
(fun enc items ->
281
+
if List.length items <> len then
282
+
Fmt.failwith "Expected array of length %d" len;
283
+
Binary.write_array_start enc len;
284
+
List.iter (fun x -> c.encode_rw enc x) items);
285
+
decode_rw =
286
+
(fun path dec ->
287
+
match read_array_length_rw path dec with
288
+
| Error e -> e
289
+
| Ok (Some n) when n = len -> decode_array_elements_rw c path dec n
290
+
| Ok (Some n) ->
291
+
for _ = 1 to n do
292
+
Binary.skip dec
293
+
done;
294
+
Error
295
+
(Error.v ~ctx:path
296
+
(Error.Invalid_value
297
+
(Fmt.str "expected array of length %d, got %d" len n)))
298
+
| Ok None -> (
299
+
match decode_array_indef_rw c path dec with
300
+
| Ok items when List.length items = len -> Ok items
301
+
| Ok items ->
302
+
Error
303
+
(Error.v ~ctx:path
304
+
(Error.Invalid_value
305
+
(Fmt.str "expected array of length %d, got %d" len
306
+
(List.length items))))
307
+
| Error e -> Error e));
308
+
}
309
+
310
+
let tuple2 ca cb =
311
+
{
312
+
kind = Fmt.str "tuple2(%s, %s)" ca.kind cb.kind;
313
+
encode_rw =
314
+
(fun enc (a, b) ->
315
+
Binary.write_array_start enc 2;
316
+
ca.encode_rw enc a;
317
+
cb.encode_rw enc b);
318
+
decode_rw =
319
+
(fun path dec ->
320
+
match read_array_length_rw path dec with
321
+
| Error e -> e
322
+
| Ok (Some 2) -> (
323
+
match ca.decode_rw (Error.ctx_with_index 0 path) dec with
324
+
| Error e -> Error e
325
+
| Ok a -> (
326
+
match cb.decode_rw (Error.ctx_with_index 1 path) dec with
327
+
| Error e -> Error e
328
+
| Ok b -> Ok (a, b)))
329
+
| Ok (Some _) | Ok None ->
330
+
Error
331
+
(Error.v ~ctx:path
332
+
(Error.Invalid_value "expected 2-element array")));
333
+
}
334
+
335
+
let tuple3 ca cb cc =
336
+
{
337
+
kind = Fmt.str "tuple3(%s, %s, %s)" ca.kind cb.kind cc.kind;
338
+
encode_rw =
339
+
(fun enc (a, b, c) ->
340
+
Binary.write_array_start enc 3;
341
+
ca.encode_rw enc a;
342
+
cb.encode_rw enc b;
343
+
cc.encode_rw enc c);
344
+
decode_rw =
345
+
(fun path dec ->
346
+
match read_array_length_rw path dec with
347
+
| Error e -> e
348
+
| Ok (Some 3) -> (
349
+
match ca.decode_rw (Error.ctx_with_index 0 path) dec with
350
+
| Error e -> Error e
351
+
| Ok a -> (
352
+
match cb.decode_rw (Error.ctx_with_index 1 path) dec with
353
+
| Error e -> Error e
354
+
| Ok b -> (
355
+
match cc.decode_rw (Error.ctx_with_index 2 path) dec with
356
+
| Error e -> Error e
357
+
| Ok c -> Ok (a, b, c))))
358
+
| Ok (Some _) | Ok None ->
359
+
Error
360
+
(Error.v ~ctx:path
361
+
(Error.Invalid_value "expected 3-element array")));
362
+
}
363
+
364
+
let tuple4 ca cb cc cd =
365
+
let bad_arity path =
366
+
Error (Error.v ~ctx:path (Error.Invalid_value "expected 4-element array"))
367
+
in
368
+
{
369
+
kind = Fmt.str "tuple4(%s, %s, %s, %s)" ca.kind cb.kind cc.kind cd.kind;
370
+
encode_rw =
371
+
(fun enc (a, b, c, d) ->
372
+
Binary.write_array_start enc 4;
373
+
ca.encode_rw enc a;
374
+
cb.encode_rw enc b;
375
+
cc.encode_rw enc c;
376
+
cd.encode_rw enc d);
377
+
decode_rw =
378
+
(fun path dec ->
379
+
match read_array_length_rw path dec with
380
+
| Error e -> e
381
+
| Ok (Some 4) -> (
382
+
match ca.decode_rw (Error.ctx_with_index 0 path) dec with
383
+
| Error e -> Error e
384
+
| Ok a -> (
385
+
match cb.decode_rw (Error.ctx_with_index 1 path) dec with
386
+
| Error e -> Error e
387
+
| Ok b -> (
388
+
match cc.decode_rw (Error.ctx_with_index 2 path) dec with
389
+
| Error e -> Error e
390
+
| Ok c -> (
391
+
match
392
+
cd.decode_rw (Error.ctx_with_index 3 path) dec
393
+
with
394
+
| Error e -> Error e
395
+
| Ok d -> Ok (a, b, c, d)))))
396
+
| Ok (Some _) | Ok None -> bad_arity path);
397
+
}
398
+
399
+
(* {1 Major type 5 - Map} *)
400
+
401
+
let read_map_length_rw path dec =
402
+
let hdr = Binary.read_header dec in
403
+
if hdr.major <> Binary.major_map then Error (stream_type_error path "map" hdr)
404
+
else
405
+
let arg = Binary.read_argument dec hdr in
406
+
if arg < 0L then Ok None else Ok (Some (Int64.to_int arg))
407
+
408
+
let assoc kc vc =
409
+
{
410
+
kind = Fmt.str "assoc(%s, %s)" kc.kind vc.kind;
411
+
encode_rw =
412
+
(fun enc pairs ->
413
+
Binary.write_map_start enc (List.length pairs);
414
+
List.iter
415
+
(fun (k, v) ->
416
+
kc.encode_rw enc k;
417
+
vc.encode_rw enc v)
418
+
pairs);
419
+
decode_rw =
420
+
(fun path dec ->
421
+
match read_map_length_rw path dec with
422
+
| Error e -> e
423
+
| Ok len_opt ->
424
+
let n = match len_opt with Some n -> n | None -> max_int in
425
+
let rec loop i acc =
426
+
if i >= n then Ok (List.rev acc)
427
+
else if len_opt = None && Binary.is_break dec then (
428
+
Binary.skip_break dec;
429
+
Ok (List.rev acc))
430
+
else
431
+
match kc.decode_rw path dec with
432
+
| Error e -> Error e
433
+
| Ok k -> (
434
+
match vc.decode_rw path dec with
435
+
| Error e -> Error e
436
+
| Ok v -> loop (i + 1) ((k, v) :: acc))
437
+
in
438
+
loop 0 []);
439
+
}
440
+
441
+
let text_map vc = assoc text vc
442
+
let int_map vc = assoc int vc
443
+
444
+
(* Records as text-keyed maps. Curried-constructor pipeline. The per-field
445
+
[Stdlib.Obj.repr]/[Stdlib.Obj.obj] is a universal-table erasure (not
446
+
[Obj.magic]): each field's known static type drives both halves of the
447
+
coercion, so the per-decode value table is type-safe by construction. *)
448
+
module Map = struct
449
+
type 'o field = {
450
+
name : string;
451
+
present : 'o -> bool;
452
+
encode_rw : Binary.encoder -> 'o -> unit;
453
+
decode_rw :
454
+
Loc.Context.t -> Binary.decoder -> (Stdlib.Obj.t, Error.t) result;
455
+
decode_missing : (Stdlib.Obj.t, string) result;
456
+
}
457
+
458
+
type ('o, 'dec) mem = {
459
+
fields : 'o field list;
460
+
build : (string -> Stdlib.Obj.t) -> 'dec;
461
+
}
462
+
463
+
let map ctor = { fields = []; build = (fun _ -> ctor) }
464
+
465
+
let mem (type o a b) name (get : o -> a) (codec : a t) (m : (o, a -> b) mem) :
466
+
(o, b) mem =
467
+
let present _ = true in
468
+
let encode_rw enc o = codec.encode_rw enc (get o) in
469
+
let decode_rw ctx dec =
470
+
let path' = Error.ctx_with_key name ctx in
471
+
match codec.decode_rw path' dec with
472
+
| Ok x -> Ok (Stdlib.Obj.repr x)
473
+
| Error e -> Error e
474
+
in
475
+
let field =
476
+
{ name; present; encode_rw; decode_rw; decode_missing = Error name }
477
+
in
478
+
{
479
+
fields = m.fields @ [ field ];
480
+
build =
481
+
(fun lookup ->
482
+
let f = m.build lookup in
483
+
let v : a = Stdlib.Obj.obj (lookup name) in
484
+
f v);
485
+
}
486
+
487
+
let mem_opt (type o a b) name (get : o -> a option) (codec : a t)
488
+
(m : (o, a option -> b) mem) : (o, b) mem =
489
+
let none_obj : Stdlib.Obj.t = Stdlib.Obj.repr (None : a option) in
490
+
let present o = match get o with Some _ -> true | None -> false in
491
+
let encode_rw enc o =
492
+
match get o with None -> () | Some x -> codec.encode_rw enc x
493
+
in
494
+
let decode_rw ctx dec =
495
+
match Binary.peek_byte dec with
496
+
| Some b
497
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
498
+
->
499
+
ignore (Binary.read_byte dec);
500
+
Ok none_obj
501
+
| _ -> (
502
+
let path' = Error.ctx_with_key name ctx in
503
+
match codec.decode_rw path' dec with
504
+
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
505
+
| Error e -> Error e)
506
+
in
507
+
let field =
508
+
{ name; present; encode_rw; decode_rw; decode_missing = Ok none_obj }
509
+
in
510
+
{
511
+
fields = m.fields @ [ field ];
512
+
build =
513
+
(fun lookup ->
514
+
let f = m.build lookup in
515
+
let v : a option = Stdlib.Obj.obj (lookup name) in
516
+
f v);
517
+
}
518
+
519
+
let mem_default (type o a b) name (get : o -> a) ~(default : a) (codec : a t)
520
+
(m : (o, a -> b) mem) : (o, b) mem =
521
+
let default_obj : Stdlib.Obj.t = Stdlib.Obj.repr default in
522
+
let present _ = true in
523
+
let encode_rw enc o = codec.encode_rw enc (get o) in
524
+
let decode_rw ctx dec =
525
+
match Binary.peek_byte dec with
526
+
| Some b
527
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
528
+
->
529
+
ignore (Binary.read_byte dec);
530
+
Ok default_obj
531
+
| _ -> (
532
+
let path' = Error.ctx_with_key name ctx in
533
+
match codec.decode_rw path' dec with
534
+
| Ok x -> Ok (Stdlib.Obj.repr x)
535
+
| Error e -> Error e)
536
+
in
537
+
let field =
538
+
{ name; present; encode_rw; decode_rw; decode_missing = Ok default_obj }
539
+
in
540
+
{
541
+
fields = m.fields @ [ field ];
542
+
build =
543
+
(fun lookup ->
544
+
let f = m.build lookup in
545
+
let v : a = Stdlib.Obj.obj (lookup name) in
546
+
f v);
547
+
}
548
+
549
+
let seal (type o) (m : (o, o) mem) : o t =
550
+
let names = List.map (fun (f : o field) -> f.name) m.fields in
551
+
let kind = Fmt.str "map({%s})" (String.concat ", " names) in
552
+
let by_name : (string, o field) Hashtbl.t =
553
+
Hashtbl.create (List.length m.fields)
554
+
in
555
+
List.iter (fun (f : o field) -> Hashtbl.replace by_name f.name f) m.fields;
556
+
let lookup_or_fail path tbl =
557
+
let lookup name =
558
+
match Hashtbl.find_opt tbl name with
559
+
| Some v -> v
560
+
| None ->
561
+
Stdlib.invalid_arg
562
+
(Fmt.str "Cbor.Codec.Map.seal: missing %s for %a" name
563
+
Loc.Context.pp path)
564
+
in
565
+
lookup
566
+
in
567
+
let encode_rw enc o =
568
+
let present_fields =
569
+
List.filter (fun (f : o field) -> f.present o) m.fields
570
+
in
571
+
Binary.write_map_start enc (List.length present_fields);
572
+
List.iter
573
+
(fun (f : o field) ->
574
+
Binary.write_text enc f.name;
575
+
f.encode_rw enc o)
576
+
present_fields
577
+
in
578
+
let decode_rw path dec =
579
+
match read_map_length_rw path dec with
580
+
| Error e -> e
581
+
| Ok len_opt -> (
582
+
let results = Hashtbl.create (List.length m.fields) in
583
+
let n = match len_opt with Some n -> n | None -> max_int in
584
+
let rec read i =
585
+
if i >= n then Ok ()
586
+
else if len_opt = None && Binary.is_break dec then (
587
+
Binary.skip_break dec;
588
+
Ok ())
589
+
else
590
+
match Binary.peek_byte dec with
591
+
| Some b when b lsr 5 = Binary.major_text -> (
592
+
let key = Binary.read_text dec in
593
+
match Hashtbl.find_opt by_name key with
594
+
| Some f -> (
595
+
match f.decode_rw path dec with
596
+
| Error e -> Error e
597
+
| Ok obj ->
598
+
Hashtbl.replace results key obj;
599
+
read (i + 1))
600
+
| None ->
601
+
Binary.skip dec;
602
+
read (i + 1))
603
+
| _ ->
604
+
Binary.skip dec;
605
+
Binary.skip dec;
606
+
read (i + 1)
607
+
in
608
+
match read 0 with
609
+
| Error e -> Error e
610
+
| Ok () -> (
611
+
let missing =
612
+
List.find_map
613
+
(fun (f : o field) ->
614
+
if Hashtbl.mem results f.name then None
615
+
else
616
+
match f.decode_missing with
617
+
| Ok obj ->
618
+
Hashtbl.replace results f.name obj;
619
+
None
620
+
| Error name -> Some name)
621
+
m.fields
622
+
in
623
+
match missing with
624
+
| Some name ->
625
+
Error (Error.v ~ctx:path (Error.Missing_member name))
626
+
| None -> Ok (m.build (lookup_or_fail path results))))
627
+
in
628
+
{ kind; encode_rw; decode_rw }
629
+
end
630
+
631
+
(* Records as integer-keyed maps. Mirrors {!Map} but indexes fields by integer
632
+
keys (the COSE / CWT layout). *)
633
+
module Map_int = struct
634
+
type 'o field = {
635
+
key : int;
636
+
present : 'o -> bool;
637
+
encode_rw : Binary.encoder -> 'o -> unit;
638
+
decode_rw :
639
+
Loc.Context.t -> Binary.decoder -> (Stdlib.Obj.t, Error.t) result;
640
+
decode_missing : (Stdlib.Obj.t, int) result;
641
+
}
642
+
643
+
type ('o, 'dec) mem = {
644
+
fields : 'o field list;
645
+
build : (int -> Stdlib.Obj.t) -> 'dec;
646
+
}
647
+
648
+
let map ctor = { fields = []; build = (fun _ -> ctor) }
649
+
650
+
let mem (type o a b) key (get : o -> a) (codec : a t) (m : (o, a -> b) mem) :
651
+
(o, b) mem =
652
+
let key_str = string_of_int key in
653
+
let present _ = true in
654
+
let encode_rw enc o = codec.encode_rw enc (get o) in
655
+
let decode_rw ctx dec =
656
+
let path' = Error.ctx_with_key key_str ctx in
657
+
match codec.decode_rw path' dec with
658
+
| Ok x -> Ok (Stdlib.Obj.repr x)
659
+
| Error e -> Error e
660
+
in
661
+
let field =
662
+
{ key; present; encode_rw; decode_rw; decode_missing = Error key }
663
+
in
664
+
{
665
+
fields = m.fields @ [ field ];
666
+
build =
667
+
(fun lookup ->
668
+
let f = m.build lookup in
669
+
let v : a = Stdlib.Obj.obj (lookup key) in
670
+
f v);
671
+
}
672
+
673
+
let mem_opt (type o a b) key (get : o -> a option) (codec : a t)
674
+
(m : (o, a option -> b) mem) : (o, b) mem =
675
+
let key_str = string_of_int key in
676
+
let none_obj : Stdlib.Obj.t = Stdlib.Obj.repr (None : a option) in
677
+
let present o = match get o with Some _ -> true | None -> false in
678
+
let encode_rw enc o =
679
+
match get o with None -> () | Some x -> codec.encode_rw enc x
680
+
in
681
+
let decode_rw ctx dec =
682
+
match Binary.peek_byte dec with
683
+
| Some b
684
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
685
+
->
686
+
ignore (Binary.read_byte dec);
687
+
Ok none_obj
688
+
| _ -> (
689
+
let path' = Error.ctx_with_key key_str ctx in
690
+
match codec.decode_rw path' dec with
691
+
| Ok x -> Ok (Stdlib.Obj.repr (Some x : a option))
692
+
| Error e -> Error e)
693
+
in
694
+
let field =
695
+
{ key; present; encode_rw; decode_rw; decode_missing = Ok none_obj }
696
+
in
697
+
{
698
+
fields = m.fields @ [ field ];
699
+
build =
700
+
(fun lookup ->
701
+
let f = m.build lookup in
702
+
let v : a option = Stdlib.Obj.obj (lookup key) in
703
+
f v);
704
+
}
705
+
706
+
let mem_default (type o a b) key (get : o -> a) ~(default : a) (codec : a t)
707
+
(m : (o, a -> b) mem) : (o, b) mem =
708
+
let key_str = string_of_int key in
709
+
let default_obj : Stdlib.Obj.t = Stdlib.Obj.repr default in
710
+
let present _ = true in
711
+
let encode_rw enc o = codec.encode_rw enc (get o) in
712
+
let decode_rw ctx dec =
713
+
match Binary.peek_byte dec with
714
+
| Some b
715
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
716
+
->
717
+
ignore (Binary.read_byte dec);
718
+
Ok default_obj
719
+
| _ -> (
720
+
let path' = Error.ctx_with_key key_str ctx in
721
+
match codec.decode_rw path' dec with
722
+
| Ok x -> Ok (Stdlib.Obj.repr x)
723
+
| Error e -> Error e)
724
+
in
725
+
let field =
726
+
{ key; present; encode_rw; decode_rw; decode_missing = Ok default_obj }
727
+
in
728
+
{
729
+
fields = m.fields @ [ field ];
730
+
build =
731
+
(fun lookup ->
732
+
let f = m.build lookup in
733
+
let v : a = Stdlib.Obj.obj (lookup key) in
734
+
f v);
735
+
}
736
+
737
+
let read_int_key dec =
738
+
let key_hdr = Binary.read_header dec in
739
+
if key_hdr.major = 0 || key_hdr.major = 1 then
740
+
let kz = read_int_signed_z dec key_hdr in
741
+
if Z.fits_int kz then Some (Z.to_int kz) else None
742
+
else None
743
+
744
+
let seal (type o) (m : (o, o) mem) : o t =
745
+
let keys = List.map (fun (f : o field) -> f.key) m.fields in
746
+
let kind =
747
+
Fmt.str "map_int({%s})" (String.concat ", " (List.map string_of_int keys))
748
+
in
749
+
let by_key : (int, o field) Hashtbl.t =
750
+
Hashtbl.create (List.length m.fields)
751
+
in
752
+
List.iter (fun (f : o field) -> Hashtbl.replace by_key f.key f) m.fields;
753
+
let lookup_or_fail path tbl =
754
+
let lookup key =
755
+
match Hashtbl.find_opt tbl key with
756
+
| Some v -> v
757
+
| None ->
758
+
Stdlib.invalid_arg
759
+
(Fmt.str "Cbor.Codec.Map_int.seal: missing %d for %a" key
760
+
Loc.Context.pp path)
761
+
in
762
+
lookup
763
+
in
764
+
let encode_rw enc o =
765
+
let present_fields =
766
+
List.filter (fun (f : o field) -> f.present o) m.fields
767
+
in
768
+
Binary.write_map_start enc (List.length present_fields);
769
+
List.iter
770
+
(fun (f : o field) ->
771
+
Binary.write_int enc f.key;
772
+
f.encode_rw enc o)
773
+
present_fields
774
+
in
775
+
let decode_rw path dec =
776
+
match read_map_length_rw path dec with
777
+
| Error e -> e
778
+
| Ok len_opt -> (
779
+
let results = Hashtbl.create (List.length m.fields) in
780
+
let n = match len_opt with Some n -> n | None -> max_int in
781
+
let rec read i =
782
+
if i >= n then Ok ()
783
+
else if len_opt = None && Binary.is_break dec then (
784
+
Binary.skip_break dec;
785
+
Ok ())
786
+
else
787
+
match Binary.peek_byte dec with
788
+
| Some b
789
+
when b lsr 5 = Binary.major_uint || b lsr 5 = Binary.major_nint
790
+
-> (
791
+
match read_int_key dec with
792
+
| Some key -> (
793
+
match Hashtbl.find_opt by_key key with
794
+
| Some f -> (
795
+
match f.decode_rw path dec with
796
+
| Error e -> Error e
797
+
| Ok obj ->
798
+
Hashtbl.replace results key obj;
799
+
read (i + 1))
800
+
| None ->
801
+
Binary.skip dec;
802
+
read (i + 1))
803
+
| None ->
804
+
Binary.skip dec;
805
+
read (i + 1))
806
+
| _ ->
807
+
Binary.skip dec;
808
+
Binary.skip dec;
809
+
read (i + 1)
810
+
in
811
+
match read 0 with
812
+
| Error e -> Error e
813
+
| Ok () -> (
814
+
let missing =
815
+
List.find_map
816
+
(fun (f : o field) ->
817
+
if Hashtbl.mem results f.key then None
818
+
else
819
+
match f.decode_missing with
820
+
| Ok obj ->
821
+
Hashtbl.replace results f.key obj;
822
+
None
823
+
| Error key -> Some key)
824
+
m.fields
825
+
in
826
+
match missing with
827
+
| Some key ->
828
+
Error
829
+
(Error.v ~ctx:path
830
+
(Error.Missing_member (string_of_int key)))
831
+
| None -> Ok (m.build (lookup_or_fail path results))))
832
+
in
833
+
{ kind; encode_rw; decode_rw }
834
+
end
835
+
836
+
(* {1 Major type 6 - Tag} *)
837
+
838
+
let tag n c =
839
+
{
840
+
kind = Fmt.str "tag(%d, %s)" n c.kind;
841
+
encode_rw =
842
+
(fun enc v ->
843
+
Binary.write_tag enc n;
844
+
c.encode_rw enc v);
845
+
decode_rw =
846
+
(fun path dec ->
847
+
let hdr = Binary.read_header dec in
848
+
if hdr.major = Binary.major_tag then
849
+
let m = Int64.to_int (Binary.read_argument dec hdr) in
850
+
if m = n then c.decode_rw (Error.ctx_with_tag n path) dec
851
+
else
852
+
Error
853
+
(Error.v ~ctx:path
854
+
(Error.Invalid_value
855
+
(Fmt.str "expected tag %d, got tag %d" n m)))
856
+
else stream_type_error path (Fmt.str "tag(%d)" n) hdr);
857
+
}
858
+
859
+
let tag_opt n c =
860
+
{
861
+
kind = Fmt.str "tag_opt(%d, %s)" n c.kind;
862
+
encode_rw =
863
+
(fun enc v ->
864
+
Binary.write_tag enc n;
865
+
c.encode_rw enc v);
866
+
decode_rw =
867
+
(fun path dec ->
868
+
match Binary.peek_byte dec with
869
+
| Some b when b lsr 5 = Binary.major_tag ->
870
+
let hdr = Binary.read_header dec in
871
+
let m = Int64.to_int (Binary.read_argument dec hdr) in
872
+
if m = n then c.decode_rw (Error.ctx_with_tag n path) dec
873
+
else c.decode_rw path dec
874
+
| _ -> c.decode_rw path dec);
875
+
}
876
+
877
+
(* {1 Major type 7 - Floats and simple values} *)
878
+
879
+
let null =
880
+
{
881
+
kind = "null";
882
+
encode_rw = (fun enc () -> Binary.write_null enc);
883
+
decode_rw =
884
+
(fun path dec ->
885
+
let hdr = Binary.read_header dec in
886
+
if hdr.major = Binary.major_simple && hdr.info = Binary.simple_null then
887
+
Ok ()
888
+
else stream_type_error path "null" hdr);
889
+
}
890
+
891
+
let bool =
892
+
{
893
+
kind = "bool";
894
+
encode_rw = (fun enc b -> Binary.write_bool enc b);
895
+
decode_rw =
896
+
(fun path dec ->
897
+
let hdr = Binary.read_header dec in
898
+
if hdr.major = Binary.major_simple && hdr.info = Binary.simple_false
899
+
then Ok false
900
+
else if hdr.major = Binary.major_simple && hdr.info = Binary.simple_true
901
+
then Ok true
902
+
else stream_type_error path "boolean" hdr);
903
+
}
904
+
905
+
let float =
906
+
{
907
+
kind = "float";
908
+
encode_rw = (fun enc f -> Binary.write_float enc f);
909
+
decode_rw =
910
+
(fun path dec ->
911
+
let hdr = Binary.read_header dec in
912
+
match hdr.major with
913
+
| 7 -> Ok (read_float_with_hdr dec hdr)
914
+
| 0 -> Ok (Z.to_float (Binary.read_argument_z dec hdr))
915
+
| 1 -> Ok (Z.to_float (Z.neg (Z.succ (Binary.read_argument_z dec hdr))))
916
+
| _ -> stream_type_error path "float" hdr);
917
+
}
918
+
919
+
(* {1 Codec transformations} *)
920
+
921
+
let map decode_f encode_f c =
922
+
{
923
+
kind = Fmt.str "map(%s)" c.kind;
924
+
encode_rw = (fun enc v -> c.encode_rw enc (encode_f v));
925
+
decode_rw =
926
+
(fun path dec ->
927
+
match c.decode_rw path dec with
928
+
| Error e -> Error e
929
+
| Ok x -> Ok (decode_f x));
930
+
}
931
+
932
+
let conv decode_f encode_f c =
933
+
{
934
+
kind = Fmt.str "conv(%s)" c.kind;
935
+
encode_rw = (fun enc v -> c.encode_rw enc (encode_f v));
936
+
decode_rw =
937
+
(fun path dec ->
938
+
match c.decode_rw path dec with
939
+
| Error e -> Error e
940
+
| Ok x -> (
941
+
match decode_f x with
942
+
| Ok y -> Ok y
943
+
| Error msg -> Error (Error.v ~ctx:path (Error.Custom msg))));
944
+
}
945
+
946
+
let const v c =
947
+
{
948
+
kind = Fmt.str "const(%s)" c.kind;
949
+
encode_rw = (fun enc _ -> c.encode_rw enc ());
950
+
decode_rw =
951
+
(fun path dec ->
952
+
match c.decode_rw path dec with Error e -> Error e | Ok () -> Ok v);
953
+
}
954
+
955
+
let nullable c =
956
+
{
957
+
kind = Fmt.str "nullable(%s)" c.kind;
958
+
encode_rw =
959
+
(fun enc opt ->
960
+
match opt with
961
+
| None -> Binary.write_null enc
962
+
| Some x -> c.encode_rw enc x);
963
+
decode_rw =
964
+
(fun path dec ->
965
+
match Binary.peek_byte dec with
966
+
| Some b
967
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
968
+
->
969
+
ignore (Binary.read_byte dec);
970
+
Ok None
971
+
| _ -> Result.map Option.some (c.decode_rw path dec));
972
+
}
973
+
974
+
let option ~default c =
975
+
{
976
+
kind = Fmt.str "option(%s)" c.kind;
977
+
encode_rw = (fun enc v -> c.encode_rw enc v);
978
+
decode_rw =
979
+
(fun path dec ->
980
+
match Binary.peek_byte dec with
981
+
| Some b
982
+
when b lsr 5 = Binary.major_simple && b land 0x1f = Binary.simple_null
983
+
->
984
+
ignore (Binary.read_byte dec);
985
+
Ok default
986
+
| _ -> c.decode_rw path dec);
987
+
}
988
+
989
+
let number = float
990
+
991
+
let fix f =
992
+
let rec self =
993
+
lazy
994
+
(f
995
+
{
996
+
kind = "fix";
997
+
encode_rw = (fun enc v -> (Lazy.force self).encode_rw enc v);
998
+
decode_rw = (fun path dec -> (Lazy.force self).decode_rw path dec);
999
+
})
1000
+
in
1001
+
Lazy.force self
1002
+
1003
+
(* {1 Sum types - Tag-discriminated variants} *)
1004
+
1005
+
module Variant = struct
1006
+
type 'a case =
1007
+
| Case : int * 'b t * ('b -> 'a) * ('a -> 'b option) -> 'a case
1008
+
| Case0 : int * 'a * ('a -> bool) -> 'a case
1009
+
1010
+
let case tag c inject project = Case (tag, c, inject, project)
1011
+
let case0 tag v is_v = Case0 (tag, v, is_v)
1012
+
1013
+
let variant cases =
1014
+
{
1015
+
kind = "variant";
1016
+
encode_rw =
1017
+
(fun enc v ->
1018
+
let rec find = function
1019
+
| [] -> failwith "No matching variant case for encoding"
1020
+
| Case (tag, c, _, project) :: rest -> (
1021
+
match project v with
1022
+
| Some x ->
1023
+
Binary.write_tag enc tag;
1024
+
c.encode_rw enc x
1025
+
| None -> find rest)
1026
+
| Case0 (tag, _, is_v) :: rest ->
1027
+
if is_v v then begin
1028
+
Binary.write_tag enc tag;
1029
+
Binary.write_null enc
1030
+
end
1031
+
else find rest
1032
+
in
1033
+
find cases);
1034
+
decode_rw =
1035
+
(fun path dec ->
1036
+
let hdr = Binary.read_header dec in
1037
+
if hdr.major <> Binary.major_tag then stream_type_error path "tag" hdr
1038
+
else
1039
+
let tag = Int64.to_int (Binary.read_argument dec hdr) in
1040
+
let rec try_cases = function
1041
+
| [] ->
1042
+
Binary.skip dec;
1043
+
Error
1044
+
(Error.v ~ctx:path
1045
+
(Error.Invalid_value
1046
+
(Fmt.str "unknown tag %d in variant" tag)))
1047
+
| Case (t, c, inject, _) :: _rest when t = tag -> (
1048
+
match c.decode_rw (Error.ctx_with_tag t path) dec with
1049
+
| Error e -> Error e
1050
+
| Ok x -> Ok (inject x))
1051
+
| Case0 (t, v, _) :: _ when t = tag ->
1052
+
Binary.skip dec;
1053
+
Ok v
1054
+
| _ :: rest -> try_cases rest
1055
+
in
1056
+
try_cases cases);
1057
+
}
1058
+
end
1059
+
1060
+
(* {1 Sum types - Singleton-map variants} *)
1061
+
1062
+
module Variant_key = struct
1063
+
type 'a case =
1064
+
| Case : string * 'b t * ('b -> 'a) * ('a -> 'b option) -> 'a case
1065
+
| Case0 : string * 'a * ('a -> bool) -> 'a case
1066
+
1067
+
let case key c inject project = Case (key, c, inject, project)
1068
+
let case0 key v is_v = Case0 (key, v, is_v)
1069
+
1070
+
let variant cases =
1071
+
{
1072
+
kind = "variant_key";
1073
+
encode_rw =
1074
+
(fun enc v ->
1075
+
let rec find = function
1076
+
| [] -> failwith "No matching variant case for encoding"
1077
+
| Case (key, c, _, project) :: rest -> (
1078
+
match project v with
1079
+
| Some x ->
1080
+
Binary.write_map_start enc 1;
1081
+
Binary.write_text enc key;
1082
+
c.encode_rw enc x
1083
+
| None -> find rest)
1084
+
| Case0 (key, _, is_v) :: rest ->
1085
+
if is_v v then begin
1086
+
Binary.write_map_start enc 1;
1087
+
Binary.write_text enc key;
1088
+
Binary.write_null enc
1089
+
end
1090
+
else find rest
1091
+
in
1092
+
find cases);
1093
+
decode_rw =
1094
+
(fun path dec ->
1095
+
match read_map_length_rw path dec with
1096
+
| Error e -> e
1097
+
| Ok (Some 1) -> (
1098
+
match Binary.peek_byte dec with
1099
+
| Some b when b lsr 5 <> Binary.major_text ->
1100
+
Binary.skip dec;
1101
+
Binary.skip dec;
1102
+
Error
1103
+
(Error.v ~ctx:path
1104
+
(Error.Invalid_value "variant map key must be text"))
1105
+
| _ ->
1106
+
let key = Binary.read_text dec in
1107
+
let rec try_cases = function
1108
+
| [] ->
1109
+
Binary.skip dec;
1110
+
Error
1111
+
(Error.v ~ctx:path
1112
+
(Error.Invalid_value
1113
+
(Fmt.str "unknown key %S in variant" key)))
1114
+
| Case (k, c, inject, _) :: _rest when k = key -> (
1115
+
match c.decode_rw (Error.ctx_with_key k path) dec with
1116
+
| Error e -> Error e
1117
+
| Ok x -> Ok (inject x))
1118
+
| Case0 (k, v, _) :: _ when k = key ->
1119
+
Binary.skip dec;
1120
+
Ok v
1121
+
| _ :: rest -> try_cases rest
1122
+
in
1123
+
try_cases cases)
1124
+
| Ok (Some n) ->
1125
+
for _ = 1 to n do
1126
+
Binary.skip dec;
1127
+
Binary.skip dec
1128
+
done;
1129
+
Error
1130
+
(Error.v ~ctx:path
1131
+
(Error.Invalid_value "variant map must have exactly one key"))
1132
+
| Ok None -> (
1133
+
if Binary.is_break dec then (
1134
+
Binary.skip_break dec;
1135
+
Error
1136
+
(Error.v ~ctx:path
1137
+
(Error.Invalid_value
1138
+
"variant map must have exactly one key")))
1139
+
else
1140
+
match Binary.peek_byte dec with
1141
+
| Some b when b lsr 5 <> Binary.major_text ->
1142
+
Binary.skip dec;
1143
+
Binary.skip dec;
1144
+
while not (Binary.is_break dec) do
1145
+
Binary.skip dec;
1146
+
Binary.skip dec
1147
+
done;
1148
+
Binary.skip_break dec;
1149
+
Error
1150
+
(Error.v ~ctx:path
1151
+
(Error.Invalid_value "variant map key must be text"))
1152
+
| _ ->
1153
+
let key = Binary.read_text dec in
1154
+
let result =
1155
+
let rec try_cases = function
1156
+
| [] ->
1157
+
Binary.skip dec;
1158
+
Error
1159
+
(Error.v ~ctx:path
1160
+
(Error.Invalid_value
1161
+
(Fmt.str "unknown key %S in variant" key)))
1162
+
| Case (k, c, inject, _) :: _rest when k = key -> (
1163
+
match
1164
+
c.decode_rw (Error.ctx_with_key k path) dec
1165
+
with
1166
+
| Error e -> Error e
1167
+
| Ok x -> Ok (inject x))
1168
+
| Case0 (k, v, _) :: _ when k = key ->
1169
+
Binary.skip dec;
1170
+
Ok v
1171
+
| _ :: rest -> try_cases rest
1172
+
in
1173
+
try_cases cases
1174
+
in
1175
+
let extra = ref 0 in
1176
+
while not (Binary.is_break dec) do
1177
+
incr extra;
1178
+
Binary.skip dec;
1179
+
Binary.skip dec
1180
+
done;
1181
+
Binary.skip_break dec;
1182
+
if !extra > 0 then
1183
+
Error
1184
+
(Error.v ~ctx:path
1185
+
(Error.Invalid_value
1186
+
"variant map must have exactly one key"))
1187
+
else result));
1188
+
}
1189
+
end
1190
+
1191
+
(* {1 Queries - streaming descent into maps and arrays} *)
1192
+
1193
+
let mem name c =
1194
+
{
1195
+
kind = Fmt.str "mem(%s, %s)" name c.kind;
1196
+
encode_rw =
1197
+
(fun enc v ->
1198
+
Binary.write_map_start enc 1;
1199
+
Binary.write_text enc name;
1200
+
c.encode_rw enc v);
1201
+
decode_rw =
1202
+
(fun path dec ->
1203
+
match read_map_length_rw path dec with
1204
+
| Error e -> e
1205
+
| Ok len_opt -> (
1206
+
let n = match len_opt with Some n -> n | None -> max_int in
1207
+
let result = ref None in
1208
+
let rec scan i =
1209
+
if i >= n then ()
1210
+
else if len_opt = None && Binary.is_break dec then
1211
+
Binary.skip_break dec
1212
+
else if !result <> None then begin
1213
+
Binary.skip dec;
1214
+
Binary.skip dec;
1215
+
scan (i + 1)
1216
+
end
1217
+
else
1218
+
match Binary.peek_byte dec with
1219
+
| Some b when b lsr 5 = Binary.major_text ->
1220
+
let key = Binary.read_text dec in
1221
+
if key = name then begin
1222
+
let r = c.decode_rw (Error.ctx_with_key name path) dec in
1223
+
result := Some r;
1224
+
scan (i + 1)
1225
+
end
1226
+
else begin
1227
+
Binary.skip dec;
1228
+
scan (i + 1)
1229
+
end
1230
+
| _ ->
1231
+
Binary.skip dec;
1232
+
Binary.skip dec;
1233
+
scan (i + 1)
1234
+
in
1235
+
scan 0;
1236
+
match !result with
1237
+
| Some r -> r
1238
+
| None -> Error (Error.v ~ctx:path (Error.Missing_member name))));
1239
+
}
1240
+
1241
+
let int_mem key c =
1242
+
let key_str = string_of_int key in
1243
+
{
1244
+
kind = Fmt.str "int_mem(%d, %s)" key c.kind;
1245
+
encode_rw =
1246
+
(fun enc v ->
1247
+
Binary.write_map_start enc 1;
1248
+
Binary.write_int enc key;
1249
+
c.encode_rw enc v);
1250
+
decode_rw =
1251
+
(fun path dec ->
1252
+
match read_map_length_rw path dec with
1253
+
| Error e -> e
1254
+
| Ok len_opt -> (
1255
+
let n = match len_opt with Some n -> n | None -> max_int in
1256
+
let result = ref None in
1257
+
let rec scan i =
1258
+
if i >= n then ()
1259
+
else if len_opt = None && Binary.is_break dec then
1260
+
Binary.skip_break dec
1261
+
else if !result <> None then begin
1262
+
Binary.skip dec;
1263
+
Binary.skip dec;
1264
+
scan (i + 1)
1265
+
end
1266
+
else
1267
+
match Binary.peek_byte dec with
1268
+
| Some b
1269
+
when b lsr 5 = Binary.major_uint
1270
+
|| b lsr 5 = Binary.major_nint ->
1271
+
let key_hdr = Binary.read_header dec in
1272
+
let kz = read_int_signed_z dec key_hdr in
1273
+
if Z.fits_int kz && Z.to_int kz = key then begin
1274
+
let r =
1275
+
c.decode_rw (Error.ctx_with_key key_str path) dec
1276
+
in
1277
+
result := Some r;
1278
+
scan (i + 1)
1279
+
end
1280
+
else begin
1281
+
Binary.skip dec;
1282
+
scan (i + 1)
1283
+
end
1284
+
| _ ->
1285
+
Binary.skip dec;
1286
+
Binary.skip dec;
1287
+
scan (i + 1)
1288
+
in
1289
+
scan 0;
1290
+
match !result with
1291
+
| Some r -> r
1292
+
| None -> Error (Error.v ~ctx:path (Error.Missing_member key_str))));
1293
+
}
1294
+
1295
+
let nth n c =
1296
+
{
1297
+
kind = Fmt.str "nth(%d, %s)" n c.kind;
1298
+
encode_rw =
1299
+
(fun enc v ->
1300
+
Binary.write_array_start enc (n + 1);
1301
+
for _ = 1 to n do
1302
+
Binary.write_null enc
1303
+
done;
1304
+
c.encode_rw enc v);
1305
+
decode_rw =
1306
+
(fun path dec ->
1307
+
match read_array_length_rw path dec with
1308
+
| Error e -> e
1309
+
| Ok (Some len) ->
1310
+
if n >= len then
1311
+
Error
1312
+
(Error.v ~ctx:path
1313
+
(Error.Out_of_range
1314
+
{ value = string_of_int n; range = Fmt.str "[0, %d)" len }))
1315
+
else begin
1316
+
for _ = 1 to n do
1317
+
Binary.skip dec
1318
+
done;
1319
+
let r = c.decode_rw (Error.ctx_with_index n path) dec in
1320
+
for _ = n + 1 to len - 1 do
1321
+
Binary.skip dec
1322
+
done;
1323
+
r
1324
+
end
1325
+
| Ok None -> (
1326
+
(* Indefinite-length array: skip up to n, then decode, then drain. *)
1327
+
let rec skip_n i =
1328
+
if i >= n then Ok ()
1329
+
else if Binary.is_break dec then begin
1330
+
Binary.skip_break dec;
1331
+
Error
1332
+
(Error.v ~ctx:path
1333
+
(Error.Out_of_range
1334
+
{ value = string_of_int n; range = Fmt.str "[0, %d)" i }))
1335
+
end
1336
+
else begin
1337
+
Binary.skip dec;
1338
+
skip_n (i + 1)
1339
+
end
1340
+
in
1341
+
match skip_n 0 with
1342
+
| Error e -> Error e
1343
+
| Ok () ->
1344
+
if Binary.is_break dec then begin
1345
+
Binary.skip_break dec;
1346
+
Error
1347
+
(Error.v ~ctx:path
1348
+
(Error.Out_of_range
1349
+
{
1350
+
value = string_of_int n;
1351
+
range = Fmt.str "[0, %d)" n;
1352
+
}))
1353
+
end
1354
+
else
1355
+
let r = c.decode_rw (Error.ctx_with_index n path) dec in
1356
+
while not (Binary.is_break dec) do
1357
+
Binary.skip dec
1358
+
done;
1359
+
Binary.skip_break dec;
1360
+
r));
1361
+
}
+256
lib/codec.mli
+256
lib/codec.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** CBOR codec combinators (RFC 8949).
7
+
8
+
Sections follow
9
+
{{:https://www.rfc-editor.org/rfc/rfc8949#section-3.1} RFC 8949 §3.1} in
10
+
spec order: major types 0 → 7, then the OCaml-side transformations and
11
+
queries that don't correspond to a single major type.
12
+
13
+
See {!Cbor} for the top-level entry points; see {!Cbor.Sort} for the closed
14
+
enumeration of CBOR sorts. *)
15
+
16
+
type 'a t = {
17
+
kind : string;
18
+
encode_rw : Binary.encoder -> 'a -> unit;
19
+
decode_rw : Loc.Context.t -> Binary.decoder -> ('a, Error.t) result;
20
+
}
21
+
(** A CBOR codec for OCaml values of type ['a]. The encoder writes the value
22
+
directly to a {!Binary.encoder}; the decoder reads it directly from a
23
+
{!Binary.decoder}. There is no intermediate {!Value.t} tree on either
24
+
direction — codecs decode bytes into ['a] in one pass. *)
25
+
26
+
val pp : Format.formatter -> _ t -> unit
27
+
(** [pp ppf c] pretty-prints [c] as [<codec:KIND>]. *)
28
+
29
+
val kind : 'a t -> string
30
+
(** [kind c] is a human-readable description of [c]'s shape, e.g. ["int"],
31
+
["text"], ["map({name, age})"], ["mem(name, text)"]. *)
32
+
33
+
(** {1:major0 Major type 0 — Unsigned integer
34
+
({{:https://www.rfc-editor.org/rfc/rfc8949#section-3.1} RFC 8949 §3.1})}
35
+
36
+
Direct values from 0 to 2^64 - 1. *)
37
+
38
+
val uint : int t
39
+
(** Codec for non-negative OCaml [int] mapping to major type 0. *)
40
+
41
+
val uint32 : int32 t
42
+
(** As {!uint} but for [int32]. *)
43
+
44
+
val uint64 : int64 t
45
+
(** As {!uint} but for [int64]. *)
46
+
47
+
(** {1:major1 Major type 1 — Negative integer (RFC 8949 §3.1)}
48
+
49
+
Negative values in [-2^64, -1]. The [int] codecs decode either major type 0
50
+
or 1, matching CDDL's [int] type. *)
51
+
52
+
val int : int t
53
+
(** Codec for OCaml [int]. Decodes either a CBOR Unsigned (major 0) or Negative
54
+
integer (major 1). *)
55
+
56
+
val int32 : int32 t
57
+
(** As {!int} but for [int32]. *)
58
+
59
+
val int64 : int64 t
60
+
(** As {!int} but for [int64]. *)
61
+
62
+
(** {1:major2 Major type 2 — Byte string (RFC 8949 §3.1)} *)
63
+
64
+
val bytes : string t
65
+
(** Codec for CBOR byte strings (CDDL [bstr] / [bytes]). *)
66
+
67
+
(** {1:major3 Major type 3 — Text string (RFC 8949 §3.1)} *)
68
+
69
+
val text : string t
70
+
(** Codec for CBOR UTF-8 text strings (CDDL [tstr] / [text]). *)
71
+
72
+
(** {1:major4 Major type 4 — Array (RFC 8949 §3.1)} *)
73
+
74
+
val array : 'a t -> 'a list t
75
+
(** [array c] is a codec for arrays of arbitrary length. *)
76
+
77
+
val array_of : len:int -> 'a t -> 'a list t
78
+
(** [array_of ~len c] requires exactly [len] elements. *)
79
+
80
+
val tuple2 : 'a t -> 'b t -> ('a * 'b) t
81
+
(** Codec for 2-element arrays as pairs. *)
82
+
83
+
val tuple3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
84
+
(** Codec for 3-element arrays as triples. *)
85
+
86
+
val tuple4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
87
+
(** Codec for 4-element arrays as quadruples. *)
88
+
89
+
(** {1:major5 Major type 5 — Map (RFC 8949 §3.1)}
90
+
91
+
Three views: {!assoc} for uniform key/value pairs, {!Map} for text-keyed
92
+
records, {!Map_int} for integer-keyed records (COSE / CWT,
93
+
{{:https://www.rfc-editor.org/rfc/rfc9052} RFC 9052} /
94
+
{{:https://www.rfc-editor.org/rfc/rfc8392} RFC 8392}). *)
95
+
96
+
val assoc : 'k t -> 'v t -> ('k * 'v) list t
97
+
(** [assoc kc vc] decodes a CBOR map into a list of [(key, value)] pairs. *)
98
+
99
+
val text_map : 'v t -> (string * 'v) list t
100
+
(** [text_map vc] is [assoc text vc]. *)
101
+
102
+
val int_map : 'v t -> (int * 'v) list t
103
+
(** [int_map vc] is [assoc int vc]. Common in COSE / CWT. *)
104
+
105
+
(** Records as text-keyed maps. Curried-constructor pipeline. *)
106
+
module Map : sig
107
+
type ('o, 'dec) mem
108
+
(** A partially-applied curried constructor for an object of type ['o]. ['dec]
109
+
tracks the constructor's remaining arrow type — every {!mem} application
110
+
consumes one argument; {!seal} fires when ['dec] equals ['o]. *)
111
+
112
+
val map : 'dec -> ('o, 'dec) mem
113
+
(** [map ctor] starts a member chain with [ctor] as the unsaturated
114
+
constructor (e.g. [fun a b c -> { a; b; c }]). *)
115
+
116
+
val mem : string -> ('o -> 'a) -> 'a t -> ('o, 'a -> 'b) mem -> ('o, 'b) mem
117
+
(** [mem name get c m] declares a required member at key [name] decoded by
118
+
[c]. *)
119
+
120
+
val mem_opt :
121
+
string ->
122
+
('o -> 'a option) ->
123
+
'a t ->
124
+
('o, 'a option -> 'b) mem ->
125
+
('o, 'b) mem
126
+
(** [mem_opt name get c m] declares an optional member: absent / null both
127
+
decode to [None]. *)
128
+
129
+
val mem_default :
130
+
string ->
131
+
('o -> 'a) ->
132
+
default:'a ->
133
+
'a t ->
134
+
('o, 'a -> 'b) mem ->
135
+
('o, 'b) mem
136
+
(** [mem_default name get ~default c m] falls back to [default] when the key
137
+
is absent or the value is null. *)
138
+
139
+
val seal : ('o, 'o) mem -> 'o t
140
+
(** [seal m] converts the saturated chain into a codec. *)
141
+
end
142
+
143
+
(** Records as integer-keyed maps. Same pipeline as {!Map}, used by COSE (RFC
144
+
9052) and CWT (RFC 8392). *)
145
+
module Map_int : sig
146
+
type ('o, 'dec) mem
147
+
(** As in {!Map.mem} but keyed by integer. *)
148
+
149
+
val map : 'dec -> ('o, 'dec) mem
150
+
val mem : int -> ('o -> 'a) -> 'a t -> ('o, 'a -> 'b) mem -> ('o, 'b) mem
151
+
152
+
val mem_opt :
153
+
int ->
154
+
('o -> 'a option) ->
155
+
'a t ->
156
+
('o, 'a option -> 'b) mem ->
157
+
('o, 'b) mem
158
+
159
+
val mem_default :
160
+
int ->
161
+
('o -> 'a) ->
162
+
default:'a ->
163
+
'a t ->
164
+
('o, 'a -> 'b) mem ->
165
+
('o, 'b) mem
166
+
167
+
val seal : ('o, 'o) mem -> 'o t
168
+
end
169
+
170
+
(** {1:major6 Major type 6 — Tagged data item (RFC 8949 §3.1, §3.4)} *)
171
+
172
+
val tag : int -> 'a t -> 'a t
173
+
(** [tag n c] wraps [c] with tag number [n]. *)
174
+
175
+
val tag_opt : int -> 'a t -> 'a t
176
+
(** [tag_opt n c] is like {!tag} but the tag is optional when decoding. *)
177
+
178
+
(** {1:major7 Major type 7 — Floating-point and simple values
179
+
({{:https://www.rfc-editor.org/rfc/rfc8949#section-3.3} RFC 8949 §3.3})} *)
180
+
181
+
val null : unit t
182
+
(** Codec for the CBOR null simple value (sub-tag 22). *)
183
+
184
+
val bool : bool t
185
+
(** Codec for CBOR booleans (simple values 20 / 21). *)
186
+
187
+
val float : float t
188
+
(** Codec for CBOR floats (sub-tags 25 / 26 / 27). *)
189
+
190
+
(** {1:transforms Codec transformations}
191
+
192
+
Combinators that don't correspond to a single CBOR major type. *)
193
+
194
+
val map : ('a -> 'b) -> ('b -> 'a) -> 'a t -> 'b t
195
+
(** [map dec enc c] post-processes [c]'s decoded value with [dec] and
196
+
pre-processes the encoded value with [enc]. *)
197
+
198
+
val conv : ('a -> ('b, string) result) -> ('b -> 'a) -> 'a t -> 'b t
199
+
(** [conv dec enc c] is like {!map} but [dec] may fail. *)
200
+
201
+
val const : 'a -> unit t -> 'a t
202
+
(** [const v c] always decodes to [v] and encodes [v] using [c]. *)
203
+
204
+
val nullable : 'a t -> 'a option t
205
+
(** [nullable c] encodes [None] as null, [Some x] as [c] would encode [x]. *)
206
+
207
+
val option : default:'a -> 'a t -> 'a t
208
+
(** [option ~default c] decodes a null as [default] instead of failing. *)
209
+
210
+
val number : float t
211
+
(** Decoder accepts both CBOR integers and floats; encodes via {!float}. *)
212
+
213
+
val fix : ('a t -> 'a t) -> 'a t
214
+
(** [fix f] creates a recursive codec. *)
215
+
216
+
(** {1:variants Sum types} *)
217
+
218
+
(** Tag-discriminated variants (RFC 8949 §3.4, major type 6). *)
219
+
module Variant : sig
220
+
type 'a case
221
+
222
+
val case : int -> 'a t -> ('a -> 'b) -> ('b -> 'a option) -> 'b case
223
+
(** [case tag c inject project] defines a case. *)
224
+
225
+
val case0 : int -> 'a -> ('a -> bool) -> 'a case
226
+
(** [case0 tag v is_v] defines a payload-less case. *)
227
+
228
+
val variant : 'a case list -> 'a t
229
+
(** [variant cases] builds a codec from [cases]. *)
230
+
end
231
+
232
+
(** Singleton-map variants (RFC 8949 §3.1, major type 5). *)
233
+
module Variant_key : sig
234
+
type 'a case
235
+
236
+
val case : string -> 'a t -> ('a -> 'b) -> ('b -> 'a option) -> 'b case
237
+
(** [case key c inject project] defines a case identified by text [key]. *)
238
+
239
+
val case0 : string -> 'a -> ('a -> bool) -> 'a case
240
+
(** [case0 key v is_v] defines a payload-less case encoded as [{key: null}].
241
+
*)
242
+
243
+
val variant : 'a case list -> 'a t
244
+
(** [variant cases] builds a codec from [cases]. *)
245
+
end
246
+
247
+
(** {1:queries Queries and updates} *)
248
+
249
+
val mem : string -> 'a t -> 'a t
250
+
(** [mem name c] queries a map member by text key [name]. *)
251
+
252
+
val int_mem : int -> 'a t -> 'a t
253
+
(** [int_mem key c] queries a map member by integer key. *)
254
+
255
+
val nth : int -> 'a t -> 'a t
256
+
(** [nth n c] queries the [n]-th element of an array (zero-indexed). *)
+144
-136
test/test_cbor.ml
+144
-136
test/test_cbor.ml
···
279
279
let unit_tests =
280
280
[
281
281
Alcotest.test_case "codec: null" `Quick (fun () ->
282
-
let encoded = Cbor.encode_string Cbor.null () in
283
-
let decoded = Cbor.decode_string_exn Cbor.null encoded in
282
+
let encoded = Cbor.to_string Cbor.Codec.null () in
283
+
let decoded = Cbor.of_string_exn Cbor.Codec.null encoded in
284
284
assert (decoded = ()));
285
285
Alcotest.test_case "codec: bool true" `Quick (fun () ->
286
-
let encoded = Cbor.encode_string Cbor.bool true in
287
-
let decoded = Cbor.decode_string_exn Cbor.bool encoded in
286
+
let encoded = Cbor.to_string Cbor.Codec.bool true in
287
+
let decoded = Cbor.of_string_exn Cbor.Codec.bool encoded in
288
288
assert (decoded = true));
289
289
Alcotest.test_case "codec: bool false" `Quick (fun () ->
290
-
let encoded = Cbor.encode_string Cbor.bool false in
291
-
let decoded = Cbor.decode_string_exn Cbor.bool encoded in
290
+
let encoded = Cbor.to_string Cbor.Codec.bool false in
291
+
let decoded = Cbor.of_string_exn Cbor.Codec.bool encoded in
292
292
assert (decoded = false));
293
293
Alcotest.test_case "codec: int positive" `Quick (fun () ->
294
-
let encoded = Cbor.encode_string Cbor.int 42 in
295
-
let decoded = Cbor.decode_string_exn Cbor.int encoded in
294
+
let encoded = Cbor.to_string Cbor.Codec.int 42 in
295
+
let decoded = Cbor.of_string_exn Cbor.Codec.int encoded in
296
296
assert (decoded = 42));
297
297
Alcotest.test_case "codec: int negative" `Quick (fun () ->
298
-
let encoded = Cbor.encode_string Cbor.int (-100) in
299
-
let decoded = Cbor.decode_string_exn Cbor.int encoded in
298
+
let encoded = Cbor.to_string Cbor.Codec.int (-100) in
299
+
let decoded = Cbor.of_string_exn Cbor.Codec.int encoded in
300
300
assert (decoded = -100));
301
301
Alcotest.test_case "codec: int64" `Quick (fun () ->
302
302
let n = 1000000000000L in
303
-
let encoded = Cbor.encode_string Cbor.int64 n in
304
-
let decoded = Cbor.decode_string_exn Cbor.int64 encoded in
303
+
let encoded = Cbor.to_string Cbor.Codec.int64 n in
304
+
let decoded = Cbor.of_string_exn Cbor.Codec.int64 encoded in
305
305
assert (decoded = n));
306
306
Alcotest.test_case "codec: float" `Quick (fun () ->
307
-
let encoded = Cbor.encode_string Cbor.float 3.14159 in
308
-
let decoded = Cbor.decode_string_exn Cbor.float encoded in
307
+
let encoded = Cbor.to_string Cbor.Codec.float 3.14159 in
308
+
let decoded = Cbor.of_string_exn Cbor.Codec.float encoded in
309
309
assert (abs_float (decoded -. 3.14159) < 0.00001));
310
310
Alcotest.test_case "codec: string" `Quick (fun () ->
311
311
let s = "Hello, CBOR!" in
312
-
let encoded = Cbor.encode_string Cbor.string s in
313
-
let decoded = Cbor.decode_string_exn Cbor.string encoded in
312
+
let encoded = Cbor.to_string Cbor.Codec.text s in
313
+
let decoded = Cbor.of_string_exn Cbor.Codec.text encoded in
314
314
assert (decoded = s));
315
315
Alcotest.test_case "codec: bytes" `Quick (fun () ->
316
316
let s = "\x00\x01\x02\x03" in
317
-
let encoded = Cbor.encode_string Cbor.bytes s in
318
-
let decoded = Cbor.decode_string_exn Cbor.bytes encoded in
317
+
let encoded = Cbor.to_string Cbor.Codec.bytes s in
318
+
let decoded = Cbor.of_string_exn Cbor.Codec.bytes encoded in
319
319
assert (decoded = s));
320
320
Alcotest.test_case "codec: array" `Quick (fun () ->
321
321
let arr = [ 1; 2; 3; 4; 5 ] in
322
-
let encoded = Cbor.encode_string (Cbor.array Cbor.int) arr in
323
-
let decoded = Cbor.decode_string_exn (Cbor.array Cbor.int) encoded in
322
+
let encoded = Cbor.to_string (Cbor.Codec.array Cbor.Codec.int) arr in
323
+
let decoded =
324
+
Cbor.of_string_exn (Cbor.Codec.array Cbor.Codec.int) encoded
325
+
in
324
326
assert (decoded = arr));
325
327
Alcotest.test_case "codec: tuple2" `Quick (fun () ->
326
328
let t = ("hello", 42) in
327
-
let encoded = Cbor.encode_string (Cbor.tuple2 Cbor.string Cbor.int) t in
329
+
let encoded =
330
+
Cbor.to_string (Cbor.Codec.tuple2 Cbor.Codec.text Cbor.Codec.int) t
331
+
in
328
332
let decoded =
329
-
Cbor.decode_string_exn (Cbor.tuple2 Cbor.string Cbor.int) encoded
333
+
Cbor.of_string_exn
334
+
(Cbor.Codec.tuple2 Cbor.Codec.text Cbor.Codec.int)
335
+
encoded
330
336
in
331
337
assert (decoded = t));
332
338
Alcotest.test_case "codec: string_map" `Quick (fun () ->
333
339
let m = [ ("a", 1); ("b", 2) ] in
334
-
let encoded = Cbor.encode_string (Cbor.string_map Cbor.int) m in
340
+
let encoded = Cbor.to_string (Cbor.Codec.text_map Cbor.Codec.int) m in
335
341
let decoded =
336
-
Cbor.decode_string_exn (Cbor.string_map Cbor.int) encoded
342
+
Cbor.of_string_exn (Cbor.Codec.text_map Cbor.Codec.int) encoded
337
343
in
338
344
assert (decoded = m));
339
345
Alcotest.test_case "codec: nullable Some" `Quick (fun () ->
340
346
let v = Some 42 in
341
-
let encoded = Cbor.encode_string (Cbor.nullable Cbor.int) v in
342
-
let decoded = Cbor.decode_string_exn (Cbor.nullable Cbor.int) encoded in
347
+
let encoded = Cbor.to_string (Cbor.Codec.nullable Cbor.Codec.int) v in
348
+
let decoded =
349
+
Cbor.of_string_exn (Cbor.Codec.nullable Cbor.Codec.int) encoded
350
+
in
343
351
assert (decoded = v));
344
352
Alcotest.test_case "codec: nullable None" `Quick (fun () ->
345
353
let v = None in
346
-
let encoded = Cbor.encode_string (Cbor.nullable Cbor.int) v in
347
-
let decoded = Cbor.decode_string_exn (Cbor.nullable Cbor.int) encoded in
354
+
let encoded = Cbor.to_string (Cbor.Codec.nullable Cbor.Codec.int) v in
355
+
let decoded =
356
+
Cbor.of_string_exn (Cbor.Codec.nullable Cbor.Codec.int) encoded
357
+
in
348
358
assert (decoded = v));
349
359
Alcotest.test_case "codec: tag" `Quick (fun () ->
350
360
let v = 12345 in
351
-
let encoded = Cbor.encode_string (Cbor.tag 1 Cbor.int) v in
352
-
let decoded = Cbor.decode_string_exn (Cbor.tag 1 Cbor.int) encoded in
361
+
let encoded = Cbor.to_string (Cbor.Codec.tag 1 Cbor.Codec.int) v in
362
+
let decoded =
363
+
Cbor.of_string_exn (Cbor.Codec.tag 1 Cbor.Codec.int) encoded
364
+
in
353
365
assert (decoded = v));
354
366
Alcotest.test_case "codec: Obj" `Quick (fun () ->
355
367
let codec =
356
-
Cbor.Obj.map (fun name age -> (name, age))
357
-
|> Cbor.Obj.mem "name" fst Cbor.string
358
-
|> Cbor.Obj.mem "age" snd Cbor.int
359
-
|> Cbor.Obj.seal
368
+
Cbor.Codec.Map.map (fun name age -> (name, age))
369
+
|> Cbor.Codec.Map.mem "name" fst Cbor.Codec.text
370
+
|> Cbor.Codec.Map.mem "age" snd Cbor.Codec.int
371
+
|> Cbor.Codec.Map.seal
360
372
in
361
373
let v = ("Alice", 30) in
362
-
let encoded = Cbor.encode_string codec v in
363
-
let decoded = Cbor.decode_string_exn codec encoded in
374
+
let encoded = Cbor.to_string codec v in
375
+
let decoded = Cbor.of_string_exn codec encoded in
364
376
assert (decoded = v));
365
377
Alcotest.test_case "codec: map transform" `Quick (fun () ->
366
378
let codec =
367
-
Cbor.map
379
+
Cbor.Codec.map
368
380
(fun s -> String.uppercase_ascii s)
369
381
(fun s -> String.lowercase_ascii s)
370
-
Cbor.string
382
+
Cbor.Codec.text
371
383
in
372
-
let encoded = Cbor.encode_string codec "HELLO" in
373
-
let decoded = Cbor.decode_string_exn codec encoded in
384
+
let encoded = Cbor.to_string codec "HELLO" in
385
+
let decoded = Cbor.of_string_exn codec encoded in
374
386
assert (decoded = "HELLO"));
375
387
Alcotest.test_case "codec: fix (recursive)" `Quick (fun () ->
376
388
let tree_codec =
377
-
Cbor.fix (fun self ->
378
-
Cbor.Variant.(
389
+
Cbor.Codec.fix (fun self ->
390
+
Cbor.Codec.Variant.(
379
391
variant
380
392
[
381
-
case 0 Cbor.int
393
+
case 0 Cbor.Codec.int
382
394
(fun x -> Leaf x)
383
395
(function Leaf x -> Some x | _ -> None);
384
-
case 1 (Cbor.tuple2 self self)
396
+
case 1
397
+
(Cbor.Codec.tuple2 self self)
385
398
(fun (l, r) -> Node (l, r))
386
399
(function Node (l, r) -> Some (l, r) | _ -> None);
387
400
]))
388
401
in
389
402
let v = Node (Leaf 1, Node (Leaf 2, Leaf 3)) in
390
-
let encoded = Cbor.encode_string tree_codec v in
391
-
let decoded = Cbor.decode_string_exn tree_codec encoded in
403
+
let encoded = Cbor.to_string tree_codec v in
404
+
let decoded = Cbor.of_string_exn tree_codec encoded in
392
405
let rec tree_equal a b =
393
406
match (a, b) with
394
407
| Leaf x, Leaf y -> x = y
···
515
528
let query_cases =
516
529
[
517
530
Alcotest.test_case "mem: string field" `Quick (fun () ->
518
-
let c = Cbor.mem "name" Cbor.string in
519
-
let result = Cbor.Private.decode_cbor_exn c person_cbor in
531
+
let c = Cbor.Codec.mem "name" Cbor.Codec.text in
532
+
let result = Cbor.decode_exn c person_cbor in
520
533
Alcotest.(check string) "name" "Alice" result);
521
534
Alcotest.test_case "mem: int field" `Quick (fun () ->
522
-
let c = Cbor.mem "age" Cbor.int in
523
-
let result = Cbor.Private.decode_cbor_exn c person_cbor in
535
+
let c = Cbor.Codec.mem "age" Cbor.Codec.int in
536
+
let result = Cbor.decode_exn c person_cbor in
524
537
Alcotest.(check int) "age" 30 result);
525
538
Alcotest.test_case "mem: bool field" `Quick (fun () ->
526
-
let c = Cbor.mem "active" Cbor.bool in
527
-
let result = Cbor.Private.decode_cbor_exn c person_cbor in
539
+
let c = Cbor.Codec.mem "active" Cbor.Codec.bool in
540
+
let result = Cbor.decode_exn c person_cbor in
528
541
Alcotest.(check bool) "active" true result);
529
542
Alcotest.test_case "mem: missing field" `Quick (fun () ->
530
-
let c = Cbor.mem "email" Cbor.string in
531
-
match Cbor.Private.decode_cbor c person_cbor with
543
+
let c = Cbor.Codec.mem "email" Cbor.Codec.text in
544
+
match Cbor.decode c person_cbor with
532
545
| Error _ -> ()
533
546
| Ok _ -> Alcotest.fail "expected error for missing field");
534
547
Alcotest.test_case "mem: wrong type" `Quick (fun () ->
535
-
let c = Cbor.mem "name" Cbor.int in
536
-
match Cbor.Private.decode_cbor c person_cbor with
548
+
let c = Cbor.Codec.mem "name" Cbor.Codec.int in
549
+
match Cbor.decode c person_cbor with
537
550
| Error _ -> ()
538
551
| Ok _ -> Alcotest.fail "expected error for wrong type");
539
552
Alcotest.test_case "mem: not a map" `Quick (fun () ->
540
-
let c = Cbor.mem "name" Cbor.string in
541
-
match Cbor.Private.decode_cbor c (V.Int (Z.of_int 42)) with
553
+
let c = Cbor.Codec.mem "name" Cbor.Codec.text in
554
+
match Cbor.decode c (V.Int (Z.of_int 42)) with
542
555
| Error _ -> ()
543
556
| Ok _ -> Alcotest.fail "expected error for non-map");
544
557
Alcotest.test_case "mem: nested" `Quick (fun () ->
545
-
let c = Cbor.mem "user" (Cbor.mem "name" Cbor.string) in
546
-
let result = Cbor.Private.decode_cbor_exn c nested_cbor in
558
+
let c = Cbor.Codec.mem "user" (Cbor.Codec.mem "name" Cbor.Codec.text) in
559
+
let result = Cbor.decode_exn c nested_cbor in
547
560
Alcotest.(check string) "nested name" "Alice" result);
548
561
Alcotest.test_case "mem: encode roundtrip" `Quick (fun () ->
549
-
let c = Cbor.mem "name" Cbor.string in
550
-
let cbor = Cbor.Private.encode_cbor c "Bob" in
551
-
let result = Cbor.Private.decode_cbor_exn c cbor in
562
+
let c = Cbor.Codec.mem "name" Cbor.Codec.text in
563
+
let cbor = Cbor.encode c "Bob" in
564
+
let result = Cbor.decode_exn c cbor in
552
565
Alcotest.(check string) "roundtrip" "Bob" result);
553
566
Alcotest.test_case "int_mem: text field" `Quick (fun () ->
554
-
let c = Cbor.int_mem 1 Cbor.string in
555
-
let result = Cbor.Private.decode_cbor_exn c int_keyed_cbor in
567
+
let c = Cbor.Codec.int_mem 1 Cbor.Codec.text in
568
+
let result = Cbor.decode_exn c int_keyed_cbor in
556
569
Alcotest.(check string) "key 1" "alg" result);
557
570
Alcotest.test_case "int_mem: bytes field" `Quick (fun () ->
558
-
let c = Cbor.int_mem 4 Cbor.bytes in
559
-
let result = Cbor.Private.decode_cbor_exn c int_keyed_cbor in
571
+
let c = Cbor.Codec.int_mem 4 Cbor.Codec.bytes in
572
+
let result = Cbor.decode_exn c int_keyed_cbor in
560
573
Alcotest.(check string) "key 4" "keyid" result);
561
574
Alcotest.test_case "int_mem: missing key" `Quick (fun () ->
562
-
let c = Cbor.int_mem 99 Cbor.string in
563
-
match Cbor.Private.decode_cbor c int_keyed_cbor with
575
+
let c = Cbor.Codec.int_mem 99 Cbor.Codec.text in
576
+
match Cbor.decode c int_keyed_cbor with
564
577
| Error _ -> ()
565
578
| Ok _ -> Alcotest.fail "expected error for missing int key");
566
579
Alcotest.test_case "int_mem: encode roundtrip" `Quick (fun () ->
567
-
let c = Cbor.int_mem 1 Cbor.string in
568
-
let cbor = Cbor.Private.encode_cbor c "HS256" in
569
-
let result = Cbor.Private.decode_cbor_exn c cbor in
580
+
let c = Cbor.Codec.int_mem 1 Cbor.Codec.text in
581
+
let cbor = Cbor.encode c "HS256" in
582
+
let result = Cbor.decode_exn c cbor in
570
583
Alcotest.(check string) "roundtrip" "HS256" result);
571
584
Alcotest.test_case "nth: first element" `Quick (fun () ->
572
-
let c = Cbor.nth 0 Cbor.int in
573
-
let result = Cbor.Private.decode_cbor_exn c array_cbor in
585
+
let c = Cbor.Codec.nth 0 Cbor.Codec.int in
586
+
let result = Cbor.decode_exn c array_cbor in
574
587
Alcotest.(check int) "nth 0" 10 result);
575
588
Alcotest.test_case "nth: last element" `Quick (fun () ->
576
-
let c = Cbor.nth 2 Cbor.int in
577
-
let result = Cbor.Private.decode_cbor_exn c array_cbor in
589
+
let c = Cbor.Codec.nth 2 Cbor.Codec.int in
590
+
let result = Cbor.decode_exn c array_cbor in
578
591
Alcotest.(check int) "nth 2" 30 result);
579
592
Alcotest.test_case "nth: out of bounds" `Quick (fun () ->
580
-
let c = Cbor.nth 5 Cbor.int in
581
-
match Cbor.Private.decode_cbor c array_cbor with
593
+
let c = Cbor.Codec.nth 5 Cbor.Codec.int in
594
+
match Cbor.decode c array_cbor with
582
595
| Error _ -> ()
583
596
| Ok _ -> Alcotest.fail "expected error for out of bounds");
584
597
Alcotest.test_case "nth: not an array" `Quick (fun () ->
585
-
let c = Cbor.nth 0 Cbor.int in
586
-
match Cbor.Private.decode_cbor c (V.Text "hello") with
598
+
let c = Cbor.Codec.nth 0 Cbor.Codec.int in
599
+
match Cbor.decode c (V.Text "hello") with
587
600
| Error _ -> ()
588
601
| Ok _ -> Alcotest.fail "expected error for non-array");
589
602
Alcotest.test_case "nth: encode roundtrip" `Quick (fun () ->
590
-
let c = Cbor.nth 2 Cbor.int in
591
-
let cbor = Cbor.Private.encode_cbor c 42 in
592
-
let result = Cbor.Private.decode_cbor_exn c cbor in
603
+
let c = Cbor.Codec.nth 2 Cbor.Codec.int in
604
+
let cbor = Cbor.encode c 42 in
605
+
let result = Cbor.decode_exn c cbor in
593
606
Alcotest.(check int) "roundtrip" 42 result);
594
607
]
595
608
596
609
let update_cases =
597
610
[
598
611
Alcotest.test_case "update_mem: identity transform" `Quick (fun () ->
599
-
let c = Cbor.update_mem "name" Cbor.string in
600
-
let result = Cbor.Private.decode_cbor_exn c person_cbor in
612
+
let result = Cbor.update_mem_exn "name" Cbor.Codec.text person_cbor in
601
613
match V.text "name" result with
602
614
| Some (V.Text s) -> Alcotest.(check string) "name unchanged" "Alice" s
603
615
| _ -> Alcotest.fail "expected text member 'name'");
604
616
Alcotest.test_case "update_mem: transform via map codec" `Quick (fun () ->
605
617
let upper_string =
606
-
Cbor.map String.uppercase_ascii String.lowercase_ascii Cbor.string
618
+
Cbor.Codec.map String.uppercase_ascii String.lowercase_ascii
619
+
Cbor.Codec.text
607
620
in
608
-
let c = Cbor.update_mem "name" upper_string in
609
-
let result = Cbor.Private.decode_cbor_exn c person_cbor in
621
+
let result = Cbor.update_mem_exn "name" upper_string person_cbor in
610
622
match V.text "name" result with
611
623
| Some (V.Text s) -> Alcotest.(check string) "name uppercased" "alice" s
612
624
| _ -> Alcotest.fail "expected text member 'name'");
613
625
Alcotest.test_case "update_mem: missing field" `Quick (fun () ->
614
-
let c = Cbor.update_mem "email" Cbor.string in
615
-
match Cbor.Private.decode_cbor c person_cbor with
626
+
match Cbor.update_mem "email" Cbor.Codec.text person_cbor with
616
627
| Error _ -> ()
617
628
| Ok _ -> Alcotest.fail "expected error for missing field");
618
629
Alcotest.test_case "update_mem: preserves other fields" `Quick (fun () ->
619
-
let c = Cbor.update_mem "name" Cbor.string in
620
-
let result = Cbor.Private.decode_cbor_exn c person_cbor in
630
+
let result = Cbor.update_mem_exn "name" Cbor.Codec.text person_cbor in
621
631
(match V.text "age" result with
622
632
| Some (V.Int n) -> Alcotest.(check int) "age preserved" 30 (Z.to_int n)
623
633
| _ -> Alcotest.fail "expected int member 'age'");
···
625
635
| Some (V.Bool b) -> Alcotest.(check bool) "active preserved" true b
626
636
| _ -> Alcotest.fail "expected bool member 'active'");
627
637
Alcotest.test_case "update_mem: not a map" `Quick (fun () ->
628
-
let c = Cbor.update_mem "name" Cbor.string in
629
-
match Cbor.Private.decode_cbor c (V.Int (Z.of_int 42)) with
638
+
match Cbor.update_mem "name" Cbor.Codec.text (V.Int (Z.of_int 42)) with
630
639
| Error _ -> ()
631
640
| Ok _ -> Alcotest.fail "expected error for non-map");
632
641
Alcotest.test_case "delete_mem: remove field" `Quick (fun () ->
633
-
let c = Cbor.delete_mem "name" in
634
-
let result = Cbor.Private.decode_cbor_exn c person_cbor in
642
+
let result = Cbor.delete_mem_exn "name" person_cbor in
635
643
Alcotest.(check bool) "name absent" false (V.mem_text "name" result);
636
644
Alcotest.(check bool) "age present" true (V.mem_text "age" result);
637
645
Alcotest.(check bool) "active present" true (V.mem_text "active" result));
638
646
Alcotest.test_case "delete_mem: absent field is no-op" `Quick (fun () ->
639
-
let c = Cbor.delete_mem "email" in
640
-
let result = Cbor.Private.decode_cbor_exn c person_cbor in
647
+
let result = Cbor.delete_mem_exn "email" person_cbor in
641
648
match V.length result with
642
649
| Some n -> Alcotest.(check int) "same length" 3 n
643
650
| None -> Alcotest.fail "expected map");
644
651
Alcotest.test_case "delete_mem: not a map" `Quick (fun () ->
645
-
let c = Cbor.delete_mem "name" in
646
-
match Cbor.Private.decode_cbor c (V.Array []) with
652
+
match Cbor.delete_mem "name" (V.Array []) with
647
653
| Error _ -> ()
648
654
| Ok _ -> Alcotest.fail "expected error for non-map");
649
655
]
···
651
657
let introspection_cases =
652
658
[
653
659
Alcotest.test_case "kind: base codecs" `Quick (fun () ->
654
-
Alcotest.(check string) "null" "null" (Cbor.kind Cbor.null);
655
-
Alcotest.(check string) "bool" "bool" (Cbor.kind Cbor.bool);
656
-
Alcotest.(check string) "int" "int" (Cbor.kind Cbor.int);
657
-
Alcotest.(check string) "int32" "int32" (Cbor.kind Cbor.int32);
658
-
Alcotest.(check string) "int64" "int64" (Cbor.kind Cbor.int64);
659
-
Alcotest.(check string) "float" "float" (Cbor.kind Cbor.float);
660
-
Alcotest.(check string) "string" "string" (Cbor.kind Cbor.string);
661
-
Alcotest.(check string) "bytes" "bytes" (Cbor.kind Cbor.bytes);
662
-
Alcotest.(check string) "any" "any" (Cbor.kind Cbor.any));
660
+
Alcotest.(check string) "null" "null" (Cbor.Codec.kind Cbor.Codec.null);
661
+
Alcotest.(check string) "bool" "bool" (Cbor.Codec.kind Cbor.Codec.bool);
662
+
Alcotest.(check string) "int" "int" (Cbor.Codec.kind Cbor.Codec.int);
663
+
Alcotest.(check string)
664
+
"int32" "int32"
665
+
(Cbor.Codec.kind Cbor.Codec.int32);
666
+
Alcotest.(check string)
667
+
"int64" "int64"
668
+
(Cbor.Codec.kind Cbor.Codec.int64);
669
+
Alcotest.(check string)
670
+
"float" "float"
671
+
(Cbor.Codec.kind Cbor.Codec.float);
672
+
Alcotest.(check string) "text" "text" (Cbor.Codec.kind Cbor.Codec.text);
673
+
Alcotest.(check string)
674
+
"bytes" "bytes"
675
+
(Cbor.Codec.kind Cbor.Codec.bytes);
676
+
Alcotest.(check string) "any" "any" (Cbor.Codec.kind Cbor.any));
663
677
Alcotest.test_case "kind: composite codecs" `Quick (fun () ->
664
678
Alcotest.(check string)
665
679
"array(int)" "array(int)"
666
-
(Cbor.kind (Cbor.array Cbor.int));
680
+
(Cbor.Codec.kind (Cbor.Codec.array Cbor.Codec.int));
667
681
Alcotest.(check string)
668
-
"nullable(string)" "nullable(string)"
669
-
(Cbor.kind (Cbor.nullable Cbor.string));
682
+
"nullable(text)" "nullable(text)"
683
+
(Cbor.Codec.kind (Cbor.Codec.nullable Cbor.Codec.text));
670
684
Alcotest.(check string)
671
-
"tuple2" "tuple2(string, int)"
672
-
(Cbor.kind (Cbor.tuple2 Cbor.string Cbor.int));
685
+
"tuple2" "tuple2(text, int)"
686
+
(Cbor.Codec.kind (Cbor.Codec.tuple2 Cbor.Codec.text Cbor.Codec.int));
673
687
Alcotest.(check string)
674
688
"tag" "tag(1, int)"
675
-
(Cbor.kind (Cbor.tag 1 Cbor.int)));
676
-
Alcotest.test_case "kind: obj codec" `Quick (fun () ->
689
+
(Cbor.Codec.kind (Cbor.Codec.tag 1 Cbor.Codec.int)));
690
+
Alcotest.test_case "kind: map codec" `Quick (fun () ->
677
691
let codec =
678
-
Cbor.Obj.map (fun name age -> (name, age))
679
-
|> Cbor.Obj.mem "name" fst Cbor.string
680
-
|> Cbor.Obj.mem "age" snd Cbor.int
681
-
|> Cbor.Obj.seal
692
+
Cbor.Codec.Map.map (fun name age -> (name, age))
693
+
|> Cbor.Codec.Map.mem "name" fst Cbor.Codec.text
694
+
|> Cbor.Codec.Map.mem "age" snd Cbor.Codec.int
695
+
|> Cbor.Codec.Map.seal
682
696
in
683
-
let k = Cbor.kind codec in
684
-
Alcotest.(check string) "obj kind" "obj({name, age})" k);
697
+
let k = Cbor.Codec.kind codec in
698
+
Alcotest.(check string) "map kind" "map({name, age})" k);
685
699
Alcotest.test_case "kind: query codecs" `Quick (fun () ->
686
700
Alcotest.(check string)
687
-
"mem" "mem(name, string)"
688
-
(Cbor.kind (Cbor.mem "name" Cbor.string));
701
+
"mem" "mem(name, text)"
702
+
(Cbor.Codec.kind (Cbor.Codec.mem "name" Cbor.Codec.text));
689
703
Alcotest.(check string)
690
-
"int_mem" "int_mem(1, string)"
691
-
(Cbor.kind (Cbor.int_mem 1 Cbor.string));
704
+
"int_mem" "int_mem(1, text)"
705
+
(Cbor.Codec.kind (Cbor.Codec.int_mem 1 Cbor.Codec.text));
692
706
Alcotest.(check string)
693
707
"nth" "nth(0, int)"
694
-
(Cbor.kind (Cbor.nth 0 Cbor.int)));
695
-
Alcotest.test_case "kind: update codecs" `Quick (fun () ->
696
-
Alcotest.(check string)
697
-
"update_mem" "update_mem(name, string)"
698
-
(Cbor.kind (Cbor.update_mem "name" Cbor.string));
699
-
Alcotest.(check string)
700
-
"delete_mem" "delete_mem(name)"
701
-
(Cbor.kind (Cbor.delete_mem "name")));
708
+
(Cbor.Codec.kind (Cbor.Codec.nth 0 Cbor.Codec.int)));
702
709
Alcotest.test_case "kind: map/conv" `Quick (fun () ->
703
710
let codec =
704
-
Cbor.map String.uppercase_ascii String.lowercase_ascii Cbor.string
711
+
Cbor.Codec.map String.uppercase_ascii String.lowercase_ascii
712
+
Cbor.Codec.text
705
713
in
706
-
Alcotest.(check string) "map(string)" "map(string)" (Cbor.kind codec));
714
+
Alcotest.(check string) "map(text)" "map(text)" (Cbor.Codec.kind codec));
707
715
]
708
716
709
717
let suite =
+74
-72
test/test_value.ml
+74
-72
test/test_value.ml
···
344
344
345
345
(* ============= High-level Codec API Tests ============= *)
346
346
347
-
(* Round-trip tests using Cbor.encode_string and Cbor.decode_string *)
347
+
(* Round-trip tests using Cbor.to_string and Cbor.of_string *)
348
348
349
349
let test_codec_int_roundtrip () =
350
350
let values = [ 0; 1; 23; 24; 100; 1000; 1000000; -1; -10; -100; -1000 ] in
351
351
List.iter
352
352
(fun v ->
353
-
let encoded = Cbor.encode_string Cbor.int v in
354
-
match Cbor.decode_string Cbor.int encoded with
353
+
let encoded = Cbor.to_string Cbor.Codec.int v in
354
+
match Cbor.of_string Cbor.Codec.int encoded with
355
355
| Ok decoded -> Alcotest.(check int) (Fmt.str "int %d" v) v decoded
356
356
| Error e -> Alcotest.fail (Cbor.Error.to_string e))
357
357
values
···
360
360
let values = [ 0L; 1L; 1000000000000L; -1L; Int64.max_int; Int64.min_int ] in
361
361
List.iter
362
362
(fun v ->
363
-
let encoded = Cbor.encode_string Cbor.int64 v in
364
-
match Cbor.decode_string Cbor.int64 encoded with
363
+
let encoded = Cbor.to_string Cbor.Codec.int64 v in
364
+
match Cbor.of_string Cbor.Codec.int64 encoded with
365
365
| Ok decoded -> Alcotest.(check int64) (Fmt.str "int64 %Ld" v) v decoded
366
366
| Error e -> Alcotest.fail (Cbor.Error.to_string e))
367
367
values
···
369
369
let test_codec_bool_roundtrip () =
370
370
List.iter
371
371
(fun v ->
372
-
let encoded = Cbor.encode_string Cbor.bool v in
373
-
match Cbor.decode_string Cbor.bool encoded with
372
+
let encoded = Cbor.to_string Cbor.Codec.bool v in
373
+
match Cbor.of_string Cbor.Codec.bool encoded with
374
374
| Ok decoded -> Alcotest.(check bool) (Fmt.str "bool %b" v) v decoded
375
375
| Error e -> Alcotest.fail (Cbor.Error.to_string e))
376
376
[ true; false ]
377
377
378
378
let test_codec_null_roundtrip () =
379
-
let encoded = Cbor.encode_string Cbor.null () in
380
-
match Cbor.decode_string Cbor.null encoded with
379
+
let encoded = Cbor.to_string Cbor.Codec.null () in
380
+
match Cbor.of_string Cbor.Codec.null encoded with
381
381
| Ok () -> ()
382
382
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
383
383
···
385
385
let values = [ 0.0; 1.0; -1.0; 1.5; 3.14159; 1e10; -1e-10 ] in
386
386
List.iter
387
387
(fun v ->
388
-
let encoded = Cbor.encode_string Cbor.float v in
389
-
match Cbor.decode_string Cbor.float encoded with
388
+
let encoded = Cbor.to_string Cbor.Codec.float v in
389
+
match Cbor.of_string Cbor.Codec.float encoded with
390
390
| Ok decoded ->
391
391
let diff = abs_float (v -. decoded) in
392
392
Alcotest.(check bool) (Fmt.str "float %g" v) true (diff < 1e-10)
···
399
399
in
400
400
List.iter
401
401
(fun v ->
402
-
let encoded = Cbor.encode_string Cbor.string v in
403
-
match Cbor.decode_string Cbor.string encoded with
402
+
let encoded = Cbor.to_string Cbor.Codec.text v in
403
+
match Cbor.of_string Cbor.Codec.text encoded with
404
404
| Ok decoded -> Alcotest.(check string) (Fmt.str "string %S" v) v decoded
405
405
| Error e -> Alcotest.fail (Cbor.Error.to_string e))
406
406
values
···
409
409
let values = [ ""; "\x00\x01\x02\x03"; String.make 100 '\xff' ] in
410
410
List.iter
411
411
(fun v ->
412
-
let encoded = Cbor.encode_string Cbor.bytes v in
413
-
match Cbor.decode_string Cbor.bytes encoded with
412
+
let encoded = Cbor.to_string Cbor.Codec.bytes v in
413
+
match Cbor.of_string Cbor.Codec.bytes encoded with
414
414
| Ok decoded -> Alcotest.(check string) "bytes" v decoded
415
415
| Error e -> Alcotest.fail (Cbor.Error.to_string e))
416
416
values
417
417
418
418
let test_codec_array_roundtrip () =
419
419
let values = [ []; [ 1 ]; [ 1; 2; 3 ]; List.init 25 (fun i -> i) ] in
420
-
let int_list = Cbor.array Cbor.int in
420
+
let int_list = Cbor.Codec.array Cbor.Codec.int in
421
421
List.iter
422
422
(fun v ->
423
-
let encoded = Cbor.encode_string int_list v in
424
-
match Cbor.decode_string int_list encoded with
423
+
let encoded = Cbor.to_string int_list v in
424
+
match Cbor.of_string int_list encoded with
425
425
| Ok decoded -> Alcotest.(check (list int)) "array" v decoded
426
426
| Error e -> Alcotest.fail (Cbor.Error.to_string e))
427
427
values
428
428
429
429
let test_codec_nested_array () =
430
-
let nested = Cbor.array (Cbor.array Cbor.int) in
430
+
let nested = Cbor.Codec.array (Cbor.Codec.array Cbor.Codec.int) in
431
431
let v = [ [ 1; 2 ]; [ 3; 4; 5 ]; [] ] in
432
-
let encoded = Cbor.encode_string nested v in
433
-
match Cbor.decode_string nested encoded with
432
+
let encoded = Cbor.to_string nested v in
433
+
match Cbor.of_string nested encoded with
434
434
| Ok decoded -> Alcotest.(check (list (list int))) "nested array" v decoded
435
435
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
436
436
437
437
let test_codec_string_map_roundtrip () =
438
-
let map = Cbor.string_map Cbor.int in
438
+
let map = Cbor.Codec.text_map Cbor.Codec.int in
439
439
let v = [ ("a", 1); ("b", 2); ("c", 3) ] in
440
-
let encoded = Cbor.encode_string map v in
441
-
match Cbor.decode_string map encoded with
440
+
let encoded = Cbor.to_string map v in
441
+
match Cbor.of_string map encoded with
442
442
| Ok decoded ->
443
443
(* Maps may reorder, so sort before comparing *)
444
444
let sort = List.sort compare in
···
447
447
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
448
448
449
449
let test_codec_int_map_roundtrip () =
450
-
let map = Cbor.int_map Cbor.string in
450
+
let map = Cbor.Codec.int_map Cbor.Codec.text in
451
451
let v = [ (1, "one"); (2, "two"); (3, "three") ] in
452
-
let encoded = Cbor.encode_string map v in
453
-
match Cbor.decode_string map encoded with
452
+
let encoded = Cbor.to_string map v in
453
+
match Cbor.of_string map encoded with
454
454
| Ok decoded ->
455
455
let sort = List.sort compare in
456
456
Alcotest.(check (list (pair int string)))
···
458
458
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
459
459
460
460
let test_codec_tuple2 () =
461
-
let codec = Cbor.tuple2 Cbor.string Cbor.int in
461
+
let codec = Cbor.Codec.tuple2 Cbor.Codec.text Cbor.Codec.int in
462
462
let v = ("hello", 42) in
463
-
let encoded = Cbor.encode_string codec v in
464
-
match Cbor.decode_string codec encoded with
463
+
let encoded = Cbor.to_string codec v in
464
+
match Cbor.of_string codec encoded with
465
465
| Ok decoded -> Alcotest.(check (pair string int)) "tuple2" v decoded
466
466
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
467
467
468
468
let test_codec_tuple3 () =
469
-
let codec = Cbor.tuple3 Cbor.int Cbor.string Cbor.bool in
469
+
let codec =
470
+
Cbor.Codec.tuple3 Cbor.Codec.int Cbor.Codec.text Cbor.Codec.bool
471
+
in
470
472
let v = (42, "hello", true) in
471
-
let encoded = Cbor.encode_string codec v in
472
-
match Cbor.decode_string codec encoded with
473
+
let encoded = Cbor.to_string codec v in
474
+
match Cbor.of_string codec encoded with
473
475
| Ok decoded ->
474
476
let a, b, c = decoded in
475
477
Alcotest.(check int) "tuple3.0" 42 a;
···
478
480
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
479
481
480
482
let test_codec_nullable () =
481
-
let codec = Cbor.nullable Cbor.int in
483
+
let codec = Cbor.Codec.nullable Cbor.Codec.int in
482
484
(* Test Some *)
483
485
let v1 = Some 42 in
484
-
let encoded1 = Cbor.encode_string codec v1 in
485
-
(match Cbor.decode_string codec encoded1 with
486
+
let encoded1 = Cbor.to_string codec v1 in
487
+
(match Cbor.of_string codec encoded1 with
486
488
| Ok decoded -> Alcotest.(check (option int)) "nullable some" v1 decoded
487
489
| Error e -> Alcotest.fail (Cbor.Error.to_string e));
488
490
(* Test None *)
489
491
let v2 = None in
490
-
let encoded2 = Cbor.encode_string codec v2 in
491
-
match Cbor.decode_string codec encoded2 with
492
+
let encoded2 = Cbor.to_string codec v2 in
493
+
match Cbor.of_string codec encoded2 with
492
494
| Ok decoded -> Alcotest.(check (option int)) "nullable none" v2 decoded
493
495
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
494
496
···
497
499
type person = { name : string; age : int; email : string option }
498
500
499
501
let person_codec =
500
-
Cbor.Obj.map (fun name age email -> { name; age; email })
501
-
|> Cbor.Obj.mem "name" (fun p -> p.name) Cbor.string
502
-
|> Cbor.Obj.mem "age" (fun p -> p.age) Cbor.int
503
-
|> Cbor.Obj.mem_opt "email" (fun p -> p.email) Cbor.string
504
-
|> Cbor.Obj.seal
502
+
Cbor.Codec.Map.map (fun name age email -> { name; age; email })
503
+
|> Cbor.Codec.Map.mem "name" (fun p -> p.name) Cbor.Codec.text
504
+
|> Cbor.Codec.Map.mem "age" (fun p -> p.age) Cbor.Codec.int
505
+
|> Cbor.Codec.Map.mem_opt "email" (fun p -> p.email) Cbor.Codec.text
506
+
|> Cbor.Codec.Map.seal
505
507
506
508
let test_obj_codec_basic () =
507
509
let v = { name = "Alice"; age = 30; email = None } in
508
-
let encoded = Cbor.encode_string person_codec v in
509
-
match Cbor.decode_string person_codec encoded with
510
+
let encoded = Cbor.to_string person_codec v in
511
+
match Cbor.of_string person_codec encoded with
510
512
| Ok decoded ->
511
513
Alcotest.(check string) "name" v.name decoded.name;
512
514
Alcotest.(check int) "age" v.age decoded.age;
···
515
517
516
518
let test_obj_codec_with_optional () =
517
519
let v = { name = "Bob"; age = 25; email = Some "bob@example.com" } in
518
-
let encoded = Cbor.encode_string person_codec v in
519
-
match Cbor.decode_string person_codec encoded with
520
+
let encoded = Cbor.to_string person_codec v in
521
+
match Cbor.of_string person_codec encoded with
520
522
| Ok decoded ->
521
523
Alcotest.(check string) "name" v.name decoded.name;
522
524
Alcotest.(check int) "age" v.age decoded.age;
···
534
536
}
535
537
536
538
let cwt_claims_codec =
537
-
Cbor.Obj_int.map (fun iss sub exp -> { iss; sub; exp })
538
-
|> Cbor.Obj_int.mem_opt 1 (fun c -> c.iss) Cbor.string
539
-
|> Cbor.Obj_int.mem_opt 2 (fun c -> c.sub) Cbor.string
540
-
|> Cbor.Obj_int.mem_opt 4 (fun c -> c.exp) Cbor.int64
541
-
|> Cbor.Obj_int.seal
539
+
Cbor.Codec.Map_int.map (fun iss sub exp -> { iss; sub; exp })
540
+
|> Cbor.Codec.Map_int.mem_opt 1 (fun c -> c.iss) Cbor.Codec.text
541
+
|> Cbor.Codec.Map_int.mem_opt 2 (fun c -> c.sub) Cbor.Codec.text
542
+
|> Cbor.Codec.Map_int.mem_opt 4 (fun c -> c.exp) Cbor.Codec.int64
543
+
|> Cbor.Codec.Map_int.seal
542
544
543
545
let test_obj_int_codec () =
544
546
let v =
···
548
550
exp = Some 1700000000L;
549
551
}
550
552
in
551
-
let encoded = Cbor.encode_string cwt_claims_codec v in
552
-
match Cbor.decode_string cwt_claims_codec encoded with
553
+
let encoded = Cbor.to_string cwt_claims_codec v in
554
+
match Cbor.of_string cwt_claims_codec encoded with
553
555
| Ok decoded ->
554
556
Alcotest.(check (option string)) "iss" v.iss decoded.iss;
555
557
Alcotest.(check (option string)) "sub" v.sub decoded.sub;
···
558
560
559
561
let test_obj_int_partial () =
560
562
let v = { iss = Some "issuer"; sub = None; exp = None } in
561
-
let encoded = Cbor.encode_string cwt_claims_codec v in
562
-
match Cbor.decode_string cwt_claims_codec encoded with
563
+
let encoded = Cbor.to_string cwt_claims_codec v in
564
+
match Cbor.of_string cwt_claims_codec encoded with
563
565
| Ok decoded ->
564
566
Alcotest.(check (option string)) "iss" v.iss decoded.iss;
565
567
Alcotest.(check (option string)) "sub" v.sub decoded.sub;
···
570
572
571
573
let test_codec_tag () =
572
574
(* Tag 1 = epoch timestamp *)
573
-
let epoch_codec = Cbor.tag 1 Cbor.int64 in
575
+
let epoch_codec = Cbor.Codec.tag 1 Cbor.Codec.int64 in
574
576
let v = 1363896240L in
575
-
let encoded = Cbor.encode_string epoch_codec v in
577
+
let encoded = Cbor.to_string epoch_codec v in
576
578
(* Should match RFC 8949 example: c11a514b67b0 *)
577
579
let hex =
578
580
String.concat ""
···
580
582
Fmt.str "%02x" (Char.code (String.get encoded i))))
581
583
in
582
584
Alcotest.(check string) "epoch tag hex" "c11a514b67b0" hex;
583
-
match Cbor.decode_string epoch_codec encoded with
585
+
match Cbor.of_string epoch_codec encoded with
584
586
| Ok decoded -> Alcotest.(check int64) "epoch value" v decoded
585
587
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
586
588
587
589
let test_codec_tag_opt () =
588
590
(* Tag 32 = URI (optional) *)
589
-
let uri_codec = Cbor.tag_opt 32 Cbor.string in
591
+
let uri_codec = Cbor.Codec.tag_opt 32 Cbor.Codec.text in
590
592
let v = "https://example.com" in
591
593
(* Encode with tag *)
592
-
let encoded = Cbor.encode_string uri_codec v in
593
-
(match Cbor.decode_string uri_codec encoded with
594
+
let encoded = Cbor.to_string uri_codec v in
595
+
(match Cbor.of_string uri_codec encoded with
594
596
| Ok decoded -> Alcotest.(check string) "uri tagged" v decoded
595
597
| Error e -> Alcotest.fail (Cbor.Error.to_string e));
596
598
(* Decode without tag should also work *)
597
-
let plain = Cbor.encode_string Cbor.string v in
598
-
match Cbor.decode_string uri_codec plain with
599
+
let plain = Cbor.to_string Cbor.Codec.text v in
600
+
match Cbor.of_string uri_codec plain with
599
601
| Ok decoded -> Alcotest.(check string) "uri untagged" v decoded
600
602
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
601
603
···
624
626
List.iter
625
627
(fun (hex, expected) ->
626
628
let bytes = hex_to_bytes hex in
627
-
match Cbor.decode_string Cbor.int64 bytes with
629
+
match Cbor.of_string Cbor.Codec.int64 bytes with
628
630
| Ok decoded -> Alcotest.(check int64) hex expected decoded
629
631
| Error e -> Alcotest.failf "%s: %s" hex (Cbor.Error.to_string e))
630
632
tests
···
645
647
List.iter
646
648
(fun (hex, expected) ->
647
649
let bytes = hex_to_bytes hex in
648
-
match Cbor.decode_string Cbor.string bytes with
650
+
match Cbor.of_string Cbor.Codec.text bytes with
649
651
| Ok decoded -> Alcotest.(check string) hex expected decoded
650
652
| Error e -> Alcotest.failf "%s: %s" hex (Cbor.Error.to_string e))
651
653
tests
652
654
653
655
let test_decode_rfc_arrays () =
654
-
let int_list = Cbor.array Cbor.int in
656
+
let int_list = Cbor.Codec.array Cbor.Codec.int in
655
657
let tests = [ ("80", []); ("83010203", [ 1; 2; 3 ]) ] in
656
658
List.iter
657
659
(fun (hex, expected) ->
658
660
let bytes = hex_to_bytes hex in
659
-
match Cbor.decode_string int_list bytes with
661
+
match Cbor.of_string int_list bytes with
660
662
| Ok decoded -> Alcotest.(check (list int)) hex expected decoded
661
663
| Error e -> Alcotest.failf "%s: %s" hex (Cbor.Error.to_string e))
662
664
tests
···
666
668
List.iter
667
669
(fun (hex, expected) ->
668
670
let bytes = hex_to_bytes hex in
669
-
match Cbor.decode_string Cbor.bool bytes with
671
+
match Cbor.of_string Cbor.Codec.bool bytes with
670
672
| Ok decoded -> Alcotest.(check bool) hex expected decoded
671
673
| Error e -> Alcotest.failf "%s: %s" hex (Cbor.Error.to_string e))
672
674
tests
673
675
674
676
let test_decode_rfc_null () =
675
677
let bytes = hex_to_bytes "f6" in
676
-
match Cbor.decode_string Cbor.null bytes with
678
+
match Cbor.of_string Cbor.Codec.null bytes with
677
679
| Ok () -> ()
678
680
| Error e -> Alcotest.fail (Cbor.Error.to_string e)
679
681
···
683
685
(* Try to decode an integer as a string *)
684
686
let bytes = hex_to_bytes "01" in
685
687
(* integer 1 *)
686
-
match Cbor.decode_string Cbor.string bytes with
688
+
match Cbor.of_string Cbor.Codec.text bytes with
687
689
| Ok _ -> Alcotest.fail "Expected type mismatch error"
688
690
| Error e ->
689
691
let msg = Cbor.Error.to_string e in
···
694
696
let test_decode_truncated () =
695
697
(* Truncated integer (header says 4 bytes follow but only 2 provided) *)
696
698
let bytes = hex_to_bytes "1a0001" in
697
-
match Cbor.decode_string Cbor.int bytes with
699
+
match Cbor.of_string Cbor.Codec.int bytes with
698
700
| Ok _ -> Alcotest.fail "Expected parse error"
699
701
| Error _ -> ()
700
702