mte/unikernel/duniverse/mirage-crypto/tests/wycheproof/wycheproof.ml

type json = Yojson.Safe.t [@@deriving of_yojson]

let pp_json = Yojson.Safe.pretty_print

type hex = string [@@deriving eq]

let pp_hex fmt buf =
  let n = String.length buf in
  let bbuf = Bytes.unsafe_of_string buf in
  for i = n - 1 downto 0 do
    let byte = Bytes.get_uint8 bbuf i in
    Format.fprintf fmt "%02x" byte
  done

let hex_of_string s =
  let fold f acc str =
    let st = ref acc in
    String.iter (fun c -> st := f !st c) str;
    !st
  and digit c =
    match c with
    | '0'..'9' -> int_of_char c - 0x30
    | 'A'..'F' -> int_of_char c - 0x41 + 10
    | 'a'..'f' -> int_of_char c - 0x61 + 10
    | _ -> invalid_arg "bad character"
  in
  let out = Bytes.create (String.length s / 2) in
  let _idx, leftover =
    fold (fun (idx, leftover) c ->
        let c = digit c in
        match leftover with
        | None -> idx, Some (c lsl 4)
        | Some c' ->
          Bytes.set_uint8 out idx (c' lor c);
          succ idx, None)
      (0, None) s
  in
  assert (leftover = None);
  Bytes.unsafe_to_string out

let hex_of_yojson json =
  let padded s = if String.length s mod 2 = 0 then s else "0" ^ s in
  match [%of_yojson: string] json with
  | Ok s -> Ok (hex_of_string (padded s))
  | Error _ as e -> e

type test_result = Valid | Acceptable | Invalid [@@deriving show]

let test_result_of_yojson = function
  | `String "valid" -> Ok Valid
  | `String "acceptable" -> Ok Acceptable
  | `String "invalid" -> Ok Invalid
  | _ -> Error "test_result"

type ecdh_test = {
  tcId : int;
  comment : string;
  curve : json option; [@yojson.default None]
  public : hex;
  private_ : hex; [@yojson.key "private"]
  shared : hex;
  result : test_result;
  flags : string list;
}
[@@deriving of_yojson, show]

let has_ignored_flag test ~ignored_flags =
  List.exists
    (fun ignored_flag -> List.mem ignored_flag test.flags)
    ignored_flags

type ecdh_test_group = {
  curve : string;
  tests : ecdh_test list;
  encoding : json option; [@yojson.default None]
  type_ : json option; [@yojson.default None] [@yojson.key "type"]
}
[@@deriving of_yojson, show]

type ecdsa_key = {
  curve : string;
  keySize : int;
  type_ : json; [@yojson.key "type"]
  uncompressed : hex;
  wx : hex;
  wy : hex;
}
[@@deriving of_yojson, show]

type dsa_test = {
  tcId : int;
  comment : string;
  msg : hex;
  sig_ : hex; [@yojson.key "sig"]
  result : test_result;
  flags : string list;
}
[@@deriving of_yojson, show]

type ecdsa_test_group = {
  key : ecdsa_key;
  keyDer : string;
  keyPem : string;
  sha : string;
  tests : dsa_test list;
  type_ : json option; [@yojson.default None] [@yojson.key "type"]
}
[@@deriving of_yojson, show]

type eddsa_key = {
  curve : string;
  keySize : int;
  pk : hex;
  sk : hex;
  type_ : json; [@yojson.key "type"]
}
[@@deriving of_yojson, show]

type eddsa_test_group = {
  jwk : json;
  key : eddsa_key;
  keyDer : string;
  keyPem : string;
  type_ : json; [@yojson.key "type"]
  tests : dsa_test list;
}
[@@deriving of_yojson, show]

type test_file = {
  algorithm : json;
  generatorVersion : json;
  header : json;
  notes : json;
  numberOfTests : json;
  schema : json;
  testGroups : json list;
}
[@@deriving of_yojson, show]

let get_json = function Ok x -> x | Error s -> failwith s

let load_file_exn path =
  Yojson.Safe.from_file path |> [%of_yojson: test_file] |> get_json

let ecdh_test_group_exn json = [%of_yojson: ecdh_test_group] json |> get_json

let ecdsa_test_group_exn json = [%of_yojson: ecdsa_test_group] json |> get_json

let eddsa_test_group_exn json = [%of_yojson: eddsa_test_group] json |> get_json