diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index e53d0fe1f178fd7ecf8037bb1291dca3b5b9c608..4122c70d07848cab16a552d7d623a5aba91a1c16 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -64,6 +64,11 @@ module Sc_rollup = struct include Sc_rollup_inbox_repr include Sc_rollup_inbox_storage module Message = Sc_rollup_inbox_message_repr + + module Internal_for_tests = struct + include Sc_rollup_inbox_repr.Internal_for_tests + include Sc_rollup_inbox_storage.Internal_for_tests + end end module Proof = Sc_rollup_proof_repr diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 2e856ff1520607f69ab35fa03e6fcd05e22c3bbb..e3a9aa8b803ed32ded95b0d0ca7e6192e18b4c0a 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2945,6 +2945,14 @@ module Sc_rollup : sig (proof * Sc_rollup_PVM_sem.input option) tzresult Lwt.t val empty : inbox_context -> Sc_rollup_repr.t -> Raw_level.t -> t Lwt.t + + module Internal_for_tests : sig + val eq_tree : tree -> tree -> bool + + val history_at_genesis : capacity:int64 -> next_index:int64 -> history + + val history_hashes : history -> Hash.t list + end end include 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 e788e348ddfcc901b84d6ba571696f5e8fc4df76..711093c2df1c814fcd29229bd0907bc82560d0b2 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -476,6 +476,14 @@ module type Merkelized_operations = sig (proof * Sc_rollup_PVM_sem.input option) tzresult Lwt.t val empty : inbox_context -> Sc_rollup_repr.t -> Raw_level_repr.t -> t Lwt.t + + module Internal_for_tests : sig + val eq_tree : tree -> tree -> bool + + val history_at_genesis : capacity:int64 -> next_index:int64 -> history + + val history_hashes : history -> Hash.t list + end end module type P = sig @@ -1277,6 +1285,33 @@ struct current_level_hash = (fun () -> initial_hash); old_levels_messages = Skip_list.genesis initial_hash; } + + module Internal_for_tests = struct + let eq_tree = Tree.equal + + let history_at_genesis ~capacity ~next_index = + { + (history_at_genesis ~capacity) with + next_index; + oldest_index = next_index; + } + + let history_hashes {sequence; oldest_index; _} = + let l = Int64_map.bindings sequence in + (* All entries with an index greater than oldest_index are well ordered. + There are put in the [lp] list. Entries with an index smaller than + oldest_index are also well ordered, but they should come after + elements in [lp]. This happens in theory when the index reaches + max_int and then overflows. *) + let ln, lp = + List.partition_map + (fun (n, h) -> + if Compare.Int64.(n < oldest_index) then Left h else Right h) + l + in + (* do a tail recursive concatenation lp @ ln *) + List.rev_append (List.rev lp) ln + end end include ( 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 2fee2212587bf0d0a5e62b974b9f9f23cfa5dbfd..74c5bbad7f44699a16f30fdb7a8618e39efff583 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli @@ -405,6 +405,18 @@ module type Merkelized_operations = sig (** [empty ctxt level] is an inbox started at some given [level] with no message at all. *) val empty : inbox_context -> Sc_rollup_repr.t -> Raw_level_repr.t -> t Lwt.t + + module Internal_for_tests : sig + val eq_tree : tree -> tree -> bool + + (** A variant of {!history_at_genesis} where one specifies next_index for + testing purpose. *) + val history_at_genesis : capacity:int64 -> next_index:int64 -> history + + (** [history_hashes history] returns the keys of the entries stored in [history] in the order of + their insertions. *) + val history_hashes : history -> Hash.t list + end end module type P = sig diff --git a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml index 33403e15db99318bcc51f4553483bbdb208f24ec..402bf746a1ed1ac900c25c72c3d64f09a9128715 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml @@ -233,7 +233,7 @@ let start_game ctxt rollup ~player:refuter ~opponent:defender = let* () = fail_when game_exists Sc_rollup_game_already_started in let* ctxt, opp_1 = Store.Opponent.find (ctxt, rollup) refuter in let* ctxt, opp_2 = Store.Opponent.find (ctxt, rollup) defender in - let* _ = + let* () = match (opp_1, opp_2) with | None, None -> return () | Some _refuter_opponent, None -> @@ -372,7 +372,7 @@ let conflicting_stakers_uncarbonated ctxt rollup staker = let parent_commitment = our_commitment.predecessor in return {other; their_commitment; our_commitment; parent_commitment} in - let* _, stakers = Store.stakers ctxt rollup in + let* _ctxt, stakers = Store.stakers ctxt rollup in List.fold_left_es (fun conflicts (other_staker, _) -> let*! res = get_conflict_point ctxt rollup staker other_staker in 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 a041bbb36f722d82df58bab4a99c0538e869052d..b14aa2dbc9492c49b3c0c60837605b4d495bbff6 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 @@ -47,18 +47,9 @@ let level = let create_context () = Context.init1 () >>=? fun (block, _contract) -> return block.context -let test_empty () = - create_context () >>=? fun ctxt -> - empty ctxt rollup level >>= fun inbox -> - fail_unless - Compare.Int64.(equal (number_of_messages_during_commitment_period inbox) 0L) - (err "An empty inbox should have no available message.") - -let setup_inbox_with_messages list_of_payloads f = +let populate_inboxes ctxt level history inbox inboxes level_tree + list_of_payloads = let open Lwt_syntax in - create_context () >>=? fun ctxt -> - let* inbox = empty ctxt rollup level in - let history = history_at_genesis ~capacity:10000L in let rec aux level history inbox inboxes level_tree = function | [] -> return (ok (level_tree, history, inbox, inboxes)) | [] :: ps -> @@ -78,7 +69,21 @@ let setup_inbox_with_messages list_of_payloads f = let level = Raw_level_repr.succ level in aux level history inbox' (inbox :: inboxes) (Some level_tree) ps in - aux level history inbox [] None list_of_payloads + aux level history inbox inboxes level_tree list_of_payloads + +let test_empty () = + create_context () >>=? fun ctxt -> + empty ctxt rollup level >>= fun inbox -> + fail_unless + Compare.Int64.(equal (number_of_messages_during_commitment_period inbox) 0L) + (err "An empty inbox should have no available message.") + +let setup_inbox_with_messages list_of_payloads f = + let open Lwt_syntax in + create_context () >>=? fun ctxt -> + let* inbox = empty ctxt rollup level in + let history = history_at_genesis ~capacity:10000L in + populate_inboxes ctxt level history inbox [] None list_of_payloads >>=? fun (level_tree, history, inbox, inboxes) -> match level_tree with | None -> fail (err "setup_inbox_with_messages called with no messages") @@ -425,6 +430,215 @@ let test_empty_inbox_proof (level, n) = | Error _ -> fail (err "Proof verification failed")) | Error _ -> fail (err "Proof production failed") +(** This helper function initializes inboxes and histories with different + capacities and populates them. *) +let init_inboxes_histories_with_different_capacities + (nb_levels, default_capacity, small_capacity, next_index) = + let open Lwt_result_syntax in + let* () = + fail_when + Int64.(of_int nb_levels <= small_capacity) + (err + (Format.sprintf + "Bad inputs: nb_levels = %d should be greater than small_capacity \ + = %Ld" + nb_levels + small_capacity)) + in + let* () = + fail_when + Int64.(of_int nb_levels >= default_capacity) + (err + (Format.sprintf + "Bad inputs: nb_levels = %d should be smaller than \ + default_capacity = %Ld" + nb_levels + default_capacity)) + in + let*? payloads = + List.init ~when_negative_length:[] nb_levels (fun i -> [string_of_int i]) + in + let mk_history ?(next_index = 0L) ~capacity () = + let open Lwt_syntax in + create_context () >>=? fun ctxt -> + let* inbox = empty ctxt rollup level in + let history = + Sc_rollup_inbox_repr.Internal_for_tests.history_at_genesis + ~capacity + ~next_index + in + populate_inboxes ctxt level history inbox [] None payloads + in + (* Here, we have `~capacity:0L`. So no history is kept *) + mk_history ~capacity:0L () >>=? fun no_history -> + (* Here, we set a [default_capacity] supposed to be greater than [nb_levels], + and keep the default [next_index]. This history will serve as a witeness *) + mk_history ~capacity:default_capacity () >>=? fun big_history -> + (* Here, we choose a small capacity supposed to be smaller than [nb_levels] to + cover cases where the history is full and older elements should be removed. + We also set a non-default [next_index] value to cover cases where the + incremented index may overflow or is negative. *) + mk_history ~next_index ~capacity:small_capacity () >>=? fun small_history -> + return (no_history, small_history, big_history) + +(** In this test, we mainly check that the number of entries in histories + doesn't exceed their respective capacities. *) +let test_history_length + ((_nb_levels, default_capacity, small_capacity, _next_index) as params) = + let open Lwt_result_syntax in + let module I = Sc_rollup_inbox_repr in + let err expected given ~exact = + err + @@ Format.sprintf + "We expect a history of %Ld capacity (%s), but we got %d elements" + expected + (if exact then "exactly" else "at most") + given + in + let no_capacity = 0L in + let* no_history, small_history, big_history = + init_inboxes_histories_with_different_capacities params + in + let _level_tree0, history0, _inbox0, _inboxes0 = no_history in + let _level_tree1, history1, _inbox1, _inboxes1 = small_history in + let _level_tree2, history2, _inbox2, _inboxes2 = big_history in + let hh0 = I.Internal_for_tests.history_hashes history0 in + let hh1 = I.Internal_for_tests.history_hashes history1 in + let hh2 = I.Internal_for_tests.history_hashes history2 in + (* The first history is supposed to have exactly 0 elements *) + let* () = + let len = List.length hh0 in + fail_unless + Int64.(equal no_capacity (of_int @@ len)) + (err no_capacity len ~exact:true) + in + (* The second history is supposed to have exactly [small_capacity], because + we are supposed to add _nb_level > small_capacity entries. *) + let* () = + let len = List.length hh1 in + fail_unless + Int64.(small_capacity = of_int len) + (err small_capacity len ~exact:false) + in + (* The third history's capacity, named [default_capacity], is supposed to be + greater than _nb_level. So, we don't expect this history to be full. *) + let* () = + let len = List.length hh2 in + fail_unless + Int64.(default_capacity > of_int len) + (err default_capacity len ~exact:true) + in + return () + +(** In this test, we check that for two inboxes of the same content, the entries + of the history with the lower capacity, taken in the insertion order, is a + prefix of the entries of the history with the higher capacity. *) +let test_history_prefix params = + let open Lwt_result_syntax in + let module I = Sc_rollup_inbox_repr in + let* no_history, small_history, big_history = + init_inboxes_histories_with_different_capacities params + in + let _level_tree0, history0, _inbox0, _inboxes0 = no_history in + let _level_tree1, history1, _inbox1, _inboxes1 = small_history in + let _level_tree2, history2, _inbox2, _inboxes2 = big_history in + let hh0 = I.Internal_for_tests.history_hashes history0 in + let hh1 = I.Internal_for_tests.history_hashes history1 in + let hh2 = I.Internal_for_tests.history_hashes history2 in + let check_is_suffix sub super = + let rec aux super to_remove = + let* () = + fail_unless + (to_remove >= 0) + (err "A bigger list cannot be a suffix of a smaller one.") + in + if to_remove = 0 then + fail_unless + (List.for_all2 ~when_different_lengths:false I.Hash.equal sub super + = Ok true) + (err "The smaller list is not a prefix the bigger one.") + else + match List.tl super with + | None -> assert false + | Some super -> aux super (to_remove - 1) + in + aux super (List.length super - List.length sub) + in + (* The empty history's hashes list is supposed to be a suffix of a history + with bigger capacity. *) + let* () = check_is_suffix hh0 hh1 in + (* The history's hashes list of the smaller capacity should be a prefix of + the history's hashes list of a bigger capacity. *) + check_is_suffix hh1 hh2 + +(** In this test, we make some checks on production and verification of + inclusion proofs depending on histories' capacity. *) +let test_inclusion_proofs_depending_on_history_capacity + ((_nb_levels, _default_capacity, _small_capacity, _next_index) as params) = + let open Lwt_result_syntax in + let module I = Sc_rollup_inbox_repr in + let* no_history, small_history, big_history = + init_inboxes_histories_with_different_capacities params + in + let _level_tree0, history0, inbox0, _inboxes0 = no_history in + let _level_tree1, history1, inbox1, _inboxes1 = small_history in + let _level_tree2, history2, inbox2, _inboxes2 = big_history in + 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* () = + fail_unless + (I.equal_history_proof hp0 hp1 && I.equal_history_proof hp1 hp2) + (err + "History proof of equal inboxes shouldn't depend on the capacity of \ + history.") + in + let proof s v = + Option.to_result ~none:[err (s ^ ": Expecting some inclusion proof.")] v + 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.produce_inclusion_proof history0 hp hp in + let*? ip1 = proof "history1" @@ I.produce_inclusion_proof history1 hp hp in + let*? ip2 = proof "history2" @@ I.produce_inclusion_proof history2 hp hp in + let* () = + fail_unless + (Option.is_none ip0) + (err + "Should not be able to get inbox inclusion proofs without a history \ + (i.e., a history with no capacity). ") + in + fail_unless + (I.verify_inclusion_proof ip1 hp hp && I.verify_inclusion_proof ip2 hp hp) + (err "Inclusion proofs are expected to be valid.") + +(** 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. *) +let test_for_successive_add_messages_with_different_histories_capacities + ((_nb_levels, _default_capacity, _small_capacity, _next_index) as params) = + let open Lwt_result_syntax in + let module I = Sc_rollup_inbox_repr in + let* no_history, small_history, big_history = + init_inboxes_histories_with_different_capacities params + in + let level_tree0, _history0, _inbox0, inboxes0 = no_history in + let level_tree1, _history1, _inbox1, inboxes1 = small_history in + let level_tree2, _history2, _inbox2, inboxes2 = big_history in + (* The latest inbox's value shouldn't depend on the value of [bound]. *) + let eq_inboxes_list = List.for_all2 ~when_different_lengths:false I.equal in + let* () = + fail_unless + (eq_inboxes_list inboxes0 inboxes1 = Ok true + && eq_inboxes_list inboxes1 inboxes2 = Ok true) + (err "Inboxes at the same level with the same content should be equal.") + in + fail_unless + (Option.equal I.Internal_for_tests.eq_tree level_tree0 level_tree1 + && Option.equal I.Internal_for_tests.eq_tree level_tree1 level_tree2) + (err "Trees of (supposedly) equal inboxes should be equal.") + let tests = let msg_size = QCheck2.Gen.(0 -- 100) in let bounded_string = QCheck2.Gen.string_size msg_size in @@ -461,6 +675,25 @@ let tests = let* n = 0 -- (List.length at + 3) in return (payloads, level_of_int level, Z.of_int n)) in + let gen_history_params = + QCheck2.Gen.( + (* We fix the number of levels/ inboxes. *) + let* nb_levels = pure 30 in + (* The default capacity is intentionally very big compared to [nb_levels]. *) + let* default_capacity = + frequencyl [(1, Int64.of_int (1000 * nb_levels)); (1, Int64.max_int)] + in + (* The small capacity is intended to be smaller than nb_levels + (but greater than zero). *) + let* small_capacity = 3 -- (nb_levels / 2) in + let* next_index_delta = -5000 -- 5000 in + let big_next_index = Int64.(add max_int (of_int next_index_delta)) in + (* for the [next_index] counter of the history, we test both default values + (i.e., 0L) and values close to [max_int]. *) + let* next_index = frequencyl [(1, 0L); (1, big_next_index)] in + return + (nb_levels, default_capacity, Int64.of_int small_capacity, next_index)) + in [ Tztest.tztest_qcheck2 ~name:"Produce inclusion proof between two related inboxes." @@ -487,4 +720,26 @@ let tests = let* m = 0 -- 1000 in return (level_of_int n, Z.of_int m)) test_empty_inbox_proof; + Tztest.tztest_qcheck2 + ~count:10 + ~name:"Checking inboxes history length" + gen_history_params + test_history_length; + Tztest.tztest_qcheck2 + ~count:10 + ~name:"Checking inboxes history content and order" + gen_history_params + test_history_prefix; + Tztest.tztest_qcheck2 + ~count:10 + ~name:"Checking inclusion proofs validity depending on history capacity" + gen_history_params + test_inclusion_proofs_depending_on_history_capacity; + Tztest.tztest_qcheck2 + ~count:10 + ~name: + "Checking results of add_messages when histories have different \ + capacities" + gen_history_params + test_for_successive_add_messages_with_different_histories_capacities; ]