2863

Committed 05 Nov 2024 06:20PM UTC coverage: 30.754% (-16.6%) from 47.311%

Build # 2863

Build Type

push

buildkite

Committed by

web-flow

Commit Message

Merge pull request #16296 from MinaProtocol/dkijania/more_multi_jobs

more multi jobs in CI

Run Details

20276 of 65930 relevant lines covered (30.75%)

8631.7 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

13.89

/src/lib/random_oracle_input/random_oracle_input.ml

open Core_kernel

module Chunked = struct
  (** The input for a random oracle, formed of full field elements and 'chunks'
      of fields that can be combined together into one or more field elements.

      The chunks are represented as [(field, length)], where
      [0 <= field < 2^length]. This allows us to efficiently combine values in
      a known range. For example,
{[
    { field_elements= [||]; packeds= [|(x, 64); (y, 32); (z, 16)|] }
]}
      results in the chunks being combined as [x * 2^(32+16) + y * 2^(64) + z].
      When the chunks do not fit within a single field element, they are
      greedily concatenated to form field elements, from left to right.
      This packing is performed by the [pack_to_fields] helper function.
  *)
  type 'field t =
    { field_elements : 'field array; packeds : ('field * int) array }
  [@@deriving sexp, compare]

  let append (t1 : _ t) (t2 : _ t) =
    { field_elements = Array.append t1.field_elements t2.field_elements
    ; packeds = Array.append t1.packeds t2.packeds
    }

  let field_elements (a : 'f array) : 'f t =
    { field_elements = a; packeds = [||] }

  let field x : _ t = field_elements [| x |]

  (** An input [[|(x_1, l_1); (x_2, l_2); ...|]] includes the values
      [[|x_1; x_2; ...|]] in the input, assuming that `0 <= x_1 < 2^l_1`,
      `0 <= x_2 < 2^l_2`, etc. so that multiple [x_i]s can be combined into a
      single field element when the sum of their [l_i]s are less than the size
      of the field modulus (in bits).
  *)
  let packeds a = { field_elements = [||]; packeds = a }

  (** [packed x = packeds [| x |]] *)
  let packed xn : _ t = packeds [| xn |]

  module type Field_intf = sig
    type t

    val size_in_bits : int

    val zero : t

    val ( + ) : t -> t -> t

    val ( * ) : t -> t -> t
  end

  (** Convert the input into a series of field elements, by concatenating
      any chunks of input that fit into a single field element.
      The concatenation is greedy, operating from left to right.
  *)
  let pack_to_fields (type t) (module F : Field_intf with type t = t)
      ~(pow2 : int -> t) { field_elements; packeds } =
    let shift_left acc n = F.( * ) acc (pow2 n) in
    let open F in
    let packed_bits =
      let xs, acc, acc_n =
        Array.fold packeds ~init:([], zero, 0)
          ~f:(fun (xs, acc, acc_n) (x, n) ->
            let n' = Int.(n + acc_n) in
            if Int.(n' < size_in_bits) then (xs, shift_left acc n + x, n')
            else (acc :: xs, x, n) )
      in
      (* if acc_n = 0, packeds was empty (or acc holds 0 bits) and we don't want to append 0 *)
      let xs = if acc_n > 0 then acc :: xs else xs in
      Array.of_list_rev xs
    in
    Array.append field_elements packed_bits
end

module Legacy = struct
  type ('field, 'bool) t =
    { field_elements : 'field array; bitstrings : 'bool list array }
  [@@deriving sexp, compare]

  let append t1 t2 =
    { field_elements = Array.append t1.field_elements t2.field_elements
    ; bitstrings = Array.append t1.bitstrings t2.bitstrings
    }

  let field_elements x = { field_elements = x; bitstrings = [||] }

  let field x = { field_elements = [| x |]; bitstrings = [||] }

  let bitstring x = { field_elements = [||]; bitstrings = [| x |] }

  let bitstrings x = { field_elements = [||]; bitstrings = x }

  let pack_bits ~max_size ~pack { field_elements = _; bitstrings } =
    let rec pack_full_fields rev_fields bits length =
      if length >= max_size then
        let field_bits, bits = List.split_n bits max_size in
        pack_full_fields (pack field_bits :: rev_fields) bits (length - max_size)
      else (rev_fields, bits, length)
    in
    let packed_field_elements, remaining_bits, remaining_length =
      Array.fold bitstrings ~init:([], [], 0)
        ~f:(fun (acc, bits, n) bitstring ->
          let n = n + List.length bitstring in
          let bits = bits @ bitstring in
          let acc, bits, n = pack_full_fields acc bits n in
          (acc, bits, n) )
    in
    if remaining_length = 0 then packed_field_elements
    else pack remaining_bits :: packed_field_elements

  let pack_to_fields ~size_in_bits ~pack { field_elements; bitstrings } =
    let max_size = size_in_bits - 1 in
    let packed_bits =
      pack_bits ~max_size ~pack { field_elements; bitstrings }
    in
    Array.append field_elements (Array.of_list_rev packed_bits)

  let to_bits ~unpack { field_elements; bitstrings } =
    let field_bits = Array.map ~f:unpack field_elements in
    List.concat @@ Array.to_list @@ Array.append field_bits bitstrings

  module Coding = struct
    (** See https://github.com/CodaProtocol/coda/blob/develop/rfcs/0038-rosetta-construction-api.md for details on schema *)

    (** Serialize a random oracle input with 32byte fields into bytes according to the RFC0038 specification *)
    let serialize ~string_of_field ~to_bool ~of_bool t =
      let len_to_string x =
        String.of_char_list
          Char.
            [ of_int_exn @@ ((x lsr 24) land 0xff)
            ; of_int_exn @@ ((x lsr 16) land 0xff)
            ; of_int_exn @@ ((x lsr 8) land 0xff)
            ; of_int_exn @@ (x land 0xff)
            ]
      in
      let len1 = len_to_string @@ Array.length t.field_elements in
      let fields =
        (* We only support 32byte fields *)
        let () =
          if Array.length t.field_elements > 0 then
            assert (String.length (string_of_field t.field_elements.(0)) = 32)
          else ()
        in
        Array.map t.field_elements ~f:string_of_field |> String.concat_array
      in
      let len2 =
        len_to_string
        @@ Array.sum (module Int) t.bitstrings ~f:(fun x -> List.length x)
      in
      let packed =
        pack_bits t ~max_size:8 ~pack:(fun bs ->
            let rec go i acc = function
              | [] ->
                  acc
              | b :: bs ->
                  go (i + 1) ((acc * 2) + if to_bool b then 1 else 0) bs
            in
            let pad =
              List.init (8 - List.length bs) ~f:(Fn.const (of_bool false))
            in
            let combined = bs @ pad in
            assert (List.length combined = 8) ;
            go 0 0 combined )
        |> List.map ~f:Char.of_int_exn
        |> List.rev |> String.of_char_list
      in
      len1 ^ fields ^ len2 ^ packed

    module Parser = struct
      (* TODO: Before using this too much; use a solid parser library instead or beef this one up with more debugging info *)

      (* The parser is a function over this monad-fail *)
      module M = Result

      module T = struct
        type ('a, 'e) t = char list -> ('a * char list, 'e) M.t

        let return a cs = M.return (a, cs)

        let bind : ('a, 'e) t -> f:('a -> ('b, 'e) t) -> ('b, 'e) t =
         fun t ~f cs ->
          let open M.Let_syntax in
          let%bind a, rest = t cs in
          f a rest

        let map = `Define_using_bind
      end

      include Monad.Make2 (T)

      let run p cs =
        p cs
        |> M.bind ~f:(fun (a, cs') ->
               match cs' with [] -> M.return a | _ -> M.fail `Expected_eof )

      let fail why _ = M.fail why

      let char c = function
        | c' :: cs when Char.equal c c' ->
            M.return (c', cs)
        | c' :: _ ->
            M.fail (`Unexpected_char c')
        | [] ->
            M.fail `Unexpected_eof

      let u8 = function
        | c :: cs ->
            M.return (c, cs)
        | [] ->
            M.fail `Unexpected_eof

      let u32 =
        let open Let_syntax in
        let open Char in
        let%map a = u8 and b = u8 and c = u8 and d = u8 in
        (to_int a lsl 24)
        lor (to_int b lsl 16)
        lor (to_int c lsl 8)
        lor to_int d

      let eof = function [] -> M.return ((), []) | _ -> M.fail `Expected_eof

      let take n cs =
        if List.length cs < n then M.fail `Unexpected_eof
        else M.return (List.split_n cs n)

      (** p zero or more times, never fails *)
      let many p =
        (fun cs ->
          let rec go xs acc =
            match p xs with
            | Ok (a, xs) ->
                go xs (a :: acc)
            | Error _ ->
                (acc, xs)
          in
          M.return @@ go cs [] )
        |> map ~f:List.rev

      let%test_unit "many" =
        [%test_eq: (char list, [ `Expected_eof ]) Result.t]
          (run (many u8) [ 'a'; 'b'; 'c' ])
          (Result.return [ 'a'; 'b'; 'c' ])

      (** p exactly n times *)
      let exactly n p =
        (fun cs ->
          let rec go xs acc = function
            | 0 ->
                M.return (acc, xs)
            | i ->
                let open M.Let_syntax in
                let%bind a, xs = p xs in
                go xs (a :: acc) (i - 1)
          in
          go cs [] n )
        |> map ~f:List.rev

      let%test_unit "exactly" =
        [%test_eq:
          (char list * char list, [ `Expected_eof | `Unexpected_eof ]) Result.t]
          ((exactly 3 u8) [ 'a'; 'b'; 'c'; 'd' ])
          (Result.return ([ 'a'; 'b'; 'c' ], [ 'd' ]))

      let return_res r cs = r |> Result.map ~f:(fun x -> (x, cs))
    end

    let bits_of_byte ~of_bool b =
      let b = Char.to_int b in
      let f x =
        of_bool
          ( match x with
          | 0 ->
              false
          | 1 ->
              true
          | _ ->
              failwith "Unexpected boolean integer" )
      in
      [ (b land (0x1 lsl 7)) lsr 7
      ; (b land (0x1 lsl 6)) lsr 6
      ; (b land (0x1 lsl 5)) lsr 5
      ; (b land (0x1 lsl 4)) lsr 4
      ; (b land (0x1 lsl 3)) lsr 3
      ; (b land (0x1 lsl 2)) lsr 2
      ; (b land (0x1 lsl 1)) lsr 1
      ; b land 0x1
      ]
      |> List.map ~f

    (** Deserialize bytes into a random oracle input with 32byte fields according to the RFC0038 specification *)
    let deserialize ~field_of_string ~of_bool s =
      let field =
        let open Parser.Let_syntax in
        let%bind u8x32 = Parser.take 32 in
        let s = String.of_char_list u8x32 in
        Parser.return_res (field_of_string s)
      in
      let parser =
        let open Parser.Let_syntax in
        let%bind len1 = Parser.u32 in
        let%bind fields = Parser.exactly len1 field in
        let%bind len2 = Parser.u32 in
        let%map bytes = Parser.(many u8) in
        let bits = List.concat_map ~f:(bits_of_byte ~of_bool) bytes in
        let bitstring = List.take bits len2 in
        { field_elements = Array.of_list fields; bitstrings = [| bitstring |] }
      in
      Parser.run parser s

    (** String of field as bits *)
    let string_of_field xs =
      List.chunks_of xs ~length:8
      |> List.map ~f:(fun xs ->
             let rec go i acc = function
               | [] ->
                   acc
               | b :: bs ->
                   go (i + 1) ((acc * 2) + if b then 1 else 0) bs
             in
             let pad = List.init (8 - List.length xs) ~f:(Fn.const false) in
             let combined = xs @ pad in
             assert (List.length combined = 8) ;
             go 0 0 combined )
      |> List.map ~f:Char.of_int_exn
      |> String.of_char_list

    (** Field of string as bits *)
    let field_of_string s ~size_in_bits =
      List.concat_map (String.to_list s) ~f:(bits_of_byte ~of_bool:Fn.id)
      |> Fn.flip List.take size_in_bits
      |> Result.return
  end

  (** Coding2 is an alternate binary coding setup where we pass two arrays of
 *  field elements instead of a single structure to simplify manipulation
 *  outside of the Mina construction API
 *
 * This is described as the second mechanism for coding Random_oracle_input in
 * RFC0038
 *
*)
  module Coding2 = struct
    module Rendered = struct
      (* as bytes, you must hex this later *)
      type 'field t_ = { prefix : 'field array; suffix : 'field array }
      [@@deriving yojson]

      type t = string t_ [@@deriving yojson]

      let map ~f { prefix; suffix } =
        { prefix = Array.map ~f prefix; suffix = Array.map ~f suffix }
    end

    let string_of_field : bool list -> string = Coding.string_of_field

    let field_of_string = Coding.field_of_string

    let serialize' t ~pack =
      { Rendered.prefix = t.field_elements
      ; suffix = pack_bits ~max_size:254 ~pack t |> Array.of_list_rev
      }

    let serialize t ~string_of_field ~pack =
      let () =
        if Array.length t.field_elements > 0 then
          assert (String.length (string_of_field t.field_elements.(0)) = 32)
        else ()
      in
      serialize' t ~pack |> Rendered.map ~f:string_of_field
  end

  let%test_module "random_oracle input" =
    ( module struct
      let gen_field ~size_in_bits =
        let open Quickcheck.Generator in
        list_with_length size_in_bits bool

      let gen_input ?size_in_bits () =
        let open Quickcheck.Generator in
        let open Let_syntax in
        let%bind size_in_bits =
          size_in_bits |> Option.map ~f:return
          |> Option.value ~default:(Int.gen_incl 2 3000)
        in
        let%bind field_elements =
          (* Treat a field as a list of bools of length [size_in_bits]. *)
          list (gen_field ~size_in_bits)
        in
        let%map bitstrings = list (list bool) in
        ( size_in_bits
        , { field_elements = Array.of_list field_elements
          ; bitstrings = Array.of_list bitstrings
          } )

      let%test_unit "coding2 equiv to hash directly" =
        let size_in_bits = 255 in
        let field = gen_field ~size_in_bits in
        Quickcheck.test ~trials:300
          Quickcheck.Generator.(
            tuple2 (gen_input ~size_in_bits ()) (tuple2 field field))
          ~f:(fun ((_, input), (x, y)) ->
            let middle = [| x; y |] in
            let expected =
              append input (field_elements middle)
              |> pack_to_fields ~size_in_bits ~pack:Fn.id
            in
            let { Coding2.Rendered.prefix; suffix } =
              Coding2.serialize' input ~pack:Fn.id
            in
            let actual = Array.(concat [ prefix; middle; suffix ]) in
            [%test_eq: bool list array] expected actual )

      let%test_unit "field/string partial isomorphism bitstrings" =
        Quickcheck.test ~trials:300
          Quickcheck.Generator.(list_with_length 255 bool)
          ~f:(fun input ->
            let serialized = Coding.string_of_field input in
            let deserialized =
              Coding.field_of_string serialized ~size_in_bits:255
            in
            [%test_eq: (bool list, unit) Result.t] (input |> Result.return)
              deserialized )

      let%test_unit "serialize/deserialize partial isomorphism 32byte fields" =
        let size_in_bits = 255 in
        Quickcheck.test ~trials:3000 (gen_input ~size_in_bits ())
          ~f:(fun (_, input) ->
            let serialized =
              Coding.(
                serialize ~string_of_field ~to_bool:Fn.id ~of_bool:Fn.id input)
            in
            let deserialized =
              Coding.(
                deserialize
                  (String.to_list serialized)
                  ~field_of_string:(field_of_string ~size_in_bits)
                  ~of_bool:Fn.id)
            in
            let normalized t =
              { t with
                bitstrings =
                  ( t.bitstrings |> Array.to_list |> List.concat
                  |> fun xs -> [| xs |] )
              }
            in
            assert (
              Array.for_all input.field_elements ~f:(fun el ->
                  List.length el = size_in_bits ) ) ;
            Result.iter deserialized ~f:(fun x ->
                assert (
                  Array.for_all x.field_elements ~f:(fun el ->
                      List.length el = size_in_bits ) ) ) ;
            [%test_eq:
              ( (bool list, bool) t
              , [ `Expected_eof | `Unexpected_eof ] )
              Result.t]
              (normalized input |> Result.return)
              (deserialized |> Result.map ~f:normalized) )

      let%test_unit "data is preserved by to_bits" =
        Quickcheck.test ~trials:300 (gen_input ())
          ~f:(fun (size_in_bits, input) ->
            let bits = to_bits ~unpack:Fn.id input in
            let bools_equal = [%equal: bool list] in
            (* Fields are accumulated at the front, check them first. *)
            let bitstring_bits =
              Array.fold ~init:bits input.field_elements ~f:(fun bits field ->
                  (* The next chunk of [size_in_bits] bits is for the field
                           element.
                  *)
                  let field_bits, rest = List.split_n bits size_in_bits in
                  assert (bools_equal field_bits field) ;
                  rest )
            in
            (* Bits come after. *)
            let remaining_bits =
              Array.fold ~init:bitstring_bits input.bitstrings
                ~f:(fun bits bitstring ->
                  (* The next bits match the bitstring. *)
                  let bitstring_bits, rest =
                    List.split_n bits (List.length bitstring)
                  in
                  assert (bools_equal bitstring_bits bitstring) ;
                  rest )
            in
            (* All bits should have been consumed. *)
            assert (List.is_empty remaining_bits) )

      let%test_unit "data is preserved by pack_to_fields" =
        Quickcheck.test ~trials:300 (gen_input ())
          ~f:(fun (size_in_bits, input) ->
            let fields = pack_to_fields ~size_in_bits ~pack:Fn.id input in
            (* Fields are accumulated at the front, check them first. *)
            let fields = Array.to_list fields in
            let bitstring_fields =
              Array.fold ~init:fields input.field_elements
                ~f:(fun fields input_field ->
                  (* The next field element should be the literal field element
                                     passed in.
                  *)
                  match fields with
                  | [] ->
                      failwith "Too few field elements"
                  | field :: rest ->
                      assert ([%equal: bool list] field input_field) ;
                      rest )
            in
            (* Check that the remaining fields have the correct size. *)
            let final_field_idx = List.length bitstring_fields - 1 in
            List.iteri bitstring_fields ~f:(fun i field_bits ->
                if i < final_field_idx then
                  (* This field should be densely packed, but should contain
                         fewer bits than the maximum field element to ensure that it
                         doesn't overflow, so we expect [size_in_bits - 1] bits for
                         maximum safe density.
                  *)
                  assert (List.length field_bits = size_in_bits - 1)
                else (
                  (* This field will be comprised of the remaining bits, up to a
                         maximum of [size_in_bits - 1]. It should not be empty.
                  *)
                  assert (not (List.is_empty field_bits)) ;
                  assert (List.length field_bits < size_in_bits) ) ) ;
            let rec go input_bitstrings packed_fields =
              match (input_bitstrings, packed_fields) with
              | [], [] ->
                  (* We have consumed all bitstrings and fields in parallel, with
                     no bits left over. Success.
                  *)
                  ()
              | [] :: input_bitstrings, packed_fields
              | input_bitstrings, [] :: packed_fields ->
                  (* We have consumed the whole of an input bitstring or the whole
                     of a packed field, move onto the next one.
                  *)
                  go input_bitstrings packed_fields
              | ( (bi :: input_bitstring) :: input_bitstrings
                , (bp :: packed_field) :: packed_fields ) ->
                  (* Consume the next bit from the next input bitstring, and the
                     next bit from the next packed field. They must match.
                  *)
                  assert (Bool.equal bi bp) ;
                  go
                    (input_bitstring :: input_bitstrings)
                    (packed_field :: packed_fields)
              | [], _ ->
                  failwith "Packed fields contain more bits than were provided"
              | _, [] ->
                  failwith
                    "There are input bits that were not present in the packed \
                     fields"
            in
            (* Check that the bits match between the input bitstring and the
                   remaining fields.
            *)
            go (Array.to_list input.bitstrings) bitstring_fields )
    end )
end

1	open Core_kernel	11✔
2
3	module Chunked = struct
4	(** The input for a random oracle, formed of full field elements and 'chunks'
5	of fields that can be combined together into one or more field elements.
6
7	The chunks are represented as [(field, length)], where
8	[0 <= field < 2^length]. This allows us to efficiently combine values in
9	a known range. For example,
10	{[
11	{ field_elements= [\|\|]; packeds= [\|(x, 64); (y, 32); (z, 16)\|] }
12	]}
13	results in the chunks being combined as [x * 2^(32+16) + y * 2^(64) + z].
14	When the chunks do not fit within a single field element, they are
15	greedily concatenated to form field elements, from left to right.
16	This packing is performed by the [pack_to_fields] helper function.
17	*)
18	type 'field t =	×
19	{ field_elements : 'field array; packeds : ('field * int) array }	×
20	[@@deriving sexp, compare]
21
22	let append (t1 : _ t) (t2 : _ t) =
23	{ field_elements = Array.append t1.field_elements t2.field_elements	859,286✔
24	; packeds = Array.append t1.packeds t2.packeds	859,286✔
25	}
26
27	let field_elements (a : 'f array) : 'f t =
28	{ field_elements = a; packeds = [\|\|] }	103,844✔
29
30	let field x : _ t = field_elements [\| x \|]	103,337✔
31
32	(** An input [[\|(x_1, l_1); (x_2, l_2); ...\|]] includes the values
33	[[\|x_1; x_2; ...\|]] in the input, assuming that `0 <= x_1 < 2^l_1`,
34	`0 <= x_2 < 2^l_2`, etc. so that multiple [x_i]s can be combined into a
35	single field element when the sum of their [l_i]s are less than the size
36	of the field modulus (in bits).
37	*)
38	let packeds a = { field_elements = [\|\|]; packeds = a }	744,709✔
39
40	(** [packed x = packeds [\| x \|]] *)
41	let packed xn : _ t = packeds [\| xn \|]	610,900✔
42
43	module type Field_intf = sig
44	type t
45
46	val size_in_bits : int
47
48	val zero : t
49
50	val ( + ) : t -> t -> t
51
52	val ( * ) : t -> t -> t
53	end
54
55	(** Convert the input into a series of field elements, by concatenating
56	any chunks of input that fit into a single field element.
57	The concatenation is greedy, operating from left to right.
58	*)
59	let pack_to_fields (type t) (module F : Field_intf with type t = t)
60	~(pow2 : int -> t) { field_elements; packeds } =
61	let shift_left acc n = F.( * ) acc (pow2 n) in	28,600✔
62	let open F in
63	let packed_bits =
64	let xs, acc, acc_n =
65	Array.fold packeds ~init:([], zero, 0)
66	~f:(fun (xs, acc, acc_n) (x, n) ->
67	let n' = Int.(n + acc_n) in	1,300,278✔
68	if Int.(n' < size_in_bits) then (xs, shift_left acc n + x, n')	1,280,995✔
69	else (acc :: xs, x, n) )	19,283✔
70	in
71	(* if acc_n = 0, packeds was empty (or acc holds 0 bits) and we don't want to append 0 *)
72	let xs = if acc_n > 0 then acc :: xs else xs in	1,094✔
73	Array.of_list_rev xs	28,600✔
74	in
75	Array.append field_elements packed_bits
76	end
77
78	module Legacy = struct
79	type ('field, 'bool) t =	×
80	{ field_elements : 'field array; bitstrings : 'bool list array }	×
81	[@@deriving sexp, compare]
82
83	let append t1 t2 =
84	{ field_elements = Array.append t1.field_elements t2.field_elements	65,832✔
85	; bitstrings = Array.append t1.bitstrings t2.bitstrings	65,832✔
86	}
87
88	let field_elements x = { field_elements = x; bitstrings = [\|\|] }	×
89
90	let field x = { field_elements = [\| x \|]; bitstrings = [\|\|] }	3,048✔
91
92	let bitstring x = { field_elements = [\|\|]; bitstrings = [\| x \|] }	37,401✔
93
94	let bitstrings x = { field_elements = [\|\|]; bitstrings = x }	×
95
96	let pack_bits ~max_size ~pack { field_elements = _; bitstrings } =
97	let rec pack_full_fields rev_fields bits length =	5,376✔
98	if length >= max_size then	74,784✔
99	let field_bits, bits = List.split_n bits max_size in	10,712✔
100	pack_full_fields (pack field_bits :: rev_fields) bits (length - max_size)	10,712✔
101	else (rev_fields, bits, length)	64,072✔
102	in
103	let packed_field_elements, remaining_bits, remaining_length =
104	Array.fold bitstrings ~init:([], [], 0)
105	~f:(fun (acc, bits, n) bitstring ->
106	let n = n + List.length bitstring in	64,072✔
107	let bits = bits @ bitstring in
108	let acc, bits, n = pack_full_fields acc bits n in
109	(acc, bits, n) )	64,072✔
110	in
111	if remaining_length = 0 then packed_field_elements	×
112	else pack remaining_bits :: packed_field_elements	5,376✔
113
114	let pack_to_fields ~size_in_bits ~pack { field_elements; bitstrings } =
115	let max_size = size_in_bits - 1 in	5,376✔
116	let packed_bits =
117	pack_bits ~max_size ~pack { field_elements; bitstrings }
118	in
119	Array.append field_elements (Array.of_list_rev packed_bits)	5,376✔
120
121	let to_bits ~unpack { field_elements; bitstrings } =
122	let field_bits = Array.map ~f:unpack field_elements in	1,800✔
123	List.concat @@ Array.to_list @@ Array.append field_bits bitstrings	1,800✔
124
125	module Coding = struct
126	(** See https://github.com/CodaProtocol/coda/blob/develop/rfcs/0038-rosetta-construction-api.md for details on schema *)
127
128	(** Serialize a random oracle input with 32byte fields into bytes according to the RFC0038 specification *)
129	let serialize ~string_of_field ~to_bool ~of_bool t =
130	let len_to_string x =	×
131	String.of_char_list	×
132	Char.
133	[ of_int_exn @@ ((x lsr 24) land 0xff)	×
134	; of_int_exn @@ ((x lsr 16) land 0xff)	×
135	; of_int_exn @@ ((x lsr 8) land 0xff)	×
136	; of_int_exn @@ (x land 0xff)	×
137	]
138	in
139	let len1 = len_to_string @@ Array.length t.field_elements in	×
140	let fields =	×
141	(* We only support 32byte fields *)
142	let () =
143	if Array.length t.field_elements > 0 then	×
144	assert (String.length (string_of_field t.field_elements.(0)) = 32)	×
145	else ()	×
146	in
147	Array.map t.field_elements ~f:string_of_field \|> String.concat_array	×
148	in
149	let len2 =
150	len_to_string
151	@@ Array.sum (module Int) t.bitstrings ~f:(fun x -> List.length x)	×
152	in
153	let packed =	×
154	pack_bits t ~max_size:8 ~pack:(fun bs ->	×
155	let rec go i acc = function	×
156	\| [] ->	×
157	acc
158	\| b :: bs ->	×
159	go (i + 1) ((acc * 2) + if to_bool b then 1 else 0) bs	×
160	in
161	let pad =
162	List.init (8 - List.length bs) ~f:(Fn.const (of_bool false))	×
163	in
164	let combined = bs @ pad in	×
165	assert (List.length combined = 8) ;	×
166	go 0 0 combined )
167	\|> List.map ~f:Char.of_int_exn	×
168	\|> List.rev \|> String.of_char_list	×
169	in
170	len1 ^ fields ^ len2 ^ packed	×
171
172	module Parser = struct
173	(* TODO: Before using this too much; use a solid parser library instead or beef this one up with more debugging info *)
174
175	(* The parser is a function over this monad-fail *)
176	module M = Result
177
178	module T = struct
179	type ('a, 'e) t = char list -> ('a * char list, 'e) M.t
180
181	let return a cs = M.return (a, cs)	×
182
183	let bind : ('a, 'e) t -> f:('a -> ('b, 'e) t) -> ('b, 'e) t =
184	fun t ~f cs ->
185	let open M.Let_syntax in	×
186	let%bind a, rest = t cs in	×
187	f a rest	×
188
189	let map = `Define_using_bind
190	end
191
192	include Monad.Make2 (T)
193
194	let run p cs =
195	p cs	×
196	\|> M.bind ~f:(fun (a, cs') ->
197	match cs' with [] -> M.return a \| _ -> M.fail `Expected_eof )	×
198
199	let fail why _ = M.fail why	×
200
201	let char c = function
202	\| c' :: cs when Char.equal c c' ->	×
203	M.return (c', cs)	×
204	\| c' :: _ ->	×
205	M.fail (`Unexpected_char c')
206	\| [] ->	×
207	M.fail `Unexpected_eof
208
209	let u8 = function
210	\| c :: cs ->	×
211	M.return (c, cs)
212	\| [] ->	×
213	M.fail `Unexpected_eof
214
215	let u32 =
216	let open Let_syntax in
217	let open Char in
218	let%map a = u8 and b = u8 and c = u8 and d = u8 in
219	(to_int a lsl 24)	×
220	lor (to_int b lsl 16)	×
221	lor (to_int c lsl 8)	×
222	lor to_int d	×
223
224	let eof = function [] -> M.return ((), []) \| _ -> M.fail `Expected_eof	×
225
226	let take n cs =
227	if List.length cs < n then M.fail `Unexpected_eof	×
228	else M.return (List.split_n cs n)	×
229
230	(** p zero or more times, never fails *)
231	let many p =
232	(fun cs ->	×
233	let rec go xs acc =	×
234	match p xs with	×
235	\| Ok (a, xs) ->	×
236	go xs (a :: acc)
237	\| Error _ ->	×
238	(acc, xs)
239	in
240	M.return @@ go cs [] )	×
241	\|> map ~f:List.rev
242
243	let%test_unit "many" =
244	[%test_eq: (char list, [ `Expected_eof ]) Result.t]	×
245	(run (many u8) [ 'a'; 'b'; 'c' ])	×
246	(Result.return [ 'a'; 'b'; 'c' ])	×
247
248	(** p exactly n times *)
249	let exactly n p =
250	(fun cs ->	×
251	let rec go xs acc = function	×
252	\| 0 ->	×
253	M.return (acc, xs)
254	\| i ->	×
255	let open M.Let_syntax in
256	let%bind a, xs = p xs in	×
257	go xs (a :: acc) (i - 1)	×
258	in
259	go cs [] n )
260	\|> map ~f:List.rev
261
262	let%test_unit "exactly" =
263	[%test_eq:	×
264	(char list * char list, [ `Expected_eof \| `Unexpected_eof ]) Result.t]	×
265	((exactly 3 u8) [ 'a'; 'b'; 'c'; 'd' ])	×
266	(Result.return ([ 'a'; 'b'; 'c' ], [ 'd' ]))	×
267
268	let return_res r cs = r \|> Result.map ~f:(fun x -> (x, cs))	×
269	end
270
271	let bits_of_byte ~of_bool b =
272	let b = Char.to_int b in	×
273	let f x =	×
274	of_bool	×
275	( match x with
276	\| 0 ->	×
277	false
278	\| 1 ->	×
279	true
280	\| _ ->	×
281	failwith "Unexpected boolean integer" )
282	in
283	[ (b land (0x1 lsl 7)) lsr 7
284	; (b land (0x1 lsl 6)) lsr 6
285	; (b land (0x1 lsl 5)) lsr 5
286	; (b land (0x1 lsl 4)) lsr 4
287	; (b land (0x1 lsl 3)) lsr 3
288	; (b land (0x1 lsl 2)) lsr 2
289	; (b land (0x1 lsl 1)) lsr 1
290	; b land 0x1
291	]
292	\|> List.map ~f
293
294	(** Deserialize bytes into a random oracle input with 32byte fields according to the RFC0038 specification *)
295	let deserialize ~field_of_string ~of_bool s =
296	let field =	×
297	let open Parser.Let_syntax in
298	let%bind u8x32 = Parser.take 32 in	×
299	let s = String.of_char_list u8x32 in	×
300	Parser.return_res (field_of_string s)	×
301	in
302	let parser =
303	let open Parser.Let_syntax in
304	let%bind len1 = Parser.u32 in
305	let%bind fields = Parser.exactly len1 field in	×
306	let%bind len2 = Parser.u32 in
307	let%map bytes = Parser.(many u8) in	×
308	let bits = List.concat_map ~f:(bits_of_byte ~of_bool) bytes in	×
309	let bitstring = List.take bits len2 in	×
310	{ field_elements = Array.of_list fields; bitstrings = [\| bitstring \|] }	×
311	in
312	Parser.run parser s
313
314	(** String of field as bits *)
315	let string_of_field xs =
316	List.chunks_of xs ~length:8	×
317	\|> List.map ~f:(fun xs ->	×
318	let rec go i acc = function	×
319	\| [] ->	×
320	acc
321	\| b :: bs ->	×
322	go (i + 1) ((acc * 2) + if b then 1 else 0) bs	×
323	in
324	let pad = List.init (8 - List.length xs) ~f:(Fn.const false) in	×
325	let combined = xs @ pad in	×
326	assert (List.length combined = 8) ;	×
327	go 0 0 combined )
328	\|> List.map ~f:Char.of_int_exn	×
329	\|> String.of_char_list
330
331	(** Field of string as bits *)
332	let field_of_string s ~size_in_bits =
333	List.concat_map (String.to_list s) ~f:(bits_of_byte ~of_bool:Fn.id)	×
334	\|> Fn.flip List.take size_in_bits	×
335	\|> Result.return
336	end
337
338	(** Coding2 is an alternate binary coding setup where we pass two arrays of
339	* field elements instead of a single structure to simplify manipulation
340	* outside of the Mina construction API
341	*
342	* This is described as the second mechanism for coding Random_oracle_input in
343	* RFC0038
344	*
345	*)
346	module Coding2 = struct
347	module Rendered = struct
348	(* as bytes, you must hex this later *)
349	type 'field t_ = { prefix : 'field array; suffix : 'field array }	×
350	[@@deriving yojson]	×
351
352	type t = string t_ [@@deriving yojson]	×
353
354	let map ~f { prefix; suffix } =
355	{ prefix = Array.map ~f prefix; suffix = Array.map ~f suffix }	×
356	end
357
358	let string_of_field : bool list -> string = Coding.string_of_field
359
360	let field_of_string = Coding.field_of_string
361
362	let serialize' t ~pack =
363	{ Rendered.prefix = t.field_elements	×
364	; suffix = pack_bits ~max_size:254 ~pack t \|> Array.of_list_rev	×
365	}
366
367	let serialize t ~string_of_field ~pack =
368	let () =	×
369	if Array.length t.field_elements > 0 then	×
370	assert (String.length (string_of_field t.field_elements.(0)) = 32)	×
371	else ()	×
372	in
373	serialize' t ~pack \|> Rendered.map ~f:string_of_field	×
374	end
375
376	let%test_module "random_oracle input" =
377	( module struct
378	let gen_field ~size_in_bits =
379	let open Quickcheck.Generator in	×
380	list_with_length size_in_bits bool
381
382	let gen_input ?size_in_bits () =
383	let open Quickcheck.Generator in	×
384	let open Let_syntax in
385	let%bind size_in_bits =
386	size_in_bits \|> Option.map ~f:return	×
387	\|> Option.value ~default:(Int.gen_incl 2 3000)	×
388	in
389	let%bind field_elements =
390	(* Treat a field as a list of bools of length [size_in_bits]. *)
391	list (gen_field ~size_in_bits)	×
392	in
393	let%map bitstrings = list (list bool) in	×
394	( size_in_bits	×
395	, { field_elements = Array.of_list field_elements	×
396	; bitstrings = Array.of_list bitstrings	×
397	} )
398
399	let%test_unit "coding2 equiv to hash directly" =
400	let size_in_bits = 255 in	×
401	let field = gen_field ~size_in_bits in
402	Quickcheck.test ~trials:300
403	Quickcheck.Generator.(
404	tuple2 (gen_input ~size_in_bits ()) (tuple2 field field))	×
405	~f:(fun ((_, input), (x, y)) ->
406	let middle = [\| x; y \|] in	×
407	let expected =
408	append input (field_elements middle)	×
409	\|> pack_to_fields ~size_in_bits ~pack:Fn.id
410	in
411	let { Coding2.Rendered.prefix; suffix } =	×
412	Coding2.serialize' input ~pack:Fn.id
413	in
414	let actual = Array.(concat [ prefix; middle; suffix ]) in	×
415	[%test_eq: bool list array] expected actual )	×
416
417	let%test_unit "field/string partial isomorphism bitstrings" =
418	Quickcheck.test ~trials:300	×
419	Quickcheck.Generator.(list_with_length 255 bool)	×
420	~f:(fun input ->
421	let serialized = Coding.string_of_field input in	×
422	let deserialized =	×
423	Coding.field_of_string serialized ~size_in_bits:255
424	in
425	[%test_eq: (bool list, unit) Result.t] (input \|> Result.return)	×
426	deserialized )
427
428	let%test_unit "serialize/deserialize partial isomorphism 32byte fields" =
429	let size_in_bits = 255 in	×
430	Quickcheck.test ~trials:3000 (gen_input ~size_in_bits ())	×
431	~f:(fun (_, input) ->
432	let serialized =	×
433	Coding.(
434	serialize ~string_of_field ~to_bool:Fn.id ~of_bool:Fn.id input)	×
435	in
436	let deserialized =
437	Coding.(
438	deserialize	×
439	(String.to_list serialized)	×
440	~field_of_string:(field_of_string ~size_in_bits)
441	~of_bool:Fn.id)
442	in
443	let normalized t =
444	{ t with	×
445	bitstrings =
446	( t.bitstrings \|> Array.to_list \|> List.concat	×
447	\|> fun xs -> [\| xs \|] )	×
448	}
449	in
450	assert (	×
451	Array.for_all input.field_elements ~f:(fun el ->	×
452	List.length el = size_in_bits ) ) ;	×
453	Result.iter deserialized ~f:(fun x ->
454	assert (	×
455	Array.for_all x.field_elements ~f:(fun el ->	×
456	List.length el = size_in_bits ) ) ) ;	×
457	[%test_eq:	×
458	( (bool list, bool) t	×
459	, [ `Expected_eof \| `Unexpected_eof ] )	×
460	Result.t]	×
461	(normalized input \|> Result.return)	×
462	(deserialized \|> Result.map ~f:normalized) )	×
463
464	let%test_unit "data is preserved by to_bits" =
465	Quickcheck.test ~trials:300 (gen_input ())	×
466	~f:(fun (size_in_bits, input) ->
467	let bits = to_bits ~unpack:Fn.id input in	×
468	let bools_equal = [%equal: bool list] in	×
469	(* Fields are accumulated at the front, check them first. *)
470	let bitstring_bits =
471	Array.fold ~init:bits input.field_elements ~f:(fun bits field ->
472	(* The next chunk of [size_in_bits] bits is for the field
473	element.
474	*)
475	let field_bits, rest = List.split_n bits size_in_bits in	×
476	assert (bools_equal field_bits field) ;	×
477	rest )
478	in
479	(* Bits come after. *)
480	let remaining_bits =	×
481	Array.fold ~init:bitstring_bits input.bitstrings
482	~f:(fun bits bitstring ->
483	(* The next bits match the bitstring. *)
484	let bitstring_bits, rest =	×
485	List.split_n bits (List.length bitstring)	×
486	in
487	assert (bools_equal bitstring_bits bitstring) ;	×
488	rest )
489	in
490	(* All bits should have been consumed. *)
491	assert (List.is_empty remaining_bits) )	×
492
493	let%test_unit "data is preserved by pack_to_fields" =
494	Quickcheck.test ~trials:300 (gen_input ())	×
495	~f:(fun (size_in_bits, input) ->
496	let fields = pack_to_fields ~size_in_bits ~pack:Fn.id input in	×
497	(* Fields are accumulated at the front, check them first. *)
498	let fields = Array.to_list fields in	×
499	let bitstring_fields =	×
500	Array.fold ~init:fields input.field_elements
501	~f:(fun fields input_field ->
502	(* The next field element should be the literal field element
503	passed in.
504	*)
505	match fields with	×
506	\| [] ->	×
507	failwith "Too few field elements"
508	\| field :: rest ->	×
509	assert ([%equal: bool list] field input_field) ;	×
510	rest )
511	in
512	(* Check that the remaining fields have the correct size. *)
513	let final_field_idx = List.length bitstring_fields - 1 in	×
514	List.iteri bitstring_fields ~f:(fun i field_bits ->
515	if i < final_field_idx then	×
516	(* This field should be densely packed, but should contain
517	fewer bits than the maximum field element to ensure that it
518	doesn't overflow, so we expect [size_in_bits - 1] bits for
519	maximum safe density.
520	*)
521	assert (List.length field_bits = size_in_bits - 1)	×
522	else (	×
523	(* This field will be comprised of the remaining bits, up to a
524	maximum of [size_in_bits - 1]. It should not be empty.
525	*)
526	assert (not (List.is_empty field_bits)) ;	×
527	assert (List.length field_bits < size_in_bits) ) ) ;	×
528	let rec go input_bitstrings packed_fields =	×
529	match (input_bitstrings, packed_fields) with	×
530	\| [], [] ->	×
531	(* We have consumed all bitstrings and fields in parallel, with
532	no bits left over. Success.
533	*)
534	()
535	\| [] :: input_bitstrings, packed_fields	×
536	\| input_bitstrings, [] :: packed_fields ->	×
537	(* We have consumed the whole of an input bitstring or the whole
538	of a packed field, move onto the next one.
539	*)
540	go input_bitstrings packed_fields
541	\| ( (bi :: input_bitstring) :: input_bitstrings	×
542	, (bp :: packed_field) :: packed_fields ) ->
543	(* Consume the next bit from the next input bitstring, and the
544	next bit from the next packed field. They must match.
545	*)
546	assert (Bool.equal bi bp) ;	×
547	go
548	(input_bitstring :: input_bitstrings)
549	(packed_field :: packed_fields)
550	\| [], _ ->	×
551	failwith "Packed fields contain more bits than were provided"
552	\| _, [] ->	×
553	failwith
554	"There are input bits that were not present in the packed \
555	fields"
556	in
557	(* Check that the bits match between the input bitstring and the
558	remaining fields.
559	*)
560	go (Array.to_list input.bitstrings) bitstring_fields )	×
561	end )
562	end	22✔

MinaProtocol / mina / 2863

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous