From 19811f89dc9455e557c2c1f7525c75f4b1454c47 Mon Sep 17 00:00:00 2001 From: "iguerNL@Functori" Date: Thu, 1 Sep 2022 22:58:17 +0200 Subject: [PATCH] Proto/Scoru: add a separate functor for history cache in Inbox --- .../bin_sc_rollup_node/context.mli | 2 - src/proto_alpha/bin_sc_rollup_node/inbox.ml | 3 +- src/proto_alpha/bin_sc_rollup_node/inbox.mli | 2 +- .../bin_sc_rollup_node/refutation_game.ml | 3 +- .../sc_rollup_node_errors.ml | 6 +- src/proto_alpha/bin_sc_rollup_node/store.ml | 4 +- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 1 + .../lib_protocol/alpha_context.mli | 35 ++- .../lib_protocol/bounded_history_repr.ml | 268 ++++++++++++++++++ .../lib_protocol/bounded_history_repr.mli | 114 ++++++++ src/proto_alpha/lib_protocol/dune | 4 + .../lib_protocol/sc_rollup_inbox_repr.ml | 238 +++------------- .../lib_protocol/sc_rollup_inbox_repr.mli | 53 ++-- .../lib_protocol/sc_rollup_proof_repr.ml | 2 +- .../lib_protocol/sc_rollup_proof_repr.mli | 2 +- .../test/pbt/test_refutation_game.ml | 13 +- .../test/unit/test_sc_rollup_inbox.ml | 121 +++++--- 17 files changed, 556 insertions(+), 315 deletions(-) create mode 100644 src/proto_alpha/lib_protocol/bounded_history_repr.ml create mode 100644 src/proto_alpha/lib_protocol/bounded_history_repr.mli diff --git a/src/proto_alpha/bin_sc_rollup_node/context.mli b/src/proto_alpha/bin_sc_rollup_node/context.mli index f547f757a0a3..d862a64055b4 100644 --- a/src/proto_alpha/bin_sc_rollup_node/context.mli +++ b/src/proto_alpha/bin_sc_rollup_node/context.mli @@ -153,8 +153,6 @@ module Inbox : sig type history_proof = Sc_rollup.Inbox.history_proof - type history = Sc_rollup.Inbox.history - include Sc_rollup.Inbox.Merkelized_operations with type tree = MessageTrees.value diff --git a/src/proto_alpha/bin_sc_rollup_node/inbox.ml b/src/proto_alpha/bin_sc_rollup_node/inbox.ml index 750b804b1896..65eb6bd66be2 100644 --- a/src/proto_alpha/bin_sc_rollup_node/inbox.ml +++ b/src/proto_alpha/bin_sc_rollup_node/inbox.ml @@ -94,8 +94,7 @@ module State = struct let*! block_level = Layer1.level_of_hash node_ctxt.store block_hash in let block_level = Raw_level.of_int32_exn block_level in if Raw_level.(block_level <= node_ctxt.genesis_info.level) then - return - @@ Sc_rollup.Inbox.history_at_genesis ~capacity:(Int64.of_int 60000) + return @@ Sc_rollup.Inbox.History.empty ~capacity:60000L else failwith "The inbox history for hash %a is missing." diff --git a/src/proto_alpha/bin_sc_rollup_node/inbox.mli b/src/proto_alpha/bin_sc_rollup_node/inbox.mli index 8e2f87bf06dd..b9895ae2bec9 100644 --- a/src/proto_alpha/bin_sc_rollup_node/inbox.mli +++ b/src/proto_alpha/bin_sc_rollup_node/inbox.mli @@ -48,7 +48,7 @@ val inbox_of_hash : (** [history_of_hash node_ctxt block_hash] returns the rollup inbox history at the end of the given validation of [block_hash]. *) val history_of_hash : - Node_context.t -> Block_hash.t -> Sc_rollup.Inbox.history tzresult Lwt.t + Node_context.t -> Block_hash.t -> Sc_rollup.Inbox.History.t tzresult Lwt.t (** [start ()] initializes the inbox to track the messages being published. *) val start : unit -> unit Lwt.t diff --git a/src/proto_alpha/bin_sc_rollup_node/refutation_game.ml b/src/proto_alpha/bin_sc_rollup_node/refutation_game.ml index 9f0a451025aa..82631b07af5a 100644 --- a/src/proto_alpha/bin_sc_rollup_node/refutation_game.ml +++ b/src/proto_alpha/bin_sc_rollup_node/refutation_game.ml @@ -94,12 +94,13 @@ module Make (Interpreter : Interpreter.S) : let* inbox = Inbox.inbox_of_hash node_ctxt hash in let* ctxt = Node_context.checkout_context node_ctxt hash in let*! messages_tree = Context.MessageTrees.find ctxt in - let*! history, history_proof = + let* history, history_proof = Context.Inbox.form_history_proof node_ctxt.context history inbox messages_tree + >|= Environment.wrap_tzresult in let module P = struct include PVM diff --git a/src/proto_alpha/bin_sc_rollup_node/sc_rollup_node_errors.ml b/src/proto_alpha/bin_sc_rollup_node/sc_rollup_node_errors.ml index af75ffce06a3..33db3b852e10 100644 --- a/src/proto_alpha/bin_sc_rollup_node/sc_rollup_node_errors.ml +++ b/src/proto_alpha/bin_sc_rollup_node/sc_rollup_node_errors.ml @@ -27,7 +27,7 @@ open Protocol.Alpha_context type error += | Cannot_produce_proof of - Sc_rollup.Inbox.t * Sc_rollup.Inbox.history * Raw_level.t + Sc_rollup.Inbox.t * Sc_rollup.Inbox.History.t * Raw_level.t | Missing_mode_operators of {mode : string; missing_operators : string list} | Bad_minimal_fees of string | Commitment_predecessor_should_be_LCC of Sc_rollup.Commitment.t @@ -102,12 +102,12 @@ let () = inbox Raw_level.pp level - Sc_rollup.Inbox.pp_history + Sc_rollup.Inbox.History.pp history) Data_encoding.( obj3 (req "inbox" Sc_rollup.Inbox.encoding) - (req "history" Sc_rollup.Inbox.history_encoding) + (req "history" Sc_rollup.Inbox.History.encoding) (req "level" Raw_level.encoding)) (function | Cannot_produce_proof (inbox, history, level) -> diff --git a/src/proto_alpha/bin_sc_rollup_node/store.ml b/src/proto_alpha/bin_sc_rollup_node/store.ml index 0767e8c18d6a..3811ac199a33 100644 --- a/src/proto_alpha/bin_sc_rollup_node/store.ml +++ b/src/proto_alpha/bin_sc_rollup_node/store.ml @@ -318,9 +318,9 @@ module Histories = Make_append_only_map (struct let string_of_key = Block_hash.to_b58check - type value = Sc_rollup.Inbox.history + type value = Sc_rollup.Inbox.History.t - let value_encoding = Sc_rollup.Inbox.history_encoding + let value_encoding = Sc_rollup.Inbox.History.encoding end) module Commitments = Make_append_only_map (struct diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 0ce62ae16032..1d09ad48c453 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -44,6 +44,7 @@ "Contract_repr", "Indexable", "Entrypoint_repr", + "Bounded_history_repr", "Sc_rollup_repr", "Sc_rollup_tick_repr", "Sc_rollup_inbox_message_repr", diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 9dcf7e00be34..64e2726632d2 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2931,8 +2931,6 @@ module Sc_rollup : sig type history_proof - type history - module Hash : sig include S.HASH @@ -2941,6 +2939,11 @@ module Sc_rollup : sig val to_context_hash : t -> Context_hash.t end + module History : + Bounded_history_repr.S + with type key = Hash.t + and type value = history_proof + type serialized_proof val serialized_proof_encoding : serialized_proof Data_encoding.t @@ -2954,20 +2957,14 @@ module Sc_rollup : sig val new_level_tree : inbox_context -> Raw_level.t -> tree Lwt.t - val history_encoding : history Data_encoding.t - - val pp_history : Format.formatter -> history -> unit - - val history_at_genesis : capacity:int64 -> history - val add_messages : inbox_context -> - history -> + History.t -> t -> Raw_level.t -> Message.serialized list -> tree option -> - (tree * history * t) tzresult Lwt.t + (tree * History.t * t) tzresult Lwt.t val add_messages_no_history : inbox_context -> @@ -2982,10 +2979,10 @@ module Sc_rollup : sig val form_history_proof : inbox_context -> - history -> + History.t -> t -> tree option -> - (history * history_proof) Lwt.t + (History.t * history_proof) tzresult Lwt.t val take_snapshot : t -> history_proof @@ -3016,22 +3013,22 @@ module Sc_rollup : sig val produce_proof : inbox_context -> - history -> + History.t -> history_proof -> Raw_level.t * Z.t -> (proof * Sc_rollup_PVM_sem.input option) tzresult Lwt.t val empty : inbox_context -> Sc_rollup_repr.t -> Raw_level.t -> t Lwt.t + (*xx*) 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 - val produce_inclusion_proof : - history -> history_proof -> history_proof -> inclusion_proof option + History.t -> + history_proof -> + history_proof -> + inclusion_proof option tzresult end end @@ -3437,7 +3434,7 @@ module Sc_rollup : sig val inbox : Inbox.history_proof - val history : Inbox.history + val history : Inbox.History.t end end diff --git a/src/proto_alpha/lib_protocol/bounded_history_repr.ml b/src/proto_alpha/lib_protocol/bounded_history_repr.ml new file mode 100644 index 000000000000..16933102e3b5 --- /dev/null +++ b/src/proto_alpha/lib_protocol/bounded_history_repr.ml @@ -0,0 +1,268 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module type KEY = sig + type t + + val compare : t -> t -> int + + val pp : Format.formatter -> t -> unit + + val encoding : t Data_encoding.t +end + +module type VALUE = sig + type t + + val equal : t -> t -> bool + + val pp : Format.formatter -> t -> unit + + val encoding : t Data_encoding.t +end + +module type S = sig + type t + + type key + + type value + + val empty : capacity:int64 -> t + + val encoding : t Data_encoding.t + + val pp : Format.formatter -> t -> unit + + val find : key -> t -> value option + + type error += + | Key_bound_to_different_value of { + key : key; + existing_value : value; + given_value : value; + } + + val remember : key -> value -> t -> t tzresult + + module Internal_for_tests : sig + val empty : capacity:int64 -> next_index:int64 -> t + + val keys : t -> key list + end +end + +module Make (Key : KEY) (Value : VALUE) : + S with type key = Key.t and type value = Value.t = struct + type key = Key.t + + type value = Value.t + + module Int64_map = Map.Make (Int64) + module Map = Map.Make (Key) + + type t = { + events : value Map.t; + (** Values stored in the structure, indexes with the keys. *) + sequence : key Int64_map.t; + (** An additional map from int64 indexes to keys, to be able + to remove old entries when the structure is full. *) + capacity : int64; + (** The max number of the entries in the structure. Once the maximum size + is reached, older entries are deleted to free space for new ones. *) + next_index : int64; + (** The index to use for the next entry to add in the structure. *) + oldest_index : int64; + (** The oldest index of the (oldest) entry that has been added to the + data structure. If the structure is empty, [oldest_index] is + equal to [next_index]. *) + size : int64; + (** Counts the number of entries that are stored in history. It + satisfies the invariant: `0 <= size <= capacity` *) + } + + let encoding : t Data_encoding.t = + let open Data_encoding in + let events_encoding = + Data_encoding.conv + Map.bindings + (fun l -> Map.add_seq (List.to_seq l) Map.empty) + Data_encoding.(list (tup2 Key.encoding Value.encoding)) + in + let sequence_encoding = + conv + Int64_map.bindings + (List.fold_left (fun m (k, v) -> Int64_map.add k v m) Int64_map.empty) + (list (tup2 int64 Key.encoding)) + in + conv + (fun {events; sequence; capacity; next_index; oldest_index; size} -> + (events, sequence, capacity, next_index, oldest_index, size)) + (fun (events, sequence, capacity, next_index, oldest_index, size) -> + {events; sequence; capacity; next_index; oldest_index; size}) + (obj6 + (req "events" events_encoding) + (req "sequence" sequence_encoding) + (req "capacity" int64) + (req "next_index" int64) + (req "oldest_index" int64) + (req "size" int64)) + + let pp fmt {events; sequence; capacity; size; oldest_index; next_index} = + Map.bindings events |> fun bindings -> + Int64_map.bindings sequence |> fun sequence_bindings -> + let pp_binding fmt (hash, history_proof) = + Format.fprintf fmt "@[%a -> %a@;@]" Key.pp hash Value.pp history_proof + in + let pp_sequence_binding fmt (counter, hash) = + Format.fprintf fmt "@[%s -> %a@;@]" (Int64.to_string counter) Key.pp hash + in + Format.fprintf + fmt + "@[History:@;\ + \ { capacity: %Ld;@;\ + \ current size: %Ld;@;\ + \ oldest index: %Ld;@;\ + \ next_index : %Ld;@;\ + \ bindings: %a;@;\ + \ sequence: %a; }@]" + capacity + size + oldest_index + next_index + (Format.pp_print_list pp_binding) + bindings + (Format.pp_print_list pp_sequence_binding) + sequence_bindings + + let empty ~capacity = + let next_index = 0L in + { + events = Map.empty; + sequence = Int64_map.empty; + capacity; + next_index; + oldest_index = next_index; + size = 0L; + } + + type error += + | Key_bound_to_different_value of { + key : key; + existing_value : value; + given_value : value; + } + + let () = + register_error_kind + `Temporary + ~id:"Bounded_history_repr.key_bound_to_different_value" + ~title:"Key already bound to a different value." + ~description: + "Remember called with a key that is already bound to a different\n\ + \ value." + Data_encoding.( + obj3 + (req "key" Key.encoding) + (req "existing_value" Value.encoding) + (req "given_value" Value.encoding)) + (function + | Key_bound_to_different_value {key; existing_value; given_value} -> + Some (key, existing_value, given_value) + | _ -> None) + (fun (key, existing_value, given_value) -> + Key_bound_to_different_value {key; existing_value; given_value}) + + let remember key value t = + let open Tzresult_syntax in + if Compare.Int64.(t.capacity <= 0L) then return t + else + match Map.find key t.events with + | Some value' when not (Value.equal value value') -> + error + @@ Key_bound_to_different_value + {key; existing_value = value'; given_value = value} + | _ -> ( + let events = Map.add key value t.events in + let current_index = t.next_index in + let next_index = Int64.succ current_index in + let t = + { + events; + sequence = Int64_map.add current_index key t.sequence; + capacity = t.capacity; + next_index; + oldest_index = t.oldest_index; + size = Int64.succ t.size; + } + in + (* A negative size means that [t.capacity] is set to [Int64.max_int] + and that the structure is full, so adding a new entry makes the size + overflows. In this case, we remove an element in the else branch to + keep the size of the structure equal to [Int64.max_int] at most. *) + if Compare.Int64.(t.size > 0L && t.size <= t.capacity) then return t + else + let l = t.oldest_index in + match Int64_map.find l t.sequence with + | None -> + (* If t.size > t.capacity > 0, there is necessarily + an entry whose index is t.oldest_index in [sequence]. *) + assert false + | Some h -> + let sequence = Int64_map.remove l t.sequence in + let events = Map.remove h events in + return + { + next_index = t.next_index; + capacity = t.capacity; + size = t.capacity; + oldest_index = Int64.succ t.oldest_index; + sequence; + events; + }) + + let find key t = Map.find_opt key t.events + + module Internal_for_tests = struct + let empty ~capacity ~next_index = + {(empty ~capacity) with next_index; oldest_index = next_index} + + let keys {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 diff --git a/src/proto_alpha/lib_protocol/bounded_history_repr.mli b/src/proto_alpha/lib_protocol/bounded_history_repr.mli new file mode 100644 index 000000000000..e8d7bddd287f --- /dev/null +++ b/src/proto_alpha/lib_protocol/bounded_history_repr.mli @@ -0,0 +1,114 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** A bounded cache associating values to keys. + +This data structure is basically a bounded association table that stores +(a finite number of) given [(key, value)], with the following properties: +{ul +{li The insertion ordering is remembered / important. When the structure is full, + older entries are removed to insert new ones;} +{li Stored keys are unique in the data-structure.} +} +*) + +(** The required interface for keys stored in the table. *) +module type KEY = sig + type t + + val compare : t -> t -> int + + val pp : Format.formatter -> t -> unit + + val encoding : t Data_encoding.t +end + +(** The required interface for values stored in the table. *) +module type VALUE = sig + type t + + val equal : t -> t -> bool + + val pp : Format.formatter -> t -> unit + + val encoding : t Data_encoding.t +end + +(** The exported interface of the data structure. *) +module type S = sig + type t + + type key + + type value + + (** [empty ~capacity] returns a new table whose maximum capacity is given. *) + val empty : capacity:int64 -> t + + (** Encoding for values of type {!t} *) + val encoding : t Data_encoding.t + + (** Pretty-printer for values of type {!t} *) + val pp : Format.formatter -> t -> unit + + (** [find key t] returns [Some value] if there exists some [value] associated + to [key] in the table, and [None] otherwise. *) + val find : key -> t -> value option + + type error += + | Key_bound_to_different_value of { + key : key; + existing_value : value; + given_value : value; + } + + (** [remember key value t] inserts a new entry [(key |-> value)] in [t]. + + If [key] already exists in [t], its associated binding [value'] should + be equal to [value]. In this case, [t] is returned unchanged. Otherwise, + an error [Key_bound_to_different_value] is returned. + + If [key] is not already present in [t], the new binding (key |-> value) is + inserted in [t]. If the number of elements would exceed [t]'s capacity + after the insertion of the new binding, the oldest binding is removed + from [t]. + + The structure [t] is returned unchanged if its [capacity] is negative or + null. + *) + val remember : key -> value -> t -> t tzresult + + module Internal_for_tests : sig + (** A more flexible [empty] function for testing purpose. *) + val empty : capacity:int64 -> next_index:int64 -> t + + (** [keys t] returns the keys of the entries stored in [t] in the order of + their insertion. *) + val keys : t -> key list + end +end + +module Make (Key : KEY) (Value : VALUE) : + S with type key = Key.t and type value = Value.t diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index 9275c35df69e..86b02d98edc4 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -73,6 +73,7 @@ Contract_repr Indexable Entrypoint_repr + Bounded_history_repr Sc_rollup_repr Sc_rollup_tick_repr Sc_rollup_inbox_message_repr @@ -325,6 +326,7 @@ contract_repr.ml contract_repr.mli indexable.ml indexable.mli entrypoint_repr.ml entrypoint_repr.mli + bounded_history_repr.ml bounded_history_repr.mli sc_rollup_repr.ml sc_rollup_repr.mli sc_rollup_tick_repr.ml sc_rollup_tick_repr.mli sc_rollup_inbox_message_repr.ml sc_rollup_inbox_message_repr.mli @@ -558,6 +560,7 @@ contract_repr.ml contract_repr.mli indexable.ml indexable.mli entrypoint_repr.ml entrypoint_repr.mli + bounded_history_repr.ml bounded_history_repr.mli sc_rollup_repr.ml sc_rollup_repr.mli sc_rollup_tick_repr.ml sc_rollup_tick_repr.mli sc_rollup_inbox_message_repr.ml sc_rollup_inbox_message_repr.mli @@ -796,6 +799,7 @@ contract_repr.ml contract_repr.mli indexable.ml indexable.mli entrypoint_repr.ml entrypoint_repr.mli + bounded_history_repr.ml bounded_history_repr.mli sc_rollup_repr.ml sc_rollup_repr.mli sc_rollup_tick_repr.ml sc_rollup_tick_repr.mli sc_rollup_inbox_message_repr.ml sc_rollup_inbox_message_repr.mli 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 070423ab8552..6c89524a2d2f 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -160,26 +160,21 @@ module V1 = struct (Skip_list.pp ~pp_content:Hash.pp ~pp_ptr:Hash.pp) history - type history = { - events : history_proof Hash.Map.t; - (** The history proofs stored in the history structure, indexed by - inboxes hashes. *) - sequence : Hash.t Int64_map.t; - (** An additional map from int64 indexes to inboxes hashes, to be able - to remove old entries when the structure is full. *) - capacity : int64; - (** The max number of the entries in the structure. Once the maximum size - is reached, older entries are deleted to free space for new ones. *) - next_index : int64; - (** The index to use for the next entry to add in the structure. *) - oldest_index : int64; - (** The oldest index of the (oldest) entry that has been added to the - data structure. If the history is empty, [oldest_index] is - equal to [next_index]. *) - size : int64; - (** Counts the number of entries that are stored in history. It - satisfies the invariant: `0 <= size <= capacity` *) - } + (** Construct an inbox [history] with a given [capacity]. If you + are running a rollup node, [capacity] needs to be large enough to + remember any levels for which you may need to produce proofs. *) + module History = + Bounded_history_repr.Make + (Hash) + (struct + type t = history_proof + + let pp = pp_history_proof + + let equal = equal_history_proof + + let encoding = history_proof_encoding + end) (* @@ -405,20 +400,14 @@ module type Merkelized_operations = sig val new_level_tree : inbox_context -> Raw_level_repr.t -> tree Lwt.t - val history_encoding : history Data_encoding.t - - val pp_history : Format.formatter -> history -> unit - - val history_at_genesis : capacity:int64 -> history - val add_messages : inbox_context -> - history -> + History.t -> t -> Raw_level_repr.t -> Sc_rollup_inbox_message_repr.serialized list -> tree option -> - (tree * history * t) tzresult Lwt.t + (tree * History.t * t) tzresult Lwt.t val add_messages_no_history : inbox_context -> @@ -433,10 +422,10 @@ module type Merkelized_operations = sig val form_history_proof : inbox_context -> - history -> + History.t -> t -> tree option -> - (history * history_proof) Lwt.t + (History.t * history_proof) tzresult Lwt.t val take_snapshot : t -> history_proof @@ -467,7 +456,7 @@ module type Merkelized_operations = sig val produce_proof : inbox_context -> - history -> + History.t -> history_proof -> Raw_level_repr.t * Z.t -> (proof * Sc_rollup_PVM_sem.input option) tzresult Lwt.t @@ -477,12 +466,11 @@ module type Merkelized_operations = sig 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 - val produce_inclusion_proof : - history -> history_proof -> history_proof -> inclusion_proof option + History.t -> + history_proof -> + history_proof -> + inclusion_proof option tzresult end end @@ -579,135 +567,11 @@ struct Sc_rollup_inbox_message_repr.unsafe_of_string (Bytes.to_string bs)) bytes - let history_encoding : history Data_encoding.t = - let open Data_encoding in - let events_encoding = Hash.Map.encoding history_proof_encoding in - let sequence_encoding = - conv - (fun m -> Int64_map.bindings m) - (List.fold_left (fun m (k, v) -> Int64_map.add k v m) Int64_map.empty) - (list (tup2 int64 Hash.encoding)) - in - conv - (fun {events; sequence; capacity; next_index; oldest_index; size} -> - (events, sequence, capacity, next_index, oldest_index, size)) - (fun (events, sequence, capacity, next_index, oldest_index, size) -> - {events; sequence; capacity; next_index; oldest_index; size}) - (obj6 - (req "events" events_encoding) - (req "sequence" sequence_encoding) - (req "capacity" int64) - (req "next_index" int64) - (req "oldest_index" int64) - (req "size" int64)) - - let pp_history fmt history = - Hash.Map.bindings history.events |> fun bindings -> - Int64_map.bindings history.sequence |> fun sequence_bindings -> - let pp_binding fmt (hash, history_proof) = - Format.fprintf - fmt - "@[%a -> %a@;@]" - Hash.pp - hash - pp_history_proof - history_proof - in - let pp_sequence_binding fmt (counter, hash) = - Format.fprintf fmt "@[%s -> %a@;@]" (Int64.to_string counter) Hash.pp hash - in - Format.fprintf - fmt - "@[History:@;\ - \ { capacity: %Ld;@;\ - \ current size: %Ld;@;\ - \ oldest index: %Ld;@;\ - \ next_index : %Ld;@;\ - \ bindings: %a;@;\ - \ sequence: %a; }@]" - history.capacity - history.size - history.oldest_index - history.next_index - (Format.pp_print_list pp_binding) - bindings - (Format.pp_print_list pp_sequence_binding) - sequence_bindings - - let history_at_genesis ~capacity = - let next_index = 0L in - { - events = Hash.Map.empty; - sequence = Int64_map.empty; - capacity; - next_index; - oldest_index = next_index; - size = 0L; - } - (** [no_history] creates an empty history with [capacity] set to zero---this makes the [remember] function a no-op. We want this behaviour in the protocol because we don't want to store previous levels of the inbox. *) - let no_history = history_at_genesis ~capacity:0L - - (** [remember ptr cell history] extends [history] with a new - mapping from [ptr] to [cell]. If [history] is full, the - oldest mapping is removed. If the history capacity is less - or equal to zero or if [ptr] is already present, then [history] - is returned unchanged, unless it's associated to a content different - from [cell], in which case a failwith is triggered. *) - let remember ptr cell history = - if Compare.Int64.(history.capacity <= 0L) then history - else - match Hash.Map.find ptr history.events with - | Some cell' when not (equal_history_proof cell cell') -> - Format.kasprintf - failwith - "Internal error: %a already exists in history with a different \ - proof" - Hash.pp - ptr - | _ -> ( - let events = Hash.Map.add ptr cell history.events in - let current_index = history.next_index in - let next_index = Int64.succ current_index in - let history = - { - events; - sequence = Int64_map.add current_index ptr history.sequence; - capacity = history.capacity; - next_index; - oldest_index = history.oldest_index; - size = Int64.succ history.size; - } - in - (* A negative size means that [history.capacity] is set to [Int64.max_int] - and that the structure is full, so adding a new entry makes the size - overflows. In this case, we remove an element in the else branch to - keep the size of the history equal to [Int64.max_int] at most. *) - if - Compare.Int64.( - history.size > 0L && history.size <= history.capacity) - then history - else - let l = history.oldest_index in - match Int64_map.find l history.sequence with - | None -> - (* If history.size > history.capacity > 0, there is necessarily - an entry whose index is history.oldest_index in [sequence]. *) - assert false - | Some h -> - let sequence = Int64_map.remove l history.sequence in - let events = Hash.Map.remove h events in - { - next_index = history.next_index; - capacity = history.capacity; - size = history.capacity; - oldest_index = Int64.succ history.oldest_index; - sequence; - events; - }) + let no_history = History.empty ~capacity:0L let take_snapshot inbox = let prev_cell = inbox.old_levels_messages in @@ -721,18 +585,18 @@ struct Bytes.to_string level_bytes let form_history_proof ctxt history inbox level_tree = - let open Lwt_syntax in - let* () = - let* tree = + let open Lwt_tzresult_syntax in + let*! () = + let*! tree = match level_tree with - | Some tree -> return tree + | Some tree -> Lwt.return tree | None -> new_level_tree ctxt inbox.level in P.commit_tree ctxt [key_of_level inbox.level] tree in let prev_cell = inbox.old_levels_messages in let prev_cell_ptr = hash_skip_list_cell prev_cell in - let history = remember prev_cell_ptr prev_cell history in + let*? history = History.remember prev_cell_ptr prev_cell history in let cell = Skip_list.next ~prev_cell ~prev_cell_ptr (current_level_hash inbox) in @@ -751,18 +615,18 @@ struct This function and {!form_history_proof} are the only places we begin new level trees. *) let archive_if_needed ctxt history inbox new_level level_tree = - let open Lwt_syntax in + let open Lwt_result_syntax in if Raw_level_repr.(inbox.level = new_level) then match level_tree with | Some tree -> return (history, inbox, tree) | None -> - let* tree = new_level_tree ctxt new_level in + let*! tree = new_level_tree ctxt new_level in return (history, inbox, tree) else let* history, old_levels_messages = form_history_proof ctxt history inbox level_tree in - let* tree = new_level_tree ctxt new_level in + let*! tree = new_level_tree ctxt new_level in let inbox = { starting_level_of_current_commitment_period = @@ -790,7 +654,7 @@ struct Raw_level_repr.(level < inbox.level) (Invalid_level_add_messages level) in - let*! history, inbox, level_tree = + let* history, inbox, level_tree = archive_if_needed ctxt history inbox level level_tree in let* level_tree, inbox = @@ -1151,8 +1015,8 @@ struct let produce_proof ctxt history inbox (l, n) = let open Lwt_tzresult_syntax in let cell_ptr = hash_skip_list_cell inbox in - let history = remember cell_ptr inbox history in - let deref ptr = Hash.Map.find_opt ptr history.events in + let*? history = History.remember cell_ptr inbox history in + let deref ptr = History.find ptr history in let compare hash = let*! tree = P.lookup_tree ctxt hash in match tree with @@ -1273,37 +1137,15 @@ struct 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 - let produce_inclusion_proof history a b = + let open Tzresult_syntax in let cell_ptr = hash_skip_list_cell b in let target_index = Skip_list.index a in - let history = remember cell_ptr b history in - let deref ptr = Hash.Map.find_opt ptr history.events in + let* history = History.remember cell_ptr b history in + let deref ptr = History.find ptr history in Skip_list.back_path ~deref ~cell_ptr ~target_index |> Option.map (lift_ptr_path deref) - |> Option.join + |> Option.join |> return end end 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 9940a5c91548..82b5fa8646f5 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli @@ -117,6 +117,14 @@ *) +module Hash : sig + include S.HASH + + val of_context_hash : Context_hash.t -> t + + val to_context_hash : t -> Context_hash.t +end + module V1 : sig (** The type of the inbox for a smart-contract rollup as stored by the protocol in the context. Values that inhabit this type @@ -162,7 +170,7 @@ module V1 : sig *) type history_proof - (** A [history] is basically a lookup table of {!history_proof}s. We + (** A [History.t] is basically a lookup table of {!history_proof}s. We need this if we want to produce inbox proofs because it allows us to dereference the 'pointer' hashes in any of the [history_proof]s. This [deref] function is passed to @@ -177,7 +185,8 @@ module V1 : sig uses a history that is sufficiently large to be able to take part in all potential refutation games occurring during the challenge period. *) - type history + module History : + Bounded_history_repr.S with type key = Hash.t and type value = history_proof val pp_history_proof : Format.formatter -> history_proof -> unit @@ -209,14 +218,6 @@ include Sc_rollup_data_version_sig.S with type t = V1.t include module type of V1 with type t = V1.t -module Hash : sig - include S.HASH - - val of_context_hash : Context_hash.t -> t - - val to_context_hash : t -> Context_hash.t -end - (** This extracts the current level hash from the inbox. Note: the current level hash is stored lazily as [fun () -> ...], and this function will call that function. So don't use this if you want to @@ -244,15 +245,6 @@ module type Merkelized_operations = sig check that in proofs. *) val new_level_tree : inbox_context -> Raw_level_repr.t -> tree Lwt.t - val history_encoding : history Data_encoding.t - - val pp_history : Format.formatter -> history -> unit - - (** Construct an empty initial [history] with a given [capacity]. If you - are running a rollup node, [capacity] needs to be large enough to - remember any levels for which you may need to produce proofs. *) - val history_at_genesis : capacity:int64 -> history - (** [add_messages ctxt history inbox level payloads level_tree] inserts a list of [payloads] as new messages in the [level_tree] of the current [level] of the [inbox]. This function returns the new level @@ -270,12 +262,12 @@ module type Merkelized_operations = sig *) val add_messages : inbox_context -> - history -> + History.t -> t -> Raw_level_repr.t -> Sc_rollup_inbox_message_repr.serialized list -> tree option -> - (tree * history * t) tzresult Lwt.t + (tree * History.t * t) tzresult Lwt.t (** [add_messages_no_history ctxt inbox level payloads level_tree] behaves as {!add_external_messages} except that it does not remember the inbox @@ -308,10 +300,10 @@ module type Merkelized_operations = sig if the inbox hasn't been added to for a while). *) val form_history_proof : inbox_context -> - history -> + History.t -> t -> tree option -> - (history * history_proof) Lwt.t + (History.t * history_proof) tzresult Lwt.t (** This is similar to {!form_history_proof} except that it is just to be used on the protocol side because it doesn't ensure the history @@ -392,7 +384,7 @@ module type Merkelized_operations = sig full history). *) val produce_proof : inbox_context -> - history -> + History.t -> history_proof -> Raw_level_repr.t * Z.t -> (proof * Sc_rollup_PVM_sem.input option) tzresult Lwt.t @@ -404,18 +396,13 @@ module type Merkelized_operations = sig 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 - (** [produce_inclusion_proof history a b] exploits [history] to produce a self-contained proof that [a] is an older version of [b]. *) val produce_inclusion_proof : - history -> history_proof -> history_proof -> inclusion_proof option + History.t -> + history_proof -> + history_proof -> + inclusion_proof option tzresult end end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml index c9f69cb75341..f6313e7904f9 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml @@ -139,7 +139,7 @@ module type PVM_with_context_and_state = sig val inbox : Sc_rollup_inbox_repr.history_proof - val history : Sc_rollup_inbox_repr.history + val history : Sc_rollup_inbox_repr.History.t end end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli index ba312894786f..81efa00c4436 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli @@ -114,7 +114,7 @@ module type PVM_with_context_and_state = sig val inbox : Sc_rollup_inbox_repr.history_proof - val history : Sc_rollup_inbox_repr.history + val history : Sc_rollup_inbox_repr.History.t end end diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml index f956b24cdc6c..ef03298bcd9c 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml @@ -1064,7 +1064,7 @@ type player_client = { inbox : Store_inbox.inbox_context * Store_inbox.tree option - * Inbox.history + * Inbox.History.t * Inbox.t; levels_and_inputs : (int * string list) list; } @@ -1135,7 +1135,7 @@ module Player_client = struct let open Lwt_syntax in let open Store_inbox in let* inbox = empty ctxt rollup origination_level in - let history = history_at_genesis ~capacity:10000L in + let history = Inbox.History.empty ~capacity:10000L in let rec aux history inbox level_tree = function | [] -> return (ctxt, level_tree, history, inbox) | (level, payloads) :: rst -> @@ -1292,8 +1292,9 @@ let operation_publish_commitment ctxt rollup predecessor inbox_level let build_proof ~player_client start_tick (game : Game.t) = let open Lwt_result_syntax in let inbox_context, messages_tree, history, inbox = player_client.inbox in - let*! history, history_proof = + let* history, history_proof = Store_inbox.form_history_proof inbox_context history inbox messages_tree + >|= Environment.wrap_tzresult in (* We start a game on a commitment that starts at [Tick.initial], the fuel is necessarily [start_tick]. *) @@ -1321,7 +1322,7 @@ let build_proof ~player_client start_tick (game : Game.t) = end end in let*! proof = Sc_rollup.Proof.produce (module P) game.level in - Lwt.return (WithExceptions.Result.get_ok ~loc:__LOC__ proof) + return (WithExceptions.Result.get_ok ~loc:__LOC__ proof) (** [next_move ~number_of_sections ~player_client game] produces the next move in the refutation game. @@ -1330,7 +1331,7 @@ let build_proof ~player_client start_tick (game : Game.t) = produces a proof. Otherwise, provides another dissection. *) let next_move ~number_of_sections ~player_client (game : Game.t) = - let open Lwt_syntax in + let open Lwt_result_syntax in let disputed_sections = disputed_sections ~our_states:player_client.states game.dissection in @@ -1376,7 +1377,7 @@ let play_until_outcome ~number_of_sections ~refuter_client ~defender_client player_turn.player.pkh in let game, _, _ = WithExceptions.Option.get ~loc:__LOC__ game_opt in - let*! refutation = + let* refutation = next_move ~number_of_sections ~player_client:player_turn game in let* incr = Incremental.begin_construction block 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 7c9e8a005be2..c2680607ee62 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 @@ -82,7 +82,7 @@ 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 + let history = History.empty ~capacity:10000L in populate_inboxes ctxt level history inbox [] None list_of_payloads >>=? fun (level_tree, history, inbox, inboxes) -> match level_tree with @@ -137,20 +137,26 @@ let test_get_message_payload payloads = payloads let test_inclusion_proof_production (list_of_payloads, n) = + let open Lwt_result_syntax 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 - Internal_for_tests.produce_inclusion_proof - history - (old_levels_messages old_inbox) - (old_levels_messages inbox) - |> function + 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." + [ + err + "It should be possible to produce an inclusion proof between two \ + versions of the same inbox."; + ] | Some proof -> fail_unless (verify_inclusion_proof @@ -160,20 +166,26 @@ let test_inclusion_proof_production (list_of_payloads, n) = (err "The produced inclusion proof is invalid.") let test_inclusion_proof_verification (list_of_payloads, n) = + let open Lwt_result_syntax 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 - Internal_for_tests.produce_inclusion_proof - history - (old_levels_messages old_inbox) - (old_levels_messages inbox) - |> function + 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." + [ + err + "It should be possible to produce an inclusion proof between two \ + versions of the same inbox."; + ] | Some proof -> let old_inbox' = Stdlib.List.nth inboxes (Random.int (1 + n)) in fail_unless @@ -272,7 +284,7 @@ let setup_node_inbox_with_messages list_of_payloads f = let* index = Tezos_context_memory.Context.init "foo" in let ctxt = Tezos_context_memory.Context.empty index in let* inbox = empty ctxt rollup level in - let history = history_at_genesis ~capacity:10000L 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 -> ( @@ -350,11 +362,15 @@ let test_inbox_proof_production (list_of_payloads, l, n) = let exp_input = next_input list_of_payloads l n in setup_node_inbox_with_messages list_of_payloads @@ fun ctxt current_level_tree history inbox _inboxes -> - let open Lwt_syntax in + 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) + >|= 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 @@ -363,24 +379,27 @@ let test_inbox_proof_production (list_of_payloads, l, n) = @@ fun _ctxt _current_level_tree _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 + let*! verification = + verify_proof (l, n) snapshot proof >|= Environment.wrap_tzresult + in match verification with | Ok v_input -> fail_unless (v_input = input && v_input = exp_input) (err "Proof verified but did not match") - | Error _ -> fail (err "Proof verification failed")) - | Error _ -> fail (err "Proof production failed") + | Error _ -> fail [err "Proof verification failed"]) + | Error _ -> fail [err "Proof production failed"] let test_inbox_proof_verification (list_of_payloads, l, n) = (* We begin with a Node inbox so we can produce a proof. *) setup_node_inbox_with_messages list_of_payloads @@ fun ctxt current_level_tree history inbox _inboxes -> - let open Lwt_syntax in + 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 + 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 @@ -392,43 +411,48 @@ let test_inbox_proof_verification (list_of_payloads, l, n) = | 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 + let*! verification = + verify_proof (l, n) snapshot proof >|= Environment.wrap_tzresult + in match verification with - | Ok _ -> fail (err "Proof should not be valid") + | Ok _ -> fail [err "Proof should not be valid"] | Error _ -> return (ok ())) - | None -> fail (err "inboxes was empty")) - | Error _ -> fail (err "Proof production failed") + | None -> fail [err "inboxes was empty"]) + | Error _ -> fail [err "Proof production failed"] let test_empty_inbox_proof (level, n) = - let open Lwt_syntax in - let* index = Tezos_context_memory.Context.init "foo" in + let open Lwt_result_syntax in + let*! index = Tezos_context_memory.Context.init "foo" in let ctxt = Tezos_context_memory.Context.empty index in - let* inbox = Node.empty ctxt rollup level in - let history = Node.history_at_genesis ~capacity:10000L in + let*! inbox = Node.empty ctxt rollup level in + let history = History.empty ~capacity:10000L in let* history, history_proof = Node.form_history_proof ctxt history inbox None + >|= Environment.wrap_tzresult in - let* result = + let*! result = Node.produce_proof ctxt history history_proof (Raw_level_repr.root, n) + >|= Environment.wrap_tzresult in match result with | Ok (proof, input) -> ( (* We now switch to a protocol inbox for verification. *) create_context () >>=? fun ctxt -> - let* inbox = empty ctxt rollup level in + let*! inbox = empty ctxt rollup level in let snapshot = take_snapshot inbox in let proof = node_proof_to_protocol_proof proof in - let* verification = + let*! verification = verify_proof (Raw_level_repr.root, n) snapshot proof + >|= Environment.wrap_tzresult in match verification with | Ok v_input -> fail_unless (v_input = input && v_input = None) (err "Proof verified but did not match") - | Error _ -> fail (err "Proof verification failed")) - | Error _ -> fail (err "Proof production failed") + | 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. *) @@ -463,7 +487,7 @@ let init_inboxes_histories_with_different_capacities create_context () >>=? fun ctxt -> let* inbox = empty ctxt rollup level in let history = - Sc_rollup_inbox_repr.Internal_for_tests.history_at_genesis + Sc_rollup_inbox_repr.History.Internal_for_tests.empty ~capacity ~next_index in @@ -502,9 +526,9 @@ let test_history_length 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 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 @@ -542,9 +566,9 @@ let test_history_prefix params = 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 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* () = @@ -594,12 +618,17 @@ let test_inclusion_proofs_depending_on_history_capacity 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 in + 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 -- GitLab