diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index bb377c8e59614936fe6cedf623119ecc7a440b68..e1655bc866ca4a7479177a6a12d508bfea505263 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -56,6 +56,7 @@ "Sc_rollup_metadata_repr", "Sc_rollup_tick_repr", "Sc_rollup_inbox_message_repr", + "Sc_rollup_inbox_merkelized_payload_hashes_repr", "Sc_rollup_outbox_message_repr", "Sc_rollup_PVM_sig", "Sc_rollup_arith", diff --git a/src/proto_alpha/lib_protocol/alpha_context.ml b/src/proto_alpha/lib_protocol/alpha_context.ml index 2a392d8c8a39e4bedfbae76076d4a9bcce264b4b..597aa79726c2aa041e1ed99e95a949b6b18346fd 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.ml +++ b/src/proto_alpha/lib_protocol/alpha_context.ml @@ -61,6 +61,8 @@ module Sc_rollup = struct module ArithPVM = Sc_rollup_arith module Wasm_2_0_0PVM = Sc_rollup_wasm.V2_0_0 module Inbox_message = Sc_rollup_inbox_message_repr + module Inbox_merkelized_payload_hashes = + Sc_rollup_inbox_merkelized_payload_hashes_repr module Inbox = struct include Sc_rollup_inbox_repr diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 7c3f9ebfb99bf48bf8f390dd987dbcd2027f3afd..dea775fb86882cddcee70b84e46e7eebf804393f 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -3180,6 +3180,59 @@ module Sc_rollup : sig val serialize : t -> serialized tzresult val deserialize : serialized -> t tzresult + + module Hash : S.HASH + + val hash_serialized_message : serialized -> Hash.t + end + + module Inbox_merkelized_payload_hashes : sig + module Hash : S.HASH + + type t + + val encoding : t Data_encoding.t + + val equal : t -> t -> bool + + val hash : t -> Hash.t + + val get_payload_hash : t -> Inbox_message.Hash.t + + val get_index : t -> int + + type merkelized_and_payload = { + merkelized : t; + payload : Inbox_message.serialized; + } + + module History : sig + include + Bounded_history_repr.S + with type key = Hash.t + and type value = merkelized_and_payload + + val no_history : t + end + + val genesis : + History.t -> Inbox_message.serialized -> (History.t * t) tzresult + + val add_payload : + History.t -> t -> Inbox_message.serialized -> (History.t * t) tzresult + + type proof + + val proof_encoding : proof Data_encoding.t + + val produce_proof : + History.t -> index:int -> t -> (merkelized_and_payload * proof) option + + val verify_proof : proof -> (t * t) tzresult + + module Internal_for_tests : sig + val find_predecessor_payload : History.t -> index:int -> t -> t option + end end type inbox_message = { diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index 3841752d300ee94ca1c8118aa83b2a079c1daf35..3d544f34579cc6cc1bc19ccb06d5cd17d2dae5b0 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -82,6 +82,7 @@ Sc_rollup_metadata_repr Sc_rollup_tick_repr Sc_rollup_inbox_message_repr + Sc_rollup_inbox_merkelized_payload_hashes_repr Sc_rollup_outbox_message_repr Sc_rollup_PVM_sig Sc_rollup_arith @@ -353,6 +354,8 @@ sc_rollup_metadata_repr.ml sc_rollup_metadata_repr.mli sc_rollup_tick_repr.ml sc_rollup_tick_repr.mli sc_rollup_inbox_message_repr.ml sc_rollup_inbox_message_repr.mli + sc_rollup_inbox_merkelized_payload_hashes_repr.ml + sc_rollup_inbox_merkelized_payload_hashes_repr.mli sc_rollup_outbox_message_repr.ml sc_rollup_outbox_message_repr.mli sc_rollup_PVM_sig.ml sc_rollup_arith.ml sc_rollup_arith.mli @@ -607,6 +610,8 @@ sc_rollup_metadata_repr.ml sc_rollup_metadata_repr.mli sc_rollup_tick_repr.ml sc_rollup_tick_repr.mli sc_rollup_inbox_message_repr.ml sc_rollup_inbox_message_repr.mli + sc_rollup_inbox_merkelized_payload_hashes_repr.ml + sc_rollup_inbox_merkelized_payload_hashes_repr.mli sc_rollup_outbox_message_repr.ml sc_rollup_outbox_message_repr.mli sc_rollup_PVM_sig.ml sc_rollup_arith.ml sc_rollup_arith.mli @@ -866,6 +871,8 @@ sc_rollup_metadata_repr.ml sc_rollup_metadata_repr.mli sc_rollup_tick_repr.ml sc_rollup_tick_repr.mli sc_rollup_inbox_message_repr.ml sc_rollup_inbox_message_repr.mli + sc_rollup_inbox_merkelized_payload_hashes_repr.ml + sc_rollup_inbox_merkelized_payload_hashes_repr.mli sc_rollup_outbox_message_repr.ml sc_rollup_outbox_message_repr.mli sc_rollup_PVM_sig.ml sc_rollup_arith.ml sc_rollup_arith.mli diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml new file mode 100644 index 0000000000000000000000000000000000000000..44f2efee02dfd1cfb34769025d0e128e60cbdbca --- /dev/null +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.ml @@ -0,0 +1,248 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += (* `Permanent *) Merkelized_payload_hashes_proof_error of string + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"sc_rollup_inbox_message_repr.merkelized_payload_hashes_proof_error" + ~title: + "Internal error: error occurred during proof production or validation" + ~description:"A merkelized payload hashes proof error." + ~pp:(fun ppf e -> Format.fprintf ppf "Proof error: %s" e) + (obj1 (req "error" string)) + (function Merkelized_payload_hashes_proof_error e -> Some e | _ -> None) + (fun e -> Merkelized_payload_hashes_proof_error e) + +module Skip_list_parameters = struct + let basis = 2 +end + +module Skip_list = Skip_list_repr.Make (Skip_list_parameters) + +(* 32 *) +let hash_prefix = "\003\250\174\238\238" (* scib2(55) *) + +module Hash = struct + let prefix = "scib2" + + let encoded_size = 55 + + module H = + Blake2B.Make + (Base58) + (struct + let name = "merkelized_payload_hashes_hash" + + let title = + "The merkelized payload hashes' hash of the smart contract rollup \ + inbox" + + let b58check_prefix = hash_prefix + + (* defaults to 32 *) + let size = None + end) + + include H + + let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size +end + +type t = (Sc_rollup_inbox_message_repr.Hash.t, Hash.t) Skip_list.cell + +let equal = Skip_list.equal Hash.equal Sc_rollup_inbox_message_repr.Hash.equal + +let hash merkelized = + let payload_hash = Skip_list.content merkelized in + let back_pointers_hashes = Skip_list.back_pointers merkelized in + Sc_rollup_inbox_message_repr.Hash.to_bytes payload_hash + :: List.map Hash.to_bytes back_pointers_hashes + |> Hash.hash_bytes + +let pp = + Skip_list.pp ~pp_content:Sc_rollup_inbox_message_repr.Hash.pp ~pp_ptr:Hash.pp + +let encoding = + Skip_list.encoding Hash.encoding Sc_rollup_inbox_message_repr.Hash.encoding + +type merkelized_and_payload = { + merkelized : t; + payload : Sc_rollup_inbox_message_repr.serialized; +} + +let equal_merkelized_and_payload {merkelized; payload} mp2 = + equal merkelized mp2.merkelized + && String.equal (payload :> string) (mp2.payload :> string) + +let pp_merkelized_and_payload fmt {merkelized; payload} = + Format.fprintf + fmt + "@[merkelized:@,%a@,payload: %a@]" + pp + merkelized + Format.pp_print_string + (payload :> string) + +let merkelized_and_payload_encoding = + let open Data_encoding in + conv + (fun {merkelized; payload} -> (merkelized, (payload :> string))) + (fun (merkelized, payload) -> + { + merkelized; + payload = Sc_rollup_inbox_message_repr.unsafe_of_string payload; + }) + (merge_objs encoding (obj1 (req "payload" string))) + +module History = struct + include + Bounded_history_repr.Make + (struct + let name = "level_inbox_history" + end) + (Hash) + (struct + type nonrec t = merkelized_and_payload + + let pp = pp_merkelized_and_payload + + let equal = equal_merkelized_and_payload + + let encoding = merkelized_and_payload_encoding + end) + + let no_history = empty ~capacity:0L +end + +let remember history merkelized payload = + let prev_cell_ptr = hash merkelized in + History.remember prev_cell_ptr {merkelized; payload} history + +let genesis history payload = + let open Result_syntax in + let payload_hash = + Sc_rollup_inbox_message_repr.hash_serialized_message payload + in + let merkelized = Skip_list.genesis payload_hash in + let+ history = remember history merkelized payload in + (history, merkelized) + +let add_payload history prev_merkelized payload = + let open Result_syntax in + let prev_merkelized_ptr = hash prev_merkelized in + let merkelized = + Skip_list.next + ~prev_cell:prev_merkelized + ~prev_cell_ptr:prev_merkelized_ptr + (Sc_rollup_inbox_message_repr.hash_serialized_message payload) + in + let* history = remember history merkelized payload in + return (history, merkelized) + +let get_payload_hash = Skip_list.content + +let get_index = Skip_list.index + +type proof = t list + +let pp_proof = Format.pp_print_list pp + +let proof_encoding = Data_encoding.list encoding + +let produce_proof history ~index merkelized = + let open Option_syntax in + let deref ptr = + let* {merkelized; payload = _} = History.find ptr history in + return merkelized + in + let current_ptr = hash merkelized in + let lift_ptr = + let rec aux acc = function + | [] -> None + | [last_ptr] -> + let+ ({merkelized; _} as merkelized_and_payload) = + History.find last_ptr history + in + (merkelized_and_payload, List.rev (merkelized :: acc)) + | ptr :: rest -> + let* merkelized = deref ptr in + aux (merkelized :: acc) rest + in + aux [] + in + let* ptr_path = + Skip_list.back_path ~deref ~cell_ptr:current_ptr ~target_index:index + in + lift_ptr ptr_path + +let verify_proof inclusion_proof = + let open Result_syntax in + let* cell = + match inclusion_proof with + | cell :: _ -> ok cell + | [] -> + error (Merkelized_payload_hashes_proof_error "inclusion proof is empty") + in + let rec aux (hash_map, ptr_list) = function + | [] -> + error (Merkelized_payload_hashes_proof_error "inclusion proof is empty") + | [target] -> + let target_ptr = hash target in + let hash_map = Hash.Map.add target_ptr target hash_map in + let ptr_list = List.rev (target_ptr :: ptr_list) in + ok (hash_map, ptr_list, target, target_ptr) + | merkelized :: tail -> + let ptr = hash merkelized in + aux (Hash.Map.add ptr merkelized hash_map, ptr :: ptr_list) tail + in + let* hash_map, ptr_list, target, target_ptr = + aux (Hash.Map.empty, []) inclusion_proof + in + let deref ptr = Hash.Map.find ptr hash_map in + let cell_ptr = hash cell in + let* () = + error_unless + (Skip_list.valid_back_path + ~equal_ptr:Hash.equal + ~deref + ~cell_ptr + ~target_ptr + ptr_list) + (Merkelized_payload_hashes_proof_error "invalid inclusion proof") + in + return (target, cell) + +module Internal_for_tests = struct + let find_predecessor_payload payloads_history ~index payloads = + let open Option_syntax in + let deref ptr = + let* {merkelized; _} = History.find ptr payloads_history in + return merkelized + in + let cell_ptr = hash payloads in + Skip_list.find ~deref ~cell_ptr ~target_index:index +end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.mli new file mode 100644 index 0000000000000000000000000000000000000000..0872181e6c2e9e78ea811669113562d770ae9e26 --- /dev/null +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_merkelized_payload_hashes_repr.mli @@ -0,0 +1,125 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type error += Merkelized_payload_hashes_proof_error of string + +module Hash : S.HASH + +(** A type representing the head of a merkelized list of + {!Sc_rollup_inbox_message_repr.serialized} message. It contains the hash of + the payload and the index on the list. *) +type t + +val encoding : t Data_encoding.t + +type merkelized_and_payload = { + merkelized : t; + payload : Sc_rollup_inbox_message_repr.serialized; +} + +(** A [History.t] is a lookup table of {!merkelized_and_payload}s. Payloads are + indexed by their hash {!Hash.t}. This history is needed in order to produce + {!proof}. + + A subtlety of this [history] type is that it is customizable depending on + how much of the inbox history you actually want to remember, using the + [capacity] parameter. In the L1 we use this with [capacity] set to zero, + which makes it immediately forget an old level as soon as we move to the + next. By contrast, the rollup node uses a history that is sufficiently large + to be able to take part in all potential refutation games occurring during + the challenge period. *) +module History : sig + include + Bounded_history_repr.S + with type key = Hash.t + and type value = merkelized_and_payload + + val no_history : t +end + +(** [hash merkelized] is the hash of [merkelized]. It is used as key to remember + a merkelized payload hash in an {!History.t}. *) +val hash : t -> Hash.t + +(** [remember history merkelized payload] remembers the [{merkelized; payload}] + in [history] with key [hash merkelized]. *) +val remember : + History.t -> + t -> + Sc_rollup_inbox_message_repr.serialized -> + History.t tzresult + +(** [genesis history payload] is the initial merkelized payload hashes with + index 0. It is remembered in [history] using [remember]. *) +val genesis : + History.t -> + Sc_rollup_inbox_message_repr.serialized -> + (History.t * t) tzresult + +(** [add_payload history merkelized payload] creates a new {!t} with [payload] + and [merkelized] as ancestor (i.e. [index = succ (get_index + merkelized)]). [merkelized] is remembered in [history] with [remember]. *) +val add_payload : + History.t -> + t -> + Sc_rollup_inbox_message_repr.serialized -> + (History.t * t) tzresult + +val equal : t -> t -> bool + +val pp : Format.formatter -> t -> unit + +(** [get_payload_hash merkelized] returns the + {!Sc_rollup_inbox_message_repr.serialized} payload's hash of + [merkelized]. *) +val get_payload_hash : t -> Sc_rollup_inbox_message_repr.Hash.t + +(** [get_index merkelized] returns the index of [merkelized]. *) +val get_index : t -> int + +(** Given two t [(a, b)] and a {!Sc_rollup_inbox_message_repr.serialized} +[payload], a [proof] guarantees that [payload] hash is equal to [a] and that + [a] is an ancestor of [b]; i.e. [get_index a < get_index b]. *) +type proof + +val pp_proof : Format.formatter -> proof -> unit + +val proof_encoding : proof Data_encoding.t + +(** [produce_proof history ~index into_] returns a {!merkelized_and_payload} + with index [index] and a proof that it is an ancestor of [into_]. Returns + [None] if no merkelized payload with [index] is found (either in the + [history] or [index] is not inferior to [get_index into_]). *) +val produce_proof : + History.t -> index:int -> t -> (merkelized_and_payload * proof) option + +(** [verify_proof proof] returns [(a, b)] where [proof] validates that [a] is an + ancestor of [b]. Fails when [proof] is not a valid inclusion proof. *) +val verify_proof : proof -> (t * t) tzresult + +module Internal_for_tests : sig + (** [find_predecessor_payload history ~index latest_merkelized] looks for the + {!t} with [index] that is an ancestor of [latest_merkelized]. *) + val find_predecessor_payload : History.t -> index:int -> t -> t option +end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.ml index 04310d03af6173ba29944f3bcd5878fe29301cfa..62effb1292f070d25ecd8ef88aa0e0bbc40d29d8 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.ml @@ -142,3 +142,34 @@ let deserialize s = let unsafe_of_string s = s let unsafe_to_string s = s + +(* 32 *) +let hash_prefix = "\003\250\174\239\012" (* scib3(55) *) + +module Hash = struct + let prefix = "scib3" + + let encoded_size = 55 + + module H = + Blake2B.Make + (Base58) + (struct + let name = "serialized_message_hash" + + let title = + "The hash of a serialized message of the smart contract rollup inbox." + + let b58check_prefix = hash_prefix + + (* defaults to 32 *) + let size = None + end) + + include H + + let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size +end + +let hash_serialized_message (payload : serialized) = + Hash.hash_string [(payload :> string)] diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.mli index 4667640b652630a512ea402bc21d0a14cc57bb85..4c7b273440929fad3dfae512aa339691ca417ad0 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_message_repr.mli @@ -81,3 +81,9 @@ val deserialize : serialized -> t tzresult val unsafe_of_string : string -> serialized val unsafe_to_string : serialized -> string + +module Hash : S.HASH + +(** [hash_serialized_message payload] is the hash of [payload]. It is used by + {!Sc_rollup_inbox_merkelized_payload_hashes_repr.t}. *) +val hash_serialized_message : serialized -> Hash.t diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.ml b/src/proto_alpha/lib_protocol/skip_list_repr.ml index b266f6ae1fec35a3db5773efcffb40762a996669..7821e2034257faa542a4acd2025e044861646447 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.ml +++ b/src/proto_alpha/lib_protocol/skip_list_repr.ml @@ -61,6 +61,12 @@ module type S = sig 'content -> ('content, 'ptr) cell + val find : + deref:('ptr -> ('content, 'ptr) cell option) -> + cell_ptr:'ptr -> + target_index:int -> + ('content, 'ptr) cell option + val back_path : deref:('ptr -> ('content, 'ptr) cell option) -> cell_ptr:'ptr -> @@ -285,21 +291,34 @@ end) : S = struct in binary_search 0 (length cell.back_pointers - 1) - let back_path ~deref ~cell_ptr ~target_index = - Option.bind (deref cell_ptr) @@ fun cell -> + let rev_back_path ~deref ~cell_ptr ~target_index = + let open Option_syntax in + let* cell = deref cell_ptr in let powers = list_powers cell in let rec aux path ptr = let path = ptr :: path in - Option.bind (deref ptr) @@ fun cell -> + let* cell = deref ptr in let index = cell.index in - if Compare.Int.(target_index = index) then Some (List.rev path) - else if Compare.Int.(target_index > index) then None + if Compare.Int.(target_index = index) then return path + else if Compare.Int.(target_index > index) then fail else - Option.bind (best_skip cell target_index powers) @@ fun best_idx -> - Option.bind (back_pointer cell best_idx) @@ fun ptr -> aux path ptr + let* best_idx = best_skip cell target_index powers in + let* ptr = back_pointer cell best_idx in + aux path ptr in aux [] cell_ptr + let find ~deref ~cell_ptr ~target_index = + let open Option_syntax in + let* rev_back_path = rev_back_path ~deref ~cell_ptr ~target_index in + let* cell_ptr = List.hd rev_back_path in + deref cell_ptr + + let back_path ~deref ~cell_ptr ~target_index = + let open Option_syntax in + let+ rev_back_path = rev_back_path ~deref ~cell_ptr ~target_index in + List.rev rev_back_path + let mem equal x l = let open FallbackArray in let n = length l in diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.mli b/src/proto_alpha/lib_protocol/skip_list_repr.mli index 621f2f5f3a3091581d3d267e141dc7f99422d584..41270ed47435c10b81b8804b98bbdd847054a01c 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.mli +++ b/src/proto_alpha/lib_protocol/skip_list_repr.mli @@ -96,6 +96,15 @@ module type S = sig 'content -> ('content, 'ptr) cell + (** [find ~deref ~cell_ptr ~target_index] returns [Some cell] where [cell] is + the cell at position [target_index]. This is done by dereferencing the last + pointer of the path returned by {!back_path}. *) + val find : + deref:('ptr -> ('content, 'ptr) cell option) -> + cell_ptr:'ptr -> + target_index:int -> + ('content, 'ptr) cell option + (** [back_path ~deref ~cell_ptr ~target_index] returns [Some path] where [path] is a sequence of back pointers to traverse to go from [cell_ptr] to the cell at position [target_index] in the diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_game.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_game.ml index 9a0624a8a767f62d9bcff7af6d7dac4b667ee95b..f61effa1d31fddea18e9a3548bfffd5a5e97ffad 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_game.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_game.ml @@ -269,7 +269,7 @@ module Arith_pvm = Sc_rollup_helpers.Arith_pvm let test_invalid_serialized_inbox_proof () = let open Lwt_result_syntax in let open Alpha_context in - let* ctxt = Test_sc_rollup_inbox.create_context () in + let* ctxt = Test_sc_rollup_inbox_legacy.create_context () in let rollup = Sc_rollup.Address.zero in let level = Raw_level.(succ root) in let*! inbox = Sc_rollup.Inbox.empty ctxt level 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 28ff48198d1fe5384cf9d95359305bec5efb728a..81113814d24d5cfec115f544d12b782b03e40216 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 @@ -31,762 +31,176 @@ Subject: These unit tests check the off-line inbox implementation for smart contract rollups *) - open Protocol -open Sc_rollup_inbox_repr - -exception Sc_rollup_inbox_test_error of string - -let err x = Exn (Sc_rollup_inbox_test_error x) - -let rollup = Sc_rollup_repr.Address.hash_string [""] - -let first_level = Raw_level_repr.(succ root) - -let inbox_message_testable = - Alcotest.testable - Sc_rollup_PVM_sig.pp_inbox_message - Sc_rollup_PVM_sig.inbox_message_equal - -let create_context () = - Context.init1 () >>=? fun (block, _contract) -> return block.context - -let make_payload message = - WithExceptions.Result.get_ok ~loc:__LOC__ - @@ Sc_rollup_inbox_message_repr.(serialize @@ External message) - -let payloads_from_messages = - List.map (fun Sc_rollup_helpers.{input_repr = input; _} -> - match input with - | Inbox_message {payload; _} -> payload - | Reveal _ -> assert false) - -let populate_inboxes ctxt level history inbox inboxes level_tree - list_of_payloads = - let open Lwt_syntax in - let rec aux level history inbox inboxes level_tree = function - | [] -> return (ok (level_tree, history, inbox, inboxes)) - | [] :: ps -> - let level = Raw_level_repr.succ level in - aux level history inbox inboxes level_tree ps - | payloads :: ps -> - add_messages ctxt history inbox level payloads level_tree - >|= Environment.wrap_tzresult - >>=? fun (level_tree, history, inbox') -> - let level = Raw_level_repr.succ level in - aux level history inbox' (inbox :: inboxes) (Some level_tree) ps - in - aux level history inbox inboxes level_tree list_of_payloads - -let test_empty () = - create_context () >>=? fun ctxt -> - empty ctxt (Raw_level_repr.of_int32_exn 42l) >>= 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 first_level in - let history = History.empty ~capacity:10000L in - populate_inboxes ctxt first_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") - | Some tree -> f ctxt tree history inbox inboxes - -let test_add_messages messages = - let payloads = List.map make_payload messages in - let nb_payloads = List.length payloads in - setup_inbox_with_messages [payloads] - @@ fun _ctxt _messages _history inbox _inboxes -> - fail_unless - Compare.Int64.( - equal - (number_of_messages_during_commitment_period inbox) - (Int64.of_int nb_payloads)) - (err "Invalid number of messages during commitment period.") - -(* An external message is prefixed with a tag whose length is one byte, and - whose value is 1. *) -let encode_external_message message = - let prefix = "\001" in - Bytes.of_string (prefix ^ message) - -let check_payload messages external_message = - Environment.Context.Tree.find messages ["payload"] >>= function - | None -> fail (err "No payload in messages") - | Some payload -> - let expected_payload = encode_external_message external_message in - fail_unless - (expected_payload = payload) - (err - (Printf.sprintf - "Expected payload %s, got %s" - (Bytes.to_string expected_payload) - (Bytes.to_string payload))) - -let test_get_message_payload messages = - let payloads = List.map make_payload messages in - setup_inbox_with_messages [payloads] - @@ fun _ctxt level_tree _history _inbox _inboxes -> - List.iteri_es - (fun i message -> - let expected_payload = encode_external_message message in - get_message_payload level_tree (Z.of_int i) >>= function - | Some payload -> - let payload = Sc_rollup_inbox_message_repr.unsafe_to_string payload in - fail_unless - (String.equal payload (Bytes.to_string expected_payload)) - (err (Printf.sprintf "Expected %s, got %s" message payload)) - | None -> - fail - (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 _ctxt _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 _ctxt _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."; - ]) - -module Tree = struct - open Tezos_context_memory.Context - type nonrec t = t +let lift k = Environment.wrap_tzresult k - type nonrec tree = tree +module Merkelized_payload_hashes = + Alpha_context.Sc_rollup.Inbox_merkelized_payload_hashes - module Tree = struct - include Tezos_context_memory.Context.Tree - - type nonrec t = t - - type nonrec tree = tree - - type key = string list - - type value = bytes - end - - let commit_tree context key tree = - let open Lwt_syntax in - let* ctxt = Tezos_context_memory.Context.add_tree context key tree in - let* (_ : value_key) = commit ~time:Time.Protocol.epoch ~message:"" ctxt in - return () - - let lookup_tree context hash = - let open Lwt_syntax in - let* _, tree = - produce_tree_proof - (index context) - (`Node (Hash.to_context_hash hash)) - (fun x -> Lwt.return (x, x)) - in - return (Some tree) - - type proof = Proof.tree Proof.t - - let verify_proof proof f = - Lwt.map Result.to_option (verify_tree_proof proof f) - - let produce_proof context tree f = - let open Lwt_syntax in - let* proof = - produce_tree_proof (index context) (`Node (Tree.hash tree)) f - in - return (Some proof) - - let kinded_hash_to_inbox_hash = function - | `Value hash | `Node hash -> Hash.of_context_hash hash - - let proof_before proof = kinded_hash_to_inbox_hash proof.Proof.before - - let proof_encoding = - Tezos_context_merkle_proof_encoding.Merkle_proof_encoding.V1.Tree32 - .tree_proof_encoding -end - -(** This is a second instance of the inbox module. It uses the {!Tree} - module above for its Irmin interface, which gives it a full context - and the ability to generate tree proofs. - - It is intended to resemble (at least well enough for these tests) - the rollup node's inbox instance. *) -module Node = Make_hashing_scheme (Tree) - -(** In the tests below we use the {!Node} inbox above to generate proofs, - but we need to test that they can be interpreted and validated by - the protocol instance of the inbox code. We rely on the two - instances having the same encoding, and use this function to - convert. *) -let node_proof_to_protocol_proof p = - let open Data_encoding.Binary in - let enc = serialized_proof_encoding in - let bytes = Node.to_serialized_proof p |> to_bytes_exn enc in - of_bytes_exn enc bytes |> of_serialized_proof - |> WithExceptions.Option.get ~loc:__LOC__ - -(** 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 = - let open Node in - let open Lwt_syntax in - let* index = Tezos_context_memory.Context.init "foo" in - let ctxt = Tezos_context_memory.Context.empty index in - let* inbox = empty ctxt first_level in - let history = History.empty ~capacity:10000L in - let rec aux level history inbox inboxes level_tree = function - | [] -> return (ok (level_tree, history, inbox, inboxes)) - | payloads :: ps -> - add_messages ctxt history inbox level payloads level_tree - >|= Environment.wrap_tzresult - >>=? fun (level_tree, history, inbox') -> - let level = Raw_level_repr.succ level in - aux level history inbox' (inbox :: inboxes) (Some level_tree) ps - in - aux first_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") - | Some tree -> f ctxt tree history inbox inboxes - -let look_in_tree key tree = - let open Lwt_syntax in - let* x = Tree.Tree.find tree [key] in - match x with - | Some x -> return (tree, x) - | None -> return (tree, Bytes.of_string "nope") - -let key_of_level level = - let level_bytes = - Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level - in - Bytes.to_string level_bytes - -let level_of_int n = Raw_level_repr.of_int32_exn (Int32.of_int n) - -let level_to_int l = Int32.to_int (Raw_level_repr.to_int32 l) - -let payload_string msg = - Sc_rollup_inbox_message_repr.unsafe_of_string - (Bytes.to_string (encode_external_message msg)) - -let inbox_message_of_input input = - match input with Sc_rollup_PVM_sig.Inbox_message x -> Some x | _ -> None - -let next_inbox_message levels_and_messages l n = - let equal = Raw_level_repr.( = ) in - let messages = - WithExceptions.Option.get ~loc:__LOC__ - @@ List.assoc ~equal l levels_and_messages - in - match List.nth messages (Z.to_int n) with - | Some Sc_rollup_helpers.{input_repr = input; _} -> - inbox_message_of_input input - | None -> ( - (* If no input at (l, n), the next input is (l+1, 0). *) - match List.assoc ~equal (Raw_level_repr.succ l) levels_and_messages with - | None -> None - | Some messages -> - let Sc_rollup_helpers.{input_repr = input; _} = - Stdlib.List.hd messages - in - inbox_message_of_input input) +module Message = Alpha_context.Sc_rollup.Inbox_message -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 ctxt current_level_tree history inbox _inboxes -> - let open Lwt_result_syntax in - let* history, history_proof = - Node.form_history_proof ctxt history inbox (Some current_level_tree) - >|= Environment.wrap_tzresult - in - let*! result = Node.produce_proof ctxt history history_proof (l, n) 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 proof = node_proof_to_protocol_proof proof in - let*! verification = verify_proof (l, n) snapshot proof 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 _ -> fail [err "Proof verification failed"]) - | Error _ -> fail [err "Proof production failed"] +let assert_equal_payload ~__LOC__ found (expected : Message.serialized) = + Assert.equal_string + ~loc:__LOC__ + (Message.unsafe_to_string expected) + (Message.unsafe_to_string found) -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 ctxt current_level_tree history inbox _inboxes -> - let open Lwt_result_syntax in - let* history, history_proof = - Node.form_history_proof ctxt history inbox (Some current_level_tree) - >|= Environment.wrap_tzresult - in - let*! result = Node.produce_proof ctxt history history_proof (l, n) 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 _ctxt _ _history _inbox inboxes -> - (* Use the incorrect inbox *) - match List.hd inboxes with - | Some inbox -> ( - let snapshot = take_snapshot inbox in - let proof = node_proof_to_protocol_proof proof 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 _ -> fail [err "Proof production failed"] +let assert_equal_payload_hash ~__LOC__ found expected = + Assert.equal + ~loc:__LOC__ + Message.Hash.equal + "Protocol hashes aren't equal" + Message.Hash.pp + expected + found -(** 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 assert_merkelized_payload ~__LOC__ ~payload_hash ~index found = let open Lwt_result_syntax in + let found_payload_hash = Merkelized_payload_hashes.get_payload_hash found in + let found_index = Merkelized_payload_hashes.get_index found 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 first_level in - let history = - Sc_rollup_inbox_repr.History.Internal_for_tests.empty - ~capacity - ~next_index - in - let payloads = List.map (List.map make_payload) payloads in - populate_inboxes ctxt first_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) = + assert_equal_payload_hash ~__LOC__ found_payload_hash payload_hash + in + Assert.equal_int ~loc:__LOC__ found_index index + +let assert_equal_merkelized_payload ~__LOC__ ~found ~expected = + let payload_hash = Merkelized_payload_hashes.get_payload_hash expected in + let index = Merkelized_payload_hashes.get_index expected in + assert_merkelized_payload ~__LOC__ ~payload_hash ~index found + +let gen_payload_size = QCheck2.Gen.(1 -- 10) + +let gen_payload = + let open QCheck2.Gen in + let+ payload = string_size gen_payload_size in + Message.unsafe_of_string payload + +let gen_payloads = + let open QCheck2.Gen in + list_size (2 -- 50) gen_payload + +let gen_index payloads = + let open QCheck2.Gen in + let max_index = List.length payloads - 1 in + let* index = 0 -- max_index in + return index + +let gen_payloads_and_index = + let open QCheck2.Gen in + let* payloads = gen_payloads in + let* index = gen_index payloads in + return (payloads, index) + +let gen_payloads_and_two_index = + let open QCheck2.Gen in + let* payloads = gen_payloads in + let* index = gen_index payloads in + let* index' = gen_index payloads in + return (payloads, index, index') + +let fill_merkelized_payload history payloads = 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.History.Internal_for_tests.keys history0 in - let hh1 = I.History.Internal_for_tests.keys history1 in - let hh2 = I.History.Internal_for_tests.keys 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* first, payloads = + match payloads with + | x :: xs -> return (x, xs) + | [] -> failwith "empty payloads" + in + let*? history, merkelized_payload = + lift @@ Merkelized_payload_hashes.genesis history first + in + Lwt.return @@ lift + @@ List.fold_left_e + (fun (history, payloads) payload -> + Merkelized_payload_hashes.add_payload history payloads payload) + (history, merkelized_payload) + payloads + +let construct_merkelized_payload payloads = + let history = Merkelized_payload_hashes.History.empty ~capacity:1000L in + fill_merkelized_payload history payloads + +let test_merkelized_payload_history payloads = 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 + let nb_payloads = List.length payloads in + let* history, merkelized_payloads = construct_merkelized_payload payloads in + let* () = + Assert.equal_int + ~loc:__LOC__ + nb_payloads + (Merkelized_payload_hashes.get_index merkelized_payloads + 1) 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.History.Internal_for_tests.keys history0 in - let hh1 = I.History.Internal_for_tests.keys history1 in - let hh2 = I.History.Internal_for_tests.keys 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.") + List.iteri_es + (fun index (expected_payload : Message.serialized) -> + let expected_payload_hash = + Message.hash_serialized_message expected_payload 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 + let found_merkelized_payload = + WithExceptions.Option.get ~loc:__LOC__ + @@ Merkelized_payload_hashes.Internal_for_tests.find_predecessor_payload + history + ~index + merkelized_payloads + in + let found_payload_hash = + Merkelized_payload_hashes.get_payload_hash found_merkelized_payload + in + assert_equal_payload_hash + ~__LOC__ + found_payload_hash + expected_payload_hash) + payloads -(** 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 test_merkelized_payload_proof (payloads, index) = 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 = - let open Result_syntax in - let* v = v |> Environment.wrap_tzresult in - 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.Internal_for_tests.produce_inclusion_proof history0 hp hp - |> Environment.wrap_tzresult - in - let*? ip1 = - proof "history1" - @@ I.Internal_for_tests.produce_inclusion_proof history1 hp hp + let* history, merkelized_payload = construct_merkelized_payload payloads in + let ( Merkelized_payload_hashes. + {merkelized = target_merkelized_payload; payload = proof_payload}, + proof ) = + WithExceptions.Option.get ~loc:__LOC__ + @@ Merkelized_payload_hashes.produce_proof history ~index merkelized_payload in - let*? ip2 = - proof "history2" - @@ I.Internal_for_tests.produce_inclusion_proof history2 hp hp + let payload : Message.serialized = + WithExceptions.Option.get ~loc:__LOC__ @@ List.nth payloads index in + let payload_hash = Message.hash_serialized_message payload in + let* () = assert_equal_payload ~__LOC__ proof_payload payload 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). ") + assert_merkelized_payload + ~__LOC__ + ~index + ~payload_hash + target_merkelized_payload in - let*? hp' = verify_inclusion_proof ip1 hp |> Environment.wrap_tzresult in - let*? hp'' = verify_inclusion_proof ip2 hp |> Environment.wrap_tzresult in - fail_unless - (hp = hp' && hp = hp'') - (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 open Lwt_result_syntax in - let payloads = List.map make_payload payloads in - create_context () >>=? fun ctxt -> - let*! inbox = empty ctxt 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 ctxt inbox inbox_level payloads None - >|= Environment.wrap_tzresult + let*? proof_ancestor_merkelized, proof_current_merkelized = + lift @@ Merkelized_payload_hashes.verify_proof proof 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. *) -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 + let* () = + assert_equal_merkelized_payload + ~__LOC__ + ~found:proof_ancestor_merkelized + ~expected:target_merkelized_payload 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.") + assert_equal_merkelized_payload + ~__LOC__ + ~found:proof_current_merkelized + ~expected:merkelized_payload 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.") + return_unit -let tests = - let msg_size = QCheck2.Gen.(0 -- 100) in - let bounded_string = QCheck2.Gen.string_size msg_size in +let merkelized_payload_tests = [ - Tztest.tztest "Empty inbox" `Quick test_empty; Tztest.tztest_qcheck2 - ~name:"Added messages are available." - QCheck2.Gen.(list_size (1 -- 50) bounded_string) - test_add_messages; + ~count:1000 + ~name:"Merkelized messages: Add messages then retrieve them from history." + gen_payloads + test_merkelized_payload_history; Tztest.tztest_qcheck2 - ~name:"Get message payload." - QCheck2.Gen.(list_size (1 -- 50) bounded_string) - 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. *) - 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." - 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" - 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; - 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; + ~count:1000 + ~name:"Merkelized messages: Produce proof and verify its validity." + gen_payloads_and_index + test_merkelized_payload_proof; ] + +let tests = merkelized_payload_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 new file mode 100644 index 0000000000000000000000000000000000000000..035c6dc3c65d175c737f2e4d26148c41d6800577 --- /dev/null +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox_legacy.ml @@ -0,0 +1,794 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** Testing + ------- + Component: Protocol (smart contract rollup inbox) + Invocation: dune exec src/proto_alpha/lib_protocol/test/unit/main.exe \ + -- test "^\[Unit\] sc rollup inbox legacy$" + Subject: These unit tests check the off-line inbox implementation for + smart contract rollups +*) + +(* This test file is going to soon disappear. Each tests here are going to be + rewritten in [test_sc_rollup_inbox] in multiples MR. *) +open Protocol +open Sc_rollup_inbox_repr + +exception Sc_rollup_inbox_test_error of string + +let err x = Exn (Sc_rollup_inbox_test_error x) + +let rollup = Sc_rollup_repr.Address.hash_string [""] + +let first_level = Raw_level_repr.(succ root) + +let inbox_message_testable = + Alcotest.testable + Sc_rollup_PVM_sig.pp_inbox_message + Sc_rollup_PVM_sig.inbox_message_equal + +let create_context () = + Context.init1 () >>=? fun (block, _contract) -> return block.context + +let make_payload message = + WithExceptions.Result.get_ok ~loc:__LOC__ + @@ Sc_rollup_inbox_message_repr.(serialize @@ External message) + +let payloads_from_messages = + List.map (fun Sc_rollup_helpers.{input_repr = input; _} -> + match input with + | Inbox_message {payload; _} -> payload + | Reveal _ -> assert false) + +let populate_inboxes ctxt level history inbox inboxes level_tree + list_of_payloads = + let open Lwt_syntax in + let rec aux level history inbox inboxes level_tree = function + | [] -> return (ok (level_tree, history, inbox, inboxes)) + | [] :: ps -> + let level = Raw_level_repr.succ level in + aux level history inbox inboxes level_tree ps + | payloads :: ps -> + add_messages ctxt history inbox level payloads level_tree + >|= Environment.wrap_tzresult + >>=? fun (level_tree, history, inbox') -> + let level = Raw_level_repr.succ level in + aux level history inbox' (inbox :: inboxes) (Some level_tree) ps + in + aux level history inbox inboxes level_tree list_of_payloads + +let test_empty () = + create_context () >>=? fun ctxt -> + empty ctxt (Raw_level_repr.of_int32_exn 42l) >>= 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 first_level in + let history = History.empty ~capacity:10000L in + populate_inboxes ctxt first_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") + | Some tree -> f ctxt tree history inbox inboxes + +let test_add_messages messages = + let payloads = List.map make_payload messages in + let nb_payloads = List.length payloads in + setup_inbox_with_messages [payloads] + @@ fun _ctxt _messages _history inbox _inboxes -> + fail_unless + Compare.Int64.( + equal + (number_of_messages_during_commitment_period inbox) + (Int64.of_int nb_payloads)) + (err "Invalid number of messages during commitment period.") + +(* An external message is prefixed with a tag whose length is one byte, and + whose value is 1. *) +let encode_external_message message = + let prefix = "\001" in + Bytes.of_string (prefix ^ message) + +let check_payload messages external_message = + Environment.Context.Tree.find messages ["payload"] >>= function + | None -> fail (err "No payload in messages") + | Some payload -> + let expected_payload = encode_external_message external_message in + fail_unless + (expected_payload = payload) + (err + (Printf.sprintf + "Expected payload %s, got %s" + (Bytes.to_string expected_payload) + (Bytes.to_string payload))) + +let test_get_message_payload messages = + let payloads = List.map make_payload messages in + setup_inbox_with_messages [payloads] + @@ fun _ctxt level_tree _history _inbox _inboxes -> + List.iteri_es + (fun i message -> + let expected_payload = encode_external_message message in + get_message_payload level_tree (Z.of_int i) >>= function + | Some payload -> + let payload = Sc_rollup_inbox_message_repr.unsafe_to_string payload in + fail_unless + (String.equal payload (Bytes.to_string expected_payload)) + (err (Printf.sprintf "Expected %s, got %s" message payload)) + | None -> + fail + (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 _ctxt _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 _ctxt _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."; + ]) + +module Tree = struct + open Tezos_context_memory.Context + + type nonrec t = t + + type nonrec tree = tree + + module Tree = struct + include Tezos_context_memory.Context.Tree + + type nonrec t = t + + type nonrec tree = tree + + type key = string list + + type value = bytes + end + + let commit_tree context key tree = + let open Lwt_syntax in + let* ctxt = Tezos_context_memory.Context.add_tree context key tree in + let* (_ : value_key) = commit ~time:Time.Protocol.epoch ~message:"" ctxt in + return () + + let lookup_tree context hash = + let open Lwt_syntax in + let* _, tree = + produce_tree_proof + (index context) + (`Node (Hash.to_context_hash hash)) + (fun x -> Lwt.return (x, x)) + in + return (Some tree) + + type proof = Proof.tree Proof.t + + let verify_proof proof f = + Lwt.map Result.to_option (verify_tree_proof proof f) + + let produce_proof context tree f = + let open Lwt_syntax in + let* proof = + produce_tree_proof (index context) (`Node (Tree.hash tree)) f + in + return (Some proof) + + let kinded_hash_to_inbox_hash = function + | `Value hash | `Node hash -> Hash.of_context_hash hash + + let proof_before proof = kinded_hash_to_inbox_hash proof.Proof.before + + let proof_encoding = + Tezos_context_merkle_proof_encoding.Merkle_proof_encoding.V1.Tree32 + .tree_proof_encoding +end + +(** This is a second instance of the inbox module. It uses the {!Tree} + module above for its Irmin interface, which gives it a full context + and the ability to generate tree proofs. + + It is intended to resemble (at least well enough for these tests) + the rollup node's inbox instance. *) +module Node = Make_hashing_scheme (Tree) + +(** In the tests below we use the {!Node} inbox above to generate proofs, + but we need to test that they can be interpreted and validated by + the protocol instance of the inbox code. We rely on the two + instances having the same encoding, and use this function to + convert. *) +let node_proof_to_protocol_proof p = + let open Data_encoding.Binary in + let enc = serialized_proof_encoding in + let bytes = Node.to_serialized_proof p |> to_bytes_exn enc in + of_bytes_exn enc bytes |> of_serialized_proof + |> WithExceptions.Option.get ~loc:__LOC__ + +(** 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 = + let open Node in + let open Lwt_syntax in + let* index = Tezos_context_memory.Context.init "foo" in + let ctxt = Tezos_context_memory.Context.empty index in + let* inbox = empty ctxt first_level in + let history = History.empty ~capacity:10000L in + let rec aux level history inbox inboxes level_tree = function + | [] -> return (ok (level_tree, history, inbox, inboxes)) + | payloads :: ps -> + add_messages ctxt history inbox level payloads level_tree + >|= Environment.wrap_tzresult + >>=? fun (level_tree, history, inbox') -> + let level = Raw_level_repr.succ level in + aux level history inbox' (inbox :: inboxes) (Some level_tree) ps + in + aux first_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") + | Some tree -> f ctxt tree history inbox inboxes + +let look_in_tree key tree = + let open Lwt_syntax in + let* x = Tree.Tree.find tree [key] in + match x with + | Some x -> return (tree, x) + | None -> return (tree, Bytes.of_string "nope") + +let key_of_level level = + let level_bytes = + Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level + in + Bytes.to_string level_bytes + +let level_of_int n = Raw_level_repr.of_int32_exn (Int32.of_int n) + +let level_to_int l = Int32.to_int (Raw_level_repr.to_int32 l) + +let payload_string msg = + Sc_rollup_inbox_message_repr.unsafe_of_string + (Bytes.to_string (encode_external_message msg)) + +let inbox_message_of_input input = + match input with Sc_rollup_PVM_sig.Inbox_message x -> Some x | _ -> None + +let next_inbox_message levels_and_messages l n = + let equal = Raw_level_repr.( = ) in + let messages = + WithExceptions.Option.get ~loc:__LOC__ + @@ List.assoc ~equal l levels_and_messages + in + match List.nth messages (Z.to_int n) with + | Some Sc_rollup_helpers.{input_repr = input; _} -> + inbox_message_of_input input + | None -> ( + (* If no input at (l, n), the next input is (l+1, 0). *) + match List.assoc ~equal (Raw_level_repr.succ l) levels_and_messages with + | None -> None + | Some messages -> + let Sc_rollup_helpers.{input_repr = input; _} = + Stdlib.List.hd messages + in + inbox_message_of_input input) + +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 ctxt current_level_tree history inbox _inboxes -> + let open Lwt_result_syntax in + let* history, history_proof = + Node.form_history_proof ctxt history inbox (Some current_level_tree) + >|= Environment.wrap_tzresult + in + let*! result = Node.produce_proof ctxt history history_proof (l, n) 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 proof = node_proof_to_protocol_proof proof in + let*! verification = verify_proof (l, n) snapshot proof 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 _ -> fail [err "Proof verification failed"]) + | Error _ -> fail [err "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 ctxt current_level_tree history inbox _inboxes -> + let open Lwt_result_syntax in + let* history, history_proof = + Node.form_history_proof ctxt history inbox (Some current_level_tree) + >|= Environment.wrap_tzresult + in + let*! result = Node.produce_proof ctxt history history_proof (l, n) 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 _ctxt _ _history _inbox inboxes -> + (* Use the incorrect inbox *) + match List.hd inboxes with + | Some inbox -> ( + let snapshot = take_snapshot inbox in + let proof = node_proof_to_protocol_proof proof 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 _ -> 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 first_level in + let history = + Sc_rollup_inbox_repr.History.Internal_for_tests.empty + ~capacity + ~next_index + in + let payloads = List.map (List.map make_payload) payloads in + populate_inboxes ctxt first_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.History.Internal_for_tests.keys history0 in + let hh1 = I.History.Internal_for_tests.keys history1 in + let hh2 = I.History.Internal_for_tests.keys 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.History.Internal_for_tests.keys history0 in + let hh1 = I.History.Internal_for_tests.keys history1 in + let hh2 = I.History.Internal_for_tests.keys 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 = + let open Result_syntax in + let* v = v |> Environment.wrap_tzresult in + 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.Internal_for_tests.produce_inclusion_proof history0 hp hp + |> Environment.wrap_tzresult + in + let*? ip1 = + proof "history1" + @@ I.Internal_for_tests.produce_inclusion_proof history1 hp hp + in + let*? ip2 = + proof "history2" + @@ I.Internal_for_tests.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 + let*? hp' = verify_inclusion_proof ip1 hp |> Environment.wrap_tzresult in + let*? hp'' = verify_inclusion_proof ip2 hp |> Environment.wrap_tzresult in + fail_unless + (hp = hp' && hp = hp'') + (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 open Lwt_result_syntax in + let payloads = List.map make_payload payloads in + create_context () >>=? fun ctxt -> + let*! inbox = empty ctxt 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 ctxt 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. *) +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 + [ + Tztest.tztest "Empty inbox" `Quick test_empty; + Tztest.tztest_qcheck2 + ~name:"Added messages are available." + QCheck2.Gen.(list_size (1 -- 50) bounded_string) + test_add_messages; + Tztest.tztest_qcheck2 + ~name:"Get message payload." + QCheck2.Gen.(list_size (1 -- 50) bounded_string) + 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. *) + 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." + 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" + 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; + 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; + ] diff --git a/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml b/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml index ba605fa96fa2d514f38bdb2f344a8eb5163c9ec0..3db8327f5efff09a1d7a88284fc0edd3c47b8ce2 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml @@ -96,6 +96,9 @@ struct let back_path list start stop = back_path ~deref:(deref list) ~cell_ptr:start ~target_index:stop + let find list start stop = + find ~deref:(deref list) ~cell_ptr:start ~target_index:stop + let search list start target_content = search ~deref:(deref list) @@ -112,6 +115,70 @@ struct let rec nlist basis n = if n = 0 then zero else succ (nlist basis (n - 1)) + let check_find i j = + let open Lwt_result_syntax in + let l = nlist basis i in + let*? () = + match find l i j with + | None -> error (err (Printf.sprintf "There must be a cell (%d)" i)) + | Some cell -> + error_unless + (index cell = j) + (err + (Printf.sprintf + "Found cell is not the correct one (found %d, expected %d)" + (index cell) + j)) + in + let*? path = + match back_path l i j with + | None -> + error (err (Printf.sprintf "There must be path from %d to %d" i j)) + | Some path -> ok path + in + let*? () = + match List.(hd (rev path)) with + | None -> + error + (err + (Printf.sprintf + " There can't be an empty path from %d to %d" + i + j)) + | Some stop_cell -> + error_unless + (j = stop_cell) + (err + (Printf.sprintf + "Found cell is not equal to stop cell of back path (%d to %d)" + i + j)) + in + return_unit + + let check_invalid_find i = + let open Lwt_result_syntax in + let l = nlist basis i in + let check_nothing_found i j = + match find l i j with + | None -> ok () + | Some _v -> + error + (err + (Printf.sprintf + "There should be no value found at %d from %d" + i + j)) + in + let*? () = check_nothing_found i (-1) in + let rec aux j = + if i <= j then return_unit + else + let*? () = check_nothing_found j i in + aux (j + 1) + in + aux 0 + let check_path i j back_path_fn = let l = nlist basis i in match back_path_fn l i j with @@ -264,6 +331,18 @@ let test_skip_list_nat_check_path (basis, i, j) = end) in M.check_path i j M.back_path +let test_skip_list_nat_check_find (basis, i, j) = + let module M = TestNat (struct + let basis = basis + end) in + M.check_find i j + +let test_skip_list_nat_check_invalid_find (basis, i) = + let module M = TestNat (struct + let basis = basis + end) in + M.check_invalid_find i + let test_skip_list_nat_check_invalid_path (basis, i) = let module M = TestNat (struct let basis = basis @@ -394,6 +473,23 @@ let tests = let* j = 0 -- i in return (basis, i, j)) test_skip_list_nat_check_path; + Tztest.tztest_qcheck2 + ~name:"Skip list: find cell with `find` and `check`" + ~count:10 + QCheck2.Gen.( + let* basis = frequency [(5, pure 2); (1, 2 -- 73)] in + let* i = 0 -- 100 in + let* j = 0 -- i in + return (basis, i, j)) + test_skip_list_nat_check_find; + Tztest.tztest_qcheck2 + ~name:"Skip list: `find` won't produce invalid value" + ~count:10 + QCheck2.Gen.( + let* basis = frequency [(5, pure 2); (1, 2 -- 73)] in + let* i = 0 -- 100 in + return (basis, i)) + test_skip_list_nat_check_invalid_find; Tztest.tztest_qcheck2 ~name:"Skip list: `back_path` won't produce invalid paths" ~count:10 @@ -425,7 +521,7 @@ let tests = test_skip_list_nat_check_invalid_path_with_search; (* We cheat here to avoid mixing non-pbt tests with pbt tests. *) Tztest.tztest_qcheck2 - ~name:"Skip list: `seearch` may not produce minimal path" + ~name:"Skip list: `search` may not produce minimal path" ~count:10 QCheck2.Gen.unit test_search_non_minimal_back_path;