1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
|
let verbose = try Sys.getenv "VERBOSE" = "1" with _ -> false
module J = Yojson.Safe
module Fmt = CCFormat
module Cbor = Containers_cbor
type json = Yojson.Safe.t
module Test = struct
type expect =
| Diagnostic of string
| Decoded of json
type t = {
hex: string;
raw: string;
expect: expect;
roundtrip: bool;
}
end
let list_assoc_opt x l = try Some (List.assoc x l) with _ -> None
let extract_tests (j : json) : Test.t list =
let l = J.Util.to_list j in
List.map
(fun o ->
let o = J.Util.to_assoc o in
let hex = J.Util.to_string @@ List.assoc "hex" o in
let raw = CCString.of_hex_exn @@ hex in
let roundtrip = J.Util.to_bool @@ List.assoc "roundtrip" o in
let expect =
match list_assoc_opt "decoded" o, list_assoc_opt "diagnostic" o with
| None, Some (`String s) -> Test.Diagnostic s
| Some o, _ -> Test.Decoded o
| _ -> failwith "cannot find expected result"
in
{ Test.hex; raw; expect; roundtrip })
l
(* a few tests we need to skip *)
let skip =
[
"c249010000000000000000", "(bigint)";
"1BFFFFFFFFFFFFFFFF", "(requires int64, loss of precision)";
"3bffffffffffffffff", "(requires int64, loss of precision)";
"1bffffffffffffffff", "(requires int64 loss of precision)";
"5f42010243030405ff", "(requires representation of indefinite length)";
]
type count = {
mutable n_ok: int;
mutable n_err: int;
mutable n_skip: int;
}
let run_test (c : count) (t : Test.t) : unit =
try
match Cbor.decode_exn t.raw with
| exception e ->
c.n_err <- c.n_err + 1;
Fmt.printf "error when decoding %S: %s@." t.hex (Printexc.to_string e)
| cbor ->
if verbose then Fmt.printf " decoded into %a@." Cbor.pp_diagnostic cbor;
(* do we skip the rest of the test? *)
(match List.assoc_opt t.hex skip with
| Some reason ->
c.n_skip <- 1 + c.n_skip;
if verbose then
Fmt.printf "> @{<Yellow>SKIP@} %S (reason: %s)@." t.hex reason
| None ->
if verbose then Fmt.printf "> RUN test %S@." t.hex;
(* check roundtrip, except on floats because we always use float64 *)
if
t.roundtrip
&&
match cbor with
| `Float _ -> false
| _ -> true
then (
let hex' = Cbor.encode cbor |> CCString.to_hex in
if hex' <> t.hex then (
Fmt.printf
" @[<v>@{<Red>mismatch@} on roundtrip:@ from %S@ to %S@]@." t.hex
hex';
c.n_err <- c.n_err + 1;
raise Exit
) else if verbose then
Fmt.printf " roundtrip ok@."
);
(match t.expect with
| Test.Diagnostic s ->
let s' = Cbor.to_string_diagnostic cbor in
(* adjust display *)
let s' =
match s' with
| "inf" -> "Infinity"
| "-inf" -> "-Infinity"
| "nan" -> "NaN"
| _ -> s'
in
if s = s' then (
c.n_ok <- c.n_ok + 1;
if verbose then Fmt.printf " @{<Green>OK@}@."
) else (
Fmt.printf " @{<Red>ERR@}: expected diagnostic %S, got %S@." s s';
c.n_err <- c.n_err + 1
)
| Test.Decoded j ->
let rec compare_cj (cbor : Cbor.t) (j : json) =
match cbor, j with
| `Null, `Null -> true
| `Float f1, `Float f2 -> Float.equal f1 f2
| `Bool b1, `Bool b2 -> b1 = b2
| `Map l, `Assoc l2 ->
List.for_all
(fun (k, v) ->
try compare_cj (List.assoc (`Text k) l) v
with Not_found -> false)
l2
| `Int i, `Int j -> i = Int64.of_int j
| `Text s1, `String s2 -> s1 = s2
| `Array l1, `List l2 ->
List.length l1 = List.length l2 && List.for_all2 compare_cj l1 l2
| `Int i, `Intlit s -> Int64.to_string i = s
| _, `Intlit "-18446744073709551617" ->
(* skip bigint test*)
true
| _ ->
Fmt.printf " TODO: compare %a with %a@." Cbor.pp_diagnostic cbor
J.pp j;
true
in
let ok = compare_cj cbor j in
if ok then (
c.n_ok <- 1 + c.n_ok;
if verbose then Fmt.printf " expect: @{<Green>OK@}@."
) else (
c.n_err <- 1 + c.n_err;
Fmt.printf " expect: @{<Red>ERROR@} (got %a, expected %a)@."
Cbor.pp_diagnostic cbor J.pp j
)))
with Exit -> ()
let run_tests (l : Test.t list) =
let c = { n_err = 0; n_ok = 0; n_skip = 0 } in
List.iter (run_test c) l;
let has_err = c.n_err <> 0 in
let total = c.n_err + c.n_ok + c.n_skip in
if (verbose || has_err) && total <> List.length l then
Fmt.printf "@{<Blue>warning@}: ran %d tests, for list of %d tests@." total
(List.length l);
if has_err then (
Fmt.printf "@.@.#####@.@{<Red>FAIL@}: %d errors, %d ok, %d skip@." c.n_err
c.n_ok c.n_skip;
exit 1
) else
Fmt.printf "@.@.#####@.@{<Green>OK@}: %d ok, %d skip@." c.n_ok c.n_skip
let () =
let color = try Sys.getenv "COLOR" = "1" with _ -> false in
if color then CCFormat.set_color_default true;
let content = CCIO.File.read_exn Sys.argv.(1) in
let j = Yojson.Safe.from_string content in
let tests = extract_tests j in
(*Format.printf "tests: %a@." (Fmt.Dump.list Test.pp) tests;*)
run_tests tests;
()
|