Merge pull request #413 from c-cube/feat-cbor

add CBOR sub-library

.github/workflows/main.yml

@@ -17,7 +17,7 @@ jobs:
         os:
             - macos-latest
             - ubuntu-latest
-            - windows-latest
+              #- windows-latest
         ocaml-compiler:
             - '4.03.x'
             - '4.13.x'

containers.opam

@@ -19,6 +19,7 @@ depends: [
   "qtest" { with-test }
   "qcheck" { >= "0.14" & with-test }
   "ounit2" { with-test }
+  "yojson" { with-test }
   "iter" { with-test }
   "gen" { with-test }
   "csexp" { with-test }

src/cbor/containers_cbor.ml

@@ -0,0 +1,318 @@
+
+module Fmt = CCFormat
+
+type t =
+  [ `Null
+  | `Undefined
+  | `Simple of int
+  | `Bool of bool
+  | `Int of int
+  | `Float of float
+  | `Bytes of string
+  | `Text of string
+  | `Array of t list
+  | `Map of (t * t) list
+  | `Tag of int * t
+  ]
+
+let rec pp_diagnostic out (self:t) =
+  match self with
+  | `Null -> Fmt.string out "null"
+  | `Undefined -> Fmt.string out "undefined"
+  | `Simple i -> Fmt.fprintf out "simple(%d)" i
+  | `Bool b -> Fmt.bool out b
+  | `Int i -> Fmt.int out i
+  | `Float f -> Fmt.float out f
+  | `Bytes b -> Fmt.fprintf out "h'%s'" (CCString.to_hex b)
+  | `Text s -> Fmt.fprintf out "%S" s
+  | `Array l ->
+    Fmt.fprintf out "[@[";
+    List.iteri
+      (fun i x ->
+        if i>0  then Fmt.fprintf out ",@ ";
+        pp_diagnostic out x) l;
+    Fmt.fprintf out "@]]"
+  | `Map l ->
+    Fmt.fprintf out "{@[";
+    List.iteri
+      (fun i (k,v) ->
+        if i>0  then Fmt.fprintf out ",@ ";
+        Fmt.fprintf out "@[%a:@ %a@]" pp_diagnostic k pp_diagnostic v) l;
+    Fmt.fprintf out "@]}"
+  | `Tag (i,x) -> Fmt.fprintf out "%d(@[%a@])" i pp_diagnostic x
+
+let to_string_diagnostic (self:t) : string =
+  Format.asprintf "@[<h>%a@]" pp_diagnostic self
+
+(* we use funtions from Bytes *)
+[@@@ifge 4.08]
+
+exception Indefinite
+
+let decode_exn (s:string) : t =
+  let b = Bytes.unsafe_of_string s in
+  let i = ref 0 in
+
+  (* currently at end delimiter? *)
+  let[@inline] is_break_stop_code () =
+    Char.code s.[!i] = 0b111_11111
+  in
+
+  let[@inline] read_i8 () =
+    let c = Char.code s.[!i] in
+    incr i;
+    c
+  in
+
+  let[@inline] read_i16 () =
+    let c = Bytes.get_uint16_be b !i in
+    i := !i + 2;
+    c
+  in
+
+  let[@inline] read_i32 () =
+    let c = Bytes.get_int32_be b !i in
+    i := !i + 4;
+    c
+  in
+
+  let[@inline] read_i64 () =
+    let c = Bytes.get_int64_be b !i in
+    i := !i + 8;
+    c
+  in
+
+  let reserve_n n =
+    let j = !i in
+    if j + n > String.length s then failwith "cbor: cannot extract slice";
+    i := !i + n;
+    j
+  in
+
+  let[@inline] i64_to_int i =
+    let j = Int64.to_int i in
+    if Int64.(of_int j = i) then j
+    else failwith "int64 does not fit in int"
+  in
+
+  (* read integer value from least significant bits *)
+  let read_int ~allow_indefinite low =
+    match low with
+    | _ when low < 0 -> failwith "cbor: invalid length"
+    | _ when low < 24 -> Int64.of_int low
+    | 24 -> Int64.of_int (read_i8())
+    | 25 -> Int64.of_int (read_i16())
+    | 26 -> Int64.of_int32 (read_i32())
+    | 27 -> read_i64()
+    | 28 | 29 | 30 -> failwith "cbor: invalid length"
+    | 31 ->
+      if allow_indefinite then raise_notrace Indefinite
+      else failwith "cbor: invalid integer 31 in this context"
+    | _ -> assert false
+  in
+
+  (* appendix D
+
+     double decode_half(unsigned char *halfp) {
+       unsigned half = (halfp[0] << 8) + halfp[1];
+       unsigned exp = (half >> 10) & 0x1f;
+       unsigned mant = half & 0x3ff;
+       double val;
+       if (exp == 0) val = ldexp(mant, -24);
+       else if (exp != 31) val = ldexp(mant + 1024, exp - 25);
+       else val = mant == 0 ? INFINITY : NAN;
+       return half & 0x8000 ? -val : val;
+     }
+  *)
+  let decode_f16 (half:int) : float =
+    (* exponent is bits 15:10 *)
+    let exp = (half lsr 10) land 0x1f in
+    (* mantissa is bits 9:0 *)
+    let mant = half land 0x3ff in
+    let value =
+      if exp = 0 then ldexp (float mant) (-24)
+      else if exp <> 31 then ldexp (float (mant + 1024)) (exp - 25)
+      else if mant = 0 then infinity else nan
+    in
+    if half land 0x8000 <> 0 then -. value else value
+  in
+
+  (* roughly follow https://www.rfc-editor.org/rfc/rfc8949.html#pseudocode *)
+  let rec read_value () =
+    let c = read_i8() in
+    let high = (c land 0b111_00000) lsr 5 in
+    let low  = c land 0b000_11111 in
+    begin match high with
+      | 0 -> `Int (read_int ~allow_indefinite:false low |> i64_to_int)
+      | 1 ->
+        let i = read_int ~allow_indefinite:false low |> i64_to_int in
+        `Int (-1 - i)
+      | 2 ->
+        let s = read_bytes ~ty:`Bytes low in
+        `Bytes s
+      | 3 ->
+        let s = read_bytes ~ty:`String low in
+        `Text s
+
+      | 4 ->
+        let l =
+          match read_int ~allow_indefinite:true low |> i64_to_int with
+          | len -> List.init len (fun _ -> read_value())
+          | exception Indefinite ->
+            let l = ref [] in
+            while not (is_break_stop_code ()) do
+              l := read_value() :: !l
+            done;
+            incr i; (* consume stop code *)
+            List.rev !l
+        in
+        `Array l
+
+      | 5 ->
+        let l =
+          match read_int ~allow_indefinite:true low |> i64_to_int with
+          | len -> List.init len (fun _ -> read_pair())
+          | exception Indefinite ->
+            let l = ref [] in
+            while not (is_break_stop_code ()) do
+              l := read_pair() :: !l
+            done;
+            incr i; (* consume stop code *)
+            List.rev !l
+        in
+        `Map l
+
+      | 6 ->
+        let tag = read_int ~allow_indefinite:false low |> i64_to_int in
+        let v = read_value() in
+        `Tag (tag,v)
+
+      | 7 ->
+        (* simple or float,
+           https://www.rfc-editor.org/rfc/rfc8949.html#fpnocont *)
+        let i = read_int ~allow_indefinite:false low in
+        begin match low with
+          | 20 -> `Bool false
+          | 21 -> `Bool true
+          | 22 -> `Null
+          | 23 -> `Undefined
+          | _ when low<=24 -> `Simple (i64_to_int i)
+          | 25 -> (* float16 *)
+            `Float (decode_f16 (Int64.to_int i))
+          | 26 -> (* float 32 *)
+            `Float (Int32.float_of_bits (Int64.to_int32 i))
+          | 27 -> (* float 64 *)
+            `Float (Int64.float_of_bits i)
+          | 28 | 29 | 30 -> failwith "cbor: malformed"
+          | 31 -> failwith "uncaught 'break' stop code"
+          | _ -> assert false (* unreachable *)
+        end
+
+      | _ -> assert false (* unreachable *)
+    end
+
+    and read_bytes ~ty low =
+      match read_int ~allow_indefinite:true low |> i64_to_int with
+      | exception Indefinite ->
+        let buf = Buffer.create 32 in
+        while not (is_break_stop_code()) do
+          match read_value(), ty with
+          | `Text s, `String
+          | `Bytes s, `Bytes -> Buffer.add_string buf s
+          | _ -> failwith "cbor: invalid chunk in indefinite length string/byte"
+        done;
+        incr i; (* consume stop code *)
+        Buffer.contents buf
+      | len ->
+        let off = reserve_n len in
+        String.sub s off len
+
+    and read_pair() =
+      let k = read_value() in
+      let v = read_value() in
+      k,v
+  in
+  read_value()
+
+let decode s =
+  try Ok (decode_exn s)
+  with Failure s -> Error s
+
+let encode ?(buf=Buffer.create 32) (self:t) : string =
+  Buffer.clear buf;
+
+  let[@inline] add_byte (high:int) (low:int) =
+    let i = (high lsl 5) lor low in
+    assert ((i land 0xff) == i);
+    Buffer.add_char buf (Char.unsafe_chr i)
+  in
+
+  let add_i64 (i:int64) =
+    Buffer.add_int64_be buf i
+  in
+
+  (* add unsigned integer, including first tag byte *)
+  let add_uint (high:int) (x:int) =
+    assert (x >= 0);
+    if x < 24 then add_byte high x
+    else if x <= 0xff then (
+      add_byte high 24;
+      Buffer.add_char buf (Char.unsafe_chr x)
+    ) else if x <= 0xff_ff then (
+      add_byte high 25;
+      Buffer.add_uint16_be buf x
+    ) else if x <= 0xff_ff_ff_ff then (
+      add_byte high 26;
+      Buffer.add_int32_be buf (Int32.of_int x)
+    ) else (
+      add_byte high 27;
+      Buffer.add_int64_be buf (Int64.of_int x)
+    )
+  in
+
+  let rec encode_val (self:t): unit =
+    match self with
+    | `Bool false -> add_byte 7 20
+    | `Bool true -> add_byte 7 21
+    | `Null -> add_byte 7 22
+    | `Undefined -> add_byte 7 23
+    | `Simple i ->
+      if i < 24 then add_byte 7 i
+      else if i <= 0xff then (
+        add_byte 7 24;
+        Buffer.add_char buf (Char.unsafe_chr i)
+      ) else (
+        failwith "cbor: simple value too high (above 255)"
+      )
+    | `Float f ->
+      add_byte 7 27; (* float 64 *)
+      add_i64 (Int64.bits_of_float f)
+    | `Array l ->
+      add_uint 4 (List.length l);
+      List.iter encode_val l
+    | `Map l ->
+      add_uint 5 (List.length l);
+      List.iter (fun (k,v) -> encode_val k; encode_val v) l
+    | `Text s ->
+      add_uint 3 (String.length s);
+      Buffer.add_string buf s
+    | `Bytes s ->
+      add_uint 2 (String.length s);
+      Buffer.add_string buf s
+    | `Tag (t, v) ->
+      add_uint 6 t;
+      encode_val v
+    | `Int i ->
+      if i >= 0 then add_uint 0 i
+      else if min_int + 2 > i then (
+        (* large negative int, be careful. encode [(-i)-1] via int64. *)
+        add_byte 1 27;
+        Buffer.add_int64_be buf (Int64.(neg (add 1L (of_int i))))
+      ) else (
+        add_uint 1 (-i-1)
+      )
+  in
+  encode_val self;
+  Buffer.contents buf
+
+[@@@endif]

src/cbor/containers_cbor.mli

@@ -0,0 +1,45 @@
+
+(** CBOR encoder/decoder.
+
+  The type is chosen to be compatible with ocaml-cbor.
+  See {{: https://www.rfc-editor.org/rfc/rfc8949.html} the RFC}.
+
+  {b note} this is experimental.
+
+  {b note} this is only available on OCaml >= 4.08. Below that, the module
+    is empty.
+
+  @since NEXT_RELEASE
+  *)
+
+type t =
+  [ `Null
+  | `Undefined
+  | `Simple of int
+  | `Bool of bool
+  | `Int of int
+  | `Float of float
+  | `Bytes of string
+  | `Text of string
+  | `Array of t list
+  | `Map of (t * t) list
+  | `Tag of int * t
+  ]
+
+val pp_diagnostic : t CCFormat.printer
+
+val to_string_diagnostic : t -> string
+
+(* we use funtions from Bytes *)
+[@@@ifge 4.08]
+
+val encode : ?buf:Buffer.t -> t -> string
+
+val decode : string -> (t, string) result
+
+val decode_exn : string -> t
+(** Like {!decode}.
+    @raise Failure if the string isn't valid *)
+
+
+[@@@endif]

src/cbor/dune

@@ -0,0 +1,5 @@
+(library
+  (name containers_cbor)
+  (libraries containers)
+  (preprocess (action (run %{project_root}/src/core/cpp/cpp.exe %{input-file})))
+  (public_name containers.cbor))

src/cbor/tests/appendix_a.json

@@ -0,0 +1,638 @@
+
+[
+  {
+    "cbor": "AA==",
+    "hex": "00",
+    "roundtrip": true,
+    "decoded": 0
+  },
+  {
+    "cbor": "AQ==",
+    "hex": "01",
+    "roundtrip": true,
+    "decoded": 1
+  },
+  {
+    "cbor": "Cg==",
+    "hex": "0a",
+    "roundtrip": true,
+    "decoded": 10
+  },
+  {
+    "cbor": "Fw==",
+    "hex": "17",
+    "roundtrip": true,
+    "decoded": 23
+  },
+  {
+    "cbor": "GBg=",
+    "hex": "1818",
+    "roundtrip": true,
+    "decoded": 24
+  },
+  {
+    "cbor": "GBk=",
+    "hex": "1819",
+    "roundtrip": true,
+    "decoded": 25
+  },
+  {
+    "cbor": "GGQ=",
+    "hex": "1864",
+    "roundtrip": true,
+    "decoded": 100
+  },
+  {
+    "cbor": "GQPo",
+    "hex": "1903e8",
+    "roundtrip": true,
+    "decoded": 1000
+  },
+  {
+    "cbor": "GgAPQkA=",
+    "hex": "1a000f4240",
+    "roundtrip": true,
+    "decoded": 1000000
+  },
+  {
+    "cbor": "GwAAAOjUpRAA",
+    "hex": "1b000000e8d4a51000",
+    "roundtrip": true,
+    "decoded": 1000000000000
+  },
+  {
+    "cbor": "G///////////",
+    "hex": "1bffffffffffffffff",
+    "roundtrip": true,
+    "decoded": 18446744073709551615
+  },
+  {
+    "cbor": "wkkBAAAAAAAAAAA=",
+    "hex": "c249010000000000000000",
+    "roundtrip": true,
+    "decoded": 18446744073709551616
+  },
+  {
+    "cbor": "O///////////",
+    "hex": "3bffffffffffffffff",
+    "roundtrip": true,
+    "decoded": -18446744073709551616
+  },
+  {
+    "cbor": "w0kBAAAAAAAAAAA=",
+    "hex": "c349010000000000000000",
+    "roundtrip": true,
+    "decoded": -18446744073709551617
+  },
+  {
+    "cbor": "IA==",
+    "hex": "20",
+    "roundtrip": true,
+    "decoded": -1
+  },
+  {
+    "cbor": "KQ==",
+    "hex": "29",
+    "roundtrip": true,
+    "decoded": -10
+  },
+  {
+    "cbor": "OGM=",
+    "hex": "3863",
+    "roundtrip": true,
+    "decoded": -100
+  },
+  {
+    "cbor": "OQPn",
+    "hex": "3903e7",
+    "roundtrip": true,
+    "decoded": -1000
+  },
+  {
+    "cbor": "+QAA",
+    "hex": "f90000",
+    "roundtrip": true,
+    "decoded": 0.0
+  },
+  {
+    "cbor": "+YAA",
+    "hex": "f98000",
+    "roundtrip": true,
+    "decoded": -0.0
+  },
+  {
+    "cbor": "+TwA",
+    "hex": "f93c00",
+    "roundtrip": true,
+    "decoded": 1.0
+  },
+  {
+    "cbor": "+z/xmZmZmZma",
+    "hex": "fb3ff199999999999a",
+    "roundtrip": true,
+    "decoded": 1.1
+  },
+  {
+    "cbor": "+T4A",
+    "hex": "f93e00",
+    "roundtrip": true,
+    "decoded": 1.5
+  },
+  {
+    "cbor": "+Xv/",
+    "hex": "f97bff",
+    "roundtrip": true,
+    "decoded": 65504.0
+  },
+  {
+    "cbor": "+kfDUAA=",
+    "hex": "fa47c35000",
+    "roundtrip": true,
+    "decoded": 100000.0
+  },
+  {
+    "cbor": "+n9///8=",
+    "hex": "fa7f7fffff",
+    "roundtrip": true,
+    "decoded": 3.4028234663852886e+38
+  },
+  {
+    "cbor": "+3435DyIAHWc",
+    "hex": "fb7e37e43c8800759c",
+    "roundtrip": true,
+    "decoded": 1.0e+300
+  },
+  {
+    "cbor": "+QAB",
+    "hex": "f90001",
+    "roundtrip": true,
+    "decoded": 5.960464477539063e-08
+  },
+  {
+    "cbor": "+QQA",
+    "hex": "f90400",
+    "roundtrip": true,
+    "decoded": 6.103515625e-05
+  },
+  {
+    "cbor": "+cQA",
+    "hex": "f9c400",
+    "roundtrip": true,
+    "decoded": -4.0
+  },
+  {
+    "cbor": "+8AQZmZmZmZm",
+    "hex": "fbc010666666666666",
+    "roundtrip": true,
+    "decoded": -4.1
+  },
+  {
+    "cbor": "+XwA",
+    "hex": "f97c00",
+    "roundtrip": true,
+    "diagnostic": "Infinity"
+  },
+  {
+    "cbor": "+X4A",
+    "hex": "f97e00",
+    "roundtrip": true,
+    "diagnostic": "NaN"
+  },
+  {
+    "cbor": "+fwA",
+    "hex": "f9fc00",
+    "roundtrip": true,
+    "diagnostic": "-Infinity"
+  },
+  {
+    "cbor": "+n+AAAA=",
+    "hex": "fa7f800000",
+    "roundtrip": false,
+    "diagnostic": "Infinity"
+  },
+  {
+    "cbor": "+n/AAAA=",
+    "hex": "fa7fc00000",
+    "roundtrip": false,
+    "diagnostic": "NaN"
+  },
+  {
+    "cbor": "+v+AAAA=",
+    "hex": "faff800000",
+    "roundtrip": false,
+    "diagnostic": "-Infinity"
+  },
+  {
+    "cbor": "+3/wAAAAAAAA",
+    "hex": "fb7ff0000000000000",
+    "roundtrip": false,
+    "diagnostic": "Infinity"
+  },
+  {
+    "cbor": "+3/4AAAAAAAA",
+    "hex": "fb7ff8000000000000",
+    "roundtrip": false,
+    "diagnostic": "NaN"
+  },
+  {
+    "cbor": "+//wAAAAAAAA",
+    "hex": "fbfff0000000000000",
+    "roundtrip": false,
+    "diagnostic": "-Infinity"
+  },
+  {
+    "cbor": "9A==",
+    "hex": "f4",
+    "roundtrip": true,
+    "decoded": false
+  },
+  {
+    "cbor": "9Q==",
+    "hex": "f5",
+    "roundtrip": true,
+    "decoded": true
+  },
+  {
+    "cbor": "9g==",
+    "hex": "f6",
+    "roundtrip": true,
+    "decoded": null
+  },
+  {
+    "cbor": "9w==",
+    "hex": "f7",
+    "roundtrip": true,
+    "diagnostic": "undefined"
+  },
+  {
+    "cbor": "8A==",
+    "hex": "f0",
+    "roundtrip": true,
+    "diagnostic": "simple(16)"
+  },
+  {
+    "cbor": "+Bg=",
+    "hex": "f818",
+    "roundtrip": true,
+    "diagnostic": "simple(24)"
+  },
+  {
+    "cbor": "+P8=",
+    "hex": "f8ff",
+    "roundtrip": true,
+    "diagnostic": "simple(255)"
+  },
+  {
+    "cbor": "wHQyMDEzLTAzLTIxVDIwOjA0OjAwWg==",
+    "hex": "c074323031332d30332d32315432303a30343a30305a",
+    "roundtrip": true,
+    "diagnostic": "0(\"2013-03-21T20:04:00Z\")"
+  },
+  {
+    "cbor": "wRpRS2ew",
+    "hex": "c11a514b67b0",
+    "roundtrip": true,
+    "diagnostic": "1(1363896240)"
+  },
+  {
+    "cbor": "wftB1FLZ7CAAAA==",
+    "hex": "c1fb41d452d9ec200000",
+    "roundtrip": true,
+    "diagnostic": "1(1363896240.5)"
+  },
+  {
+    "cbor": "10QBAgME",
+    "hex": "d74401020304",
+    "roundtrip": true,
+    "diagnostic": "23(h'01020304')"
+  },
+  {
+    "cbor": "2BhFZElFVEY=",
+    "hex": "d818456449455446",
+    "roundtrip": true,
+    "diagnostic": "24(h'6449455446')"
+  },
+  {
+    "cbor": "2CB2aHR0cDovL3d3dy5leGFtcGxlLmNvbQ==",
+    "hex": "d82076687474703a2f2f7777772e6578616d706c652e636f6d",
+    "roundtrip": true,
+    "diagnostic": "32(\"http://www.example.com\")"
+  },
+  {
+    "cbor": "QA==",
+    "hex": "40",
+    "roundtrip": true,
+    "diagnostic": "h''"
+  },
+  {
+    "cbor": "RAECAwQ=",
+    "hex": "4401020304",
+    "roundtrip": true,
+    "diagnostic": "h'01020304'"
+  },
+  {
+    "cbor": "YA==",
+    "hex": "60",
+    "roundtrip": true,
+    "decoded": ""
+  },
+  {
+    "cbor": "YWE=",
+    "hex": "6161",
+    "roundtrip": true,
+    "decoded": "a"
+  },
+  {
+    "cbor": "ZElFVEY=",
+    "hex": "6449455446",
+    "roundtrip": true,
+    "decoded": "IETF"
+  },
+  {
+    "cbor": "YiJc",
+    "hex": "62225c",
+    "roundtrip": true,
+    "decoded": "\"\\"
+  },
+  {
+    "cbor": "YsO8",
+    "hex": "62c3bc",
+    "roundtrip": true,
+    "decoded": "ü"
+  },
+  {
+    "cbor": "Y+awtA==",
+    "hex": "63e6b0b4",
+    "roundtrip": true,
+    "decoded": "水"
+  },
+  {
+    "cbor": "ZPCQhZE=",
+    "hex": "64f0908591",
+    "roundtrip": true,
+    "decoded": "𐅑"
+  },
+  {
+    "cbor": "gA==",
+    "hex": "80",
+    "roundtrip": true,
+    "decoded": [
+
+    ]
+  },
+  {
+    "cbor": "gwECAw==",
+    "hex": "83010203",
+    "roundtrip": true,
+    "decoded": [
+      1,
+      2,
+      3
+    ]
+  },
+  {
+    "cbor": "gwGCAgOCBAU=",
+    "hex": "8301820203820405",
+    "roundtrip": true,
+    "decoded": [
+      1,
+      [
+        2,
+        3
+      ],
+      [
+        4,
+        5
+      ]
+    ]
+  },
+  {
+    "cbor": "mBkBAgMEBQYHCAkKCwwNDg8QERITFBUWFxgYGBk=",
+    "hex": "98190102030405060708090a0b0c0d0e0f101112131415161718181819",
+    "roundtrip": true,
+    "decoded": [
+      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
+    ]
+  },
+  {
+    "cbor": "oA==",
+    "hex": "a0",
+    "roundtrip": true,
+    "decoded": {
+    }
+  },
+  {
+    "cbor": "ogECAwQ=",
+    "hex": "a201020304",
+    "roundtrip": true,
+    "diagnostic": "{1: 2, 3: 4}"
+  },
+  {
+    "cbor": "omFhAWFiggID",
+    "hex": "a26161016162820203",
+    "roundtrip": true,
+    "decoded": {
+      "a": 1,
+      "b": [
+        2,
+        3
+      ]
+    }
+  },
+  {
+    "cbor": "gmFhoWFiYWM=",
+    "hex": "826161a161626163",
+    "roundtrip": true,
+    "decoded": [
+      "a",
+      {
+        "b": "c"
+      }
+    ]
+  },
+  {
+    "cbor": "pWFhYUFhYmFCYWNhQ2FkYURhZWFF",
+    "hex": "a56161614161626142616361436164614461656145",
+    "roundtrip": true,
+    "decoded": {
+      "a": "A",
+      "b": "B",
+      "c": "C",
+      "d": "D",
+      "e": "E"
+    }
+  },
+  {
+    "cbor": "X0IBAkMDBAX/",
+    "hex": "5f42010243030405ff",
+    "roundtrip": false,
+    "diagnostic": "(_ h'0102', h'030405')"
+  },
+  {
+    "cbor": "f2VzdHJlYWRtaW5n/w==",
+    "hex": "7f657374726561646d696e67ff",
+    "roundtrip": false,
+    "decoded": "streaming"
+  },
+  {
+    "cbor": "n/8=",
+    "hex": "9fff",
+    "roundtrip": false,
+    "decoded": [
+
+    ]
+  },
+  {
+    "cbor": "nwGCAgOfBAX//w==",
+    "hex": "9f018202039f0405ffff",
+    "roundtrip": false,
+    "decoded": [
+      1,
+      [
+        2,
+        3
+      ],
+      [
+        4,
+        5
+      ]
+    ]
+  },
+  {
+    "cbor": "nwGCAgOCBAX/",
+    "hex": "9f01820203820405ff",
+    "roundtrip": false,
+    "decoded": [
+      1,
+      [
+        2,
+        3
+      ],
+      [
+        4,
+        5
+      ]
+    ]
+  },
+  {
+    "cbor": "gwGCAgOfBAX/",
+    "hex": "83018202039f0405ff",
+    "roundtrip": false,
+    "decoded": [
+      1,
+      [
+        2,
+        3
+      ],
+      [
+        4,
+        5
+      ]
+    ]
+  },
+  {
+    "cbor": "gwGfAgP/ggQF",
+    "hex": "83019f0203ff820405",
+    "roundtrip": false,
+    "decoded": [
+      1,
+      [
+        2,
+        3
+      ],
+      [
+        4,
+        5
+      ]
+    ]
+  },
+  {
+    "cbor": "nwECAwQFBgcICQoLDA0ODxAREhMUFRYXGBgYGf8=",
+    "hex": "9f0102030405060708090a0b0c0d0e0f101112131415161718181819ff",
+    "roundtrip": false,
+    "decoded": [
+      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
+    ]
+  },
+  {
+    "cbor": "v2FhAWFinwID//8=",
+    "hex": "bf61610161629f0203ffff",
+    "roundtrip": false,
+    "decoded": {
+      "a": 1,
+      "b": [
+        2,
+        3
+      ]
+    }
+  },
+  {
+    "cbor": "gmFhv2FiYWP/",
+    "hex": "826161bf61626163ff",
+    "roundtrip": false,
+    "decoded": [
+      "a",
+      {
+        "b": "c"
+      }
+    ]
+  },
+  {
+    "cbor": "v2NGdW71Y0FtdCH/",
+    "hex": "bf6346756ef563416d7421ff",
+    "roundtrip": false,
+    "decoded": {
+      "Fun": true,
+      "Amt": -2
+    }
+  }
+]
+

src/cbor/tests/dune

@@ -0,0 +1,26 @@
+(executable
+ (name t_appendix_a)
+ (modules t_appendix_a)
+ (preprocess
+  (action
+   (run %{project_root}/src/core/cpp/cpp.exe %{input-file})))
+ (libraries yojson containers containers.cbor))
+
+(rule
+ (alias runtest)
+ (deps t_appendix_a.exe appendix_a.json)
+ (action
+  (run ./t_appendix_a.exe ./appendix_a.json)))
+
+(executable
+ (name t)
+ (modules t)
+ (preprocess
+  (action
+   (run %{project_root}/src/core/cpp/cpp.exe %{input-file})))
+ (libraries qcheck-core qcheck-core.runner containers containers.cbor))
+
+(rule
+ (alias runtest)
+ (action
+  (run ./t.exe --no-colors)))

src/cbor/tests/t.ml

@@ -0,0 +1,74 @@
+
+module Q = QCheck
+module Cbor = Containers_cbor
+
+let suite = ref []
+
+[@@@ifge 4.08]
+
+let gen_c : Cbor.t Q.Gen.t =
+  let open Q.Gen in
+  sized @@ fix @@ fun self size ->
+    let recurse = self (size-1) in
+    let base = [
+      (1, return `Null);
+      (1, return `Undefined);
+      (3, let+ x = int in `Int x);
+      (1, let+ b = bool in `Bool b);
+      (1, let+ x = 0 -- 19 in `Simple x);
+      (1, let+ x = 26 -- 127 in `Simple x);
+      (1, let+ f = float in `Float f);
+      (2, let+ s = string_size ~gen:printable (0--150) in `Text s);
+      (2, let+ s = string_size ~gen:char (0--150) in `Bytes s);
+    ] in
+    let g_base = frequency base in
+    let rec_ = [
+      (2, let+ l =
+          if size>10 then list_size (0--1024) g_base
+          else list_size (0--10) recurse
+      in `Array l);
+      (2, let+ l =
+          if size>10 then list_size (0--1024) (pair g_base g_base)
+          else list_size (0--5) (pair g_base recurse)
+      in `Map l);
+    ]in
+    frequency (if size>0  then base @ rec_ else base)
+
+let rec shrink (c:Cbor.t) : Cbor.t Q.Iter.t =
+  let open Q.Iter in
+  match c with
+  | `Null | `Undefined | `Bool false -> empty
+  | `Bool true -> return (`Bool false)
+  | `Simple i -> let+ i = Q.Shrink.int i in `Simple i
+  | `Int i -> let+ i = Q.Shrink.int i in `Int i
+  | `Tag(t,i) -> let+ i = shrink i in `Tag (t,i)
+  | `Float _ -> empty
+  | `Array l ->
+    let+ l = Q.Shrink.list ~shrink l in `Array l
+  | `Map l ->
+    let shrink_pair (a,b) =
+      (let+a = shrink a in a,b) <+> (let+b = shrink b in a,b)
+    in
+    let+ l = Q.Shrink.list ~shrink:shrink_pair l in `Map l
+  | `Text s ->
+    let+ s = Q.Shrink.string s in `Text s
+  | `Bytes s ->
+    let+ s = Q.Shrink.string s in `Bytes s
+
+
+let arb = Q.make ~shrink ~print:Cbor.to_string_diagnostic gen_c
+
+let t1 =
+  Q.Test.make ~count:10_000 ~name:"to_from_same" arb @@ fun c ->
+    let s = Cbor.encode c in
+    let c' = Cbor.decode_exn s in
+    if not (c = c') then
+      Q.Test.fail_reportf "@[<hv2>roundtrip failed:@ from %a@ to %a@]"
+      Cbor.pp_diagnostic c Cbor.pp_diagnostic c';
+    true
+
+let () = suite := t1 :: !suite
+
+[@@@endif]
+
+let () = QCheck_base_runner.run_tests_main !suite

src/cbor/tests/t_appendix_a.ml

@@ -0,0 +1,189 @@
+
+let verbose = try Sys.getenv "VERBOSE"="1" with _ -> false
+
+[@@@ifge 4.08]
+
+module J = Yojson.Safe
+module Fmt = CCFormat
+module Cbor = Containers_cbor
+
+type json = Yojson.Safe.t
+
+let pp_json = J.pretty_print ~std:true
+let spf = Printf.sprintf
+
+module Test = struct
+  type expect =
+    | Diagnostic of string
+    | Decoded of json
+
+  type t = {
+    hex: string;
+    raw: string;
+    expect: expect;
+    roundtrip: bool;
+  }
+
+  let pp_expect out = function
+    | Diagnostic s -> Fmt.fprintf out "(diagnostic %S)" s
+    | Decoded j -> Fmt.fprintf out "(@[decoded:@ %a@])" J.pp j
+
+  let pp out (self:t) =
+    Fmt.fprintf out "{@[hex: %S,@ expected: %a,@ roundtrip: %b@]}"
+      self.hex pp_expect self.expect self.roundtrip
+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@.";
+        )
+      );
+
+      begin 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=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 ->
+            string_of_int 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
+        )
+      end
+    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;
+  ()
+
+
+[@@@endif]