CBOR monotone: Major type 7 is short field encoded

cbor/CBOR.ml

@@ -6,223 +6,264 @@ module SE = EndianString.BigEndian_unsafe
 
 exception Error of string
 
-let (@@) f x = f x
-let (|>) x f = f x
-let list_iteri f l = let i = ref 0 in List.iter (fun x -> f !i x; incr i) l
+exception Noncanonical of string
+
 let fail fmt = ksprintf (fun s -> raise (Error s)) fmt
+let noncanonical fmt = ksprintf (fun s -> raise (Noncanonical s))
+    ("noncanonical CTAP2 CBOR: " ^^ fmt)
 
 module Encode = struct
 
-let start () = Buffer.create 10
+  let start () = Buffer.create 10
 
-let init b ~maj add =
-  assert (maj >= 0 && maj < 8);
-  assert (add >= 0 && add < 32);
-  Buffer.add_char b @@ char_of_int @@ (maj lsl 5) lor add
+  let init b ~maj add =
+    assert (maj >= 0 && maj < 8);
+    assert (add >= 0 && add < 32);
+    Buffer.add_char b @@ char_of_int @@ (maj lsl 5) lor add
 
-let put_n b n f x =
-  let s = Bytes.create n in
-  f s 0 x;
-  Buffer.add_string b (Bytes.unsafe_to_string s)
+  let put_n b n f x =
+    let s = Bytes.create n in
+    f s 0 x;
+    Buffer.add_string b (Bytes.unsafe_to_string s)
 
-let max_uint32 =
-  match Sys.word_size with
-  | 32 -> max_int (* max signed int, but on 32-bit this is enough *)
-  | _ -> int_of_string "0xFF_FF_FF_FF" (* so that it compiles on 32-bit *)
+  let max_uint32 =
+    match Sys.word_size with
+    | 32 -> max_int (* max signed int, but on 32-bit this is enough *)
+    | _ -> int_of_string "0xFF_FF_FF_FF" (* so that it compiles on 32-bit *)
 
-let put b ~maj n =
-  assert (n >= 0);
-  if n < 24 then
-    init b ~maj n
-  else if n < 256 then
-    begin init b ~maj 24; Buffer.add_char b @@ char_of_int n end
-  else if n < 65536 then
-    begin init b ~maj 25; put_n b 2 BE.set_int16 n end
-  else if n <= max_uint32 then
-    begin init b ~maj 26; put_n b 4 BE.set_int32 @@ Int32.of_int n end
-  else
-    begin init b ~maj 27; put_n b 8 BE.set_int64 @@ Int64.of_int n end
+  let put b ~maj n =
+    assert (n >= 0);
+    if n < 24 then
+      init b ~maj n
+    else if n < 256 then
+      begin init b ~maj 24; Buffer.add_char b @@ char_of_int n end
+    else if n < 65536 then
+      begin init b ~maj 25; put_n b 2 BE.set_int16 n end
+    else if n <= max_uint32 then
+      begin init b ~maj 26; put_n b 4 BE.set_int32 @@ Int32.of_int n end
+    else
+      begin init b ~maj 27; put_n b 8 BE.set_int64 @@ Int64.of_int n end
 
-let int b n =
-  let (maj,n) = if n < 0 then 1, -1 - n else 0, n in
-  put b ~maj n
+  let int b n =
+    let (maj,n) = if n < 0 then 1, -1 - n else 0, n in
+    put b ~maj n
 
-let hex_char x =
-  assert (x >= 0 && x < 16);
-  if x <= 9 then Char.chr @@ Char.code '0' + x
-  else Char.chr @@ Char.code 'a' + x - 10
+  let hex_char x =
+    assert (x >= 0 && x < 16);
+    if x <= 9 then Char.chr @@ Char.code '0' + x
+    else Char.chr @@ Char.code 'a' + x - 10
 
-let to_hex s =
-  let r = Bytes.create (String.length s * 2) in
-  for i = 0 to String.length s - 1 do
-    Bytes.set r (i*2) @@ hex_char @@ Char.code s.[i] lsr 4;
-    Bytes.set r (i*2+1) @@ hex_char @@ Char.code s.[i] land 0b1111;
-  done;
-  Bytes.to_string r
+  let to_hex s =
+    let r = Bytes.create (String.length s * 2) in
+    for i = 0 to String.length s - 1 do
+      Bytes.set r (i*2) @@ hex_char @@ Char.code s.[i] lsr 4;
+      Bytes.set r (i*2+1) @@ hex_char @@ Char.code s.[i] land 0b1111;
+    done;
+    Bytes.to_string r
 
 end
 
 module Simple = struct
 
-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
-]
+  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
+    ]
 
-let encode item =
-  let open Encode in
-  let b = start () in
-  let rec write = function
-  | `Null -> put b ~maj:7 22;
-  | `Undefined -> put b ~maj:7 23;
-  | `Bool false -> put b ~maj:7 20;
-  | `Bool true -> put b ~maj:7 21;
-  | `Simple n when (n >= 0 && n <= 23) || (n >= 32 && n <= 255) -> put b ~maj:7 n
-  | `Simple n -> fail "encode: simple(%d)" n
-  | `Int n -> int b n
-  | `Float f -> init b ~maj:7 27; put_n b 8 BE.set_double f
-  | `Bytes s -> put b ~maj:2 (String.length s); Buffer.add_string b s
-  | `Text s -> put b ~maj:3 (String.length s); Buffer.add_string b s
-  | `Array l -> put b ~maj:4 (List.length l); List.iter write l
-  | `Map m -> put b ~maj:5 (List.length m); List.iter (fun (a,b) -> write a; write b) m
-  in
-  write item;
-  Buffer.contents b
+  let encode item =
+    let open Encode in
+    let b = start () in
+    let rec write = function
+      | `Null -> put b ~maj:7 22;
+      | `Undefined -> put b ~maj:7 23;
+      | `Bool false -> put b ~maj:7 20;
+      | `Bool true -> put b ~maj:7 21;
+      | `Simple n when (n >= 0 && n <= 23) || (n >= 32 && n <= 255) -> put b ~maj:7 n
+      | `Simple n -> fail "encode: simple(%d)" n
+      | `Int n -> int b n
+      | `Float f -> init b ~maj:7 27; put_n b 8 BE.set_double f
+      | `Bytes s -> put b ~maj:2 (String.length s); Buffer.add_string b s
+      | `Text s -> put b ~maj:3 (String.length s); Buffer.add_string b s
+      | `Array l -> put b ~maj:4 (List.length l); List.iter write l
+      | `Map m -> put b ~maj:5 (List.length m); List.iter (fun (a,b) -> write a; write b) m
+    in
+    write item;
+    Buffer.contents b
 
-let need (s,i) n =
-  if n > String.length s || !i + n > String.length s then
-    fail "truncated: len %d pos %d need %d" (String.length s) !i n;
-  let j = !i in
-  i := !i + n;
-  j
+  let need (s,i) n =
+    if n > String.length s || !i + n > String.length s then
+      fail "truncated: len %d pos %d need %d" (String.length s) !i n;
+    let j = !i in
+    i := !i + n;
+    j
 
-let get_byte (s,_ as r) = int_of_char @@ s.[need r 1]
-let get_n (s,_ as r) n f = f s @@ need r n
-let get_s (s,_ as r) n = String.sub s (need r n) n
+  let get_byte (s,_ as r) = int_of_char @@ s.[need r 1]
+  let get_n (s,_ as r) n f = f s @@ need r n
+  let get_s (s,_ as r) n = String.sub s (need r n) n
 
-let get_additional byte1 = byte1 land 0b11111
-let is_indefinite byte1 = get_additional byte1 = 31
+  let get_additional byte1 = byte1 land 0b11111
+  let is_indefinite byte1 = get_additional byte1 = 31
 
-let int64_max_int = Int64.of_int max_int
-let two_min_int32 = 2 * Int32.to_int Int32.min_int
+  let int64_max_int = Int64.of_int max_int
+  let two_min_int32 = 2 * Int32.to_int Int32.min_int
 
-let extract_number byte1 r =
-  match get_additional byte1 with
-  | n when n < 24 -> n
-  | 24 -> get_byte r
-  | 25 -> get_n r 2 SE.get_uint16
-  | 26 ->
-    let n = Int32.to_int @@ get_n r 4 SE.get_int32 in
-    if n < 0 then n - two_min_int32 else n
-  | 27 ->
-    let n = get_n r 8 SE.get_int64 in
-    if n > int64_max_int || n < 0L then fail "extract_number: %Lu" n;
-    Int64.to_int n
-  | n -> fail "bad additional %d" n
+  let extract_number byte1 r =
+    let guard_min min n = if n < min
+      then noncanonical "non-compact number encoding: %d < %d" n min
+      else n
+    in
+    match get_additional byte1 with
+    | n when n < 24 -> n
+    | 24 -> guard_min 24 @@ get_byte r
+    | 25 -> guard_min 256 @@ get_n r 2 SE.get_uint16
+    | 26 ->
+      let n = guard_min (256*256) @@ Int32.to_int @@ get_n r 4 SE.get_int32 in
+      if n < 0 then n - two_min_int32 else n
+    | 27 ->
+      let n = get_n r 8 SE.get_int64 in
+      if n > int64_max_int || n < 0L then fail "extract_number: %Lu" n;
+      if Int64.compare n 0x1_0000_0000L < 0
+      then noncanonical "non-compact number encoding: %Ld < %Ld" n 0x1_0000_0000L;
+      Int64.to_int n
+    | n -> fail "bad additional %d" n
 
-let get_float16 s i =
-  let half = Char.code s.[i] lsl 8 + Char.code s.[i+1] in
-  let mant = half land 0x3ff in
-  let value =
-    match (half lsr 10) land 0x1f with (* exp *)
-    | 31 when mant = 0 -> infinity
-    | 31 -> nan
-    | 0 -> ldexp (float mant) ~-24
-    | exp -> ldexp (float @@ mant + 1024) (exp - 25)
-  in
-  if half land 0x8000 = 0 then value else ~-. value
+  let get_float16 s i =
+    let half = Char.code s.[i] lsl 8 + Char.code s.[i+1] in
+    let mant = half land 0x3ff in
+    let value =
+      match (half lsr 10) land 0x1f with (* exp *)
+      | 31 when mant = 0 -> infinity
+      | 31 -> nan
+      | 0 -> ldexp (float mant) ~-24
+      | exp -> ldexp (float @@ mant + 1024) (exp - 25)
+    in
+    if half land 0x8000 = 0 then value else ~-. value
 
-exception Break
+  let monotonic s s' =
+    let major_typ s = int_of_char s.[0] lsr 5 in
+    let get_number s = match get_additional (int_of_char s.[0]) with
+      | n when n < 24 -> 1, Int64.of_int n
+      | 24 -> 2, Int64.of_int (int_of_char s.[1])
+      | 25 -> 3, Int64.of_int (SE.get_uint16 s 1)
+      | 26 -> 5, Int64.logand 0xFFFFFFFFL (Int64.of_int32 (SE.get_int32 s 1))
+      | 27 -> 9, SE.get_int64 s 1
+      | _ -> assert false
+    in
+    major_typ s < major_typ s' ||
+    major_typ s = major_typ s' &&
+    let off, n = get_number s and _, n' = get_number s' in
+    Int64.unsigned_compare n n' < 0 ||
+    Int64.unsigned_compare n n' = 0 &&
+    begin
+      List.mem (major_typ s) [2; 3; 4; 5] &&
+      let len = Int64.to_int n in
+      String.sub s off len < String.sub s' off len
+    end
 
-let extract_list byte1 r f =
-  if is_indefinite byte1 then
-    let l = ref [] in
-    try while true do l := f r :: !l done; assert false with Break -> List.rev !l
-  else
-    let n = extract_number byte1 r in Array.to_list @@ Array.init n (fun _ -> f r)
+  exception Break
 
-let rec extract_pair r =
-  let a = extract r in
-  let b = try extract r with Break -> fail "extract_pair: unexpected break" in
-  a,b
-and extract_string byte1 r f =
-  if is_indefinite byte1 then
+  let extract_list byte1 r f =
+    if is_indefinite byte1 then
+      noncanonical "indefinite length array or map"
+    else
+      let n = extract_number byte1 r in Array.to_list @@ Array.init n (fun _ -> f r)
+
+  let rec extract_pair ((s, i) as r) =
+    let start = !i in
+    let a = extract r in
+    let finish = !i in
+    let raw = String.sub s start (finish - start) in
+    let b = try extract r with Break -> fail "extract_pair: unexpected break" in
+    raw, (a,b)
+  and extract_map byte1 r =
+    let kvs = extract_list byte1 r extract_pair in
+    let _, kvs =
+      List.fold_right (fun (curr, kv) (next, acc) ->
+          match next with
+          | None -> (Some curr, kv :: acc)
+          | Some next ->
+            if not (monotonic curr next) then noncanonical "unsorted map";
+            (Some curr, kv :: acc))
+        kvs (None, [])
+    in
+    kvs
+  and extract_string byte1 r =
+    if is_indefinite byte1 then
+      noncanonical "indefinite length string"
+    else
+      let n = extract_number byte1 r in get_s r n
+  and extract r =
+    let byte1 = get_byte r in
+    match byte1 lsr 5 with
+    | 0 -> `Int (extract_number byte1 r)
+    | 1 -> `Int (-1 - extract_number byte1 r)
+    | 2 -> `Bytes (extract_string byte1 r)
+    | 3 -> `Text (extract_string byte1 r)
+    | 4 -> `Array (extract_list byte1 r extract)
+    | 5 -> `Map (extract_map byte1 r)
+    | 6 -> noncanonical "tagged value"
+    | 7 ->
+      begin match get_additional byte1 with
+        | n when n < 20 -> `Simple n
+        | 20 -> `Bool false
+        | 21 -> `Bool true
+        | 22 -> `Null
+        | 23 -> `Undefined
+        | 24 -> `Simple (get_byte r)
+        | 25 -> `Float (get_n r 2 get_float16)
+        | 26 -> `Float (get_n r 4 SE.get_float)
+        | 27 -> `Float (get_n r 8 SE.get_double)
+        | 31 -> raise Break
+        | a -> fail "extract: (7,%d)" a
+      end
+    | _ -> assert false
+
+  let decode_partial s =
+    let i = ref 0 in
+    let x = try extract (s,i) with Break -> fail "decode: unexpected break" in
+    x, String.sub s !i (String.length s - !i)
+
+  let decode s : t =
+    let x, rest = decode_partial s in
+    if rest = "" then x
+    else fail "decode: extra data: len %d pos %d" (String.length s) (String.length s - String.length rest)
+
+  let to_diagnostic item =
     let b = Buffer.create 10 in
-    try while true do Buffer.add_string b (f @@ extract r) done; assert false with Break -> Buffer.contents b
-  else
-    let n = extract_number byte1 r in get_s r n
-and extract r =
-  let byte1 = get_byte r in
-  match byte1 lsr 5 with
-  | 0 -> `Int (extract_number byte1 r)
-  | 1 -> `Int (-1 - extract_number byte1 r)
-  | 2 -> `Bytes (extract_string byte1 r (function `Bytes s -> s | _ -> fail "extract: not a bytes chunk"))
-  | 3 -> `Text (extract_string byte1 r (function `Text s -> s | _ -> fail "extract: not a text chunk"))
-  | 4 -> `Array (extract_list byte1 r extract)
-  | 5 -> `Map (extract_list byte1 r extract_pair)
-  | 6 -> let _tag = extract_number byte1 r in extract r
-  | 7 ->
-    begin match get_additional byte1 with
-    | n when n < 20 -> `Simple n
-    | 20 -> `Bool false
-    | 21 -> `Bool true
-    | 22 -> `Null
-    | 23 -> `Undefined
-    | 24 -> `Simple (get_byte r)
-    | 25 -> `Float (get_n r 2 get_float16)
-    | 26 -> `Float (get_n r 4 SE.get_float)
-    | 27 -> `Float (get_n r 8 SE.get_double)
-    | 31 -> raise Break
-    | a -> fail "extract: (7,%d)" a
-    end
-  | _ -> assert false
-
-let decode_partial s =
-  let i = ref 0 in
-  let x = try extract (s,i) with Break -> fail "decode: unexpected break" in
-  x, String.sub s !i (String.length s - !i)
-
-let decode s : t =
-  let x, rest = decode_partial s in
-  if rest = "" then x
-  else fail "decode: extra data: len %d pos %d" (String.length s) (String.length s - String.length rest)
-
-let to_diagnostic item =
-  let b = Buffer.create 10 in
-  let put = Buffer.add_string b in
-  let rec write = function
-  | `Null -> put "null"
-  | `Bool false -> put "false"
-  | `Bool true -> put "true"
-  | `Simple n -> bprintf b "simple(%d)" n
-  | `Undefined -> put "undefined"
-  | `Int n -> bprintf b "%d" n
-  | `Float f ->
-    begin match classify_float f with
-    | FP_nan -> put "NaN"
-    | FP_infinite -> put (if f < 0. then "-Infinity" else "Infinity")
-    | FP_zero | FP_normal | FP_subnormal -> bprintf b "%g" f
-    end
-  | `Bytes s -> bprintf b "h'%s'" (Encode.to_hex s)
-  | `Text s -> bprintf b "\"%s\"" s
-  | `Array l ->
-    put "[";
-    l |> list_iteri (fun i x -> if i <> 0 then put ", "; write x);
-    put "]"
-  | `Map m ->
-    put "{";
-    m |> list_iteri (fun i (k,v) -> if i <> 0 then put ", "; write k; put ": "; write v);
-    put "}"
-  in
-  write item;
-  Buffer.contents b
+    let put = Buffer.add_string b in
+    let rec write = function
+      | `Null -> put "null"
+      | `Bool false -> put "false"
+      | `Bool true -> put "true"
+      | `Simple n -> bprintf b "simple(%d)" n
+      | `Undefined -> put "undefined"
+      | `Int n -> bprintf b "%d" n
+      | `Float f ->
+        begin match classify_float f with
+          | FP_nan -> put "NaN"
+          | FP_infinite -> put (if f < 0. then "-Infinity" else "Infinity")
+          | FP_zero | FP_normal | FP_subnormal -> bprintf b "%g" f
+        end
+      | `Bytes s -> bprintf b "h'%s'" (Encode.to_hex s)
+      | `Text s -> bprintf b "\"%s\"" s
+      | `Array l ->
+        put "[";
+        l |> List.iteri (fun i x -> if i <> 0 then put ", "; write x);
+        put "]"
+      | `Map m ->
+        put "{";
+        m |> List.iteri (fun i (k,v) -> if i <> 0 then put ", "; write k; put ": "; write v);
+        put "}"
+    in
+    write item;
+    Buffer.contents b
 
 end (* Simple *)

cbor/CBOR.mli

@@ -2,6 +2,8 @@
 
 exception Error of string
 
+exception Noncanonical of string
+
 module Simple : sig
 
 type t =

cbor/appendix_a.json

@@ -0,0 +1,720 @@
+[
+  {
+    "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,
+    "noncanonical": true,
+    "decoded": 18446744073709551616
+  },
+  {
+    "cbor": "O///////////",
+    "hex": "3bffffffffffffffff",
+    "roundtrip": true,
+    "decoded": -18446744073709551616
+  },
+  {
+    "cbor": "w0kBAAAAAAAAAAA=",
+    "hex": "c349010000000000000000",
+    "roundtrip": true,
+    "noncanonical": 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,
+    "noncanonical": true,
+    "diagnostic": "0(\"2013-03-21T20:04:00Z\")"
+  },
+  {
+    "cbor": "wRpRS2ew",
+    "hex": "c11a514b67b0",
+    "roundtrip": true,
+    "noncanonical": true,
+    "diagnostic": "1(1363896240)"
+  },
+  {
+    "cbor": "wftB1FLZ7CAAAA==",
+    "hex": "c1fb41d452d9ec200000",
+    "roundtrip": true,
+    "noncanonical": true,
+    "diagnostic": "1(1363896240.5)"
+  },
+  {
+    "cbor": "10QBAgME",
+    "hex": "d74401020304",
+    "roundtrip": true,
+    "noncanonical": true,
+    "diagnostic": "23(h'01020304')"
+  },
+  {
+    "cbor": "2BhFZElFVEY=",
+    "hex": "d818456449455446",
+    "roundtrip": true,
+    "noncanonical": true,
+    "diagnostic": "24(h'6449455446')"
+  },
+  {
+    "cbor": "2CB2aHR0cDovL3d3dy5leGFtcGxlLmNvbQ==",
+    "hex": "d82076687474703a2f2f7777772e6578616d706c652e636f6d",
+    "roundtrip": true,
+    "noncanonical": 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,
+    "noncanonical": true,
+    "diagnostic": "(_ h'0102', h'030405')"
+  },
+  {
+    "cbor": "f2VzdHJlYWRtaW5n/w==",
+    "hex": "7f657374726561646d696e67ff",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": "streaming"
+  },
+  {
+    "cbor": "n/8=",
+    "hex": "9fff",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": [
+
+    ]
+  },
+  {
+    "cbor": "nwGCAgOfBAX//w==",
+    "hex": "9f018202039f0405ffff",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": [
+      1,
+      [
+        2,
+        3
+      ],
+      [
+        4,
+        5
+      ]
+    ]
+  },
+  {
+    "cbor": "nwGCAgOCBAX/",
+    "hex": "9f01820203820405ff",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": [
+      1,
+      [
+        2,
+        3
+      ],
+      [
+        4,
+        5
+      ]
+    ]
+  },
+  {
+    "cbor": "gwGCAgOfBAX/",
+    "hex": "83018202039f0405ff",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": [
+      1,
+      [
+        2,
+        3
+      ],
+      [
+        4,
+        5
+      ]
+    ]
+  },
+  {
+    "cbor": "gwGfAgP/ggQF",
+    "hex": "83019f0203ff820405",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": [
+      1,
+      [
+        2,
+        3
+      ],
+      [
+        4,
+        5
+      ]
+    ]
+  },
+  {
+    "cbor": "nwECAwQFBgcICQoLDA0ODxAREhMUFRYXGBgYGf8=",
+    "hex": "9f0102030405060708090a0b0c0d0e0f101112131415161718181819ff",
+    "roundtrip": false,
+    "noncanonical": 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": "v2FhAWFinwID//8=",
+    "hex": "bf61610161629f0203ffff",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": {
+      "a": 1,
+      "b": [
+        2,
+        3
+      ]
+    }
+  },
+  {
+    "cbor": "gmFhv2FiYWP/",
+    "hex": "826161bf61626163ff",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": [
+      "a",
+      {
+        "b": "c"
+      }
+    ]
+  },
+  {
+    "cbor": "v2NGdW71Y0FtdCH/",
+    "hex": "bf6346756ef563416d7421ff",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": {
+      "Fun": true,
+      "Amt": -2
+    }
+  },
+  {
+    "cbor": "pGJya/VidXD1ZHBsYXT0aWNsaWVudFBpbvU=",
+    "hex": "a462726bf5627570f564706c6174f469636c69656e7450696ef5",
+    "roundtrip": false,
+    "decoded": {
+      "rk": true,
+      "up": true,
+      "plat": false,
+      "clientPin": true
+    }
+  },
+  {
+    "cbor": "pGRwbGF09GJya/VpY2xpZW50UGlu9WJ1cPU=",
+    "hex": "a464706c6174f462726bf569636c69656e7450696ef5627570f5",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": {
+      "up": true,
+      "clientPin": true,
+      "rk": true,
+      "plat": false
+    }
+  },
+  {
+    "cbor": "GAE=",
+    "hex": "1801",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": 1
+  },
+  {
+    "cbor": "GQAB",
+    "hex": "190001",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": 1
+  },
+  {
+    "cbor": "GgAAAAE=",
+    "hex": "1a00000001",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": 1
+  },
+  {
+    "cbor": "GwAAAAAAAAAB",
+    "hex": "1b0000000000000001",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": 1
+  },
+  {
+    "cbor": "OAA=",
+    "hex": "3800",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": -1
+  },
+  {
+    "cbor": "OwAAAAAAAQRp",
+    "hex": "3B0000000000010469",
+    "roundtrip": false,
+    "noncanonical": true,
+    "decoded": -66666
+  }
+]

cbor/dune

@@ -1,5 +1,16 @@
 (library
  (name cbor)
  (public_name webauthn.cbor)
+ (modules CBOR)
  (wrapped false)
  (libraries ocplib-endian))
+
+(executable
+  (name test)
+  (modules test)
+  (libraries webauthn.cbor yojson))
+
+(rule
+  (alias runtest)
+  (deps test.exe appendix_a.json)
+  (action (run ./test.exe appendix_a.json)))

cbor/test.ml

@@ -0,0 +1,96 @@
+type result = Decoded of Yojson.Basic.t | Diagnostic of string
+
+type test = {
+  cbor : string;
+  result : result;
+  noncanonical : bool;
+}
+
+let (@@) f x = f x
+let (|>) x f = f x
+let eprintfn fmt = Printf.ksprintf prerr_endline fmt
+let fail fmt = Printf.ksprintf failwith fmt
+
+let of_hex s =
+  assert (String.length s mod 2 = 0);
+  let n = String.length s / 2 in
+  let r = Bytes.create n in
+  for i = 0 to pred n do
+    Bytes.set r i @@ Char.chr @@ int_of_string ("0x" ^ String.sub s (i*2) 2)
+  done;
+  Bytes.to_string r
+
+let read file =
+  let open Yojson.Basic in
+  Yojson.Safe.from_file file (* large ints *)
+  |> Yojson.Safe.to_basic
+  |> Util.to_list
+  |> List.map begin function
+    | `Assoc a ->
+      let cbor = of_hex @@ Util.to_string @@ List.assoc "hex" a in
+      let result =
+        try
+          Diagnostic (Util.to_string @@ List.assoc "diagnostic" a)
+        with Not_found -> 
+          Decoded (List.assoc "decoded" a)
+      in
+      let noncanonical = try
+          Util.to_bool @@ List.assoc "noncanonical" a
+        with Not_found -> false
+      in
+      { cbor; result; noncanonical }
+    | _ -> assert false
+    end
+
+let rec json_of_cbor : CBOR.Simple.t -> Yojson.Basic.t = function
+| (`Null | `Bool _ | `Int _ | `Float _ as x) -> x
+| `Undefined | `Simple _ -> `Null
+| `Bytes x -> `String x
+| `Text x -> `String x
+| `Array x -> `List (List.map json_of_cbor x)
+| `Map x -> `Assoc (List.map (fun (k,v) ->
+  match k with
+  | `Text s -> s, json_of_cbor v
+  | _ -> fail "json_of_cbor: expected string key") x)
+
+let () =
+  match List.tl @@ Array.to_list Sys.argv with
+  | file::[] ->
+    eprintfn "I: running tests from %s" file;
+    let tests = read file in
+    eprintfn "I: total tests = %d" (List.length tests);
+    let ok = ref 0 in
+    let failed = ref 0 in
+    let ignored = ref 0 in
+    let nr = ref (-1) in
+    tests |> List.iter begin fun test ->
+      try
+        incr nr;
+        if test.noncanonical then
+          try let cbor = CBOR.Simple.decode test.cbor in
+            fail "expected reject noncanonical CBOR, got %s"
+              (CBOR.Simple.to_diagnostic cbor)
+          with CBOR.Noncanonical _ -> incr ok
+        else
+          let cbor = CBOR.Simple.decode test.cbor in
+          let diag = CBOR.Simple.to_diagnostic cbor in
+          let () = match test.result with
+            | Diagnostic s ->
+              if s <> diag then fail "expected %s, got %s" s diag
+            | Decoded json ->
+              let json' = json_of_cbor cbor in
+              if json <> json' then fail "expected %s, got %s, aka %s"
+                  (Yojson.Basic.to_string json) (Yojson.Basic.to_string json') diag
+          in
+          incr ok
+      with exn ->
+        let ignore = List.mem !nr [10; 12] in
+        eprintfn "%s test %d: %s"
+          (if ignore then "W: ignoring" else "E:") !nr (match exn with Failure s -> s | _ -> Printexc.to_string exn);
+        incr (if ignore then ignored else failed)
+    end;
+    eprintfn "I: finished. tests ok = %d failed = %d ignored = %d" !ok !failed !ignored;
+    exit (if !failed = 0 then 0 else 1)
+  | _ ->
+    eprintfn "E: no test file given";
+    exit 2