Native CBOR codec with type-safe combinators
ocaml-cbor: add error-path quality tests, fix mem/int_mem stream desync
The new error_quality_cases suite asserts that rendered Cbor.Error messages
name the specific path, key, index, or bound where decoding failed — not just
a generic complaint. The first run of these tests caught a real bug in
[Cbor.Codec.mem] / [int_mem]: when the inner codec failed on the matched
value, the stream was left at an unknown position (header consumed but body
not), and the post-match drain loop then read garbage from inside the
previous text/bytes content, surfacing as "unexpected end of input" instead
of the real type mismatch.
Fix: extract a [drain_map_entries] helper used only on the success path; on
inner-decode error, return the error directly without trying to walk the rest
of the map. The trailing-bytes check in [Cbor.of_reader] passes the typed
error through unchanged.
Also wires up the cfdp_eio test sublib that an earlier session left
half-migrated: adds [test/eio/dune], appends [Alcotest.run] to
[test_cfdp_eio.ml], drops the dangling [Test_eio.suite] reference from
[test/test.ml]. The whole monorepo builds clean again.
306 cbor tests pass (9 new error-quality cases).
+138
-38
+43
-37
lib/codec.ml
+43
-37
lib/codec.ml
···
1190
1190
1191
1191
(* {1 Queries - streaming descent into maps and arrays} *)
1192
1192
1193
+
(* Drain remaining (i..n) key/value pairs, used after a successful match
1194
+
so the stream is positioned past the map. Indefinite maps stop on the
1195
+
break code. *)
1196
+
let rec drain_map_entries len_opt n dec i =
1197
+
if i >= n then ()
1198
+
else if len_opt = None && Binary.is_break dec then Binary.skip_break dec
1199
+
else begin
1200
+
Binary.skip dec;
1201
+
Binary.skip dec;
1202
+
drain_map_entries len_opt n dec (i + 1)
1203
+
end
1204
+
1193
1205
let mem name c =
1194
1206
{
1195
1207
kind = Fmt.str "mem(%s, %s)" name c.kind;
···
1202
1214
(fun path dec ->
1203
1215
match read_map_length_rw path dec with
1204
1216
| Error e -> e
1205
-
| Ok len_opt -> (
1217
+
| Ok len_opt ->
1206
1218
let n = match len_opt with Some n -> n | None -> max_int in
1207
-
let result = ref None in
1219
+
let missing () =
1220
+
Error (Error.v ~ctx:path (Error.Missing_member name))
1221
+
in
1208
1222
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)
1223
+
if i >= n then missing ()
1224
+
else if len_opt = None && Binary.is_break dec then begin
1225
+
Binary.skip_break dec;
1226
+
missing ()
1216
1227
end
1217
1228
else
1218
1229
match Binary.peek_byte dec with
1219
1230
| Some b when b lsr 5 = Binary.major_text ->
1220
1231
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
1232
+
if key = name then (
1233
+
match c.decode_rw (Error.ctx_with_key name path) dec with
1234
+
| Error _ as e -> e
1235
+
| Ok _ as ok ->
1236
+
drain_map_entries len_opt n dec (i + 1);
1237
+
ok)
1226
1238
else begin
1227
1239
Binary.skip dec;
1228
1240
scan (i + 1)
···
1232
1244
Binary.skip dec;
1233
1245
scan (i + 1)
1234
1246
in
1235
-
scan 0;
1236
-
match !result with
1237
-
| Some r -> r
1238
-
| None -> Error (Error.v ~ctx:path (Error.Missing_member name))));
1247
+
scan 0);
1239
1248
}
1240
1249
1241
1250
let int_mem key c =
···
1251
1260
(fun path dec ->
1252
1261
match read_map_length_rw path dec with
1253
1262
| Error e -> e
1254
-
| Ok len_opt -> (
1263
+
| Ok len_opt ->
1255
1264
let n = match len_opt with Some n -> n | None -> max_int in
1256
-
let result = ref None in
1265
+
let missing () =
1266
+
Error (Error.v ~ctx:path (Error.Missing_member key_str))
1267
+
in
1257
1268
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)
1269
+
if i >= n then missing ()
1270
+
else if len_opt = None && Binary.is_break dec then begin
1271
+
Binary.skip_break dec;
1272
+
missing ()
1265
1273
end
1266
1274
else
1267
1275
match Binary.peek_byte dec with
···
1270
1278
|| b lsr 5 = Binary.major_nint ->
1271
1279
let key_hdr = Binary.read_header dec in
1272
1280
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 =
1281
+
if Z.fits_int kz && Z.to_int kz = key then (
1282
+
match
1275
1283
c.decode_rw (Error.ctx_with_key key_str path) dec
1276
-
in
1277
-
result := Some r;
1278
-
scan (i + 1)
1279
-
end
1284
+
with
1285
+
| Error _ as e -> e
1286
+
| Ok _ as ok ->
1287
+
drain_map_entries len_opt n dec (i + 1);
1288
+
ok)
1280
1289
else begin
1281
1290
Binary.skip dec;
1282
1291
scan (i + 1)
···
1286
1295
Binary.skip dec;
1287
1296
scan (i + 1)
1288
1297
in
1289
-
scan 0;
1290
-
match !result with
1291
-
| Some r -> r
1292
-
| None -> Error (Error.v ~ctx:path (Error.Missing_member key_str))));
1298
+
scan 0);
1293
1299
}
1294
1300
1295
1301
let nth n c =
+95
-1
test/test_cbor.ml
+95
-1
test/test_cbor.ml
···
714
714
Alcotest.(check string) "map(text)" "map(text)" (Cbor.Codec.kind codec));
715
715
]
716
716
717
+
(* Error-quality tests: verify rendered error messages name the specific
718
+
path/key/index where the failure occurred, not just a generic complaint. *)
719
+
720
+
let assert_error_contains ~codec ~value ~substrings =
721
+
match Cbor.decode codec value with
722
+
| Ok _ ->
723
+
Alcotest.failf "expected decode error, got Ok (substrings=%a)"
724
+
Fmt.(list ~sep:comma string)
725
+
substrings
726
+
| Error e ->
727
+
let s = Cbor.Error.to_string e in
728
+
List.iter
729
+
(fun affix ->
730
+
Alcotest.(check bool)
731
+
(Fmt.str "error message contains %S (got: %s)" affix s)
732
+
true
733
+
(Astring.String.is_infix ~affix s))
734
+
substrings
735
+
736
+
let error_quality_cases =
737
+
[
738
+
Alcotest.test_case "mem: missing-key error names the key" `Quick (fun () ->
739
+
assert_error_contains
740
+
~codec:(Cbor.Codec.mem "email" Cbor.Codec.text)
741
+
~value:person_cbor ~substrings:[ "email" ]);
742
+
Alcotest.test_case "mem: type mismatch names the key in the path" `Quick
743
+
(fun () ->
744
+
assert_error_contains
745
+
~codec:(Cbor.Codec.mem "name" Cbor.Codec.int)
746
+
~value:person_cbor ~substrings:[ "name"; "int" ]);
747
+
Alcotest.test_case "int_mem: missing key names the integer key" `Quick
748
+
(fun () ->
749
+
let map_no_99 = V.Map [ (V.Int (Z.of_int 1), V.Text "alg") ] in
750
+
assert_error_contains
751
+
~codec:(Cbor.Codec.int_mem 99 Cbor.Codec.text)
752
+
~value:map_no_99 ~substrings:[ "99" ]);
753
+
Alcotest.test_case "nth: out-of-range index appears in the message" `Quick
754
+
(fun () ->
755
+
let three_ints =
756
+
V.Array
757
+
[ V.Int (Z.of_int 10); V.Int (Z.of_int 20); V.Int (Z.of_int 30) ]
758
+
in
759
+
assert_error_contains
760
+
~codec:(Cbor.Codec.nth 5 Cbor.Codec.int)
761
+
~value:three_ints ~substrings:[ "5" ]);
762
+
Alcotest.test_case "array: type mismatch reports element index" `Quick
763
+
(fun () ->
764
+
let mixed =
765
+
V.Array [ V.Int (Z.of_int 1); V.Text "two"; V.Int (Z.of_int 3) ]
766
+
in
767
+
assert_error_contains
768
+
~codec:(Cbor.Codec.array Cbor.Codec.int)
769
+
~value:mixed ~substrings:[ "1"; "text" ]);
770
+
Alcotest.test_case "Map.seal: type mismatch on a field names the field"
771
+
`Quick (fun () ->
772
+
let codec =
773
+
Cbor.Codec.Map.(
774
+
map (fun name age -> (name, age))
775
+
|> mem "name" fst Cbor.Codec.text
776
+
|> mem "age" snd Cbor.Codec.int
777
+
|> seal)
778
+
in
779
+
let bad_age =
780
+
V.Map
781
+
[ (V.Text "name", V.Text "Alice"); (V.Text "age", V.Text "thirty") ]
782
+
in
783
+
assert_error_contains ~codec ~value:bad_age ~substrings:[ "age"; "int" ]);
784
+
Alcotest.test_case "Map.seal: missing required member names the member"
785
+
`Quick (fun () ->
786
+
let codec =
787
+
Cbor.Codec.Map.(
788
+
map (fun name age -> (name, age))
789
+
|> mem "name" fst Cbor.Codec.text
790
+
|> mem "age" snd Cbor.Codec.int
791
+
|> seal)
792
+
in
793
+
let just_name = V.Map [ (V.Text "name", V.Text "Alice") ] in
794
+
assert_error_contains ~codec ~value:just_name ~substrings:[ "age" ]);
795
+
Alcotest.test_case "tag: mismatch reports both expected and actual tag"
796
+
`Quick (fun () ->
797
+
let value = V.Tag (7, V.Int (Z.of_int 0)) in
798
+
assert_error_contains
799
+
~codec:(Cbor.Codec.tag 5 Cbor.Codec.int)
800
+
~value ~substrings:[ "5"; "7" ]);
801
+
Alcotest.test_case "out_of_range: int decode beyond OCaml int names value"
802
+
`Quick (fun () ->
803
+
(* Int64.max_int fits in CBOR major 0 (8-byte uint) but not in OCaml
804
+
[int] (63-bit on 64-bit platforms), so the int codec must reject it
805
+
with an Out_of_range error that names the offending value. *)
806
+
let big = V.Int (Z.of_int64 Int64.max_int) in
807
+
assert_error_contains ~codec:Cbor.Codec.int ~value:big
808
+
~substrings:[ "9223372036854775807" ]);
809
+
]
810
+
717
811
let suite =
718
812
( "cbor",
719
813
rfc_tests @ unit_tests @ hostile_cases @ query_cases @ update_cases
720
-
@ introspection_cases )
814
+
@ introspection_cases @ error_quality_cases )