diff --git a/src/proto_alpha/lib_protocol/dal_slot_repr.ml b/src/proto_alpha/lib_protocol/dal_slot_repr.ml index 515927adb8288aeae132e40fef7ada89e4a00a84..7448c9ce5a6095df36f2c886d53d9246edb7e40c 100644 --- a/src/proto_alpha/lib_protocol/dal_slot_repr.ml +++ b/src/proto_alpha/lib_protocol/dal_slot_repr.ml @@ -622,15 +622,7 @@ module History = struct in let page = {Dal.content = data; index = pid.Page.page_index} in let fail_with_error_msg what = - Format.kasprintf - proof_error - "%s (page data=%s, page id=%a, commitment=%a)." - what - (Bytes.to_string data) - Page.pp - pid - Commitment.pp - commitment + Format.kasprintf proof_error "%s (page id=%a)." what Page.pp pid in match Dal.verify_page dal commitment page proof with | Ok true -> return () diff --git a/src/proto_alpha/lib_protocol/test/helpers/dal_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/dal_helpers.ml index 2564b612d923529561633097316e24e5b0492249..68b5d35714144db48a3b2c1f8efad6ad60512839 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/dal_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/dal_helpers.ml @@ -29,18 +29,6 @@ module P = S.Page module Hist = S.History module Ihist = Hist.Internal_for_tests -(* Some global constants. *) - -let genesis_history = Hist.genesis - -let genesis_history_cache = Hist.History_cache.empty ~capacity:3000L - -let level_one = Raw_level_repr.(succ root) - -let level_ten = Raw_level_repr.(of_int32_exn 10l) - -(* Helper functions. *) - (** Error used below for functions that don't return their failures in the monad error. *) type error += Test_failure of string @@ -57,7 +45,7 @@ let () = (function Test_failure e -> Some e | _ -> None) (fun e -> Test_failure e) -let dal_mk_env dal_params = +let mk_cryptobox dal_params = let open Result_syntax in let parameters = Cryptobox.Internal_for_tests.initialisation_parameters_from_slot_size @@ -68,159 +56,181 @@ let dal_mk_env dal_params = | Ok dal -> return dal | Error (`Fail s) -> fail [Test_failure s] -let dal_mk_polynomial_from_slot dal slot_data = - let open Result_syntax in - match Cryptobox.polynomial_from_slot dal slot_data with - | Ok p -> return p - | Error (`Slot_wrong_size s) -> - fail - [ - Test_failure - (Format.sprintf "polynomial_from_slot: Slot_wrong_size (%s)" s); - ] - -let dal_mk_prove_page dal polynomial page_id = - let open Result_syntax in - match Cryptobox.prove_page dal polynomial page_id.P.page_index with - | Ok p -> return p - | Error `Segment_index_out_of_range -> - fail [Test_failure "compute_proof_segment: Segment_index_out_of_range"] - -let mk_slot ?(level = level_one) ?(index = S.Index.zero) - ?(fill_function = fun _i -> 'x') dal = - let open Result_syntax in - let params = Cryptobox.Internal_for_tests.parameters dal in - let slot_data = Bytes.init params.slot_size fill_function in - let* polynomial = dal_mk_polynomial_from_slot dal slot_data in - let commitment = Cryptobox.commit dal polynomial in - return - ( slot_data, - polynomial, - S.Header.{id = {published_level = level; index}; commitment} ) - -let mk_page_id published_level slot_index page_index = - P.{slot_id = {published_level; index = slot_index}; page_index} - -let no_data = Some (fun ~default_char:_ _ -> None) - -let mk_page_info ?(default_char = 'x') ?level ?(page_index = P.Index.zero) - ?(custom_data = None) dal (slot : S.Header.t) polynomial = - let open Result_syntax in - let level = - match level with None -> slot.id.published_level | Some level -> level - in - let params = Cryptobox.Internal_for_tests.parameters dal in - let page_id = mk_page_id level slot.id.index page_index in - let* page_proof = dal_mk_prove_page dal polynomial page_id in - match custom_data with - | None -> - let page_data = Bytes.make params.page_size default_char in - return (Some (page_data, page_proof), page_id) - | Some mk_data -> ( - match mk_data ~default_char params.page_size with - | None -> return (None, page_id) - | Some page_data -> return (Some (page_data, page_proof), page_id)) - -let succ_slot_index index = - Option.value_f - S.Index.(of_int (to_int index + 1)) - ~default:(fun () -> S.Index.zero) - -let next_char c = Char.(chr ((code c + 1) mod 255)) - -(** Auxiliary test function used by both unit and PBT tests: This function - produces a proof from the given information and verifies the produced result, - if any. The result of each step is checked with [check_produce_result] and - [check_verify_result], respectively. *) -let produce_and_verify_proof ~check_produce ?check_verify dal skip_list cache - ~page_info ~page_id = - let open Lwt_result_syntax in - let params = Cryptobox.Internal_for_tests.parameters dal in - let*! res = - Hist.produce_proof params ~page_info page_id skip_list cache - >|= Environment.wrap_tzresult - in - let* () = check_produce res page_info in - match check_verify with - | None -> return_unit - | Some check_verify -> - let*? proof, _input_opt = res in - let*! res = - Hist.verify_proof params page_id skip_list proof - >|= Environment.wrap_tzresult - in - check_verify res page_info - -(* Some check functions. *) - -(** Check that/if the returned content is the expected one. *) -let assert_content_is ~__LOC__ ~expected returned = - Assert.equal - ~loc:__LOC__ - (Option.equal Bytes.equal) - "Returned %s doesn't match the expected one" - (fun fmt opt -> - match opt with - | None -> Format.fprintf fmt "" - | Some bs -> Format.fprintf fmt "" (Bytes.to_string bs)) - returned - expected - -let expected_data page_info proof_status = - match (page_info, proof_status) with - | Some (d, _p), `Confirmed -> Some d - | None, `Confirmed -> assert false - | _ -> None - -let proof_status_to_string = function - | `Confirmed -> "CONFIRMED" - | `Unconfirmed -> "UNCONFIRMED" - -let successful_check_produce_result ~__LOC__ proof_status res page_info = - let open Lwt_result_syntax in - let* proof, input_opt = Assert.get_ok ~__LOC__ res in - let* () = - if Hist.Internal_for_tests.proof_statement_is proof proof_status then - return_unit - else - failwith - "Expected to have a %s page proof. Got %a@." - (proof_status_to_string proof_status) - Hist.pp_proof - proof - in - assert_content_is - ~__LOC__ - input_opt - ~expected:(expected_data page_info proof_status) - -let failing_check_produce_result ~__LOC__ err_string res _page_info = - Assert.proto_error ~loc:__LOC__ res (function - | Hist.Dal_proof_error s -> String.equal s err_string - | _ -> false) - -let successful_check_verify_result ~__LOC__ proof_status res page_info = - let open Lwt_result_syntax in - let* content = Assert.get_ok ~__LOC__ res in - let expected = expected_data page_info proof_status in - assert_content_is ~__LOC__ ~expected content - -(** Checks if the two provided Page.proof are equal. *) -let eq_page_proof = - let bytes_opt_of_proof page_proof = - Data_encoding.Binary.to_bytes_opt P.proof_encoding page_proof - in - fun pp1 pp2 -> - Option.equal Bytes.equal (bytes_opt_of_proof pp1) (bytes_opt_of_proof pp2) - -let slot_confirmed_but_page_data_not_provided ~__LOC__ = - failing_check_produce_result - ~__LOC__ - "The page ID's slot is confirmed, but no page content and proof are \ - provided." - -let slot_not_confirmed_but_page_data_provided ~__LOC__ = - failing_check_produce_result - ~__LOC__ - "The page ID's slot is not confirmed, but page content and proof are \ - provided." +module Make (Parameters : sig + val dal_parameters : Alpha_context.Constants.Parametric.dal + + val cryptobox : Cryptobox.t +end) = +struct + (* Some global constants. *) + + let params = Parameters.dal_parameters.cryptobox_parameters + + let cryptobox = Parameters.cryptobox + + let genesis_history = Hist.genesis + + let genesis_history_cache = Hist.History_cache.empty ~capacity:3000L + + let level_one = Raw_level_repr.(succ root) + + let level_ten = Raw_level_repr.(of_int32_exn 10l) + + (* Helper functions. *) + + let dal_mk_polynomial_from_slot slot_data = + let open Result_syntax in + match Cryptobox.polynomial_from_slot cryptobox slot_data with + | Ok p -> return p + | Error (`Slot_wrong_size s) -> + fail + [ + Test_failure + (Format.sprintf "polynomial_from_slot: Slot_wrong_size (%s)" s); + ] + + let dal_mk_prove_page polynomial page_id = + let open Result_syntax in + match Cryptobox.prove_page cryptobox polynomial page_id.P.page_index with + | Ok p -> return p + | Error `Segment_index_out_of_range -> + fail [Test_failure "compute_proof_segment: Segment_index_out_of_range"] + + let mk_slot ?(level = level_one) ?(index = S.Index.zero) + ?(fill_function = fun _i -> 'x') () = + let open Result_syntax in + let slot_data = Bytes.init params.slot_size fill_function in + let* polynomial = dal_mk_polynomial_from_slot slot_data in + let commitment = Cryptobox.commit cryptobox polynomial in + return + ( slot_data, + polynomial, + S.Header.{id = {published_level = level; index}; commitment} ) + + let mk_page_id published_level slot_index page_index = + P.{slot_id = {published_level; index = slot_index}; page_index} + + let no_data = Some (fun ~default_char:_ _ -> None) + + let mk_page_info ?(default_char = 'x') ?level ?(page_index = P.Index.zero) + ?(custom_data = None) (slot : S.Header.t) polynomial = + let open Result_syntax in + let level = + match level with None -> slot.id.published_level | Some level -> level + in + let page_id = mk_page_id level slot.id.index page_index in + let* page_proof = dal_mk_prove_page polynomial page_id in + match custom_data with + | None -> + let page_data = Bytes.make params.page_size default_char in + return (Some (page_data, page_proof), page_id) + | Some mk_data -> ( + match mk_data ~default_char params.page_size with + | None -> return (None, page_id) + | Some page_data -> return (Some (page_data, page_proof), page_id)) + + let succ_slot_index index = + Option.value_f + S.Index.(of_int (to_int index + 1)) + ~default:(fun () -> S.Index.zero) + + let next_char c = Char.(chr ((code c + 1) mod 255)) + + (** Auxiliary test function used by both unit and PBT tests: This function + produces a proof from the given information and verifies the produced result, + if any. The result of each step is checked with [check_produce_result] and + [check_verify_result], respectively. *) + let produce_and_verify_proof ~check_produce ?check_verify skip_list cache + ~page_info ~page_id = + let open Lwt_result_syntax in + let*! res = + Hist.produce_proof params ~page_info page_id skip_list cache + >|= Environment.wrap_tzresult + in + let* () = check_produce res page_info in + match check_verify with + | None -> return_unit + | Some check_verify -> + let*? proof, _input_opt = res in + let*! res = + Hist.verify_proof params page_id skip_list proof + >|= Environment.wrap_tzresult + in + check_verify res page_info + + (* Some check functions. *) + + (** Check that/if the returned content is the expected one. *) + let assert_content_is ~__LOC__ ~expected returned = + Assert.equal + ~loc:__LOC__ + (Option.equal Bytes.equal) + "Returned %s doesn't match the expected one" + (fun fmt opt -> + match opt with + | None -> Format.fprintf fmt "" + | Some bs -> Format.fprintf fmt "" (Bytes.to_string bs)) + returned + expected + + let expected_data page_info proof_status = + match (page_info, proof_status) with + | Some (d, _p), `Confirmed -> Some d + | None, `Confirmed -> assert false + | _ -> None + + let proof_status_to_string = function + | `Confirmed -> "CONFIRMED" + | `Unconfirmed -> "UNCONFIRMED" + + let successful_check_produce_result ~__LOC__ proof_status res page_info = + let open Lwt_result_syntax in + let* proof, input_opt = Assert.get_ok ~__LOC__ res in + let* () = + if Hist.Internal_for_tests.proof_statement_is proof proof_status then + return_unit + else + failwith + "Expected to have a %s page proof. Got %a@." + (proof_status_to_string proof_status) + Hist.pp_proof + proof + in + assert_content_is + ~__LOC__ + input_opt + ~expected:(expected_data page_info proof_status) + + let failing_check_produce_result ~__LOC__ ~dal_proof_error res _page_info = + Assert.proto_error ~loc:__LOC__ res (function + | Hist.Dal_proof_error s -> String.equal s dal_proof_error + | _ -> false) + + let successful_check_verify_result ~__LOC__ proof_status res page_info = + let open Lwt_result_syntax in + let* content = Assert.get_ok ~__LOC__ res in + let expected = expected_data page_info proof_status in + assert_content_is ~__LOC__ ~expected content + + (** Checks if the two provided Page.proof are equal. *) + let eq_page_proof = + let bytes_opt_of_proof page_proof = + Data_encoding.Binary.to_bytes_opt P.proof_encoding page_proof + in + fun pp1 pp2 -> + Option.equal Bytes.equal (bytes_opt_of_proof pp1) (bytes_opt_of_proof pp2) + + let slot_confirmed_but_page_data_not_provided ~__LOC__ = + failing_check_produce_result + ~__LOC__ + ~dal_proof_error: + "The page ID's slot is confirmed, but no page content and proof are \ + provided." + + let slot_not_confirmed_but_page_data_provided ~__LOC__ = + failing_check_produce_result + ~__LOC__ + ~dal_proof_error: + "The page ID's slot is not confirmed, but page content and proof are \ + provided." +end diff --git a/src/proto_alpha/lib_protocol/test/helpers/dal_helpers.mli b/src/proto_alpha/lib_protocol/test/helpers/dal_helpers.mli index 1d79e7f06683a9c573ad1a1bf382df97a024137a..770ed1203f2ad7f9945a3d55b5097492101117d1 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/dal_helpers.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/dal_helpers.mli @@ -25,124 +25,130 @@ open Protocol -(** Some global constants. *) - -val genesis_history : Dal_slot_repr.History.t - -val genesis_history_cache : Dal_slot_repr.History.History_cache.t - -val level_one : Raw_level_repr.t - -val level_ten : Raw_level_repr.t - -(** Helper functions. *) - (** Returns an object of type {!Cryptobox.t} from the given DAL paramters. *) -val dal_mk_env : Cryptobox.parameters -> (Cryptobox.t, error trace) result - -(** Returns the slot's polynomial from the given slot's data. *) -val dal_mk_polynomial_from_slot : - Cryptobox.t -> bytes -> (Cryptobox.polynomial, error trace) result - -(** Using the given slot's polynomial, this function computes the page proof of - the page whose ID is provided. *) -val dal_mk_prove_page : - Cryptobox.t -> - Cryptobox.polynomial -> - Dal_slot_repr.Page.t -> - (Cryptobox.page_proof, error trace) result - -(** Constructs a slot whose ID is defined from the given level and given index, - and whose data are built using the given fill function. The function returns - the slot's data, polynomial, and header (in the sense: ID + kate - commitment). *) -val mk_slot : - ?level:Raw_level_repr.t -> - ?index:Dal_slot_repr.Index.t -> - ?fill_function:(int -> char) -> - Cryptobox.t -> - (bytes * Cryptobox.polynomial * Dal_slot_repr.Header.t, error trace) result - -(** Constructs a record value of type Page.id. *) -val mk_page_id : - Raw_level_repr.t -> Dal_slot_repr.Index.t -> int -> Dal_slot_repr.Page.t - -val no_data : (default_char:char -> int -> bytes option) option - -(** Constructs a page whose level and slot indexes are those of the given slot - (except if level is redefined via [?level]), and whose page index and data - are given by arguments [page_index] and [mk_data]. If [mk_data] is set to [No], - the function returns the pair (None, page_id). Otherwise, the page's [data] - and [proof] is computed, and the function returns [Some (data, proof), - page_id]. *) -val mk_page_info : - ?default_char:char -> - ?level:Raw_level_repr.t -> - ?page_index:int -> - ?custom_data:(default_char:char -> int -> bytes option) option -> - Cryptobox.t -> - Dal_slot_repr.Header.t -> - Cryptobox.polynomial -> - ( (bytes * Cryptobox.page_proof) option * Dal_slot_repr.Page.t, - error trace ) - result - -(** Returns the char after [c]. Restarts from the char whose code is 0 if [c]'s - code is 255. *) -val next_char : char -> char - -(** Increment the given slot index. Returns zero in case of overflow. *) -val succ_slot_index : Dal_slot_repr.Index.t -> Dal_slot_repr.Index.t - -(** Auxiliary test function used by both unit and PBT tests: This function - produces a proof from the given information and verifies the produced result, - if any. The result of each step is checked with [check_produce_result] and - [check_verify_result], respectively. *) -val produce_and_verify_proof : - check_produce: - ((Dal_slot_repr.History.proof * bytes option) tzresult -> - (bytes * Cryptobox.page_proof) option -> - (unit, tztrace) result Lwt.t) -> - ?check_verify: - (bytes option tzresult -> - (bytes * Cryptobox.page_proof) option -> - (unit, tztrace) result Lwt.t) -> - Cryptobox.t -> - Dal_slot_repr.History.t -> - Dal_slot_repr.History.History_cache.t -> - page_info:(bytes * Cryptobox.page_proof) option -> - page_id:Dal_slot_repr.Page.t -> - (unit, tztrace) result Lwt.t - -(** Check if two page proofs are equal. *) -val eq_page_proof : Cryptobox.page_proof -> Cryptobox.page_proof -> bool - -(** Helper for the case where produce_proof is expected to succeed. *) -val successful_check_produce_result : - __LOC__:string -> - [`Confirmed | `Unconfirmed] -> - (Dal_slot_repr.History.proof * bytes option, tztrace) result -> - (bytes * 'a) option -> - (unit, tztrace) result Lwt.t - -(** Helper for the case where verify_proof is expected to succeed. *) -val successful_check_verify_result : - __LOC__:string -> - [> `Confirmed] -> - (bytes option, tztrace) result -> - (bytes * 'a) option -> - (unit, tztrace) result Lwt.t - -(** Helper for the case where produce_proof is expected to fail because the slot - is confirmed but no page information are provided. *) -val slot_confirmed_but_page_data_not_provided : - __LOC__:string -> ('a, tztrace) result -> 'b -> unit tzresult Lwt.t - -(** Helper for the case where produce_proof is expected to fail because the slot - is not confirmed but page_info are provided. *) -val slot_not_confirmed_but_page_data_provided : - __LOC__:string -> ('a, tztrace) result -> 'b -> unit tzresult Lwt.t - -(** Helper for the case where produce_proof is expected to fail. *) -val failing_check_produce_result : - __LOC__:string -> string -> ('a, tztrace) result -> 'b -> unit tzresult Lwt.t +val mk_cryptobox : Cryptobox.parameters -> Cryptobox.t tzresult + +module Make (P : sig + val dal_parameters : Alpha_context.Constants.Parametric.dal + + val cryptobox : Cryptobox.t +end) : sig + (** Some global constants. *) + + val genesis_history : Dal_slot_repr.History.t + + val genesis_history_cache : Dal_slot_repr.History.History_cache.t + + val level_one : Raw_level_repr.t + + val level_ten : Raw_level_repr.t + + (** Helper functions. *) + + (** Returns the slot's polynomial from the given slot's data. *) + val dal_mk_polynomial_from_slot : bytes -> Cryptobox.polynomial tzresult + + (** Using the given slot's polynomial, this function computes the page proof of + the page whose ID is provided. *) + val dal_mk_prove_page : + Cryptobox.polynomial -> + Dal_slot_repr.Page.t -> + Cryptobox.page_proof tzresult + + (** Constructs a slot whose ID is defined from the given level and given + index, and whose data are built using the given fill function. The function + returns the slot's data, polynomial, and header (in the sense: ID + kate + commitment). *) + val mk_slot : + ?level:Raw_level_repr.t -> + ?index:Dal_slot_repr.Index.t -> + ?fill_function:(int -> char) -> + unit -> + (bytes * Cryptobox.polynomial * Dal_slot_repr.Header.t) tzresult + + (** Constructs a record value of type Page.id. *) + val mk_page_id : + Raw_level_repr.t -> Dal_slot_repr.Index.t -> int -> Dal_slot_repr.Page.t + + val no_data : (default_char:char -> int -> bytes option) option + + (** Constructs a page whose level and slot indexes are those of the given slot + (except if level is redefined via [?level]), and whose page index and data + are given by arguments [page_index] and [mk_data]. If [mk_data] is set to + [No], the function returns the pair (None, page_id). Otherwise, the page's + [data] and [proof] is computed, and the function returns [Some (data, + proof), page_id]. *) + val mk_page_info : + ?default_char:char -> + ?level:Raw_level_repr.t -> + ?page_index:int -> + ?custom_data:(default_char:char -> int -> bytes option) option -> + Dal_slot_repr.Header.t -> + Cryptobox.polynomial -> + ( (bytes * Cryptobox.page_proof) option * Dal_slot_repr.Page.t, + error trace ) + result + + (** Returns the char after [c]. Restarts from the char whose code is 0 if [c]'s + code is 255. *) + val next_char : char -> char + + (** Increment the given slot index. Returns zero in case of overflow. *) + val succ_slot_index : Dal_slot_repr.Index.t -> Dal_slot_repr.Index.t + + (** Auxiliary test function used by both unit and PBT tests: This function + produces a proof from the given information and verifies the produced + result, if any. The result of each step is checked with + [check_produce_result] and [check_verify_result], respectively. *) + val produce_and_verify_proof : + check_produce: + ((Dal_slot_repr.History.proof * bytes option) tzresult -> + (bytes * Cryptobox.page_proof) option -> + (unit, tztrace) result Lwt.t) -> + ?check_verify: + (bytes option tzresult -> + (bytes * Cryptobox.page_proof) option -> + (unit, tztrace) result Lwt.t) -> + Dal_slot_repr.History.t -> + Dal_slot_repr.History.History_cache.t -> + page_info:(bytes * Cryptobox.page_proof) option -> + page_id:Dal_slot_repr.Page.t -> + (unit, tztrace) result Lwt.t + + (** Check if two page proofs are equal. *) + val eq_page_proof : Cryptobox.page_proof -> Cryptobox.page_proof -> bool + + (** Helper for the case where produce_proof is expected to succeed. *) + val successful_check_produce_result : + __LOC__:string -> + [`Confirmed | `Unconfirmed] -> + (Dal_slot_repr.History.proof * bytes option) tzresult -> + (bytes * 'a) option -> + (unit, tztrace) result Lwt.t + + (** Helper for the case where verify_proof is expected to succeed. *) + val successful_check_verify_result : + __LOC__:string -> + [> `Confirmed] -> + bytes option tzresult -> + (bytes * 'a) option -> + (unit, tztrace) result Lwt.t + + (** Helper for the case where produce_proof is expected to fail because the slot + is confirmed but no page information are provided. *) + val slot_confirmed_but_page_data_not_provided : + __LOC__:string -> 'a tzresult -> 'b -> unit tzresult Lwt.t + + (** Helper for the case where produce_proof is expected to fail because the slot + is not confirmed but page_info are provided. *) + val slot_not_confirmed_but_page_data_provided : + __LOC__:string -> 'a tzresult -> 'b -> unit tzresult Lwt.t + + (** Helper for the case where produce_proof is expected to fail. *) + val failing_check_produce_result : + __LOC__:string -> + dal_proof_error:string -> + 'a tzresult -> + 'b -> + unit tzresult Lwt.t +end diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_dal_slot_proof.ml b/src/proto_alpha/lib_protocol/test/pbt/test_dal_slot_proof.ml index 3af2aa4dc51a6af56e6b33e59b661280fc5698eb..34b05e7b2091329fb650f78493e29e936a84e877 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_dal_slot_proof.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_dal_slot_proof.ml @@ -32,173 +32,201 @@ *) open Protocol -open Dal_helpers - -(* Introduce some intermediate types *) - -(** The slot is not confirmed (skipped) iff the boolean is [true]. *) -type slot_skipped = bool - -type slots = slot_skipped list - -type levels = slots list - -(** Given a list of {!levels}, where each element is of type {!slots} = {!slot} - list, and where each slot is a boolean, this function populates an - empty slots_history skip list and a corresponding history_cache as follows: - - the function starts from a given [start_level] (default is 1) - - levels are incremented by 2 (to allow having levels without confirmed slots - for test purpose). - - every element in the list of levels represents the slots of a single level. - - each slot of a given level is not confirmed iff the boolean is true. *) -let populate_slots_history dal (levels_data : levels) = - let open Result_syntax in - (* Make and insert a slot. *) - let add_slot level sindex (cell, cache, slots_info) skip_slot = - let index = - Option.value_f (Dal_slot_repr.Index.of_int sindex) ~default:(fun () -> - assert false) + +module Make (Parameters : sig + val name : string + + val count : int + + val dal_parameters : Alpha_context.Constants.Parametric.dal +end) = +struct + open Dal_helpers.Make (struct + include Parameters + + let cryptobox = + WithExceptions.Result.get_ok ~loc:__LOC__ + @@ Dal_helpers.mk_cryptobox Parameters.dal_parameters.cryptobox_parameters + end) + + (* Introduce some intermediate types. *) + + (** The slot is not confirmed (skipped) iff the boolean is [true]. *) + type slot_skipped = bool + + type slots = slot_skipped list + + type levels = slots list + + (** Given a list of {!levels}, where each element is of type {!slots} = {!slot} + list, and where each slot is a boolean, this function populates an + empty slots_history skip list and a corresponding history_cache as follows: + - the function starts from a given [start_level] (default is 1) + - levels are incremented by 2 (to allow having levels without confirmed slots + for test purpose). + - every element in the list of levels represents the slots of a single level. + - each slot of a given level is not confirmed iff the boolean is true. *) + let populate_slots_history (levels_data : levels) = + let open Result_syntax in + (* Make and insert a slot. *) + let add_slot level sindex (cell, cache, slots_info) skip_slot = + let index = + Option.value_f (Dal_slot_repr.Index.of_int sindex) ~default:(fun () -> + assert false) + in + let* _data, poly, slot = mk_slot ~level ~index () in + let* cell, cache = + if skip_slot then return (cell, cache) + else + Dal_slot_repr.History.add_confirmed_slot_headers cell cache [slot] + |> Environment.wrap_tzresult + in + return (cell, cache, (poly, slot, skip_slot) :: slots_info) in - let* _data, poly, slot = mk_slot ~level ~index dal in - let* cell, cache = - if skip_slot then return (cell, cache) - else - Dal_slot_repr.History.add_confirmed_slot_headers cell cache [slot] - |> Environment.wrap_tzresult + (* Insert the slots of a level. *) + let add_slots level accu slots_data = + (* We start at level one, and we skip even levels for test purpose (which + means that no DAL slot is confirmed for them). *) + let curr_level = + Int32.of_int (1 + (2 * level)) |> Raw_level_repr.of_int32_exn + in + List.fold_left_i_e (add_slot curr_level) accu slots_data in - return (cell, cache, (poly, slot, skip_slot) :: slots_info) - in - (* Insert the slots of a level. *) - let add_slots level accu slots_data = - (* We start at level one, and we skip even levels for test purpose (which - means that no DAL slot is confirmed for them). *) - let curr_level = - Int32.of_int (1 + (2 * level)) |> Raw_level_repr.of_int32_exn + (* Insert the slots of all the levels. *) + let add_levels = List.fold_left_i_e add_slots in + add_levels (genesis_history, genesis_history_cache, []) levels_data + + (** This function returns the (correct) information of a page to + prove that it is confirmed, or None if the page's slot is skipped. *) + let request_confirmed_page (poly, slot, skip_slot) = + let open Result_syntax in + if skip_slot then + (* We cannot check that a page of an unconfirmed slot is confirmed. *) + return None + else + let* page_info, page_id = mk_page_info slot poly in + return @@ Some (page_info, page_id) + + (** This function returns information of a page to prove that it is + unconfirmed, if the page's slot is skipped, the information look correct + (but the slot is not confirmed). Otherwise, we increment the publish_level + field to simulate a non confirmed slot (as for even levels, no slot is + confirmed. See {!populate_slots_history}). *) + let request_unconfirmed_page (poly, slot, skip_slot) = + let open Result_syntax in + (* If the slot is unconfirmed, we test that a page belonging to it is not + confirmed. If the slot is confirmed, we check that the page of the + slot at the next level is unconfirmed (since we insert levels without + any confirmed slot). *) + let level = + let open Dal_slot_repr.Header in + if skip_slot then slot.id.published_level + else Raw_level_repr.succ slot.id.published_level in - List.fold_left_i_e (add_slot curr_level) accu slots_data - in - (* Insert the slots of all the levels. *) - let add_levels = List.fold_left_i_e add_slots in - add_levels (genesis_history, genesis_history_cache, []) levels_data - -(** This function returns the (correct) information of a page to - prove that it is confirmed, or None if the page's slot is skipped. *) -let request_confirmed_page dal (poly, slot, skip_slot) = - let open Result_syntax in - if skip_slot then - (* We cannot check that a page of an unconfirmed slot is confirmed. *) - return None - else - let* page_info, page_id = mk_page_info dal slot poly in - return @@ Some (page_info, page_id) - -(** This function returns information of a page to prove that it is unconfirmed, -if the page's slot is skipped, the information look correct (but the slot is not -confirmed). Otherwise, we increment the publish_level field to simulate a non -confirmed slot (as for even levels, no slot is confirmed. See -{!populate_slots_history}). *) -let request_unconfirmed_page dal (poly, slot, skip_slot) = - let open Result_syntax in - (* If the slot is unconfirmed, we test that a page belonging to it is not - confirmed. If the slot is confirmed, we check that the page of the - slot at the next level is unconfirmed (since we insert levels without - any confirmed slot). *) - let level = - let open Dal_slot_repr.Header in - if skip_slot then slot.id.published_level - else Raw_level_repr.succ slot.id.published_level - in - let* _page_info, page_id = mk_page_info ~level dal slot poly in - (* We should not provide the page's info if we want to build an - unconfirmation proof. *) - return @@ Some (None, page_id) - -(** This helper function allows to test DAL's {!produce_proof} and {!verify_proof} - functions, using the data constructed from {!populate_slots_history} above. *) -let helper_check_pbt_pages dal last_cell last_cache slots_info ~page_to_request - ~check_produce ~check_verify = - let open Lwt_result_syntax in - List.iter_es - (fun item -> - let*? mk_test = page_to_request dal item in - match mk_test with - | None -> return_unit - | Some (page_info, page_id) -> - produce_and_verify_proof - dal - last_cell - last_cache - ~page_info - ~page_id - ~check_produce - ~check_verify) - slots_info - -(** Making some confirmation pages tests for slots that are confirmed. *) -let test_confirmed_pages dal (levels_data : levels) = - let open Lwt_result_syntax in - let*? last_cell, last_cache, slots_info = - populate_slots_history dal levels_data - in - helper_check_pbt_pages - dal - last_cell - last_cache - slots_info - ~page_to_request:request_confirmed_page - ~check_produce:(successful_check_produce_result ~__LOC__ `Confirmed) - ~check_verify:(successful_check_verify_result ~__LOC__ `Confirmed) - -(** Making some unconfirmation pages tests for slots that are confirmed. *) -let test_unconfirmed_pages dal (levels_data : levels) = - let open Lwt_result_syntax in - let*? last_cell, last_cache, slots_info = - populate_slots_history dal levels_data - in - helper_check_pbt_pages - dal - last_cell - last_cache - slots_info - ~page_to_request:request_unconfirmed_page - ~check_produce:(successful_check_produce_result ~__LOC__ `Unconfirmed) - ~check_verify:(successful_check_verify_result ~__LOC__ `Unconfirmed) - -let tests = - Result.value_f - (dal_mk_env - { - Dal_slot_repr.History.redundancy_factor = 16; - page_size = 4096 / 64; - slot_size = 1048576 / 64; - number_of_shards = 2048 / 64; - }) - ~default:(fun () -> - Format.eprintf "failed to initialize Cryptobox.t" ; - assert false) - |> fun dal -> - let gen_dal_config : levels QCheck2.Gen.t = - QCheck2.Gen.( - let nb_slots = pure 20 in - let nb_levels = pure 5 in - (* The slot is confirmed iff the boolean is true *) - let slot = bool in - let slots = list_size nb_slots slot in - list_size nb_levels slots) - in - [ - Tztest.tztest_qcheck2 - ~name:"Pbt tests: confirmed pages" - ~count:10 - gen_dal_config - (test_confirmed_pages dal); - Tztest.tztest_qcheck2 - ~name:"Pbt tests: unconfirmed pages" - ~count:10 - gen_dal_config - (test_unconfirmed_pages dal); - ] + let* _page_info, page_id = mk_page_info ~level slot poly in + (* We should not provide the page's info if we want to build an + unconfirmation proof. *) + return @@ Some (None, page_id) + + (** This helper function allows to test DAL's {!produce_proof} and + {!verify_proof} functions, using the data constructed from + {!populate_slots_history} above. *) + let helper_check_pbt_pages last_cell last_cache slots_info ~page_to_request + ~check_produce ~check_verify = + let open Lwt_result_syntax in + List.iter_es + (fun item -> + let*? mk_test = page_to_request item in + match mk_test with + | None -> return_unit + | Some (page_info, page_id) -> + produce_and_verify_proof + last_cell + last_cache + ~page_info + ~page_id + ~check_produce + ~check_verify) + slots_info + + (** Making some confirmation pages tests for slots that are confirmed. *) + let test_confirmed_pages (levels_data : levels) = + let open Lwt_result_syntax in + let*? last_cell, last_cache, slots_info = + populate_slots_history levels_data + in + helper_check_pbt_pages + last_cell + last_cache + slots_info + ~page_to_request:request_confirmed_page + ~check_produce:(successful_check_produce_result ~__LOC__ `Confirmed) + ~check_verify:(successful_check_verify_result ~__LOC__ `Confirmed) + + (** Making some unconfirmation pages tests for slots that are confirmed. *) + let test_unconfirmed_pages (levels_data : levels) = + let open Lwt_result_syntax in + let*? last_cell, last_cache, slots_info = + populate_slots_history levels_data + in + helper_check_pbt_pages + last_cell + last_cache + slots_info + ~page_to_request:request_unconfirmed_page + ~check_produce:(successful_check_produce_result ~__LOC__ `Unconfirmed) + ~check_verify:(successful_check_verify_result ~__LOC__ `Unconfirmed) + + let tests = + let gen_dal_config : levels QCheck2.Gen.t = + QCheck2.Gen.( + let nb_slots = pure 20 in + let nb_levels = pure 5 in + (* The slot is confirmed iff the boolean is true *) + let slot = bool in + let slots = list_size nb_slots slot in + list_size nb_levels slots) + in + [ + Tztest.tztest_qcheck2 + ~name:"Pbt tests: confirmed pages" + ~count:Parameters.count + gen_dal_config + test_confirmed_pages; + Tztest.tztest_qcheck2 + ~name:"Pbt tests: unconfirmed pages" + ~count:Parameters.count + gen_dal_config + test_unconfirmed_pages; + ] + + let tests = + [(Format.sprintf "[%s] Dal slots refutation" Parameters.name, tests)] +end let () = - let tests = [("Dal slots refutation", tests)] in + let open Tezos_protocol_alpha_parameters.Default_parameters in + let module Sandbox = Make (struct + let name = "sandbox" + + let count = 20 + + let dal_parameters = constants_sandbox.dal + end) in + let module Test = Make (struct + let name = "test" + + let count = 10 + + let dal_parameters = constants_test.dal + end) in + let module Mainnet = Make (struct + let name = "mainnet" + + (* The tests with mainnet parameters are really really slow!! *) + let count = 2 + + let dal_parameters = constants_mainnet.dal + end) in + let tests = Sandbox.tests @ Test.tests @ Mainnet.tests in Alcotest_lwt.run "Refutation_game" tests |> Lwt_main.run diff --git a/src/proto_alpha/lib_protocol/test/unit/test_dal_slot_proof.ml b/src/proto_alpha/lib_protocol/test/unit/test_dal_slot_proof.ml index 2cf9853bc9992e5f334471d60abf5c78e18eabf8..a481d5d2d3727f27002d072fdbc33f0b7c7279fd 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_dal_slot_proof.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_dal_slot_proof.ml @@ -33,365 +33,370 @@ open Protocol module S = Dal_slot_repr +module H = S.Header module P = S.Page module Hist = S.History -open Dal_helpers - -(* Tests to check insertion of slots in a dal skip list. *) - -(** Check insertion of a new slot in the given skip list. *) -let skip_list_ordering dal skip_list ~mk_level ~mk_slot_index ~check_result = - let open Lwt_result_syntax in - let {S.Header.id; _} = Hist.Internal_for_tests.content skip_list in - let*? _data, _poly, slot = - mk_slot ~level:(mk_level id) ~index:(mk_slot_index id) dal - in - Hist.add_confirmed_slot_headers_no_cache skip_list [slot] - |> Environment.wrap_tzresult |> check_result - -(** This test attempts to add a slot on top of genesis cell zero which would - break the ordering. In fact, confirmed slots' skip list is ordered by slots - ID: the slots' level should increase or the level is equal in which case the - slots' index should increase. In the test below, we attempt to insert a slot - where (published_level, slot_index) doesn't increase (is the same as the - genesis cell). *) -let insertion_breaks_skip_list_ordering dal () = - skip_list_ordering - dal - genesis_history - ~mk_level:(fun id -> id.S.Header.published_level) - ~mk_slot_index:(fun id -> id.S.Header.index) - ~check_result:(fun res -> - Assert.proto_error ~loc:__LOC__ res (function - | Hist.Add_element_in_slots_skip_list_violates_ordering -> true - | _ -> false)) - -(** This test attempts to add a slot on top of genesis cell zero which satisfies - the ordering. *) -let correct_insertion_in_skip_list_ordering_1 dal () = - let open Lwt_result_syntax in - skip_list_ordering - dal - genesis_history - ~mk_level:(fun id -> Raw_level_repr.succ id.S.Header.published_level) - ~mk_slot_index:(fun id -> id.S.Header.index) - ~check_result:(fun res -> - let* _skip_list = Assert.get_ok ~__LOC__ res in - return_unit) - -(** This test attempts to add a slot on top of genesis cell zero which satisfies - the ordering. *) -let correct_insertion_in_skip_list_ordering_2 dal () = - let open Lwt_result_syntax in - skip_list_ordering - dal - genesis_history - ~mk_level:(fun id -> id.S.Header.published_level) - ~mk_slot_index:(fun id -> succ_slot_index id.S.Header.index) - ~check_result:(fun res -> - let* _skip_list = Assert.get_ok ~__LOC__ res in - return_unit) - -(** This test attempts to add two slots on top of genesis cell zero which satisfies - the ordering. *) -let correct_insertion_in_skip_list_ordering_3 dal () = - let open Lwt_result_syntax in - skip_list_ordering - dal - genesis_history - ~mk_level:(fun id -> id.S.Header.published_level) - ~mk_slot_index:(fun id -> succ_slot_index id.S.Header.index) - ~check_result:(fun res -> - let* skip_list = Assert.get_ok ~__LOC__ res in - skip_list_ordering - dal - skip_list - ~mk_level:(fun id -> - Raw_level_repr.(succ (succ id.S.Header.published_level))) - ~mk_slot_index:(fun id -> id.S.Header.index) - ~check_result:(fun res -> - let* _skip_list = Assert.get_ok ~__LOC__ res in - return_unit)) - -(* Tests of construct/verify proofs that confirm/unconfirm pages on top of - genesis skip list (whose unique cell is slot zero). *) - -(** This test attempts to construct a proof to confirm a slot page from the - genesis skip list. Proof production is expected to fail. *) -let confirmed_page_on_genesis dal () = - let {S.Header.id = {published_level; index}; _} = - Hist.Internal_for_tests.content genesis_history - in - let page_id = mk_page_id published_level index P.Index.zero in - produce_and_verify_proof - dal - genesis_history - genesis_history_cache - (* values of level and slot index are equal to slot zero. We would get a - page confirmation proof. But, no proof that confirms the existence of a page - in slot [zero] is possible. *) - ~page_info:None - ~page_id - ~check_produce:(slot_confirmed_but_page_data_not_provided ~__LOC__) - -(** This test attempts to construct a proof to unconfirm a slot page from the - genesis skip list. Proof production is expected to succeed. *) -let unconfirmed_page_on_genesis dal incr_level = - let {S.Header.id = {published_level; index}; _} = - Hist.Internal_for_tests.content genesis_history - in - let level, sindex = - if incr_level then (Raw_level_repr.succ published_level, index) - else (published_level, succ_slot_index index) - in - let page_id = mk_page_id level sindex P.Index.zero in - produce_and_verify_proof - dal - genesis_history - genesis_history_cache - ~page_info:None - ~page_id - ~check_produce:(successful_check_produce_result ~__LOC__ `Unconfirmed) - ~check_verify:(successful_check_verify_result ~__LOC__ `Unconfirmed) - -(* Tests of construct/verify proofs that attempt to confirm pages on top of a - (confirmed) slot added in genesis_history skip list. *) - -(** Helper function that adds a slot a top of the genesis skip list. *) -let helper_confirmed_slot_on_genesis ~level ~mk_page_info ~check_produce - ?check_verify dal = - let open Lwt_result_syntax in - let*? _slot_data, polynomial, slot = mk_slot ~level dal in - let*? skip_list, cache = - Hist.add_confirmed_slot_headers genesis_history genesis_history_cache [slot] - |> Environment.wrap_tzresult - in - let*? page_info, page_id = mk_page_info dal slot polynomial in - produce_and_verify_proof - dal - skip_list - cache - ~page_info - ~page_id - ?check_verify - ~check_produce - -(** Test where a slot is confirmed, requesting a proof for a confirmed page, - where the correct data and page proof are provided. *) -let confirmed_slot_on_genesis_confirmed_page_good_data dal () = - helper_confirmed_slot_on_genesis - dal - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info - ~check_produce:(successful_check_produce_result ~__LOC__ `Confirmed) - ~check_verify:(successful_check_verify_result ~__LOC__ `Confirmed) - -(** Test where a slot is confirmed, requesting a proof for a confirmed page, - where the page data and proof are not given. *) -let confirmed_slot_on_genesis_confirmed_page_no_data dal () = - helper_confirmed_slot_on_genesis - dal - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info:(mk_page_info ~custom_data:no_data) - ~check_produce:(slot_confirmed_but_page_data_not_provided ~__LOC__) - -(** Test where a slot is confirmed, requesting a proof for a confirmed page, - where correct data are provided, but the given page proof is wrong. *) -let confirmed_slot_on_genesis_confirmed_page_bad_page_proof dal () = - let open Result_syntax in - helper_confirmed_slot_on_genesis - dal - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info:(fun dal slot poly -> - let* page_info1, _page_id1 = mk_page_info ~page_index:1 dal slot poly in - let* page_info2, page_id2 = mk_page_info ~page_index:2 dal slot poly in - assert ( - match (page_info1, page_info2) with - | Some (_d1, p1), Some (_d2, p2) -> not (eq_page_proof p1 p2) - | _ -> false) ; - return (page_info1, page_id2)) - ~check_produce: - (failing_check_produce_result - ~__LOC__ - "Wrong page content for the given page index and slot commitment \ - (page \ - data=xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx, \ - page id=(published_level: 11, slot_index: 0, page_index: 2), \ - commitment=sh1veuXUPvxu6SWCWtN5v2erwCQVc787gZbFT5LEbixWPLdzb8gemTzAoodnoxJ5HHU2rqu9Ph).") - -(** Test where a slot is confirmed, requesting a proof for a confirmed page, - where correct page proof is provided, but given page data is altered. *) -let confirmed_slot_on_genesis_confirmed_page_bad_data_right_length dal () = - helper_confirmed_slot_on_genesis - dal - ~level:(Raw_level_repr.succ level_ten) - ~mk_page_info: - (mk_page_info - ~custom_data: - (Some - (fun ~default_char page_size -> - Some - (Bytes.init page_size (fun i -> - if i = 0 then next_char default_char else default_char))))) - ~check_produce: - (failing_check_produce_result - ~__LOC__ - "Wrong page content for the given page index and slot commitment \ - (page \ - data=yxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx, \ - page id=(published_level: 11, slot_index: 0, page_index: 0), \ - commitment=sh1veuXUPvxu6SWCWtN5v2erwCQVc787gZbFT5LEbixWPLdzb8gemTzAoodnoxJ5HHU2rqu9Ph).") - -(* Variants of the tests above: Construct/verify proofs that attempt to - unconfirm pages on top of a (confirmed) slot added in genesis_history skip - list. - - All the tests are somehow equivalent when building "Unconfirmed page" proof, - because the page's data & page's proof are ignored in this case. -*) -(** Specialisation of helper {!helper_confirmed_slot_on_genesis}, where some - parameters are fixed. *) -let helper_confirmed_slot_on_genesis_unconfirmed_page ~check_produce - ?check_verify ~page_level ~mk_page_info dal = - helper_confirmed_slot_on_genesis - dal - ~level:(Raw_level_repr.succ page_level) - ~mk_page_info - ~check_produce - ?check_verify - -(** Unconfirmation proof for a page with good data. *) -let confirmed_slot_on_genesis_unconfirmed_page_good_data dal () = - helper_confirmed_slot_on_genesis_unconfirmed_page - dal - ~page_level:level_ten - ~mk_page_info:(mk_page_info ~level:level_ten) - ~check_produce:(slot_not_confirmed_but_page_data_provided ~__LOC__) - -(** Unconfirmation proof for a page with no data. *) -let confirmed_slot_on_genesis_unconfirmed_page_no_data dal () = - helper_confirmed_slot_on_genesis_unconfirmed_page - dal - ~page_level:level_ten - ~mk_page_info:(mk_page_info ~custom_data:no_data ~level:level_ten) - ~check_produce:(successful_check_produce_result ~__LOC__ `Unconfirmed) - -(** Unconfirmation proof for a page with bad page proof. *) -let confirmed_slot_on_genesis_unconfirmed_page_bad_proof dal () = - let open Result_syntax in - let level = level_ten in - helper_confirmed_slot_on_genesis_unconfirmed_page - dal - ~page_level:level - ~mk_page_info:(fun dal slot poly -> - let* page_info1, _page_id1 = - mk_page_info ~level:level_ten ~page_index:1 dal slot poly - in - let* _page_info2, page_id2 = - mk_page_info ~level:level_ten ~page_index:2 dal slot poly - in - assert ( - match (page_info1, _page_info2) with - | Some (_d1, p1), Some (_d2, p2) -> not (eq_page_proof p1 p2) - | _ -> false) ; - return (page_info1, page_id2)) - ~check_produce:(slot_not_confirmed_but_page_data_provided ~__LOC__) - -(** Unconfirmation proof for a page with bad data. *) -let confirmed_slot_on_genesis_unconfirmed_page_bad_data dal () = - let level = level_ten in - helper_confirmed_slot_on_genesis_unconfirmed_page - dal - ~page_level:level - ~mk_page_info: - (mk_page_info - ~level:level_ten - ~custom_data: - (Some - (fun ~default_char page_size -> - Some - (Bytes.init page_size (fun i -> - if i = 0 then next_char default_char else default_char))))) - ~check_produce:(slot_not_confirmed_but_page_data_provided ~__LOC__) - -(* The list of tests. *) +module Make (Parameters : sig + val name : string + + val dal_parameters : Alpha_context.Constants.Parametric.dal +end) = +struct + open Dal_helpers.Make (struct + include Parameters + + let cryptobox = + WithExceptions.Result.get_ok ~loc:__LOC__ + @@ Dal_helpers.mk_cryptobox Parameters.dal_parameters.cryptobox_parameters + end) + + (* Tests to check insertion of slots in a dal skip list. *) + + (** Check insertion of a new slot in the given skip list. *) + let skip_list_ordering skip_list ~mk_level ~mk_slot_index ~check_result = + let open Lwt_result_syntax in + let {S.Header.id; _} = Hist.Internal_for_tests.content skip_list in + let level = mk_level id in + let index = mk_slot_index id in + let*? _data, _poly, slot = mk_slot ~level ~index () in + Hist.add_confirmed_slot_headers_no_cache skip_list [slot] + |> Environment.wrap_tzresult |> check_result + + (** This test attempts to add a slot on top of genesis cell zero which would + break the ordering. In fact, confirmed slots' skip list is ordered by slots + ID: the slots' level should increase or the level is equal in which case the + slots' index should increase. In the test below, we attempt to insert a slot + where (published_level, slot_index) doesn't increase (is the same as the + genesis cell). *) + let insertion_breaks_skip_list_ordering () = + skip_list_ordering + genesis_history + ~mk_level:(fun id -> id.H.published_level) + ~mk_slot_index:(fun id -> id.H.index) + ~check_result:(fun res -> + Assert.proto_error ~loc:__LOC__ res (function + | Hist.Add_element_in_slots_skip_list_violates_ordering -> true + | _ -> false)) + + (** This test attempts to add a slot on top of genesis cell zero which satisfies + the ordering. *) + let correct_insertion_in_skip_list_ordering_1 () = + let open Lwt_result_syntax in + skip_list_ordering + genesis_history + ~mk_level:(fun id -> Raw_level_repr.succ id.H.published_level) + ~mk_slot_index:(fun id -> id.H.index) + ~check_result:(fun res -> + let* _skip_list = Assert.get_ok ~__LOC__ res in + return_unit) + + (** This test attempts to add a slot on top of genesis cell zero which satisfies + the ordering. *) + let correct_insertion_in_skip_list_ordering_2 () = + let open Lwt_result_syntax in + skip_list_ordering + genesis_history + ~mk_level:(fun id -> id.H.published_level) + ~mk_slot_index:(fun id -> succ_slot_index id.H.index) + ~check_result:(fun res -> + let* _skip_list = Assert.get_ok ~__LOC__ res in + return_unit) + + (** This test attempts to add two slots on top of genesis cell zero which satisfies + the ordering. *) + let correct_insertion_in_skip_list_ordering_3 () = + let open Lwt_result_syntax in + skip_list_ordering + genesis_history + ~mk_level:(fun id -> id.H.published_level) + ~mk_slot_index:(fun id -> succ_slot_index id.H.index) + ~check_result:(fun res -> + let* skip_list = Assert.get_ok ~__LOC__ res in + skip_list_ordering + skip_list + ~mk_level:(fun id -> + Raw_level_repr.(succ (succ id.H.published_level))) + ~mk_slot_index:(fun id -> id.H.index) + ~check_result:(fun res -> + let* _skip_list = Assert.get_ok ~__LOC__ res in + return_unit)) + + (* Tests of construct/verify proofs that confirm/unconfirm pages on top of + genesis skip list (whose unique cell is slot zero). *) + + (** This test attempts to construct a proof to confirm a slot page from the + genesis skip list. Proof production is expected to fail. *) + let confirmed_page_on_genesis () = + let {H.id = {published_level; index}; _} = + Hist.Internal_for_tests.content genesis_history + in + let page_id = mk_page_id published_level index P.Index.zero in + produce_and_verify_proof + genesis_history + genesis_history_cache + (* values of level and slot index are equal to slot zero. We would get a + page confirmation proof. But, no proof that confirms the existence of a page + in slot [zero] is possible. *) + ~page_info:None + ~page_id + ~check_produce:(slot_confirmed_but_page_data_not_provided ~__LOC__) + + (** This test attempts to construct a proof to unconfirm a slot page from the + genesis skip list. Proof production is expected to succeed. *) + let unconfirmed_page_on_genesis incr_level = + let {H.id = {published_level; index}; _} = + Hist.Internal_for_tests.content genesis_history + in + let level, sindex = + if incr_level then (Raw_level_repr.succ published_level, index) + else (published_level, succ_slot_index index) + in + let page_id = mk_page_id level sindex P.Index.zero in + produce_and_verify_proof + genesis_history + genesis_history_cache + ~page_info:None + ~page_id + ~check_produce:(successful_check_produce_result ~__LOC__ `Unconfirmed) + ~check_verify:(successful_check_verify_result ~__LOC__ `Unconfirmed) + + (* Tests of construct/verify proofs that attempt to confirm pages on top of a + (confirmed) slot added in genesis_history skip list. *) + + (** Helper function that adds a slot a top of the genesis skip list. *) + let helper_confirmed_slot_on_genesis ~level ~mk_page_info ~check_produce + ?check_verify () = + let open Lwt_result_syntax in + let*? _slot_data, polynomial, slot = mk_slot ~level () in + let*? skip_list, cache = + Hist.add_confirmed_slot_headers + genesis_history + genesis_history_cache + [slot] + |> Environment.wrap_tzresult + in + let*? page_info, page_id = mk_page_info slot polynomial in + produce_and_verify_proof + skip_list + cache + ~page_info + ~page_id + ?check_verify + ~check_produce + + (** Test where a slot is confirmed, requesting a proof for a confirmed page, + where the correct data and page proof are provided. *) + let confirmed_slot_on_genesis_confirmed_page_good_data = + helper_confirmed_slot_on_genesis + ~level:(Raw_level_repr.succ level_ten) + ~mk_page_info + ~check_produce:(successful_check_produce_result ~__LOC__ `Confirmed) + ~check_verify:(successful_check_verify_result ~__LOC__ `Confirmed) + + (** Test where a slot is confirmed, requesting a proof for a confirmed page, + where the page data and proof are not given. *) + let confirmed_slot_on_genesis_confirmed_page_no_data = + helper_confirmed_slot_on_genesis + ~level:(Raw_level_repr.succ level_ten) + ~mk_page_info:(mk_page_info ~custom_data:no_data) + ~check_produce:(slot_confirmed_but_page_data_not_provided ~__LOC__) + + (** Test where a slot is confirmed, requesting a proof for a confirmed page, + where correct data are provided, but the given page proof is wrong. *) + let confirmed_slot_on_genesis_confirmed_page_bad_page_proof = + let open Result_syntax in + helper_confirmed_slot_on_genesis + ~level:(Raw_level_repr.succ level_ten) + ~mk_page_info:(fun slot poly -> + let* page_info1, _page_id1 = mk_page_info ~page_index:1 slot poly in + let* page_info2, page_id2 = mk_page_info ~page_index:2 slot poly in + assert ( + match (page_info1, page_info2) with + | Some (_d1, p1), Some (_d2, p2) -> not (eq_page_proof p1 p2) + | _ -> false) ; + return (page_info1, page_id2)) + ~check_produce: + (failing_check_produce_result + ~__LOC__ + ~dal_proof_error: + "Wrong page content for the given page index and slot commitment \ + (page id=(published_level: 11, slot_index: 0, page_index: 2)).") + + (** Test where a slot is confirmed, requesting a proof for a confirmed page, + where correct page proof is provided, but given page data is altered. *) + let confirmed_slot_on_genesis_confirmed_page_bad_data_right_length = + helper_confirmed_slot_on_genesis + ~level:(Raw_level_repr.succ level_ten) + ~mk_page_info: + (mk_page_info + ~custom_data: + (Some + (fun ~default_char page_size -> + Some + (Bytes.init page_size (fun i -> + if i = 0 then next_char default_char else default_char))))) + ~check_produce: + (failing_check_produce_result + ~__LOC__ + ~dal_proof_error: + "Wrong page content for the given page index and slot commitment \ + (page id=(published_level: 11, slot_index: 0, page_index: 0)).") + + (* Variants of the tests above: Construct/verify proofs that attempt to + unconfirm pages on top of a (confirmed) slot added in genesis_history skip + list. + + All the tests are somehow equivalent when building "Unconfirmed page" proof, + because the page's data & page's proof are ignored in this case. + *) + + (** Specialisation of helper {!helper_confirmed_slot_on_genesis}, where some + parameters are fixed. *) + let helper_confirmed_slot_on_genesis_unconfirmed_page ~check_produce + ?check_verify ~page_level ~mk_page_info = + helper_confirmed_slot_on_genesis + ~level:(Raw_level_repr.succ page_level) + ~mk_page_info + ~check_produce + ?check_verify + + (** Unconfirmation proof for a page with good data. *) + let confirmed_slot_on_genesis_unconfirmed_page_good_data = + helper_confirmed_slot_on_genesis_unconfirmed_page + ~page_level:level_ten + ~mk_page_info:(mk_page_info ~level:level_ten) + ~check_produce:(slot_not_confirmed_but_page_data_provided ~__LOC__) + + (** Unconfirmation proof for a page with no data. *) + let confirmed_slot_on_genesis_unconfirmed_page_no_data = + helper_confirmed_slot_on_genesis_unconfirmed_page + ~page_level:level_ten + ~mk_page_info:(mk_page_info ~custom_data:no_data ~level:level_ten) + ~check_produce:(successful_check_produce_result ~__LOC__ `Unconfirmed) + + (** Unconfirmation proof for a page with bad page proof. *) + let confirmed_slot_on_genesis_unconfirmed_page_bad_proof = + let open Result_syntax in + let level = level_ten in + helper_confirmed_slot_on_genesis_unconfirmed_page + ~page_level:level + ~mk_page_info:(fun slot poly -> + let* page_info1, _page_id1 = + mk_page_info ~level:level_ten ~page_index:1 slot poly + in + let* _page_info2, page_id2 = + mk_page_info ~level:level_ten ~page_index:2 slot poly + in + assert ( + match (page_info1, _page_info2) with + | Some (_d1, p1), Some (_d2, p2) -> not (eq_page_proof p1 p2) + | _ -> false) ; + return (page_info1, page_id2)) + ~check_produce:(slot_not_confirmed_but_page_data_provided ~__LOC__) + + (** Unconfirmation proof for a page with bad data. *) + let confirmed_slot_on_genesis_unconfirmed_page_bad_data = + let level = level_ten in + helper_confirmed_slot_on_genesis_unconfirmed_page + ~page_level:level + ~mk_page_info: + (mk_page_info + ~level:level_ten + ~custom_data: + (Some + (fun ~default_char page_size -> + Some + (Bytes.init page_size (fun i -> + if i = 0 then next_char default_char else default_char))))) + ~check_produce:(slot_not_confirmed_but_page_data_provided ~__LOC__) + + (* The list of tests. *) + let tests = + let mk_title = Format.sprintf "[%s] %s" Parameters.name in + let tztest title test_function = + Tztest.tztest (mk_title title) `Quick test_function + in + let qcheck2 title gen test = + Tztest.tztest_qcheck2 ~name:(mk_title title) ~count:1 gen test + in + let bool = QCheck2.Gen.bool in + let ordering_tests = + [ + tztest + "add a slot on top of genesis that breaks ordering" + insertion_breaks_skip_list_ordering; + tztest + "add a slot on top of genesis that satisfies ordering (1/2)" + correct_insertion_in_skip_list_ordering_1; + tztest + "add a slot on top of genesis that satisfies ordering (2/2)" + correct_insertion_in_skip_list_ordering_2; + tztest + "add two slots on top of genesis that satisfy ordering" + correct_insertion_in_skip_list_ordering_3; + ] + in + let proofs_tests_on_genesis = + [ + tztest "Confirmed page on genesis" confirmed_page_on_genesis; + qcheck2 "Unconfirmed page on genesis" bool unconfirmed_page_on_genesis; + ] + in + + let confirmed_slot_on_genesis_confirmed_page_tests = + [ + tztest + "Confirmed slot on top of genesis: confirmed page with good data" + confirmed_slot_on_genesis_confirmed_page_good_data; + tztest + "Confirmed slot on top of genesis: confirmed page with no data" + confirmed_slot_on_genesis_confirmed_page_no_data; + tztest + "Confirmed slot on top of genesis: confirmed page with bad proof" + confirmed_slot_on_genesis_confirmed_page_bad_page_proof; + tztest + "Confirmed slot on top of genesis: confirmed page with bad data " + confirmed_slot_on_genesis_confirmed_page_bad_data_right_length; + ] + in + let confirmed_slot_on_genesis_unconfirmed_page_tests = + [ + tztest + "Confirmed slot on top of genesis: unconfirmed page with good data" + confirmed_slot_on_genesis_unconfirmed_page_good_data; + tztest + "Confirmed slot on top of genesis: unconfirmed page with no data" + confirmed_slot_on_genesis_unconfirmed_page_no_data; + tztest + "Confirmed slot on top of genesis: unconfirmed page with bad proof" + confirmed_slot_on_genesis_unconfirmed_page_bad_proof; + tztest + "Confirmed slot on top of genesis: unconfirmed page with bad data \ + (altered)" + confirmed_slot_on_genesis_unconfirmed_page_bad_data; + ] + in + ordering_tests @ proofs_tests_on_genesis + @ confirmed_slot_on_genesis_confirmed_page_tests + @ confirmed_slot_on_genesis_unconfirmed_page_tests +end + let tests = - Result.value_f - (dal_mk_env - { - Hist.redundancy_factor = 16; - page_size = 4096 / 64; - slot_size = 1048576 / 64; - number_of_shards = 2048 / 64; - }) - ~default:(fun () -> - Format.eprintf "failed to initialize Cryptobox.t" ; - assert false) - |> fun dal -> - let tztest title test_function = - Tztest.tztest title `Quick (test_function dal) - in - let qcheck2 name gen test = - Tztest.tztest_qcheck2 ~name ~count:1 gen (test dal) - in - let bool = QCheck2.Gen.bool in - let ordering_tests = - [ - tztest - "add a slot on top of genesis that breaks ordering" - insertion_breaks_skip_list_ordering; - tztest - "add a slot on top of genesis that satisfies ordering (1/2)" - correct_insertion_in_skip_list_ordering_1; - tztest - "add a slot on top of genesis that satisfies ordering (2/2)" - correct_insertion_in_skip_list_ordering_2; - tztest - "add two slots on top of genesis that satisfy ordering" - correct_insertion_in_skip_list_ordering_3; - ] - in - let proofs_tests_on_genesis = - [ - tztest "Confirmed page on genesis" confirmed_page_on_genesis; - qcheck2 "Unconfirmed page on genesis" bool unconfirmed_page_on_genesis; - ] - in - - let confirmed_slot_on_genesis_confirmed_page_tests = - [ - tztest - "Confirmed slot on top of genesis: confirmed page with good data" - confirmed_slot_on_genesis_confirmed_page_good_data; - tztest - "Confirmed slot on top of genesis: confirmed page with no data" - confirmed_slot_on_genesis_confirmed_page_no_data; - tztest - "Confirmed slot on top of genesis: confirmed page with bad proof" - confirmed_slot_on_genesis_confirmed_page_bad_page_proof; - tztest - "Confirmed slot on top of genesis: confirmed page with bad data " - confirmed_slot_on_genesis_confirmed_page_bad_data_right_length; - ] - in - let confirmed_slot_on_genesis_unconfirmed_page_tests = - [ - tztest - "Confirmed slot on top of genesis: unconfirmed page with good data" - confirmed_slot_on_genesis_unconfirmed_page_good_data; - tztest - "Confirmed slot on top of genesis: unconfirmed page with no data" - confirmed_slot_on_genesis_unconfirmed_page_no_data; - tztest - "Confirmed slot on top of genesis: unconfirmed page with bad proof" - confirmed_slot_on_genesis_unconfirmed_page_bad_proof; - tztest - "Confirmed slot on top of genesis: unconfirmed page with bad data \ - (altered)" - confirmed_slot_on_genesis_unconfirmed_page_bad_data; - ] - in - ordering_tests @ proofs_tests_on_genesis - @ confirmed_slot_on_genesis_confirmed_page_tests - @ confirmed_slot_on_genesis_unconfirmed_page_tests + let open Tezos_protocol_alpha_parameters.Default_parameters in + let module Test = Make (struct + let name = "test" + + let dal_parameters = constants_test.dal + end) in + let module Sandbox = Make (struct + let name = "sandbox" + + let dal_parameters = constants_sandbox.dal + end) in + let module Mainnet = Make (struct + let name = "mainnet" + + let dal_parameters = constants_mainnet.dal + end) in + Sandbox.tests @ Test.tests @ Mainnet.tests