diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 9bc93ba4fbd60da1fd40325e9a439dec16ff33a3..647d189f236bb6c13181781add002704d0ffe6d2 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -183,7 +183,17 @@ module First_level_of_protocol = struct end module Ratio = Ratio_repr -module Raw_level = Raw_level_repr + +module Raw_level = struct + include Raw_level_repr + + module Internal_for_tests = struct + let add = add + + let sub = sub + end +end + module Cycle = Cycle_repr module Fees = Fees_storage diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 23953c79d48f760d41cc63d2772b11ad86e3932b..4014a7a24ee5eff4f9163991836772f036a3566b 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -244,6 +244,12 @@ module Raw_level : sig module Set : Set.S with type elt = raw_level module Map : Map.S with type key = raw_level + + module Internal_for_tests : sig + val add : raw_level -> int -> raw_level + + val sub : raw_level -> int -> raw_level option + end end (** This module re-exports definitions from {!Cycle_repr}. *) @@ -3251,6 +3257,8 @@ module Sc_rollup : sig val pp_inbox_message : Format.formatter -> inbox_message -> unit + val inbox_message_equal : inbox_message -> inbox_message -> bool + val pp_reveal_data : Format.formatter -> reveal_data -> unit val pp_input : Format.formatter -> input -> unit @@ -3380,8 +3388,8 @@ module Sc_rollup : sig val produce_inclusion_proof : History.t -> history_proof -> - history_proof -> - inclusion_proof option tzresult + Raw_level.t -> + (inclusion_proof * history_proof) tzresult val serialized_proof_of_string : string -> serialized_proof end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml index bc8175a7f942f32afbef8f0d302dd415778f0d96..12867a7bffdd5461022eadf8ecfa04927d357fd4 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -530,13 +530,6 @@ let pp_inclusion_proof fmt proof = let number_of_proof_steps proof = List.length proof -let lift_ptr_path deref ptr_path = - let rec aux accu = function - | [] -> Some (List.rev accu) - | x :: xs -> Option.bind (deref x) @@ fun c -> aux (c :: accu) xs - in - aux [] ptr_path - (* See the main docstring for this type (in the mli file) for definitions of the three proof parameters [starting_point], [message] and [snapshot]. In the below we deconstruct @@ -760,6 +753,27 @@ let verify_inclusion_proof inclusion_proof snapshot_history_proof = in return target +let produce_inclusion_proof history inbox_snapshot l = + let open Result_syntax in + let deref ptr = History.find ptr history in + let compare {hash = _; level} = Raw_level_repr.compare level l in + let result = Skip_list.search ~deref ~compare ~cell:inbox_snapshot in + match result with + | Skip_list.{rev_path; last_cell = Found history_proof} -> + return (List.rev rev_path, history_proof) + | {last_cell = Nearest _; _} + | {last_cell = No_exact_or_lower_ptr; _} + | {last_cell = Deref_returned_none; _} -> + (* We are only interested in the result where [search] returns a path to + the cell we were looking for. All the other cases should be + considered as an error. *) + tzfail + @@ Inbox_proof_error + (Format.asprintf + "Skip_list.search failed to find a valid path: %a" + (Skip_list.pp_search_result ~pp_cell:pp_history_proof) + result) + let verify_proof (l, n) inbox_snapshot {inclusion_proof; message_proof} = assert (Z.(geq n zero)) ; let open Result_syntax in @@ -782,25 +796,8 @@ let verify_proof (l, n) inbox_snapshot {inclusion_proof; message_proof} = let produce_proof ~get_level_tree_history history inbox_snapshot (l, n) = let open Lwt_result_syntax in - let deref ptr = History.find ptr history in - let compare {hash = _; level} = Raw_level_repr.compare level l in - let result = Skip_list.search ~deref ~compare ~cell:inbox_snapshot in - let* inclusion_proof, history_proof = - match result with - | Skip_list.{rev_path; last_cell = Found history_proof} -> - return (List.rev rev_path, history_proof) - | {last_cell = Nearest _; _} - | {last_cell = No_exact_or_lower_ptr; _} - | {last_cell = Deref_returned_none; _} -> - (* We are only interested in the result where [search] returns a path to - the cell we were looking for. All the other cases should be - considered as an error. *) - tzfail - @@ Inbox_proof_error - (Format.asprintf - "Skip_list.search failed to find a valid path: %a" - (Skip_list.pp_search_result ~pp_cell:pp_history_proof) - result) + let*? inclusion_proof, history_proof = + produce_inclusion_proof history inbox_snapshot l in let level_proof = Skip_list.content history_proof in let* ({payload; proof = _} as message_proof) = @@ -851,17 +848,13 @@ let empty level = module Internal_for_tests = struct let eq_tree = Sc_rollup_inbox_merkelized_payload_hashes_repr.equal - let produce_inclusion_proof history a b = - let open Result_syntax in - let cell_ptr = hash_history_proof b in - let target_index = Skip_list.index a in - let* history = History.remember cell_ptr b history in - let deref ptr = History.find ptr history in - Skip_list.back_path ~deref ~cell_ptr ~target_index - |> Option.map (lift_ptr_path deref) - |> Option.join |> return + let produce_inclusion_proof = produce_inclusion_proof let serialized_proof_of_string x = x + + let get_level_of_history_proof (history_proof : history_proof) = + let ({level; _} : level_proof) = Skip_list.content history_proof in + level end type inbox = t diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli index b6cb7c9b347b44e31ecd50a6c4297287bc43af58..33cf6ba506ae1cd391d5ccc57e74e02179460b60 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli @@ -365,12 +365,14 @@ module Internal_for_tests : sig val produce_inclusion_proof : History.t -> history_proof -> - history_proof -> - inclusion_proof option tzresult + Raw_level_repr.t -> + (inclusion_proof * history_proof) tzresult (** Allows to create a dumb {!serialized_proof} from a string, instead of serializing a proof with {!to_serialized_proof}. *) val serialized_proof_of_string : string -> serialized_proof + + val get_level_of_history_proof : history_proof -> Raw_level_repr.t end type inbox = t diff --git a/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml index d562124bb1cca9b49c88e8c1e091e3103acdec02..b16a11b05dc6b2a3f92a8e1666c0f29affc08818 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/sc_rollup_helpers.ml @@ -260,24 +260,6 @@ let pp_message fmt {input; message} = | `Message msg -> msg | `EOL -> "EOL") -(** An empty inbox level is a SOL and EOL. *) -let make_empty_level (timestamp, predecessor) inbox_level = - let sol = {input = make_sol ~inbox_level; message = `SOL} in - let info_per_level = - { - input = make_info_per_level ~inbox_level ~predecessor ~timestamp; - message = `Info_per_level (timestamp, predecessor); - } - in - - let eol = - { - input = make_eol ~inbox_level ~message_counter:(Z.of_int 2); - message = `EOL; - } - in - (inbox_level, [sol; info_per_level; eol]) - (** Creates inputs based on string messages. *) let strs_to_inputs inbox_level messages = List.fold_left @@ -287,8 +269,10 @@ let strs_to_inputs inbox_level messages = ([], Z.of_int 2) messages -(** Transform messages into inputs and wrap them between SOL and EOL. *) -let wrap_messages (timestamp, predecessor) inbox_level strs = +(** Transform messages into inputs and wrap them between [SOL; info_per_level] + and EOL. *) +let wrap_messages ?(timestamp = Timestamp.of_seconds 0L) + ?(predecessor = Tezos_crypto.Block_hash.zero) inbox_level strs = let sol = {input = make_sol ~inbox_level; message = `SOL} in let rev_inputs, message_counter = strs_to_inputs inbox_level strs in let inputs = List.rev rev_inputs in @@ -301,9 +285,12 @@ let wrap_messages (timestamp, predecessor) inbox_level strs = let eol = {input = make_eol ~inbox_level ~message_counter; message = `EOL} in (sol :: info_per_level :: inputs) @ [eol] +(** An empty inbox level is a SOL, info_per_level and EOL. *) +let make_empty_level ?timestamp ?predecessor inbox_level = + wrap_messages ?timestamp ?predecessor inbox_level [] + let gen_messages_for_levels ~start_level ~max_level gen_message = let open QCheck2.Gen in - let dumb_info = (Timestamp.of_seconds 0L, Tezos_crypto.Block_hash.zero) in let rec aux acc n = match n with | n when n < 0 -> @@ -316,14 +303,14 @@ let gen_messages_for_levels ~start_level ~max_level gen_message = in let* empty_level = bool in let* level_messages = - if empty_level then return (make_empty_level dumb_info inbox_level) + if empty_level then return (make_empty_level inbox_level) else let* messages = let* input = gen_message in let* inputs = small_list gen_message in return (input :: inputs) in - return (inbox_level, wrap_messages dumb_info inbox_level messages) + return (wrap_messages inbox_level messages) in aux (level_messages :: acc) (n - 1) in @@ -463,6 +450,9 @@ let gen_message_reprs_for_levels_repr ~start_level ~max_level gen_message_repr = module Level_tree_histories = Map.Make (Sc_rollup.Inbox_merkelized_payload_hashes.Hash) +type level_tree_histories = + Sc_rollup.Inbox_merkelized_payload_hashes.History.t Level_tree_histories.t + let get_level_tree_history level_tree_histories level_tree_hash = Level_tree_histories.find level_tree_hash level_tree_histories |> WithExceptions.Option.get ~loc:__LOC__ @@ -475,13 +465,13 @@ let get_level_tree_history level_tree_histories level_tree_hash = test/unit/test_sc_rollup_inbox. The main difference is: we use [Alpha_context.Sc_rollup.Inbox] instead of [Sc_rollup_repr_inbox] in the former. *) -let construct_inbox ~inbox ?origination_level levels_and_inputs = +let fill_inbox ~inbox ~shift_level ?origination_level + ?(with_level_tree_history = true) history level_tree_histories inputs = let open Result_syntax in - let history = Sc_rollup.Inbox.History.empty ~capacity:10000L in - let level_tree_histories = Level_tree_histories.empty in - let rec aux level_tree_histories history inbox = function + let rec aux i level_tree_histories history inbox = function | [] -> return (level_tree_histories, history, inbox) - | ((level, inputs) : Raw_level.t * Sc_rollup.input list) :: rst -> + | (inputs : Sc_rollup.input list) :: rst -> + let level = Raw_level.Internal_for_tests.add shift_level i in assert ( match origination_level with | Some origination_level -> Raw_level.(origination_level < level) @@ -494,8 +484,11 @@ let construct_inbox ~inbox ?origination_level levels_and_inputs = inputs in let level_tree_history = - Sc_rollup.Inbox_merkelized_payload_hashes.History.empty - ~capacity:1000L + let capacity = + if with_level_tree_history then Int64.of_int @@ List.length payloads + else 0L + in + Sc_rollup.Inbox_merkelized_payload_hashes.History.empty ~capacity in let* level_tree_history, level_tree, history, inbox = Sc_rollup.Inbox.add_messages @@ -516,6 +509,56 @@ let construct_inbox ~inbox ?origination_level levels_and_inputs = level_tree_history level_tree_histories in - aux level_tree_histories history inbox rst + aux (i + 1) level_tree_histories history inbox rst + in + aux 0 level_tree_histories history inbox inputs + +let construct_inbox ?(inbox_creation_level = Raw_level.(root)) + ?origination_level ?(with_histories = true) level_and_inputs = + let inbox = Sc_rollup.Inbox.empty inbox_creation_level in + let history = + let capacity = if with_histories then 10000L else 0L in + Sc_rollup.Inbox.History.empty ~capacity + in + let level_tree_histories = Level_tree_histories.empty in + fill_inbox + ?origination_level + ~inbox + ~with_level_tree_history:with_histories + ~shift_level:inbox_creation_level + history + level_tree_histories + level_and_inputs + +let inbox_message_of_input input = + match input with Sc_rollup.Inbox_message x -> Some x | _ -> None + +let payloads_from_messages = + List.map (fun {input; _} -> + match input with + | Inbox_message {payload; _} -> payload + | Reveal _ -> assert false) + +let first_after ~shift_level list_of_inputs level message_counter = + let level_index = Int32.to_int @@ Raw_level.diff level shift_level in + let inputs = + WithExceptions.Option.get ~loc:__LOC__ + @@ List.nth list_of_inputs level_index in - aux level_tree_histories history inbox levels_and_inputs + match List.nth inputs (Z.to_int message_counter) with + | Some input -> inbox_message_of_input input + | None -> ( + (* If no input at (l, n), the next input is (l+1, 0). *) + match List.nth list_of_inputs (level_index + 1) with + | None -> None + | Some inputs -> + let input = Stdlib.List.hd inputs in + inbox_message_of_input input) + +let list_of_inputs_from_list_of_messages (list_of_messages : message list list) + = + List.map + (fun inputs -> + let payloads = List.map (fun {input; _} -> input) inputs in + payloads) + list_of_messages diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index e7b675475fad52daf97daa2ae0bc8dbd26204ad0..6df28f288c4156894acb98ccdc0647a8b4ce5586 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -2045,22 +2045,18 @@ let full_history_inbox all_inbox_messages = (* Add the SOL/Info_per_level/EOL to the list of inbox messages. *) let all_inbox_messages = List.map - (fun (inbox_level, info, inbox_messages) -> - (inbox_level, wrap_messages info inbox_level inbox_messages)) + (fun (inbox_level, (timestamp, predecessor), inbox_messages) -> + wrap_messages ~timestamp ~predecessor inbox_level inbox_messages) all_inbox_messages in (* Create a inbox adding the messages from [all_inbox_messages]. *) let all_inbox_inputs = List.map - (fun (level, messages) -> - ( level, - List.map - (fun Sc_rollup_helpers.{input; message = _} -> input) - messages )) + (fun messages -> + List.map (fun Sc_rollup_helpers.{input; message = _} -> input) messages) all_inbox_messages in - let inbox = Sc_rollup.Inbox.empty Raw_level.root in - Sc_rollup_helpers.construct_inbox ~inbox all_inbox_inputs + Sc_rollup_helpers.construct_inbox all_inbox_inputs let input_included ~snapshot ~full_history_inbox (l, n) = let open Sc_rollup_helpers in @@ -2390,7 +2386,7 @@ let test_curfew_is_clean () = | None -> return_unit (** [test_curfew_period_is_started_only_after_first_publication checks that - publishing the first commitment of a given [inbox_level] after + publishing the first commitment of a given [inbox_level] after [inbox_level + challenge_window] is still possible. *) let test_curfew_period_is_started_only_after_first_publication () = let open Lwt_result_syntax in diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml index 570b0f95cc8baf89db88901488bbc4782d1c882f..3de5ac7fc7575d9dfe0d386c837115825b0f43c1 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml @@ -106,10 +106,6 @@ let assert_fails_with ~__LOC__ (res : unit Environment.Error_monad.tzresult) trace | Ok () -> Lwt.return false -let keep_inputs = - List.map (fun (level, messages) -> - (level, List.map (fun (x : message) -> x.input) messages)) - let initial_of_dissection dissection = List.hd dissection |> WithExceptions.Option.get ~loc:__LOC__ @@ -883,7 +879,7 @@ module Arith_test_pvm = struct (state, fuel, tick, []) messages - let eval_levels_and_inputs ~metadata ?fuel levels_and_inputs = + let eval_inputs ~metadata ?fuel list_of_inputs = let open Lwt_result_syntax in let*! state = initial_state () in let*! state_hash = state_hash state in @@ -901,13 +897,13 @@ module Arith_test_pvm = struct (* 3. We evaluate the inbox. *) let* state, _fuel, tick, our_states = List.fold_left_es - (fun (state, fuel, tick, our_states) (_level, messages) -> + (fun (state, fuel, tick, our_states) messages -> let* state, fuel, tick, our_states' = eval_inbox ?fuel ~messages ~tick state in return (state, fuel, tick, our_states @ our_states')) (state, fuel, tick, our_states) - levels_and_inputs + list_of_inputs in let our_states = List.sort (fun (x, _) (y, _) -> Compare.Int.compare x y) our_states @@ -921,11 +917,11 @@ module Arith_test_pvm = struct return (state, tick, our_states) end -let construct_inbox_proto block levels_and_messages contract = +let construct_inbox_proto block list_of_messages contract = let open Lwt_result_syntax in let* block, infos_per_level = List.fold_left_es - (fun ((block : Block.t), acc) (inbox_level, (messages : message list)) -> + (fun ((block : Block.t), acc) (messages : message list) -> (* Print infos: *) let messages = List.filter_map @@ -953,19 +949,19 @@ let construct_inbox_proto block levels_and_messages contract = let* ctxt = Context.(to_alpha_ctxt (B block)) in let timestamp = Timestamp.current ctxt in - let acc = (inbox_level, (timestamp, predecessor)) :: acc in + let acc = (timestamp, predecessor) :: acc in return (block, acc)) (block, []) - levels_and_messages + list_of_messages in return (block, List.rev infos_per_level) (** Construct the inbox for the protocol side. *) -let construct_inbox_proto block levels_and_messages contract = +let construct_inbox_proto block list_of_messages contract = WithExceptions.Result.get_ok ~loc:__LOC__ @@ Lwt_main.run - @@ construct_inbox_proto block levels_and_messages contract + @@ construct_inbox_proto block list_of_messages contract (** Kind of strategy a player can play @@ -1021,33 +1017,27 @@ type player_client = { Sc_rollup_helpers.Level_tree_histories.t * Inbox.History.t * Inbox.t; - levels_and_inputs : (Raw_level.t * input list) list; + list_of_inputs : input list list; metadata : Metadata.t; context : Tezos_context_memory.Context.t; } -let pp_levels_and_inputs ~verbose ppf levels_and_inputs = +let pp_list_of_inputs ~verbose ppf list_of_inputs = let open Format in if verbose then (pp_print_list - (fun ppf (level, messages) -> - fprintf - ppf - "level %a, inputs: %a" - Raw_level.pp - level - (pp_print_list pp_input) - messages) + (fun ppf messages -> + fprintf ppf "inputs: %a" (pp_print_list pp_input) messages) ppf) - levels_and_inputs + list_of_inputs else fprintf ppf "%d inputs" (List.fold_left - (fun acc (_, messages) -> acc + List.length messages) + (fun acc messages -> acc + List.length messages) 0 - levels_and_inputs) + list_of_inputs) let pp_player_client ~verbose ppf { @@ -1055,7 +1045,7 @@ let pp_player_client ~verbose ppf states = _; final_tick; inbox = _; - levels_and_inputs; + list_of_inputs; metadata = _; context = _; } = @@ -1066,8 +1056,8 @@ let pp_player_client ~verbose ppf player Tick.pp final_tick - (pp_levels_and_inputs ~verbose) - levels_and_inputs + (pp_list_of_inputs ~verbose) + list_of_inputs module Player_client = struct let empty_memory_ctxt id = @@ -1076,169 +1066,167 @@ module Player_client = struct @@ let+ index = Tezos_context_memory.Context.init id in Tezos_context_memory.Context.empty index - (** Construct an inbox based on [levels_and_messages] in the player context. *) - let construct_inbox ~inbox ~origination_level levels_and_messages = + (** Construct an inbox based on [list_of_messages] in the player context. *) + let construct_inbox ~inbox ~origination_level list_of_messages = + let history = Sc_rollup.Inbox.History.empty ~capacity:10000L in + let level_tree_histories = Level_tree_histories.empty in WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Sc_rollup_helpers.construct_inbox + @@ Sc_rollup_helpers.fill_inbox ~inbox ~origination_level - levels_and_messages + ~shift_level:(Raw_level.of_int32_exn 2l) + history + level_tree_histories + list_of_messages - (** Generate [our_states] for [levels_and_inputs] based on the strategy. + (** Generate [our_states] for [list_of_inputs] based on the strategy. It needs [start_level] and [max_level] in case it will need to generate new inputs. *) - let gen_our_states ~metadata strategy ~start_level ~max_level - levels_and_inputs = + let gen_our_states ~metadata strategy ~start_level ~max_level list_of_inputs = let open QCheck2.Gen in - let eval_inputs (levels_and_inputs : (Raw_level.t * input trace) trace) = + let eval_inputs (list_of_inputs : input trace trace) = Lwt_main.run @@ let open Lwt_result_syntax in - let*! r = - Arith_test_pvm.eval_levels_and_inputs ~metadata levels_and_inputs - in + let*! r = Arith_test_pvm.eval_inputs ~metadata list_of_inputs in Lwt.return @@ WithExceptions.Result.get_ok ~loc:__LOC__ r in match strategy with | Perfect -> (* The perfect player does not lie, evaluates correctly the inputs. *) - let _state, tick, our_states = eval_inputs levels_and_inputs in - return (tick, our_states, levels_and_inputs) + let _state, tick, our_states = eval_inputs list_of_inputs in + return (tick, our_states, list_of_inputs) | Random -> (* Random player generates its own list of inputs. *) - let* new_levels_and_messages = + let* new_messages = gen_arith_pvm_messages_for_levels ~start_level ~max_level in - let new_levels_and_inputs = keep_inputs new_levels_and_messages in - let _state, tick, our_states = eval_inputs new_levels_and_inputs in - return (tick, our_states, new_levels_and_inputs) + let new_inputs = list_of_inputs_from_list_of_messages new_messages in + let _state, tick, our_states = eval_inputs new_inputs in + return (tick, our_states, new_inputs) | Lazy -> - (* Lazy player removes inputs from [levels_and_inputs]. *) - let n = List.length levels_and_inputs in + (* Lazy player removes inputs from [list_of_inputs]. *) + let n = List.length list_of_inputs in let* remove_k = 1 -- n in - let new_levels_and_inputs = - List.take_n (n - remove_k) levels_and_inputs - in - let _state, tick, our_states = eval_inputs new_levels_and_inputs in - return (tick, our_states, new_levels_and_inputs) + let new_inputs = List.take_n (n - remove_k) list_of_inputs in + let _state, tick, our_states = eval_inputs new_inputs in + return (tick, our_states, new_inputs) | Eager -> (* Eager player executes correctly the inbox until a certain point. *) let nb_of_input = List.fold_left - (fun acc (_level, inputs) -> acc + List.length inputs) + (fun acc inputs -> acc + List.length inputs) 0 - levels_and_inputs + list_of_inputs in let* corrupt_at_k = 0 -- (nb_of_input - 1) in let message = "42 7 +" in (* Once an input is corrupted, everything after will be corrupted as well. *) - let new_levels_and_inputs = + let new_inputs = let idx = ref (-1) in List.map - (fun (inbox_level, inputs) -> - ( inbox_level, - List.map - (fun input -> - incr idx ; - if !idx = corrupt_at_k then - match input with - | Sc_rollup.Inbox_message - {inbox_level; message_counter; _} -> - make_external_input - ~inbox_level - ~message_counter - message - | _ -> (* We don't produce any reveals. *) assert false - else input) - inputs )) - levels_and_inputs + (fun inputs -> + List.map + (fun input -> + incr idx ; + if !idx = corrupt_at_k then + match input with + | Sc_rollup.Inbox_message {inbox_level; message_counter; _} + -> + make_external_input + ~inbox_level + ~message_counter + message + | _ -> (* We don't produce any reveals. *) assert false + else input) + inputs) + list_of_inputs in - let _state, tick, our_states = eval_inputs new_levels_and_inputs in - return (tick, our_states, new_levels_and_inputs) + let _state, tick, our_states = eval_inputs new_inputs in + return (tick, our_states, new_inputs) | Keen -> (* Keen player will add more inputs. *) let* offset = 1 -- 5 in - let* new_levels_and_messages = + let* new_messages = gen_arith_pvm_messages_for_levels ~start_level:max_level ~max_level:(max_level + offset) in - let new_levels_and_inputs = keep_inputs new_levels_and_messages in - let new_levels_and_inputs = levels_and_inputs @ new_levels_and_inputs in - let _state, tick, our_states = eval_inputs new_levels_and_inputs in - return (tick, our_states, new_levels_and_inputs) + let new_inputs = list_of_inputs_from_list_of_messages new_messages in + let new_inputs = list_of_inputs @ new_inputs in + let _state, tick, our_states = eval_inputs new_inputs in + return (tick, our_states, new_inputs) | SOL_hater -> - let new_levels_and_inputs = - List.map - (fun (level, inputs) -> (level, Stdlib.List.tl inputs)) - levels_and_inputs + let new_inputs = + List.map (fun inputs -> Stdlib.List.tl inputs) list_of_inputs in - let _state, tick, our_states = eval_inputs new_levels_and_inputs in - return (tick, our_states, new_levels_and_inputs) + let _state, tick, our_states = eval_inputs new_inputs in + return (tick, our_states, new_inputs) | EOL_hater -> - let new_levels_and_inputs = + let new_inputs = List.map - (fun (level, inputs) -> + (fun inputs -> let rev_inputs = List.rev inputs in let without_eol = Stdlib.List.tl rev_inputs in - (level, List.rev without_eol)) - levels_and_inputs + List.rev without_eol) + list_of_inputs in - let _state, tick, our_states = eval_inputs new_levels_and_inputs in - return (tick, our_states, new_levels_and_inputs) + let _state, tick, our_states = eval_inputs new_inputs in + return (tick, our_states, new_inputs) | Info_hater -> - let* corrupt_at_l = 0 -- List.length levels_and_inputs in + let* corrupt_at_l = 0 -- List.length list_of_inputs in let dumb_timestamp = Time_repr.of_seconds 42L in let dumb_predecessor = Tezos_crypto.Block_hash.zero in - let new_levels_and_inputs = + let new_inputs = List.mapi - (fun i ((inbox_level, inputs) as x) -> + (fun i inputs -> if i = corrupt_at_l then let inputs = match inputs with | sol :: _info_per_level :: rst -> let new_info_per_level = make_info_per_level - ~inbox_level + ~inbox_level: + Raw_level.(Internal_for_tests.add root (i + 1)) ~timestamp:dumb_timestamp ~predecessor:dumb_predecessor in sol :: new_info_per_level :: rst | _ -> assert false in - (inbox_level, inputs) - else x) - levels_and_inputs + inputs + else inputs) + list_of_inputs in - let _state, tick, our_states = eval_inputs new_levels_and_inputs in - return (tick, our_states, new_levels_and_inputs) + let _state, tick, our_states = eval_inputs new_inputs in + return (tick, our_states, new_inputs) (** [gen ~inbox ~rollup ~origination_level ~start_level ~max_level player - levels_and_inputs] generates a {!player_client} based on + list_of_inputs] generates a {!player_client} based on its {!player.strategy}. *) let gen ~inbox ~rollup ~origination_level ~start_level ~max_level player - levels_and_inputs = + list_of_inputs = let open QCheck2.Gen in let ctxt = empty_memory_ctxt "foo" in let metadata = Sc_rollup.Metadata.{address = rollup; origination_level} in - let* tick, our_states, levels_and_inputs = + let* tick, our_states, list_of_inputs = gen_our_states ~metadata player.strategy ~start_level ~max_level - levels_and_inputs + list_of_inputs in - let inbox = construct_inbox ~inbox ~origination_level levels_and_inputs in + let inbox = construct_inbox ~inbox ~origination_level list_of_inputs in return { player; final_tick = tick; states = our_states; inbox; - levels_and_inputs; + list_of_inputs; metadata; context = ctxt; } @@ -1298,10 +1286,7 @@ let build_proof ~player_client start_tick (game : Game.t) = let fuel = tick_to_int_exn start_tick in let metadata = player_client.metadata in let*! r = - Arith_test_pvm.eval_levels_and_inputs - ~metadata - ~fuel - player_client.levels_and_inputs + Arith_test_pvm.eval_inputs ~metadata ~fuel player_client.list_of_inputs in let state, _, _ = WithExceptions.Result.get_ok ~loc:__LOC__ r in let module P = struct @@ -1472,18 +1457,18 @@ let gen_game ~p1_strategy ~p2_strategy = in let start_level = origination_level + 1 in let max_level = start_level + commitment_period - 1 in - let* levels_and_messages = + let* list_of_messages = gen_arith_pvm_messages_for_levels ~start_level ~max_level in let block, infos_per_level = - construct_inbox_proto block levels_and_messages contract3 + construct_inbox_proto block list_of_messages contract3 in (* Once we created the protocol inbox, we only need inputs. *) - let levels_and_inputs = keep_inputs levels_and_messages in + let list_of_inputs = list_of_inputs_from_list_of_messages list_of_messages in - let levels_and_inputs = + let list_of_inputs = let _incr_counter = function | Inbox_message {inbox_level; message_counter; payload} -> Inbox_message @@ -1491,22 +1476,21 @@ let gen_game ~p1_strategy ~p2_strategy = | Reveal _ -> assert false in Stdlib.List.map2 - (fun (level, messages) (level', (timestamp, predecessor)) -> - assert (level = level') ; + (fun messages (timestamp, predecessor) -> match messages with - | sol :: _info_per_level :: (_ as rst) -> + | sol :: Inbox_message {inbox_level; _} :: (_ as rst) -> (* The info per level created by the generator is invalid, it did not have the correct timestamp and predecessor, we replace it. *) let info_per_level = Sc_rollup_helpers.make_info_per_level - ~inbox_level:level + ~inbox_level ~timestamp ~predecessor in - (level, sol :: info_per_level :: rst) + sol :: info_per_level :: rst | _ -> assert false) - levels_and_inputs + list_of_inputs infos_per_level in let* p1_client = @@ -1517,7 +1501,7 @@ let gen_game ~p1_strategy ~p2_strategy = ~max_level ~rollup p1 - levels_and_inputs + list_of_inputs in let* p2_client = Player_client.gen @@ -1527,7 +1511,7 @@ let gen_game ~p1_strategy ~p2_strategy = ~max_level ~rollup p2 - levels_and_inputs + list_of_inputs in let* p1_start = bool in let commitment_level = origination_level + commitment_period in @@ -1539,7 +1523,7 @@ let gen_game ~p1_strategy ~p2_strategy = p1_client, p2_client, p1_start, - levels_and_inputs ) + list_of_inputs ) (** Shrinker is really slow. Deactivating it. *) let gen_game ~p1_strategy ~p2_strategy = @@ -1549,7 +1533,7 @@ let gen_game ~p1_strategy ~p2_strategy = ~shrink:(fun _ -> Seq.empty) (** [prepare_game block rollup lcc commitment_level p1_client p2_client contract - levels_and_messages] prepares a context where [p1_client] and [p2_client] + list_of_messages] prepares a context where [p1_client] and [p2_client] are in conflict for one commitment. *) let prepare_game ~p1_start block rollup lcc commitment_level p1_client p2_client = @@ -1614,7 +1598,7 @@ let test_game ~p1_strategy ~p2_strategy () = p1_client, p2_client, p1_start, - levels_and_messages ) -> + list_of_messages ) -> let verbose = false in Format.asprintf "@[@,\ @@ -1631,8 +1615,8 @@ let test_game ~p1_strategy ~p2_strategy () = (pp_player_client ~verbose) p2_client (if p1_start then "p1" else "p2") - (pp_levels_and_inputs ~verbose) - levels_and_messages) + (pp_list_of_inputs ~verbose) + list_of_messages) ~count:100 ~name ~gen:(gen_game ~p1_strategy ~p2_strategy) @@ -1643,7 +1627,7 @@ let test_game ~p1_strategy ~p2_strategy () = p1_client, p2_client, p1_start, - _levels_and_messages ) -> + _list_of_messages ) -> let open Lwt_result_syntax in (* Otherwise, there is no conflict. *) QCheck2.assume diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox.ml index 4f2d6a6fda805a1d0ccad625fb0a329fbeb3133a..aba40f42d43e4789e025df649cf5ee4386d18e38 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox.ml @@ -35,10 +35,14 @@ open Protocol let lift k = Environment.wrap_tzresult k +let lift_lwt k = Lwt.map Environment.wrap_tzresult k + module Merkelized_payload_hashes = Alpha_context.Sc_rollup.Inbox_merkelized_payload_hashes module Message = Alpha_context.Sc_rollup.Inbox_message +module Inbox = Alpha_context.Sc_rollup.Inbox +open Alpha_context let assert_equal_payload ~__LOC__ found (expected : Message.serialized) = Assert.equal_string @@ -69,11 +73,22 @@ let assert_equal_merkelized_payload ~__LOC__ ~found ~expected = let index = Merkelized_payload_hashes.get_index expected in assert_merkelized_payload ~__LOC__ ~payload_hash ~index found +let assert_inbox_proof_error expected_msg result = + Assert.error ~loc:__LOC__ result (function + | Environment.Ecoproto_error (Sc_rollup_inbox_repr.Inbox_proof_error msg) + -> + expected_msg = msg + | _ -> false) + let gen_payload_size = QCheck2.Gen.(1 -- 10) +let gen_payload_string = + let open QCheck2.Gen in + string_size gen_payload_size + let gen_payload = let open QCheck2.Gen in - let+ payload = string_size gen_payload_size in + let+ payload = gen_payload_string in Message.unsafe_of_string payload let gen_payloads = @@ -99,6 +114,37 @@ let gen_payloads_and_two_index = let* index' = gen_index payloads in return (payloads, index, index') +let gen_list_of_messages ?(inbox_creation_level = 0) ~max_level () = + Sc_rollup_helpers.gen_messages_for_levels + ~start_level:inbox_creation_level + ~max_level + gen_payload_string + +let gen_inclusion_proof_inputs ?inbox_creation_level ?(max_level = 15) () = + let open QCheck2.Gen in + let* list_of_messages = + gen_list_of_messages ?inbox_creation_level ~max_level () + in + let list_of_inputs = + Sc_rollup_helpers.list_of_inputs_from_list_of_messages list_of_messages + in + let* index = 0 -- (List.length list_of_inputs - 2) in + let level = Raw_level.of_int32_exn (Int32.of_int index) in + return (list_of_inputs, level) + +let gen_proof_inputs ?inbox_creation_level ?max_level () = + let open QCheck2.Gen in + let* list_of_inputs, level = + gen_inclusion_proof_inputs ?inbox_creation_level ?max_level () + in + let level_index = Int32.to_int @@ Raw_level.to_int32 level in + let inputs_at_level = + WithExceptions.Option.get ~loc:__LOC__ + @@ List.nth list_of_inputs level_index + in + let* message_counter = 0 -- (List.length inputs_at_level - 1) in + return (list_of_inputs, level, Z.of_int message_counter) + let fill_merkelized_payload history payloads = let open Lwt_result_syntax in let* first, payloads = @@ -116,14 +162,96 @@ let fill_merkelized_payload history payloads = (history, merkelized_payload) payloads -let construct_merkelized_payload payloads = +let construct_merkelized_payload_hashes payloads = let history = Merkelized_payload_hashes.History.empty ~capacity:1000L in fill_merkelized_payload history payloads -let test_merkelized_payload_history payloads = +module Node_inbox = struct + type t = { + inbox : Inbox.t; + history : Inbox.History.t; + level_tree_histories : Sc_rollup_helpers.level_tree_histories; + } + + let new_inbox level = + { + inbox = Inbox.empty level; + history = Inbox.History.empty ~capacity:10000L; + level_tree_histories = Sc_rollup_helpers.Level_tree_histories.empty; + } + + let fill_inbox inbox ~shift_level list_of_inputs = + let open Result_syntax in + let* level_tree_histories, history, inbox = + Sc_rollup_helpers.fill_inbox + ~inbox:inbox.inbox + ~shift_level + inbox.history + inbox.level_tree_histories + list_of_inputs + in + return {inbox; level_tree_histories; history} + + let construct_inbox ~inbox_creation_level list_of_inputs = + let open Result_syntax in + let* level_tree_histories, history, inbox = + Sc_rollup_helpers.construct_inbox + ~inbox_creation_level + ~with_histories:true + list_of_inputs + in + return {inbox; level_tree_histories; history} +end + +module Protocol_inbox = struct + let new_inbox level = Inbox.empty level + + let fill_inbox inbox ~shift_level list_of_inputs = + let open Result_syntax in + let* _level_tree_histories, _history, inbox = + Sc_rollup_helpers.fill_inbox + ~inbox + ~shift_level + ~with_level_tree_history:false + (Inbox.History.empty ~capacity:0L) + Sc_rollup_helpers.Level_tree_histories.empty + list_of_inputs + in + return inbox + + let add_new_level inbox messages = + let next_level = Raw_level.succ @@ Sc_rollup.Inbox.inbox_level inbox in + let messages = Sc_rollup_helpers.wrap_messages next_level messages in + let inputs = + Sc_rollup_helpers.list_of_inputs_from_list_of_messages [messages] + in + fill_inbox ~shift_level:next_level inbox inputs + + let add_new_empty_level inbox = + let next_level = Raw_level.succ @@ Sc_rollup.Inbox.inbox_level inbox in + let empty_level = + Sc_rollup_helpers.( + list_of_inputs_from_list_of_messages @@ [make_empty_level next_level]) + in + fill_inbox ~shift_level:next_level inbox empty_level + + let construct_inbox ~inbox_creation_level list_of_inputs = + let open Result_syntax in + let* _level_tree_histories, _history, inbox = + Sc_rollup_helpers.construct_inbox + ~inbox_creation_level + ~with_histories:false + list_of_inputs + in + return inbox +end + +let test_merkelized_payload_hashes_history payloads = let open Lwt_result_syntax in let nb_payloads = List.length payloads in - let* history, merkelized_payloads = construct_merkelized_payload payloads in + let* history, merkelized_payloads = + construct_merkelized_payload_hashes payloads + in let* () = Assert.equal_z ~loc:__LOC__ @@ -151,9 +279,11 @@ let test_merkelized_payload_history payloads = expected_payload_hash) payloads -let test_merkelized_payload_proof (payloads, index) = +let test_merkelized_payload_hashes_proof (payloads, index) = let open Lwt_result_syntax in - let* history, merkelized_payload = construct_merkelized_payload payloads in + let* history, merkelized_payload = + construct_merkelized_payload_hashes payloads + in let ( Merkelized_payload_hashes. {merkelized = target_merkelized_payload; payload = proof_payload}, proof ) = @@ -189,18 +319,222 @@ let test_merkelized_payload_proof (payloads, index) = in return_unit -let merkelized_payload_tests = +let test_inclusion_proof_production (list_of_inputs, level) = + let open Lwt_result_syntax in + let inbox_creation_level = Raw_level.root in + let*? node_inbox = + Node_inbox.construct_inbox ~inbox_creation_level list_of_inputs + in + let*? node_inbox_history, node_inbox_snapshot = + lift @@ Inbox.form_history_proof node_inbox.history node_inbox.inbox + in + let*? proof, node_old_level_messages = + lift + @@ Inbox.Internal_for_tests.produce_inclusion_proof + node_inbox_history + node_inbox_snapshot + level + in + let*? proto_inbox = + Protocol_inbox.construct_inbox ~inbox_creation_level list_of_inputs + in + (* we add a level only to archive the latest message *) + let*? proto_inbox = Protocol_inbox.add_new_empty_level proto_inbox in + let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in + let*? found_old_levels_messages = + lift @@ Inbox.verify_inclusion_proof proof proto_inbox_snapshot + in + Assert.equal + ~loc:__LOC__ + Inbox.equal_history_proof + "snapshot is the same in the proto and node" + Inbox.pp_history_proof + node_old_level_messages + found_old_levels_messages + +let test_inclusion_proof_verification (list_of_inputs, level) = + let open Lwt_result_syntax in + let inbox_creation_level = Raw_level.root in + let*? node_inbox = + Node_inbox.construct_inbox ~inbox_creation_level list_of_inputs + in + let*? node_inbox_history, node_inbox_snapshot = + lift @@ Inbox.form_history_proof node_inbox.history node_inbox.inbox + in + let*? proof, _node_old_level_messages = + lift + @@ Inbox.Internal_for_tests.produce_inclusion_proof + node_inbox_history + node_inbox_snapshot + level + in + let*? proto_inbox = + Protocol_inbox.construct_inbox ~inbox_creation_level list_of_inputs + in + (* This snapshot is not the same one as node_inbox_snapshot because the + node_inbox_snapshot includes the current_level_proof. *) + let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in + let result = + lift @@ Inbox.verify_inclusion_proof proof proto_inbox_snapshot + in + assert_inbox_proof_error "invalid inclusion proof" result + +let test_inbox_proof_production (list_of_inputs, level, message_counter) = + let open Lwt_result_syntax in + let inbox_creation_level = Raw_level.root in + (* We begin with a Node inbox so we can produce a proof. *) + let exp_message = + Sc_rollup_helpers.first_after + ~shift_level:inbox_creation_level + list_of_inputs + level + message_counter + in + let*? node_inbox = + Node_inbox.construct_inbox ~inbox_creation_level list_of_inputs + in + let*? node_inbox_history, node_inbox_snapshot = + lift @@ Inbox.form_history_proof node_inbox.history node_inbox.inbox + in + let* proof, input = + lift_lwt + @@ Inbox.produce_proof + ~get_level_tree_history: + (Sc_rollup_helpers.get_level_tree_history + node_inbox.level_tree_histories) + node_inbox_history + node_inbox_snapshot + (level, message_counter) + in + (* We now switch to a protocol inbox built from the same messages for + verification. *) + let*? proto_inbox = + Protocol_inbox.construct_inbox ~inbox_creation_level list_of_inputs + in + let*? proto_inbox = Protocol_inbox.add_new_empty_level proto_inbox in + let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in + let* () = + Assert.equal + ~loc:__LOC__ + Inbox.equal_history_proof + "snapshot is the same in the proto and node" + Inbox.pp_history_proof + node_inbox_snapshot + proto_inbox_snapshot + in + let*? v_input = + lift + @@ Inbox.verify_proof (level, message_counter) proto_inbox_snapshot proof + in + let* () = + Assert.equal + ~loc:__LOC__ + (Option.equal Sc_rollup.inbox_message_equal) + "Input returns by the production is the expected one." + (Format.pp_print_option Sc_rollup.pp_inbox_message) + input + v_input + in + Assert.equal + ~loc:__LOC__ + (Option.equal Sc_rollup.inbox_message_equal) + "Input returns by the verification is the expected one." + (Format.pp_print_option Sc_rollup.pp_inbox_message) + exp_message + v_input + +let test_inbox_proof_verification (list_of_inputs, level, message_counter) = + let open Lwt_result_syntax in + let inbox_creation_level = Raw_level.root in + (* We begin with a Node inbox so we can produce a proof. *) + let*? node_inbox = + Node_inbox.construct_inbox ~inbox_creation_level list_of_inputs + in + let get_level_tree_history = + Sc_rollup_helpers.get_level_tree_history node_inbox.level_tree_histories + in + let*? node_inbox_history, node_inbox_snapshot = + lift @@ Inbox.form_history_proof node_inbox.history node_inbox.inbox + in + let* proof, _input = + lift_lwt + @@ Inbox.produce_proof + ~get_level_tree_history + node_inbox_history + node_inbox_snapshot + (level, message_counter) + in + (* We now switch to a protocol inbox built from the same messages for + verification. *) + let*? proto_inbox = + Protocol_inbox.construct_inbox ~inbox_creation_level list_of_inputs + in + (* This snapshot is not the same one as node_inbox_snapshot because the + node_inbox_snapshot includes the current_level_proof. *) + let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in + let* () = + let result = + lift + @@ Inbox.verify_proof (level, message_counter) proto_inbox_snapshot proof + in + assert_inbox_proof_error "invalid inclusion proof" result + in + let*? proto_inbox = Protocol_inbox.add_new_empty_level proto_inbox in + let proto_inbox_snapshot = Inbox.take_snapshot proto_inbox in + let invalid_message_counter = + if Z.(equal message_counter zero) then Z.succ message_counter + else Z.pred message_counter + in + let* () = + let result = + lift + @@ Inbox.verify_proof + (level, invalid_message_counter) + proto_inbox_snapshot + proof + in + assert_inbox_proof_error "found index in message_proof is incorrect" result + in + return_unit + +let merkelized_payload_hashes_tests = [ Tztest.tztest_qcheck2 ~count:1000 ~name:"Merkelized messages: Add messages then retrieve them from history." gen_payloads - test_merkelized_payload_history; + test_merkelized_payload_hashes_history; Tztest.tztest_qcheck2 ~count:1000 ~name:"Merkelized messages: Produce proof and verify its validity." gen_payloads_and_index - test_merkelized_payload_proof; + test_merkelized_payload_hashes_proof; + ] + +let inbox_tests = + [ + Tztest.tztest_qcheck2 + ~count:1000 + ~name:"produce inclusion proof and verifies it." + (gen_inclusion_proof_inputs ()) + test_inclusion_proof_production; + Tztest.tztest_qcheck2 + ~count:1000 + ~name:"negative test of inclusion proof." + (gen_inclusion_proof_inputs ()) + test_inclusion_proof_verification; + Tztest.tztest_qcheck2 + ~count:1000 + ~name:"produce inbox proof and verifies it." + (gen_proof_inputs ()) + test_inbox_proof_production; + Tztest.tztest_qcheck2 + ~count:1000 + ~name:"negative test of inbox proof." + (gen_proof_inputs ()) + test_inbox_proof_verification; ] -let tests = merkelized_payload_tests @ Test_sc_rollup_inbox_legacy.tests +let tests = + merkelized_payload_hashes_tests @ inbox_tests + @ Test_sc_rollup_inbox_legacy.tests diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox_legacy.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox_legacy.ml index 6cc5752a111e173730069fb8760fd063ab1f8a97..449de5e3aa9e0e19f7a0f39ca10e73b04258e7ab 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox_legacy.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox_legacy.ml @@ -198,77 +198,6 @@ let test_get_message_payload messages = (err (Printf.sprintf "No message payload number %d in messages" i))) messages -let test_inclusion_proof_production (list_of_messages, n) = - let open Lwt_result_syntax in - let list_of_payloads = List.map (List.map make_payload) list_of_messages in - setup_inbox_with_messages list_of_payloads - @@ fun _level_tree_histories _messages history _inbox inboxes -> - let inbox = Stdlib.List.hd inboxes in - let old_inbox = Stdlib.List.nth inboxes n in - let*? res = - Internal_for_tests.produce_inclusion_proof - history - (old_levels_messages old_inbox) - (old_levels_messages inbox) - |> Environment.wrap_tzresult - in - match res with - | None -> - fail - [ - err - "It should be possible to produce an inclusion proof between two \ - versions of the same inbox."; - ] - | Some proof -> - let*? found_old_levels_messages = - verify_inclusion_proof proof (old_levels_messages inbox) - |> Environment.wrap_tzresult - in - fail_unless - (Sc_rollup_inbox_repr.equal_history_proof - found_old_levels_messages - (old_levels_messages old_inbox)) - (err "The produced inclusion proof is invalid.") - -let test_inclusion_proof_verification (list_of_messages, n) = - let open Lwt_result_syntax in - let list_of_payloads = List.map (List.map make_payload) list_of_messages in - setup_inbox_with_messages list_of_payloads - @@ fun _level_tree_histories _messages history _inbox inboxes -> - let inbox = Stdlib.List.hd inboxes in - let old_inbox = Stdlib.List.nth inboxes n in - let*? res = - Internal_for_tests.produce_inclusion_proof - history - (old_levels_messages old_inbox) - (old_levels_messages inbox) - |> Environment.wrap_tzresult - in - match res with - | None -> - fail - [ - err - "It should be possible to produce an inclusion proof between two \ - versions of the same inbox."; - ] - | Some proof -> ( - let other_inbox = Stdlib.List.nth inboxes 1 in - let res = - verify_inclusion_proof proof (old_levels_messages other_inbox) - |> Environment.wrap_tzresult - in - match res with - | Error _ -> return_unit - | Ok _found_old_levels_messages -> - fail - [ - err - "It should not be possible to verify an inclusion proof with a \ - different inbox."; - ]) - (** This is basically identical to {!setup_inbox_with_messages}, except that it uses the {!Node} instance instead of the protocol instance. *) let setup_node_inbox_with_messages list_of_payloads f = @@ -360,93 +289,6 @@ let fail_with_proof_error_msg errors fail_msg = let msg = Option.(msg |> map (fun s -> ": " ^ s) |> value ~default:"") in fail (err (fail_msg ^ msg)) -let test_inbox_proof_production (levels_and_messages, l, n) = - (* We begin with a Node inbox so we can produce a proof. *) - let exp_input = next_inbox_message levels_and_messages l n in - let list_of_payloads = - List.map - (fun (_, messages) -> payloads_from_messages messages) - levels_and_messages - in - setup_node_inbox_with_messages list_of_payloads - @@ fun level_tree_histories _current_level_tree history inbox _inboxes -> - let open Lwt_result_syntax in - let*? history, history_proof = - form_history_proof history inbox |> Environment.wrap_tzresult - in - let*! result = - produce_proof - ~get_level_tree_history:(get_level_tree_history level_tree_histories) - history - history_proof - (l, n) - >|= Environment.wrap_tzresult - in - match result with - | Ok (proof, input) -> ( - (* We now switch to a protocol inbox built from the same messages - for verification. *) - (* The snapshot takes the snapshot at the end of the last level, - we need to set the level ahead to match the inbox. *) - setup_inbox_with_messages (list_of_payloads @ [[make_payload "foo"]]) - @@ fun _ctxt _ _history inbox _inboxes -> - let snapshot = take_snapshot inbox in - let verification = - verify_proof (l, n) snapshot proof |> Environment.wrap_tzresult - in - match verification with - | Ok v_input -> - Alcotest.(check (option inbox_message_testable)) - "input = v_input" - input - v_input ; - Alcotest.(check (option inbox_message_testable)) - "exp_input = v_input" - exp_input - v_input ; - return_unit - | Error errors -> - fail_with_proof_error_msg errors "Proof verification failed") - | Error errors -> fail_with_proof_error_msg errors "Proof production failed" - -let test_inbox_proof_verification (levels_and_messages, l, n) = - (* We begin with a Node inbox so we can produce a proof. *) - let list_of_payloads = - List.map - (fun (_, messages) -> payloads_from_messages messages) - levels_and_messages - in - setup_node_inbox_with_messages list_of_payloads - @@ fun level_tree_histories _current_level_tree history inbox _inboxes -> - let open Lwt_result_syntax in - let*? history, history_proof = - form_history_proof history inbox |> Environment.wrap_tzresult - in - let*! result = - produce_proof - ~get_level_tree_history:(get_level_tree_history level_tree_histories) - history - history_proof - (l, n) - >|= Environment.wrap_tzresult - in - match result with - | Ok (proof, _input) -> ( - (* We now switch to a protocol inbox built from the same messages - for verification. *) - setup_inbox_with_messages (list_of_payloads @ [[make_payload "foo"]]) - @@ fun _level_tree_histories _ _history _inbox inboxes -> - (* Use the incorrect inbox *) - match List.hd inboxes with - | Some inbox -> ( - let snapshot = take_snapshot inbox in - let verification = verify_proof (l, n) snapshot proof in - match verification with - | Ok _ -> fail [err "Proof should not be valid"] - | Error _ -> return (ok ())) - | None -> fail [err "inboxes was empty"]) - | Error errors -> fail_with_proof_error_msg errors "Proof production failed" - (** This helper function initializes inboxes and histories with different capacities and populates them. *) let init_inboxes_histories_with_different_capacities @@ -620,6 +462,11 @@ let test_inclusion_proofs_depending_on_history_capacity let hp0 = I.old_levels_messages inbox0 in let hp1 = I.old_levels_messages inbox1 in let (hp2 as hp) = I.old_levels_messages inbox2 in + let pred_level_of_hp = + WithExceptions.Option.get ~loc:__LOC__ + @@ Raw_level_repr.pred + @@ I.Internal_for_tests.get_level_of_history_proof hp + in let* () = fail_unless (I.equal_history_proof hp0 hp1 && I.equal_history_proof hp1 hp2) @@ -629,58 +476,39 @@ let test_inclusion_proofs_depending_on_history_capacity in let proof s v = let open Result_syntax in - let* v = v |> Environment.wrap_tzresult in - Option.to_result ~none:[err (s ^ ": Expecting some inclusion proof.")] v + let v = v |> Environment.wrap_tzresult in + match v with + | Ok v -> return v + | Error _ -> fail [err (s ^ ": Expecting some inclusion proof.")] in (* Producing inclusion proofs using history1 and history2 should succeeed. But, we should not be able to produce any proof with history0 as bound is 0. *) - let*? ip0 = - I.Internal_for_tests.produce_inclusion_proof history0 hp hp + let ip0 = + I.Internal_for_tests.produce_inclusion_proof history0 hp pred_level_of_hp |> Environment.wrap_tzresult in - let*? ip1 = + let*? ip1, hp1' = proof "history1" - @@ I.Internal_for_tests.produce_inclusion_proof history1 hp hp + @@ I.Internal_for_tests.produce_inclusion_proof history1 hp pred_level_of_hp in - let*? ip2 = + let*? ip2, hp2' = proof "history2" - @@ I.Internal_for_tests.produce_inclusion_proof history2 hp hp + @@ I.Internal_for_tests.produce_inclusion_proof history2 hp pred_level_of_hp in let* () = fail_unless - (Option.is_none ip0) + (Result.is_error ip0) (err "Should not be able to get inbox inclusion proofs without a history \ (i.e., a history with no capacity). ") in - let*? hp' = verify_inclusion_proof ip1 hp |> Environment.wrap_tzresult in - let*? hp'' = verify_inclusion_proof ip2 hp |> Environment.wrap_tzresult in + let*? hp1'' = verify_inclusion_proof ip1 hp1 |> Environment.wrap_tzresult in + let*? hp2'' = verify_inclusion_proof ip2 hp2 |> Environment.wrap_tzresult in fail_unless - (hp = hp' && hp = hp'') + (hp1' = hp1'' && hp2' = hp2'' && hp1' = hp2') (err "Inclusion proofs are expected to be valid.") -(** In this test, we make sure that the snapshot of an inbox is taken - at the beginning of a block level. *) -let test_inbox_snapshot_taking payloads = - let payloads = List.map make_payload payloads in - let inbox = empty first_level in - let inbox_level = inbox_level inbox in - let expected_snapshot = take_snapshot inbox in - (* Now, if we add messages to the inbox at [current_level], the inbox's - snapshot for this level should not changed. *) - let _ = - add_messages_no_history inbox inbox_level payloads None - |> Environment.wrap_tzresult - in - let new_snapshot = take_snapshot inbox in - fail_unless - (equal_history_proof expected_snapshot new_snapshot) - (err - "Adding messages in an inbox for a level should not modify the snapshot \ - when the current level is equal to the level where the messages are \ - added.") - (** This test checks that inboxes of the same levels that are supposed to contain the same messages are equal. It also check the level trees obtained from the last calls to add_messages are equal. *) @@ -728,31 +556,6 @@ let tests = test_get_message_payload; ] @ - let gen_inclusion_proof_inputs = - QCheck2.Gen.( - let small = 2 -- 10 in - let* a = list_size small bounded_string in - let* b = list_size small bounded_string in - let* l = list_size small (list_size small bounded_string) in - let l = a :: b :: l in - let* n = 0 -- (List.length l - 2) in - return (l, n)) - in - let gen_proof_inputs = - QCheck2.Gen.( - let* levels = 2 -- 15 in - let* levels_and_messages = - Sc_rollup_helpers.gen_message_reprs_for_levels_repr - ~start_level:1 - ~max_level:levels - bounded_string - in - let* l = 1 -- (levels - 1) in - let l = level_of_int l in - let messages_at_l = Stdlib.List.assoc l levels_and_messages in - let* n = 0 -- List.length messages_at_l in - return (levels_and_messages, l, Z.of_int n)) - in let gen_history_params = QCheck2.Gen.( (* We fix the number of levels/ inboxes. *) @@ -773,24 +576,6 @@ let tests = (nb_levels, default_capacity, Int64.of_int small_capacity, next_index)) in [ - Tztest.tztest_qcheck2 - ~name:"Produce inclusion proof between two related inboxes." - gen_inclusion_proof_inputs - test_inclusion_proof_production; - Tztest.tztest_qcheck2 - ~name:"Verify inclusion proofs." - gen_inclusion_proof_inputs - test_inclusion_proof_verification; - Tztest.tztest_qcheck2 - ~count:10 - ~name:"Produce inbox proofs" - gen_proof_inputs - test_inbox_proof_production; - Tztest.tztest_qcheck2 - ~count:10 - ~name:"Verify inbox proofs" - gen_proof_inputs - test_inbox_proof_verification; Tztest.tztest_qcheck2 ~count:10 ~name:"Checking inboxes history length" @@ -813,13 +598,4 @@ let tests = capacities" gen_history_params test_for_successive_add_messages_with_different_histories_capacities; - Tztest.tztest_qcheck2 - ~count:10 - ~name: - "Take snapshot is not impacted by messages added during the current \ - level" - (let open QCheck2.Gen in - let* payloads = list_size (1 -- 10) bounded_string in - return payloads) - test_inbox_snapshot_taking; ]