Native CBOR codec with type-safe combinators
ocaml-cbor: clear remaining merlint issues
- Add doc comments to Map_int.{map,mem,mem_opt,mem_default,seal} (E325).
- Rewrite uint/int/text/bytes doc comments to lead with [name] (E331).
- Re-export Value.pp / Value.equal at the top of Cbor (E305: type t was
missing pp).
- Refactor Codec.nth into nth_decode_definite + nth_decode_indefinite to
drop below the function-length threshold.
- Add a test_codec.ml smoke suite (round-trips through every major-type
combinator) to satisfy E605 and exercise the codec.ml surface directly.
315 tests pass; merlint clean on ocaml-cbor.
+189
-62
+3
lib/cbor.ml
+3
lib/cbor.ml
···
13
13
type t = Value.t
14
14
type 'a codec = 'a Codec.t
15
15
16
+
let pp = Value.pp
17
+
let equal = Value.equal
18
+
16
19
(* Generic codec for any CBOR data item — passes the streaming bytes straight
17
20
through {!Binary.read_cbor} / {!Binary.write_cbor}. Lives here (not in
18
21
{!Codec}) because it bridges to {!Value.t}. *)
+6
lib/cbor.mli
+6
lib/cbor.mli
···
62
62
type t = Value.t
63
63
(** A CBOR value. Alias for {!Value.t}. *)
64
64
65
+
val pp : Format.formatter -> t -> unit
66
+
(** [pp ppf v] pretty-prints [v] in diagnostic notation (RFC 8949 §8). *)
67
+
68
+
val equal : t -> t -> bool
69
+
(** [equal a b] is structural equality on CBOR values. *)
70
+
65
71
(** {1:codec Codecs}
66
72
67
73
A {!codec} is an opaque description of how an OCaml type maps to a CBOR
+48
-52
lib/codec.ml
+48
-52
lib/codec.ml
···
1298
1298
scan 0);
1299
1299
}
1300
1300
1301
+
let out_of_range_index path n upper =
1302
+
Error
1303
+
(Error.v ~ctx:path
1304
+
(Error.Out_of_range
1305
+
{ value = string_of_int n; range = Fmt.str "[0, %d)" upper }))
1306
+
1307
+
let nth_decode_definite path c n dec len =
1308
+
if n >= len then out_of_range_index path n len
1309
+
else begin
1310
+
for _ = 1 to n do
1311
+
Binary.skip dec
1312
+
done;
1313
+
let r = c.decode_rw (Error.ctx_with_index n path) dec in
1314
+
for _ = n + 1 to len - 1 do
1315
+
Binary.skip dec
1316
+
done;
1317
+
r
1318
+
end
1319
+
1320
+
let nth_decode_indefinite path c n dec =
1321
+
let rec skip_to_n i =
1322
+
if i >= n then Ok ()
1323
+
else if Binary.is_break dec then begin
1324
+
Binary.skip_break dec;
1325
+
out_of_range_index path n i
1326
+
end
1327
+
else begin
1328
+
Binary.skip dec;
1329
+
skip_to_n (i + 1)
1330
+
end
1331
+
in
1332
+
match skip_to_n 0 with
1333
+
| Error _ as e -> e
1334
+
| Ok () ->
1335
+
if Binary.is_break dec then begin
1336
+
Binary.skip_break dec;
1337
+
out_of_range_index path n n
1338
+
end
1339
+
else
1340
+
let r = c.decode_rw (Error.ctx_with_index n path) dec in
1341
+
while not (Binary.is_break dec) do
1342
+
Binary.skip dec
1343
+
done;
1344
+
Binary.skip_break dec;
1345
+
r
1346
+
1301
1347
let nth n c =
1302
1348
{
1303
1349
kind = Fmt.str "nth(%d, %s)" n c.kind;
···
1312
1358
(fun path dec ->
1313
1359
match read_array_length_rw path dec with
1314
1360
| Error e -> e
1315
-
| Ok (Some len) ->
1316
-
if n >= len then
1317
-
Error
1318
-
(Error.v ~ctx:path
1319
-
(Error.Out_of_range
1320
-
{ value = string_of_int n; range = Fmt.str "[0, %d)" len }))
1321
-
else begin
1322
-
for _ = 1 to n do
1323
-
Binary.skip dec
1324
-
done;
1325
-
let r = c.decode_rw (Error.ctx_with_index n path) dec in
1326
-
for _ = n + 1 to len - 1 do
1327
-
Binary.skip dec
1328
-
done;
1329
-
r
1330
-
end
1331
-
| Ok None -> (
1332
-
(* Indefinite-length array: skip up to n, then decode, then drain. *)
1333
-
let rec skip_n i =
1334
-
if i >= n then Ok ()
1335
-
else if Binary.is_break dec then begin
1336
-
Binary.skip_break dec;
1337
-
Error
1338
-
(Error.v ~ctx:path
1339
-
(Error.Out_of_range
1340
-
{ value = string_of_int n; range = Fmt.str "[0, %d)" i }))
1341
-
end
1342
-
else begin
1343
-
Binary.skip dec;
1344
-
skip_n (i + 1)
1345
-
end
1346
-
in
1347
-
match skip_n 0 with
1348
-
| Error e -> Error e
1349
-
| Ok () ->
1350
-
if Binary.is_break dec then begin
1351
-
Binary.skip_break dec;
1352
-
Error
1353
-
(Error.v ~ctx:path
1354
-
(Error.Out_of_range
1355
-
{
1356
-
value = string_of_int n;
1357
-
range = Fmt.str "[0, %d)" n;
1358
-
}))
1359
-
end
1360
-
else
1361
-
let r = c.decode_rw (Error.ctx_with_index n path) dec in
1362
-
while not (Binary.is_break dec) do
1363
-
Binary.skip dec
1364
-
done;
1365
-
Binary.skip_break dec;
1366
-
r));
1361
+
| Ok (Some len) -> nth_decode_definite path c n dec len
1362
+
| Ok None -> nth_decode_indefinite path c n dec);
1367
1363
}
+17
-10
lib/codec.mli
+17
-10
lib/codec.mli
···
36
36
Direct values from 0 to 2^64 - 1. *)
37
37
38
38
val uint : int t
39
-
(** Codec for non-negative OCaml [int] mapping to major type 0. *)
39
+
(** [uint] is the codec for non-negative OCaml [int]. Maps to major type 0. *)
40
40
41
41
val uint32 : int32 t
42
-
(** As {!uint} but for [int32]. *)
42
+
(** [uint32] is {!uint} for [int32]. *)
43
43
44
44
val uint64 : int64 t
45
-
(** As {!uint} but for [int64]. *)
45
+
(** [uint64] is {!uint} for [int64]. *)
46
46
47
47
(** {1:major1 Major type 1 — Negative integer (RFC 8949 §3.1)}
48
48
49
-
Negative values in [-2^64, -1]. The [int] codecs decode either major type 0
49
+
Negative values in [-2^64, -1]. The {!int} codecs decode either major type 0
50
50
or 1, matching CDDL's [int] type. *)
51
51
52
52
val int : int t
53
-
(** Codec for OCaml [int]. Decodes either a CBOR Unsigned (major 0) or Negative
54
-
integer (major 1). *)
53
+
(** [int] is the codec for OCaml [int]. Decodes either a CBOR Unsigned (major 0)
54
+
or Negative integer (major 1). *)
55
55
56
56
val int32 : int32 t
57
-
(** As {!int} but for [int32]. *)
57
+
(** [int32] is {!int} for [int32]. *)
58
58
59
59
val int64 : int64 t
60
-
(** As {!int} but for [int64]. *)
60
+
(** [int64] is {!int} for [int64]. *)
61
61
62
62
(** {1:major2 Major type 2 — Byte string (RFC 8949 §3.1)} *)
63
63
64
64
val bytes : string t
65
-
(** Codec for CBOR byte strings (CDDL [bstr] / [bytes]). *)
65
+
(** [bytes] is the codec for CBOR byte strings (CDDL [bstr] / [bytes]). *)
66
66
67
67
(** {1:major3 Major type 3 — Text string (RFC 8949 §3.1)} *)
68
68
69
69
val text : string t
70
-
(** Codec for CBOR UTF-8 text strings (CDDL [tstr] / [text]). *)
70
+
(** [text] is the codec for CBOR UTF-8 text strings (CDDL [tstr] / [text]). *)
71
71
72
72
(** {1:major4 Major type 4 — Array (RFC 8949 §3.1)} *)
73
73
···
147
147
(** As in {!Map.mem} but keyed by integer. *)
148
148
149
149
val map : 'dec -> ('o, 'dec) mem
150
+
(** [map ctor] starts a member chain. See {!Map.map}. *)
151
+
150
152
val mem : int -> ('o -> 'a) -> 'a t -> ('o, 'a -> 'b) mem -> ('o, 'b) mem
153
+
(** [mem key get c m] declares a required member at integer key [key]. *)
151
154
152
155
val mem_opt :
153
156
int ->
···
155
158
'a t ->
156
159
('o, 'a option -> 'b) mem ->
157
160
('o, 'b) mem
161
+
(** [mem_opt key get c m] declares an optional member at integer key [key]. *)
158
162
159
163
val mem_default :
160
164
int ->
···
163
167
'a t ->
164
168
('o, 'a -> 'b) mem ->
165
169
('o, 'b) mem
170
+
(** [mem_default key get ~default c m] falls back to [default] when [key] is
171
+
absent or null. *)
166
172
167
173
val seal : ('o, 'o) mem -> 'o t
174
+
(** [seal m] converts the saturated chain into a codec. *)
168
175
end
169
176
170
177
(** {1:major6 Major type 6 — Tagged data item (RFC 8949 §3.1, §3.4)} *)
+1
test/test.ml
+1
test/test.ml
+112
test/test_codec.ml
+112
test/test_codec.ml
···
1
+
(** Smoke tests for {!Cbor.Codec}: round-trips through each major-type
2
+
combinator on small canonical inputs. Exhaustive coverage of edge cases (RFC
3
+
8949 Appendix A, hostile inputs, error-path quality) lives in {!Test_cbor}
4
+
and {!Test_value}; this file targets the codec.ml surface directly. *)
5
+
6
+
let roundtrip codec value =
7
+
let s = Cbor.to_string codec value in
8
+
Cbor.of_string_exn codec s
9
+
10
+
let test_int_roundtrip () =
11
+
Alcotest.(check int) "int 0" 0 (roundtrip Cbor.Codec.int 0);
12
+
Alcotest.(check int) "int 42" 42 (roundtrip Cbor.Codec.int 42);
13
+
Alcotest.(check int) "int -1" (-1) (roundtrip Cbor.Codec.int (-1));
14
+
Alcotest.(check int) "int max_int" max_int (roundtrip Cbor.Codec.int max_int);
15
+
Alcotest.(check int) "int min_int" min_int (roundtrip Cbor.Codec.int min_int)
16
+
17
+
let test_text_roundtrip () =
18
+
Alcotest.(check string) "text empty" "" (roundtrip Cbor.Codec.text "");
19
+
Alcotest.(check string)
20
+
"text ascii" "hello"
21
+
(roundtrip Cbor.Codec.text "hello");
22
+
Alcotest.(check string)
23
+
"text utf-8" "üñîçødé"
24
+
(roundtrip Cbor.Codec.text "üñîçødé")
25
+
26
+
let test_bytes_roundtrip () =
27
+
Alcotest.(check string) "bytes empty" "" (roundtrip Cbor.Codec.bytes "");
28
+
Alcotest.(check string)
29
+
"bytes binary" "\x00\x01\xff"
30
+
(roundtrip Cbor.Codec.bytes "\x00\x01\xff")
31
+
32
+
let test_array_roundtrip () =
33
+
let codec = Cbor.Codec.array Cbor.Codec.int in
34
+
let v = [ 1; 2; 3; 4; 5 ] in
35
+
Alcotest.(check (list int)) "array int" v (roundtrip codec v)
36
+
37
+
let test_map_record_roundtrip () =
38
+
let codec =
39
+
Cbor.Codec.Map.(
40
+
map (fun name age -> (name, age))
41
+
|> mem "name" fst Cbor.Codec.text
42
+
|> mem "age" snd Cbor.Codec.int
43
+
|> seal)
44
+
in
45
+
let v = ("Alice", 30) in
46
+
let s = Cbor.to_string codec v in
47
+
let name, age = Cbor.of_string_exn codec s in
48
+
Alcotest.(check string) "name" "Alice" name;
49
+
Alcotest.(check int) "age" 30 age
50
+
51
+
let test_map_int_record_roundtrip () =
52
+
let codec =
53
+
Cbor.Codec.Map_int.(
54
+
map (fun a b -> (a, b))
55
+
|> mem 1 fst Cbor.Codec.text |> mem 4 snd Cbor.Codec.int64 |> seal)
56
+
in
57
+
let v = ("alg", 42L) in
58
+
let s = Cbor.to_string codec v in
59
+
let alg, exp = Cbor.of_string_exn codec s in
60
+
Alcotest.(check string) "key 1" "alg" alg;
61
+
Alcotest.(check int64) "key 4" 42L exp
62
+
63
+
let test_tag_roundtrip () =
64
+
let codec = Cbor.Codec.tag 1 Cbor.Codec.int64 in
65
+
Alcotest.(check int64) "tag 1 epoch" 1700000000L (roundtrip codec 1700000000L)
66
+
67
+
let test_nullable_roundtrip () =
68
+
let codec = Cbor.Codec.nullable Cbor.Codec.text in
69
+
Alcotest.(check (option string))
70
+
"Some" (Some "x")
71
+
(roundtrip codec (Some "x"));
72
+
Alcotest.(check (option string)) "None" None (roundtrip codec None)
73
+
74
+
let test_variant_roundtrip () =
75
+
let codec =
76
+
Cbor.Codec.Variant.(
77
+
variant
78
+
[
79
+
case 0 Cbor.Codec.float
80
+
(fun r -> `Circle r)
81
+
(function `Circle r -> Some r | _ -> None);
82
+
case 1
83
+
(Cbor.Codec.tuple2 Cbor.Codec.float Cbor.Codec.float)
84
+
(fun (w, h) -> `Rect (w, h))
85
+
(function `Rect (w, h) -> Some (w, h) | _ -> None);
86
+
])
87
+
in
88
+
Alcotest.(check bool)
89
+
"Circle 1.0 roundtrips" true
90
+
(match roundtrip codec (`Circle 1.0) with
91
+
| `Circle 1.0 -> true
92
+
| _ -> false);
93
+
Alcotest.(check bool)
94
+
"Rect (2.0, 3.0) roundtrips" true
95
+
(match roundtrip codec (`Rect (2.0, 3.0)) with
96
+
| `Rect (2.0, 3.0) -> true
97
+
| _ -> false)
98
+
99
+
let suite =
100
+
( "codec",
101
+
[
102
+
Alcotest.test_case "int roundtrip" `Quick test_int_roundtrip;
103
+
Alcotest.test_case "text roundtrip" `Quick test_text_roundtrip;
104
+
Alcotest.test_case "bytes roundtrip" `Quick test_bytes_roundtrip;
105
+
Alcotest.test_case "array roundtrip" `Quick test_array_roundtrip;
106
+
Alcotest.test_case "Map record roundtrip" `Quick test_map_record_roundtrip;
107
+
Alcotest.test_case "Map_int record roundtrip" `Quick
108
+
test_map_int_record_roundtrip;
109
+
Alcotest.test_case "tag roundtrip" `Quick test_tag_roundtrip;
110
+
Alcotest.test_case "nullable roundtrip" `Quick test_nullable_roundtrip;
111
+
Alcotest.test_case "Variant roundtrip" `Quick test_variant_roundtrip;
112
+
] )