diff --git a/src/proto_alpha/bin_sc_rollup_node/inbox.ml b/src/proto_alpha/bin_sc_rollup_node/inbox.ml index 5859b99d03f722623b398b4b24b3dbd30422a76c..d07955e84a58431ccb13fea65c7bc0fd1a641dc7 100644 --- a/src/proto_alpha/bin_sc_rollup_node/inbox.ml +++ b/src/proto_alpha/bin_sc_rollup_node/inbox.ml @@ -48,21 +48,21 @@ module State = struct let inbox_of_hash node_ctxt store block_hash = let open Lwt_syntax in let open Node_context in - let+ possible_inbox = Store.Inboxes.find store block_hash in + let* possible_inbox = Store.Inboxes.find store block_hash in match possible_inbox with | None -> (* We won't find inboxes for blocks before the rollup origination level. Fortunately this case will only ever be called once when dealing with the rollup origination block. After that we would always find an inbox. *) - Sc_rollup.Inbox.empty node_ctxt.rollup_address node_ctxt.initial_level - | Some inbox -> inbox + Store.Inbox.empty store node_ctxt.rollup_address node_ctxt.initial_level + | Some inbox -> return inbox let history_of_hash store block_hash = Store.Histories.find_with_default store block_hash ~on_default:(fun () -> Store.Inbox.history_at_genesis ~bound:(Int64.of_int 60000)) - let get_message_tree = Store.MessageTrees.get + let find_message_tree = Store.MessageTrees.find let set_message_tree = Store.MessageTrees.set end @@ -103,6 +103,7 @@ let process_head Node_context.({l1_ctxt; rollup_address; _} as node_ctxt) store let*! res = get_messages l1_ctxt head_hash rollup_address in match res with | Error e -> head_processing_failure e + | Ok [] -> return_unit | Ok messages -> let*! () = Inbox_event.get_messages head_hash level (List.length messages) @@ -119,7 +120,7 @@ let process_head Node_context.({l1_ctxt; rollup_address; _} as node_ctxt) store let*! inbox = State.inbox_of_hash node_ctxt store predecessor in lift @@ let*! history = State.history_of_hash store predecessor in - let*! messages_tree = State.get_message_tree store predecessor in + let*! messages_tree = State.find_message_tree store predecessor in let*? level = Raw_level.of_int32 level in let*? messages = List.map_e @@ -128,7 +129,13 @@ let process_head Node_context.({l1_ctxt; rollup_address; _} as node_ctxt) store messages in let* messages_tree, history, inbox = - Store.Inbox.add_messages history inbox level messages messages_tree + Store.Inbox.add_messages + store + history + inbox + level + messages + messages_tree in let*! () = State.set_message_tree store head_hash messages_tree in let*! () = State.add_inbox store head_hash inbox in diff --git a/src/proto_alpha/bin_sc_rollup_node/interpreter.ml b/src/proto_alpha/bin_sc_rollup_node/interpreter.ml index c552c9d6136b36954ac0284c4e874e5c27f30a9b..d5aef675ca8de345985a9fc7a4812b818ee4173c 100644 --- a/src/proto_alpha/bin_sc_rollup_node/interpreter.ml +++ b/src/proto_alpha/bin_sc_rollup_node/interpreter.ml @@ -87,27 +87,39 @@ module Make (PVM : Pvm.S) : S = struct in (* Obtain inbox and its messages for this block. *) - let*! inbox = Store.Inboxes.get store hash in - let inbox_level = Inbox.inbox_level inbox in - let*! messages = Store.Messages.get store hash in + let*! inbox_opt = Store.Inboxes.find store hash in (* Iterate the PVM state with all the messages for this level. *) - let* state = - List.fold_left_i_es - (fun message_counter state external_message -> - let message = Sc_rollup.Inbox.Message.External external_message in - let*? payload = - Environment.wrap_tzresult - (Sc_rollup.Inbox.Message.serialize message) + let* state, messages = + match inbox_opt with + | Some inbox -> + let inbox_level = Inbox.inbox_level inbox in + let*! messages = Store.Messages.get store hash in + let* state = + List.fold_left_i_es + (fun message_counter state external_message -> + let message = + Sc_rollup.Inbox.Message.External external_message + in + let*? payload = + Environment.wrap_tzresult + (Sc_rollup.Inbox.Message.serialize message) + in + let input = + Sc_rollup. + { + inbox_level; + message_counter = Z.of_int message_counter; + payload; + } + in + let*! state = feed_input state input in + return state) + predecessor_state + messages in - let input = - Sc_rollup. - {inbox_level; message_counter = Z.of_int message_counter; payload} - in - let*! state = feed_input state input in - return state) - predecessor_state - messages + return (state, messages) + | None -> return (predecessor_state, []) in (* Write final state to store. *) diff --git a/src/proto_alpha/bin_sc_rollup_node/store.ml b/src/proto_alpha/bin_sc_rollup_node/store.ml index 6d459c5dca8c4373b7930967e4ad5e4a7152dd6d..7ec698f4a6395eec7089827031d9c5281a77f473 100644 --- a/src/proto_alpha/bin_sc_rollup_node/store.ml +++ b/src/proto_alpha/bin_sc_rollup_node/store.ml @@ -209,7 +209,59 @@ module IStoreProof = module Inbox = struct include Sc_rollup.Inbox - include Sc_rollup.Inbox.MakeHashingScheme (IStoreTree) + + include Sc_rollup.Inbox.MakeHashingScheme (struct + module Tree = IStoreTree + + type t = IStore.t + + type tree = Tree.tree + + let commit_tree store key tree = + let open Lwt_syntax in + let info () = IStore.Info.v ~author:"Tezos" 0L ~message:"" in + let path = "inbox_internal_trees" :: key in + let* result = IStore.set_tree ~info store path tree in + match result with + | Ok () -> + let* (_ : IStore.commit) = + IStore.Commit.v (IStore.repo store) ~info:(info ()) ~parents:[] tree + in + return () + | Error _ -> assert false + + let to_inbox_hash kinded_hash = + match kinded_hash with + | `Value h | `Node h -> Hash.of_bytes_exn (Context_hash.to_bytes h) + + let from_inbox_hash inbox_hash = + let ctxt_hash = Hash.to_context_hash inbox_hash in + let store_hash = + IStore.Hash.unsafe_of_raw_string (Context_hash.to_string ctxt_hash) + in + `Node store_hash + + let lookup_tree store hash = + IStore.Tree.of_hash (IStore.repo store) (from_inbox_hash hash) + + type proof = IStoreProof.Proof.tree IStoreProof.Proof.t + + let verify_proof proof f = + Lwt.map Result.to_option (IStoreProof.verify_tree_proof proof f) + + let produce_proof store tree f = + let open Lwt_syntax in + match IStoreTree.kinded_key tree with + | Some k -> + let* p = IStoreProof.produce_tree_proof (IStore.repo store) k f in + return (Some p) + | None -> return None + + let proof_before proof = to_inbox_hash proof.IStoreProof.Proof.before + + let proof_encoding = + Tezos_context_helpers.Merkle_proof_encoding.V1.Tree32.tree_proof_encoding + end) end (** State of the PVM that this rollup node deals with *) @@ -243,10 +295,7 @@ module MessageTrees = struct (** [get store block_hash] retrieves the message tree for [block_hash]. If it is not present, an empty tree is returned. *) - let get store block_hash = - let open Lwt_syntax in - let+ tree = IStore.find_tree store (key block_hash) in - Option.value ~default:(IStoreTree.empty ()) tree + let find store block_hash = IStore.find_tree store (key block_hash) (** [set store block_hash message_tree] set the message tree for [block_hash]. *) let set store block_hash message_tree = diff --git a/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml index 13600e97c04803cb2ffe73e6b870b365ce660caa..6af08b3235c9f1ad29b4bdf996475240213d7174 100644 --- a/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/sc_rollup_benchmarks.ml @@ -256,18 +256,21 @@ module Sc_rollup_add_external_messages_benchmark = struct add_messages_for_level ctxt inbox rollup in let* rollup, ctxt = ctxt_with_rollup in - let inbox = - Sc_rollup_inbox_repr.empty rollup (Raw_context.current_level ctxt).level + let*! inbox = + Sc_rollup_inbox_repr.empty + (Raw_context.recover ctxt) + rollup + (Raw_context.current_level ctxt).level in let* inbox, ctxt = add_messages_for_level ctxt inbox rollup in let+ messages, _ctxt = Lwt.return @@ Environment.wrap_tzresult @@ Raw_context.Sc_rollup_in_memory_inbox.current_messages ctxt rollup in - (inbox, messages) + (inbox, ctxt, messages) in - let inbox, current_messages = + let inbox, ctxt, current_messages = match Lwt_main.run @@ prepare_benchmark_scenario () with | Ok result -> result | Error _ -> assert false @@ -277,6 +280,7 @@ module Sc_rollup_add_external_messages_benchmark = struct let closure () = ignore (Sc_rollup_inbox_repr.add_messages_no_history + (Raw_context.recover ctxt) inbox last_level [message] diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 78c2da2971faa8f899958ddd6c103896a5fd6a37..8fbfcbaef326740afda4fcc2d2bf6f0c869caf4b 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -2792,22 +2792,30 @@ module Sc_rollup : sig val encoding : t Data_encoding.t - val empty : Address.t -> Raw_level.t -> t - val inbox_level : t -> Raw_level.t val number_of_available_messages : t -> Z.t val consume_n_messages : int32 -> t -> t option tzresult - module Hash : S.HASH + type history_proof + + module Hash : sig + include S.HASH + + val of_context_hash : Context_hash.t -> t + + val to_context_hash : t -> Context_hash.t + end module type MerkelizedOperations = sig type tree - type message = tree + type inbox_context + + val hash_level_tree : tree -> Hash.t - type messages = tree + val new_level_tree : inbox_context -> Raw_level.t -> tree Lwt.t type history @@ -2818,23 +2826,33 @@ module Sc_rollup : sig val history_at_genesis : bound:int64 -> history val add_messages : + inbox_context -> history -> t -> Raw_level.t -> Message.serialized list -> - messages -> - (messages * history * t) tzresult Lwt.t + tree option -> + (tree * history * t) tzresult Lwt.t val add_messages_no_history : + inbox_context -> t -> Raw_level.t -> Message.serialized list -> - messages -> - (messages * t, error trace) result Lwt.t + tree option -> + (tree * t) tzresult Lwt.t + + val get_message_payload : + tree -> Z.t -> Sc_rollup_inbox_message_repr.serialized option Lwt.t - val get_message : messages -> Z.t -> message option Lwt.t + val form_history_proof : + inbox_context -> + history -> + t -> + tree option -> + (history * history_proof) Lwt.t - val get_message_payload : messages -> Z.t -> string option Lwt.t + val take_snapshot : t -> history_proof type inclusion_proof @@ -2844,35 +2862,69 @@ module Sc_rollup : sig val number_of_proof_steps : inclusion_proof -> int - val produce_inclusion_proof : history -> t -> t -> inclusion_proof option + val produce_inclusion_proof : + history -> history_proof -> history_proof -> inclusion_proof option - val verify_inclusion_proof : inclusion_proof -> t -> t -> bool + val verify_inclusion_proof : + inclusion_proof -> history_proof -> history_proof -> bool + + type proof + + val pp_proof : Format.formatter -> proof -> unit + + val proof_encoding : proof Data_encoding.t + + val verify_proof : + Raw_level.t * Z.t -> + history_proof -> + proof -> + Sc_rollup_PVM_sem.input option tzresult Lwt.t + + val produce_proof : + inbox_context -> + history -> + 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 end - include MerkelizedOperations with type tree = Context.tree + include + MerkelizedOperations + with type tree = Context.tree + and type inbox_context = Context.t - module type TREE = sig - type t + module type P = sig + module Tree : + Context.TREE with type key = string list and type value = bytes - type tree + type t = Tree.t - type key = string list + type tree = Tree.tree - type value = bytes + val commit_tree : t -> string list -> tree -> unit Lwt.t - val find : tree -> key -> value option Lwt.t + val lookup_tree : t -> Hash.t -> tree option Lwt.t - val find_tree : tree -> key -> tree option Lwt.t + type proof - val add : tree -> key -> value -> tree Lwt.t + val proof_encoding : proof Data_encoding.t - val is_empty : tree -> bool + val proof_before : proof -> Hash.t - val hash : tree -> Context_hash.t + val verify_proof : + proof -> (tree -> (tree * 'a) Lwt.t) -> (tree * 'a) option Lwt.t + + val produce_proof : + Tree.t -> + tree -> + (tree -> (tree * 'a) Lwt.t) -> + (proof * 'a) option Lwt.t end - module MakeHashingScheme (Tree : TREE) : - MerkelizedOperations with type tree = Tree.tree + module MakeHashingScheme (P : P) : + MerkelizedOperations with type tree = P.tree and type inbox_context = P.t val add_external_messages : context -> rollup -> string list -> (t * Z.t * context) tzresult Lwt.t @@ -2886,10 +2938,6 @@ module Sc_rollup : sig (t * Z.t * context) tzresult Lwt.t val inbox : context -> rollup -> (t * context) tzresult Lwt.t - - module Proof : sig - type t - end end type input = { @@ -3180,7 +3228,7 @@ module Sc_rollup : sig with type proof = Sc_rollup_wasm.V2_0_0.ProtocolImplementation.proof) module Proof : sig - type t = {pvm_step : wrapped_proof; inbox : Inbox.Proof.t option} + type t = {pvm_step : wrapped_proof; inbox : Inbox.proof option} module type PVM_with_context_and_state = sig include PVM.S @@ -3192,9 +3240,11 @@ module Sc_rollup : sig val produce : (module PVM_with_context_and_state) -> - Sc_rollup_inbox_repr.t -> - Raw_level_repr.t -> - (t, error) result Lwt.t + Inbox.inbox_context -> + Inbox.history -> + Inbox.history_proof -> + Raw_level.t -> + t tzresult Lwt.t end module Game : sig @@ -3206,7 +3256,7 @@ module Sc_rollup : sig type t = { turn : player; - inbox_snapshot : Inbox.t; + inbox_snapshot : Inbox.history_proof; level : Raw_level.t; pvm_name : string; dissection : dissection_chunk list; @@ -3249,7 +3299,7 @@ module Sc_rollup : sig val outcome_encoding : outcome Data_encoding.t val initial : - Inbox.t -> + Inbox.history_proof -> pvm_name:string -> parent:Commitment.t -> child:Commitment.t -> @@ -3263,7 +3313,7 @@ module Sc_rollup : sig State_hash.t option -> Tick.t -> dissection_chunk list -> - (unit, error) result Lwt.t + (unit, reason) result Lwt.t val play : t -> refutation -> (outcome, t) Either.t Lwt.t end diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index b6fc73d5b79997badef41351ca5f47b2d9cf9fae..3df346352b62d6cc014039a534f90a0720339783 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -548,6 +548,7 @@ let () = Data_encoding.unit (function Sc_rollup_feature_disabled -> Some () | _ -> None) (fun () -> Sc_rollup_feature_disabled) ; + register_error_kind `Temporary ~id:"operation.wrong_voting_period" diff --git a/src/proto_alpha/lib_protocol/raw_context.ml b/src/proto_alpha/lib_protocol/raw_context.ml index 942324657bd104c76eeb15dc70f37f07d174c7f0..9e0e0457e3f510c80f5d62e52b812b337f270193 100644 --- a/src/proto_alpha/lib_protocol/raw_context.ml +++ b/src/proto_alpha/lib_protocol/raw_context.ml @@ -1441,9 +1441,7 @@ module Sc_rollup_in_memory_inbox = struct rollup ctxt.back.sc_rollup_current_messages in - match messages with - | None -> (Tree.empty ctxt, ctxt) - | Some tree -> (tree, ctxt) + (messages, ctxt) let set_current_messages ctxt rollup tree = let open Tzresult_syntax in diff --git a/src/proto_alpha/lib_protocol/raw_context.mli b/src/proto_alpha/lib_protocol/raw_context.mli index 8cf6e5fedb414867ae27473e3f0bc84e613b70e0..eef60d8c3117c1c550ed074203bf4586e57f8273 100644 --- a/src/proto_alpha/lib_protocol/raw_context.mli +++ b/src/proto_alpha/lib_protocol/raw_context.mli @@ -377,7 +377,8 @@ module Tx_rollup : sig end module Sc_rollup_in_memory_inbox : sig - val current_messages : t -> Sc_rollup_repr.t -> (Context.tree * t) tzresult + val current_messages : + t -> Sc_rollup_repr.t -> (Context.tree option * t) tzresult val set_current_messages : t -> Sc_rollup_repr.t -> Context.tree -> t tzresult end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_errors.ml b/src/proto_alpha/lib_protocol/sc_rollup_errors.ml index 1e0ef8c0f354fe47904a1c4d271ff0655751f318..19e181bef9db331a6af48e71cb9b5ab6549ea56d 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_errors.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_errors.ml @@ -52,6 +52,7 @@ type error += | (* `Temporary *) Sc_rollup_timeout_level_not_reached | (* `Temporary *) Sc_rollup_max_number_of_messages_reached_for_commitment_period + | (* `Permanent *) Sc_rollup_add_zero_messages | (* `Temporary *) Sc_rollup_invalid_outbox_message_index | (* `Temporary *) Sc_rollup_outbox_level_expired | (* `Temporary *) Sc_rollup_outbox_message_already_applied @@ -192,6 +193,16 @@ let () = Some () | _ -> None) (fun () -> Sc_rollup_max_number_of_messages_reached_for_commitment_period) ; + let description = "Tried to add zero messages to a SC rollup" in + register_error_kind + `Permanent + ~id:"sc_rollup_errors.sc_rollup_add_zero_messages" + ~title:description + ~description + ~pp:(fun ppf () -> Format.fprintf ppf "%s" description) + Data_encoding.unit + (function Sc_rollup_add_zero_messages -> Some () | _ -> None) + (fun () -> Sc_rollup_add_zero_messages) ; let description = "Attempted to cement a disputed commitment." in register_error_kind `Temporary diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml index 310a968230f8d1adfb373654862bcfe9e1676289..2d0c8abe41e1c337cba7356e6b8b443b35e99c63 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.ml @@ -36,7 +36,7 @@ type dissection_chunk = { module V1 = struct type t = { turn : player; - inbox_snapshot : Sc_rollup_inbox_repr.t; + inbox_snapshot : Sc_rollup_inbox_repr.history_proof; level : Raw_level_repr.t; pvm_name : string; dissection : dissection_chunk list; @@ -87,7 +87,7 @@ module V1 = struct dissection = dissection2; } = player_equal turn1 turn2 - && Sc_rollup_inbox_repr.equal inbox_snapshot1 inbox_snapshot2 + && Sc_rollup_inbox_repr.equal_history_proof inbox_snapshot1 inbox_snapshot2 && Raw_level_repr.equal level1 level2 && String.equal pvm_name1 pvm_name2 && List.equal dissection_chunk_equal dissection1 dissection2 @@ -117,7 +117,7 @@ module V1 = struct {turn; inbox_snapshot; level; pvm_name; dissection}) (obj5 (req "turn" player_encoding) - (req "inbox_snapshot" Sc_rollup_inbox_repr.encoding) + (req "inbox_snapshot" Sc_rollup_inbox_repr.history_proof_encoding) (req "level" Raw_level_repr.encoding) (req "pvm_name" string) (req "dissection" dissection_encoding)) @@ -144,7 +144,7 @@ module V1 = struct game.dissection pp_player game.turn - Sc_rollup_inbox_repr.pp + Sc_rollup_inbox_repr.pp_history_proof game.inbox_snapshot Raw_level_repr.pp game.level @@ -392,11 +392,9 @@ let outcome_encoding = (fun (loser, reason) -> {loser; reason}) (obj2 (req "loser" player_encoding) (req "reason" reason_encoding)) -type error += Game_error of string - -let game_error reason = +let invalid_move reason = let open Lwt_result_syntax in - fail (Game_error reason) + fail (Invalid_move reason) let find_choice game tick = let open Lwt_result_syntax in @@ -408,31 +406,31 @@ let find_choice game tick = if Sc_rollup_tick_repr.(tick = state_tick) then return (state, tick, next_state, next_tick) else traverse (next :: others) - | _ -> game_error "This choice was not proposed" + | _ -> invalid_move "This choice was not proposed" in traverse game.dissection let check pred reason = let open Lwt_result_syntax in - if pred then return () else game_error reason + if pred then return () else invalid_move reason let check_dissection start start_tick stop stop_tick dissection = - let open Lwt_tzresult_syntax in + let open Lwt_result_syntax in let len = Z.of_int @@ List.length dissection in let dist = Sc_rollup_tick_repr.distance start_tick stop_tick in let should_be_equal_to what = Format.asprintf "The number of sections must be equal to %a" Z.pp_print what in - let* _ = + let* () = if Z.(geq dist (of_int 32)) then check Z.(equal len (of_int 32)) (should_be_equal_to (Z.of_int 32)) else if Z.(gt dist one) then check Z.(equal len (succ dist)) (should_be_equal_to Z.(succ dist)) else - game_error + invalid_move (Format.asprintf "Cannot have a dissection of only one section") in - let* _ = + let* () = match (List.hd dissection, List.last_opt dissection) with | Some {state_hash = a; tick = a_tick}, Some {state_hash = b; tick = b_tick} -> @@ -472,21 +470,21 @@ let check_dissection start start_tick stop stop_tick dissection = b_tick pp stop_tick)) - | _ -> game_error "Dissection should contain at least 2 elements" + | _ -> invalid_move "Dissection should contain at least 2 elements" in let rec traverse states = match states with | {state_hash = None; _} :: {state_hash = Some _; _} :: _ -> - game_error "Cannot return to a Some state after being at a None state" + invalid_move "Cannot return to a Some state after being at a None state" | {tick; _} :: ({tick = next_tick; state_hash = _} as next) :: others -> if Sc_rollup_tick_repr.(tick < next_tick) then let incr = Sc_rollup_tick_repr.distance tick next_tick in if Z.(leq incr (div dist (of_int 2))) then traverse (next :: others) else - game_error + invalid_move "Maximum tick increment in dissection must be less than half \ total dissection length" - else game_error "Ticks should only increase in dissection" + else invalid_move "Ticks should only increase in dissection" | _ -> return () in traverse dissection @@ -503,10 +501,10 @@ let check_dissection start start_tick stop stop_tick dissection = let check_proof_start_stop start start_tick stop stop_tick proof = let open Lwt_result_syntax in let dist = Sc_rollup_tick_repr.distance start_tick stop_tick in - let* _ = check Z.(equal dist one) "dist should be equal to 1" in + let* () = check Z.(equal dist one) "dist should be equal to 1" in let start_proof = Sc_rollup_proof_repr.start proof in let stop_proof = Sc_rollup_proof_repr.stop proof in - let* _ = + let* () = check (Option.equal State_hash.equal start (Some start_proof)) (match start with @@ -540,7 +538,7 @@ let play game refutation = in match refutation.step with | Dissection states -> - let* _ = check_dissection start start_tick stop stop_tick states in + let* () = check_dissection start start_tick stop stop_tick states in return (Either.Right { @@ -551,19 +549,23 @@ let play game refutation = dissection = states; }) | Proof proof -> - let* _ = check_proof_start_stop start start_tick stop stop_tick proof in + let* () = + check_proof_start_stop start start_tick stop stop_tick proof + in let {inbox_snapshot; level; pvm_name; _} = game in - let* proof_valid = + let*! (proof_valid_tzresult : bool tzresult) = Sc_rollup_proof_repr.valid inbox_snapshot level ~pvm_name proof in - let* _ = check proof_valid "Invalid proof" in + let* () = + match proof_valid_tzresult with + | Ok true -> return () + | Ok false -> invalid_move "Invalid proof: no detail given" + | Error e -> + invalid_move (Format.asprintf "Invalid proof: %a" pp_trace e) + in return (Either.Left {loser = opponent game.turn; reason = Conflict_resolved}) in - let game_over reason = - Either.Left {loser = game.turn; reason = Invalid_move reason} - in match result with | Ok x -> Lwt.return x - | Error (Game_error e) -> Lwt.return @@ game_over e - | Error _ -> Lwt.return @@ game_over "undefined" + | Error reason -> Lwt.return @@ Either.Left {loser = game.turn; reason} diff --git a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.mli index 351ad0ffe53d9ba3963f04cc680389bbb8fd732b..3092e5f93b4eed708f5b748e35c07ac564029dbb 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_game_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_game_repr.mli @@ -168,7 +168,7 @@ module V1 : sig *) type t = { turn : player; - inbox_snapshot : Sc_rollup_inbox_repr.t; + inbox_snapshot : Sc_rollup_inbox_repr.history_proof; level : Raw_level_repr.t; pvm_name : string; dissection : dissection_chunk list; @@ -241,7 +241,7 @@ end blocked state by immediately providing a proof of a single tick increment from that state to its successor. *) val initial : - Sc_rollup_inbox_repr.t -> + Sc_rollup_inbox_repr.history_proof -> pvm_name:string -> parent:Sc_rollup_commitment_repr.t -> child:Sc_rollup_commitment_repr.t -> @@ -308,7 +308,7 @@ val find_choice : * Sc_rollup_tick_repr.t * Sc_rollup_repr.State_hash.t option * Sc_rollup_tick_repr.t, - error ) + reason ) result Lwt.t @@ -335,7 +335,7 @@ val check_dissection : Sc_rollup_repr.State_hash.t option -> Sc_rollup_tick_repr.t -> dissection_chunk list -> - (unit, error) result Lwt.t + (unit, reason) result Lwt.t (** Applies the move [refutation] to the game. Checks the move is valid and returns an [Invalid_move] outcome if not. 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 6d3cd8fce6bbb0df218ece00888f2ea8a8bfafce..1554cd4ff26e6fab17ab65e262f4389c59e376a4 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 @@ -103,3 +103,5 @@ let deserialize s = | Some msg -> return msg let unsafe_of_string s = s + +let unsafe_to_string s = s 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 11bad2ffa7c3b8f46e1a5c0f70d607adfe7cb877..987b57e60b0a6d12aa8ad2c8c25a4a8ad2257fa8 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 @@ -63,10 +63,12 @@ type t = Internal of internal_inbox_message | External of string type serialized = private string -val unsafe_of_string : string -> serialized - (** [serialize msg] encodes the inbox message [msg] in binary format. *) val serialize : t -> serialized tzresult (** [deserialize bs] decodes [bs] as an inbox_message [t]. *) val deserialize : serialized -> t tzresult + +val unsafe_of_string : string -> serialized + +val unsafe_to_string : serialized -> string 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 2d3beec2de03fe13040aba219968293078243234..a388681e9650392d14b09bdbc52b5c45cb4579b1 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.ml @@ -25,10 +25,9 @@ (** - A Merkelized inbox represents a list of available messages. This - list is decomposed into sublist of messages, one for each Tezos - level greater than the level of the Last Cemented Commitment - (LCC). + A Merkelized inbox represents a list of available messages. This list + is decomposed into sublists of messages, one for each non-empty Tezos + level greater than the level of the Last Cemented Commitment (LCC). This module is designed to: @@ -38,15 +37,15 @@ inclusions (only for inboxes obtained at the end of block validation) ; - 3. offer an efficient function to add a new batch of messages in - the inbox at the current level. + 3. offer an efficient function to add a new batch of messages in the + inbox at the current level. - To solve (1), we simply maintain the number of available messages - in a field. + To solve (1), we simply maintain the number of available messages in + a field. - To solve (2), we use a proof tree H which is implemented by a merkelized - skip list allowing for compact inclusion proofs - (See {!skip_list_repr.ml}). + To solve (2), we use a proof tree H which is implemented by a sparse + merkelized skip list allowing for compact inclusion proofs (See + {!skip_list_repr.ml}). To solve (3), we maintain a separate proof tree C witnessing the contents of messages of the current level. @@ -62,6 +61,10 @@ type error += Invalid_level_add_messages of Raw_level_repr.t type error += Invalid_number_of_messages_to_consume of int64 +type error += Inbox_proof_error of string + +type error += Tried_to_add_zero_messages + let () = let open Data_encoding in register_error_kind @@ -84,7 +87,30 @@ let () = integer." (obj1 (req "consume_n_messages" int64)) (function Invalid_number_of_messages_to_consume n -> Some n | _ -> None) - (fun n -> Invalid_number_of_messages_to_consume n) + (fun n -> Invalid_number_of_messages_to_consume n) ; + + register_error_kind + `Permanent + ~id:"sc_rollup_inbox.inbox_proof_error" + ~title: + "Internal error: error occurred during proof production or validation" + ~description:"An inbox proof error." + ~pp:(fun ppf e -> Format.fprintf ppf "Inbox proof error: %s" e) + (obj1 (req "error" string)) + (function Inbox_proof_error e -> Some e | _ -> None) + (fun e -> Inbox_proof_error e) ; + + register_error_kind + `Permanent + ~id:"sc_rollup_inbox.add_zero_messages" + ~title:"Internal error: trying to add zero messages" + ~description: + "Message adding functions must be called with a positive number of \ + messages" + ~pp:(fun ppf _ -> Format.fprintf ppf "Tried to add zero messages") + empty + (function Tried_to_add_zero_messages -> Some () | _ -> None) + (fun () -> Tried_to_add_zero_messages) (* 32 *) let hash_prefix = "\003\250\174\238\208" (* scib1(55) *) @@ -113,7 +139,9 @@ module Hash = struct let () = Base58.check_encoded_prefix b58check_encoding prefix encoded_size let of_context_hash context_hash = - hash_bytes [Context_hash.to_bytes context_hash] + Context_hash.to_bytes context_hash |> of_bytes_exn + + let to_context_hash hash = to_bytes hash |> Context_hash.of_bytes_exn include Path_encoding.Make_hex (H) end @@ -124,24 +152,20 @@ end module Skip_list = Skip_list_repr.Make (Skip_list_parameters) -type proof_hash = Hash.t - -type history_proof_hash = Hash.t - -type history_proof = (proof_hash, history_proof_hash) Skip_list.cell +module V1 = struct + type history_proof = (Hash.t, Hash.t) Skip_list.cell -let equal_history_proof = Skip_list.equal Hash.equal Hash.equal + let equal_history_proof = Skip_list.equal Hash.equal Hash.equal -let history_proof_encoding : history_proof Data_encoding.t = - Skip_list.encoding Hash.encoding Hash.encoding + let history_proof_encoding : history_proof Data_encoding.t = + Skip_list.encoding Hash.encoding Hash.encoding -let pp_history_proof = Skip_list.pp ~pp_content:Hash.pp ~pp_ptr:Hash.pp + let pp_history_proof = Skip_list.pp ~pp_content:Hash.pp ~pp_ptr:Hash.pp -module V1 = struct (* At a given level, an inbox is composed of metadata of type [t] and - [current_messages], a [tree] representing the messages of the current level + [current_level], a [tree] representing the messages of the current level (held by the [Raw_context.t] in the protocol). The metadata contains : @@ -154,27 +178,19 @@ module V1 = struct the number of messages during the commitment period ; - [starting_level_of_current_commitment_period] : the level marking the beginning of the current commitment period ; - - [current_messages_hash] : the root hash of [current_messages] ; + - [current_level_hash] : the root hash of [current_level] ; - [old_levels_messages] : a witness of the inbox history. When new messages are appended to the current level inbox, the metadata stored in the context may be related to an older level. In that situation, an archival process is applied to the metadata. - This process saves the [current_messages_hash] in the - [old_levels_messages] and empties [current_messages]. If - there are intermediate levels between [inbox.level] and the current - level, this archival process is applied until we reach the current - level using an empty [current_messages]. See {!MakeHashingScheme.archive} - for details. - - The [current_messages_hash] is either: - - the hash of 'empty bytes' when there are no current messages ; - - the root hash of the tree, where the contents of each message sit at the - key [[message_index, "payload"]], where [message_index] is the index of the - message in the list of [current_messages], if there are one or more - messages. + This process saves the [current_level_hash] in the + [old_levels_messages] and empties [current_level]. It then + initialises a new level tree for the new messages---note that any + intermediate levels are simply skipped. See + {!MakeHashingScheme.archive_if_needed} for details. -*) + *) type t = { rollup : Sc_rollup_repr.t; level : Raw_level_repr.t; @@ -183,7 +199,7 @@ module V1 = struct starting_level_of_current_commitment_period : Raw_level_repr.t; message_counter : Z.t; (* Lazy to avoid hashing O(n^2) time in [add_messages] *) - current_messages_hash : unit -> Hash.t; + current_level_hash : unit -> Hash.t; old_levels_messages : history_proof; } @@ -196,7 +212,7 @@ module V1 = struct nb_messages_in_commitment_period; starting_level_of_current_commitment_period; message_counter; - current_messages_hash; + current_level_hash; old_levels_messages; } = inbox1 @@ -213,7 +229,7 @@ module V1 = struct starting_level_of_current_commitment_period inbox2.starting_level_of_current_commitment_period) && Z.equal message_counter inbox2.message_counter - && Hash.equal (current_messages_hash ()) (inbox2.current_messages_hash ()) + && Hash.equal (current_level_hash ()) (inbox2.current_level_hash ()) && equal_history_proof old_levels_messages inbox2.old_levels_messages let pp fmt @@ -224,7 +240,7 @@ module V1 = struct nb_messages_in_commitment_period; starting_level_of_current_commitment_period; message_counter; - current_messages_hash; + current_level_hash; old_levels_messages; } = Format.fprintf @@ -244,7 +260,7 @@ module V1 = struct Raw_level_repr.pp level Hash.pp - (current_messages_hash ()) + (current_level_hash ()) nb_available_messages (Int64.to_string nb_messages_in_commitment_period) Raw_level_repr.pp @@ -256,6 +272,10 @@ module V1 = struct let inbox_level inbox = inbox.level + let old_levels_messages inbox = inbox.old_levels_messages + + let current_level_hash inbox = inbox.current_level_hash () + let old_levels_messages_encoding = Skip_list.encoding Hash.encoding Hash.encoding @@ -269,7 +289,7 @@ module V1 = struct nb_messages_in_commitment_period; starting_level_of_current_commitment_period; level; - current_messages_hash; + current_level_hash; old_levels_messages; } -> ( rollup, @@ -278,7 +298,7 @@ module V1 = struct nb_messages_in_commitment_period, starting_level_of_current_commitment_period, level, - current_messages_hash (), + current_level_hash (), old_levels_messages )) (fun ( rollup, message_counter, @@ -286,7 +306,7 @@ module V1 = struct nb_messages_in_commitment_period, starting_level_of_current_commitment_period, level, - current_messages_hash, + current_level_hash, old_levels_messages ) -> { rollup; @@ -295,7 +315,7 @@ module V1 = struct nb_messages_in_commitment_period; starting_level_of_current_commitment_period; level; - current_messages_hash = (fun () -> current_messages_hash); + current_level_hash = (fun () -> current_level_hash); old_levels_messages; }) (obj8 @@ -307,7 +327,7 @@ module V1 = struct "starting_level_of_current_commitment_period" Raw_level_repr.encoding) (req "level" Raw_level_repr.encoding) - (req "current_messages_hash" Hash.encoding) + (req "current_level_hash" Hash.encoding) (req "old_levels_messages" old_levels_messages_encoding))) let number_of_available_messages inbox = @@ -326,20 +346,6 @@ module V1 = struct let starting_level_of_current_commitment_period inbox = inbox.starting_level_of_current_commitment_period - let no_messages_hash = Hash.hash_bytes [Bytes.empty] - - let empty rollup level = - { - rollup; - level; - message_counter = Z.zero; - nb_available_messages = 0L; - nb_messages_in_commitment_period = 0L; - starting_level_of_current_commitment_period = level; - current_messages_hash = (fun () -> no_messages_hash); - old_levels_messages = Skip_list.genesis no_messages_hash; - } - let consume_n_messages n ({nb_available_messages; _} as inbox) : t option tzresult = let n = Int64.of_int32 n in @@ -371,14 +377,19 @@ let of_versioned = function V1 inbox -> inbox [@@inline] let to_versioned inbox = V1 inbox [@@inline] -let key_of_message = Data_encoding.Binary.to_string_exn Data_encoding.z +let key_of_message ix = + ["message"; Data_encoding.Binary.to_string_exn Data_encoding.z ix] + +let level_key = ["level"] module type MerkelizedOperations = sig + type inbox_context + type tree - type messages = tree + val hash_level_tree : tree -> Hash.t - type message = tree + val new_level_tree : inbox_context -> Raw_level_repr.t -> tree Lwt.t type history @@ -389,23 +400,33 @@ module type MerkelizedOperations = sig val history_at_genesis : bound:int64 -> history val add_messages : + inbox_context -> history -> t -> Raw_level_repr.t -> Sc_rollup_inbox_message_repr.serialized list -> - messages -> - (messages * history * t) tzresult Lwt.t + tree option -> + (tree * history * t) tzresult Lwt.t val add_messages_no_history : + inbox_context -> t -> Raw_level_repr.t -> Sc_rollup_inbox_message_repr.serialized list -> - messages -> - (messages * t) tzresult Lwt.t + tree option -> + (tree * t) tzresult Lwt.t - val get_message : messages -> Z.t -> message option Lwt.t + val get_message_payload : + tree -> Z.t -> Sc_rollup_inbox_message_repr.serialized option Lwt.t + + val form_history_proof : + inbox_context -> + history -> + t -> + tree option -> + (history * history_proof) Lwt.t - val get_message_payload : messages -> Z.t -> string option Lwt.t + val take_snapshot : t -> history_proof type inclusion_proof @@ -415,51 +436,98 @@ module type MerkelizedOperations = sig val number_of_proof_steps : inclusion_proof -> int - val produce_inclusion_proof : history -> t -> t -> inclusion_proof option + val produce_inclusion_proof : + history -> history_proof -> history_proof -> inclusion_proof option + + val verify_inclusion_proof : + inclusion_proof -> history_proof -> history_proof -> bool + + type proof + + val pp_proof : Format.formatter -> proof -> unit - val verify_inclusion_proof : inclusion_proof -> t -> t -> bool + val proof_encoding : proof Data_encoding.t + + val verify_proof : + Raw_level_repr.t * Z.t -> + history_proof -> + proof -> + Sc_rollup_PVM_sem.input option tzresult Lwt.t + + val produce_proof : + inbox_context -> + history -> + history_proof -> + Raw_level_repr.t * Z.t -> + (proof * Sc_rollup_PVM_sem.input option) tzresult Lwt.t + + val empty : inbox_context -> Sc_rollup_repr.t -> Raw_level_repr.t -> t Lwt.t end -module type TREE = sig - type t +module type P = sig + module Tree : Context.TREE with type key = string list and type value = bytes - type tree + type t = Tree.t - type key = string list + type tree = Tree.tree + + val commit_tree : Tree.t -> string list -> Tree.tree -> unit Lwt.t - type value = bytes + val lookup_tree : Tree.t -> Hash.t -> tree option Lwt.t - val find : tree -> key -> value option Lwt.t + type proof - val find_tree : tree -> key -> tree option Lwt.t + val proof_encoding : proof Data_encoding.t - val add : tree -> key -> value -> tree Lwt.t + val proof_before : proof -> Hash.t - val is_empty : tree -> bool + val verify_proof : + proof -> (tree -> (tree * 'a) Lwt.t) -> (tree * 'a) option Lwt.t - val hash : tree -> Context_hash.t + val produce_proof : + Tree.t -> tree -> (tree -> (tree * 'a) Lwt.t) -> (proof * 'a) option Lwt.t end -module MakeHashingScheme (Tree : TREE) : - MerkelizedOperations with type tree = Tree.tree = struct - module Tree = Tree +module MakeHashingScheme (P : P) : + MerkelizedOperations with type tree = P.tree and type inbox_context = P.t = +struct + module Tree = P.Tree - type tree = Tree.tree + type inbox_context = P.t - type messages = tree + type tree = P.tree - type message = tree + let hash_level_tree level_tree = Hash.of_context_hash (Tree.hash level_tree) - let add_message inbox payload messages = + let set_level tree level = + let level_bytes = + Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level + in + Tree.add tree level_key level_bytes + + let find_level tree = + let open Lwt_syntax in + let+ level_bytes = Tree.(find tree level_key) in + Option.bind + level_bytes + (Data_encoding.Binary.of_bytes_opt Raw_level_repr.encoding) + + (** Initialise the merkle tree for a new level in the inbox. We have + to include the [level] in this structure so that it cannot be + forged by a malicious rollup node. *) + let new_level_tree ctxt level = + let tree = Tree.empty ctxt in + set_level tree level + + let add_message inbox payload level_tree = let open Lwt_tzresult_syntax in let message_index = inbox.message_counter in let message_counter = Z.succ message_index in - let key = key_of_message message_index in let nb_available_messages = Int64.succ inbox.nb_available_messages in - let*! messages = + let*! level_tree = Tree.add - messages - [key; "payload"] + level_tree + (key_of_message message_index) (Bytes.of_string (payload : Sc_rollup_inbox_message_repr.serialized :> string)) in @@ -468,26 +536,33 @@ module MakeHashingScheme (Tree : TREE) : in let inbox = { - inbox with + starting_level_of_current_commitment_period = + inbox.starting_level_of_current_commitment_period; + current_level_hash = inbox.current_level_hash; + rollup = inbox.rollup; + level = inbox.level; + old_levels_messages = inbox.old_levels_messages; message_counter; nb_available_messages; nb_messages_in_commitment_period; } in - return (messages, inbox) - - let get_message messages message_index = - let key = key_of_message message_index in - Tree.(find_tree messages [key]) + return (level_tree, inbox) - let get_message_payload messages message_index = + let get_message_payload level_tree message_index = + let open Lwt_syntax in let key = key_of_message message_index in - Tree.(find messages [key; "payload"]) >|= Option.map Bytes.to_string - - let hash_old_levels_messages cell = - let current_messages_hash = Skip_list.content cell in + let* bytes = Tree.(find level_tree key) in + return + @@ Option.map + (fun bs -> + Sc_rollup_inbox_message_repr.unsafe_of_string (Bytes.to_string bs)) + bytes + + let hash_skip_list_cell cell = + let current_level_hash = Skip_list.content cell in let back_pointers_hashes = Skip_list.back_pointers cell in - Hash.to_bytes current_messages_hash + Hash.to_bytes current_level_hash :: List.map Hash.to_bytes back_pointers_hashes |> Hash.hash_bytes @@ -536,20 +611,18 @@ module MakeHashingScheme (Tree : TREE) : let history_at_genesis ~bound = {events = Hash.Map.empty; sequence = Int64_map.empty; bound; counter = 0L} - type without_history_witness - - type with_history_witness + (** [no_history] creates an empty history with [bound] 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 ~bound:0L - type _ with_history = - | No_history : without_history_witness with_history - | With_history : history -> with_history_witness with_history - - (** [remember_history ptr cell history] extends [history] with a new + (** [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 bound is less or equal to zero, then this function returns [history] untouched. *) - let remember_history ptr cell history = + let remember ptr cell history = if Compare.Int64.(history.bound <= 0L) then history else let events = Hash.Map.add ptr cell history.events in @@ -564,7 +637,10 @@ module MakeHashingScheme (Tree : TREE) : in if Int64.(equal history.counter history.bound) then match Int64_map.min_binding history.sequence with - | None -> history + | None -> + (* This case is impossible as the map [history.sequence] was + added to a few lines earlier. *) + assert false | Some (l, h) -> let sequence = Int64_map.remove l history.sequence in let events = Hash.Map.remove h events in @@ -576,86 +652,114 @@ module MakeHashingScheme (Tree : TREE) : } else history - let remember : - type history_witness. - history_proof_hash -> - history_proof -> - history_witness with_history -> - history_witness with_history = - fun ptr cell history -> - match history with - | No_history -> No_history - | With_history history -> With_history (remember_history ptr cell history) - - let archive_if_needed history inbox target_level = - let archive_level history inbox = - let prev_cell = inbox.old_levels_messages in - let prev_cell_ptr = hash_old_levels_messages prev_cell in - let history = remember prev_cell_ptr prev_cell history in - let old_levels_messages = - Skip_list.next - ~prev_cell - ~prev_cell_ptr - (inbox.current_messages_hash ()) + let take_snapshot inbox = + let prev_cell = inbox.old_levels_messages in + let prev_cell_ptr = hash_skip_list_cell prev_cell in + Skip_list.next ~prev_cell ~prev_cell_ptr (current_level_hash inbox) + + 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 form_history_proof ctxt history inbox level_tree = + let open Lwt_syntax in + let* () = + let* tree = + match level_tree with + | Some tree -> return tree + | None -> new_level_tree ctxt inbox.level in - let level = Raw_level_repr.succ inbox.level in - let current_messages_hash () = no_messages_hash 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 cell = + Skip_list.next ~prev_cell ~prev_cell_ptr (current_level_hash inbox) + in + return (history, cell) + + (** [archive_if_needed ctxt history inbox new_level level_tree] + is responsible for ensuring that the {!add_messages_aux} function + below has a correctly set-up [level_tree] to which to add the + messages. If [new_level] is a higher level than the current inbox, + we create a new inbox level tree at that level in which to start + adding messages, and archive the earlier levels depending on the + [history] parameter's [bound]. If [level_tree] is [None] (this + happens when the inbox is first created) we similarly create a new + empty level tree with the right [level] key. + + 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 + 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 + 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 inbox = { + starting_level_of_current_commitment_period = + inbox.starting_level_of_current_commitment_period; + current_level_hash = inbox.current_level_hash; rollup = inbox.rollup; nb_available_messages = inbox.nb_available_messages; nb_messages_in_commitment_period = inbox.nb_messages_in_commitment_period; - starting_level_of_current_commitment_period = - inbox.starting_level_of_current_commitment_period; old_levels_messages; - level; - current_messages_hash; + level = new_level; message_counter = Z.zero; } in - (history, inbox) - in - let rec aux (history, inbox) = - if Raw_level_repr.(inbox.level = target_level) then (history, inbox) - else aux (archive_level history inbox) - in - aux (history, inbox) + return (history, inbox, tree) - let hash_messages messages = - if Tree.is_empty messages then no_messages_hash - else Hash.of_context_hash @@ Tree.hash messages - - let add_messages_aux history inbox level payloads messages = + let add_messages_aux ctxt history inbox level payloads level_tree = let open Lwt_tzresult_syntax in + let* () = + fail_when + (match payloads with [] -> true | _ -> false) + Tried_to_add_zero_messages + in let* () = fail_when Raw_level_repr.(level < inbox.level) (Invalid_level_add_messages level) in - let history, inbox = archive_if_needed history inbox level in - let* messages, inbox = + let*! history, inbox, level_tree = + archive_if_needed ctxt history inbox level level_tree + in + let* level_tree, inbox = List.fold_left_es - (fun (messages, inbox) payload -> add_message inbox payload messages) - (messages, inbox) + (fun (level_tree, inbox) payload -> + add_message inbox payload level_tree) + (level_tree, inbox) payloads in - let current_messages_hash () = hash_messages messages in - return (messages, history, {inbox with current_messages_hash}) + let current_level_hash () = hash_level_tree level_tree in + return (level_tree, history, {inbox with current_level_hash}) - let add_messages history inbox level payloads messages = + let add_messages ctxt history inbox level payloads level_tree = let open Lwt_tzresult_syntax in - let* messages, With_history history, inbox = - add_messages_aux (With_history history) inbox level payloads messages + let* level_tree, history, inbox = + add_messages_aux ctxt history inbox level payloads level_tree in - return (messages, history, inbox) + return (level_tree, history, inbox) - let add_messages_no_history inbox level payloads messages = + let add_messages_no_history ctxt inbox level payloads level_tree = let open Lwt_tzresult_syntax in - let* messages, No_history, inbox = - add_messages_aux No_history inbox level payloads messages + let* level_tree, _, inbox = + add_messages_aux ctxt no_history inbox level payloads level_tree in - return (messages, inbox) + return (level_tree, inbox) (* An [inclusion_proof] is a path in the Merkelized skip list showing that a given inbox history is a prefix of another one. @@ -663,7 +767,7 @@ module MakeHashingScheme (Tree : TREE) : levels of the two inboxes. [Irmin.Proof.{tree_proof, stream_proof}] could not be reused here - because there is no obviously encoding of sequences in these data + because there is no obvious encoding of sequences in these data structures with the same guarantee about the size of proofs. *) type inclusion_proof = history_proof list @@ -683,186 +787,488 @@ module MakeHashingScheme (Tree : TREE) : in aux [] ptr_path - let produce_inclusion_proof history inbox1 inbox2 = - let cell_ptr = hash_old_levels_messages inbox2.old_levels_messages in - let target_index = Skip_list.index inbox1.old_levels_messages in - let (With_history history) = - remember cell_ptr inbox2.old_levels_messages (With_history history) - in + let produce_inclusion_proof history a b = + 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 Skip_list.back_path ~deref ~cell_ptr ~target_index |> Option.map (lift_ptr_path deref) |> Option.join - let verify_inclusion_proof proof inbox1 inbox2 = - let assoc = List.map (fun c -> (hash_old_levels_messages c, c)) proof in + let verify_inclusion_proof proof a b = + let assoc = List.map (fun c -> (hash_skip_list_cell c, c)) proof in let path = List.split assoc |> fst in let deref = let open Hash.Map in let map = of_seq (List.to_seq assoc) in fun ptr -> find_opt ptr map in - let cell_ptr = hash_old_levels_messages inbox2.old_levels_messages in - let target_ptr = hash_old_levels_messages inbox1.old_levels_messages in + let cell_ptr = hash_skip_list_cell b in + let target_ptr = hash_skip_list_cell a in Skip_list.valid_back_path ~equal_ptr:Hash.equal ~deref ~cell_ptr ~target_ptr path + + type proof = + (* See the main docstring for this type (in the mli file) for + definitions of the three proof parameters [starting_point], + [message] and [snapshot]. In the below we deconstruct + [starting_point] into [(l, n)] where [l] is a level and [n] is a + message index. + + In a [Single_level] proof, [level] is the skip list cell for the + level [l], [inc] is an inclusion proof of [level] into + [snapshot] and [message_proof] is a tree proof showing that + + [exists level_tree . + (hash_level_tree level_tree = level.content) + AND (payload_and_level n level_tree = (_, (message, l)))] + + Note: in the case that [message] is [None] this shows that + there's no value at the index [n]; in this case we also must + check that [level] equals [snapshot] (otherwise, we'd need a + [Level_crossing] proof instead. *) + | Single_level of { + level : history_proof; + inc : inclusion_proof; + message_proof : P.proof; + } + (* See the main docstring for this type (in the mli file) for + definitions of the three proof parameters [starting_point], + [message] and [snapshot]. In the below we deconstruct + [starting_point] as [(l, n)] where [l] is a level and [n] is a + message index. + + In a [Level_crossing] proof, [lower] is the skip list cell for + the level [l] and [upper] must be the skip list cell that comes + immediately after it in [snapshot]. If the inbox has been + constructed correctly using the functions in this module that + will be the next non-empty level in the inbox. + + [inc] is an inclusion proof of [upper] into [snapshot]. + [upper_level] is the level of [upper]. + + The tree proof [lower_message_proof] shows the following: + + [exists level_tree . + (hash_level_tree level_tree = lower.content) + AND (payload_and_level n level_tree = (_, (None, l)))] + + in other words, there is no message at index [n] in + level [l]. This means that level has been fully read. + + The tree proof [upper_message_proof] shows the following: + + [exists level_tree . + (hash_level_tree level_tree = upper.content) + AND (payload_and_level 0 level_tree = (_, (message, upper_level)))] + + in other words, if we look in the next non-empty level the + message at index zero is [message]. *) + | Level_crossing of { + lower : history_proof; + upper : history_proof; + inc : inclusion_proof; + lower_message_proof : P.proof; + upper_message_proof : P.proof; + upper_level : Raw_level_repr.t; + } + + let pp_proof fmt proof = + match proof with + | Single_level {level; _} -> + let hash = Skip_list.content level in + Format.fprintf fmt "Single_level inbox proof at %a" Hash.pp hash + | Level_crossing {lower; upper; upper_level; _} -> + let lower_hash = Skip_list.content lower in + let upper_hash = Skip_list.content upper in + Format.fprintf + fmt + "Level_crossing inbox proof between %a and %a (upper_level %a)" + Hash.pp + lower_hash + Hash.pp + upper_hash + Raw_level_repr.pp + upper_level + + let proof_encoding = + let open Data_encoding in + union + ~tag_size:`Uint8 + [ + case + ~title:"Single_level" + (Tag 0) + (obj3 + (req "level" history_proof_encoding) + (req "inclusion_proof" inclusion_proof_encoding) + (req "message_proof" P.proof_encoding)) + (function + | Single_level {level; inc; message_proof} -> + Some (level, inc, message_proof) + | _ -> None) + (fun (level, inc, message_proof) -> + Single_level {level; inc; message_proof}); + case + ~title:"Level_crossing" + (Tag 1) + (obj6 + (req "lower" history_proof_encoding) + (req "upper" history_proof_encoding) + (req "inclusion_proof" inclusion_proof_encoding) + (req "lower_message_proof" P.proof_encoding) + (req "upper_message_proof" P.proof_encoding) + (req "upper_level" Raw_level_repr.encoding)) + (function + | Level_crossing + { + lower; + upper; + inc; + lower_message_proof; + upper_message_proof; + upper_level; + } -> + Some + ( lower, + upper, + inc, + lower_message_proof, + upper_message_proof, + upper_level ) + | _ -> None) + (fun ( lower, + upper, + inc, + lower_message_proof, + upper_message_proof, + upper_level ) -> + Level_crossing + { + lower; + upper; + inc; + lower_message_proof; + upper_message_proof; + upper_level; + }); + ] + + let proof_error reason = + let open Lwt_tzresult_syntax in + fail (Inbox_proof_error reason) + + let check p reason = unless p (fun () -> proof_error reason) + + (** Utility function that checks the inclusion proof [inc] for any + inbox proof. + + In the case of a [Single_level] proof this is just an inclusion + proof between [level] and the inbox snapshot targeted the proof. + + In the case of a [Level_crossing] proof [inc] must be an inclusion + proof between [upper] and the inbox snapshot. In this case we must + additionally check that [lower] is the immediate predecessor of + [upper] in the inbox skip list. NB: there may be many 'inbox + levels' apart, but if the intervening levels are empty they will + be immediate neighbours in the skip list because it misses empty + levels out. *) + let check_inclusions proof snapshot = + check + (match proof with + | Single_level {inc; level; _} -> + verify_inclusion_proof inc level snapshot + | Level_crossing {inc; lower; upper; _} -> ( + let prev_cell = Skip_list.back_pointer upper 0 in + match prev_cell with + | None -> false + | Some p -> + verify_inclusion_proof inc upper snapshot + && Hash.equal p (hash_skip_list_cell lower))) + "invalid inclusions" + + (** To construct or verify a tree proof we need a function of type + + [tree -> (tree, result) Lwt.t] + + where [result] is some data extracted from the tree that we care + about proving. [payload_and_level n] is such a function, used for + checking both the inbox level specified inside the tree and the + message at a particular index, [n]. + + For this function, the [result] is + + [(payload, level) : string option * Raw_level_repr.t option] + + where [payload] is [None] if there was no message at the index. + The [level] part of the result will only be [None] if the [tree] + is not in the correct format for an inbox level. This should not + happen if the [tree] was correctly initialised with + [new_level_tree]. *) + let payload_and_level n tree = + let open Lwt_syntax in + let* payload = get_message_payload tree n in + let* level = find_level tree in + return (tree, (payload, level)) + + (** Utility function that handles all the verification needed for a + particular message proof at a particular level. It calls + [P.verify_proof], but also checks the proof has the correct + [P.proof_before] hash and the [level] stored inside the tree is + the expected one. *) + let check_message_proof message_proof level_hash (l, n) label = + let open Lwt_tzresult_syntax in + let* () = + check + (Hash.equal level_hash (P.proof_before message_proof)) + (Format.sprintf "message_proof (%s) does not match history" label) + in + let*! result = P.verify_proof message_proof (payload_and_level n) in + match result with + | None -> proof_error (Format.sprintf "message_proof is invalid (%s)" label) + | Some (_, (_, None)) -> + proof_error + (Format.sprintf "badly encoded level in message_proof (%s)" label) + | Some (_, (payload_opt, Some proof_level)) -> + let* () = + check + (Raw_level_repr.equal proof_level l) + (Format.sprintf "incorrect level in message_proof (%s)" label) + in + return payload_opt + + let verify_proof (l, n) snapshot proof = + assert (Z.(geq n zero)) ; + let open Lwt_tzresult_syntax in + let* () = check_inclusions proof snapshot in + match proof with + | Single_level p -> ( + let level_hash = Skip_list.content p.level in + let* payload_opt = + check_message_proof p.message_proof level_hash (l, n) "single level" + in + match payload_opt with + | None -> + if equal_history_proof snapshot p.level then return None + else proof_error "payload is None but proof.level not top level" + | Some payload -> + return + @@ Some + Sc_rollup_PVM_sem. + {inbox_level = l; message_counter = n; payload}) + | Level_crossing p -> ( + let lower_level_hash = Skip_list.content p.lower in + let* should_be_none = + check_message_proof + p.lower_message_proof + lower_level_hash + (l, n) + "lower" + in + let* () = + match should_be_none with + | None -> return () + | Some _ -> proof_error "more messages to read in lower level" + in + let upper_level_hash = Skip_list.content p.upper in + let* payload_opt = + check_message_proof + p.upper_message_proof + upper_level_hash + (p.upper_level, Z.zero) + "upper" + in + match payload_opt with + | None -> + if equal_history_proof snapshot p.upper then return None + else proof_error "payload is None but proof.upper is not top level" + | Some payload -> + return + @@ Some + Sc_rollup_PVM_sem. + { + inbox_level = p.upper_level; + message_counter = Z.zero; + payload; + }) + + (** Utility function; we convert all our calls to be consistent with + [Lwt_tzresult_syntax]. *) + let option_to_result e lwt_opt = + let open Lwt_syntax in + let* opt = lwt_opt in + match opt with None -> proof_error e | Some x -> return (ok x) + + 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 compare hash = + (* TODO: #3321 replace with Lwt_option_syntax when that's in the + environment V6 *) + let ( let* ) x f = + Lwt.(x >>= function None -> return None | Some y -> f y) + in + let result = + let* tree = P.lookup_tree ctxt hash in + let* level = find_level tree in + Lwt.return (Some (Raw_level_repr.compare level l)) + in + Lwt.map (fun x -> Option.value x ~default:(-1)) result + in + let* path = + option_to_result + (Format.sprintf + "Skip_list.search failed to find path to requested level (%ld)" + (Raw_level_repr.to_int32 l)) + (Skip_list.search ~deref ~compare ~cell_ptr) + in + let* inc = + option_to_result + "failed to deref some level in the path" + (Lwt.return (lift_ptr_path deref path)) + in + let* level = + option_to_result + "Skip_list.search returned empty list" + (Lwt.return (List.last_opt inc)) + in + let* level_tree = + option_to_result + "could not find level_tree in the inbox_context" + (P.lookup_tree ctxt (Skip_list.content level)) + in + let* message_proof, (payload_opt, _) = + option_to_result + "failed to produce message proof for level_tree" + (P.produce_proof ctxt level_tree (payload_and_level n)) + in + match payload_opt with + | Some payload -> + return + ( Single_level {level; inc; message_proof}, + Some + Sc_rollup_PVM_sem.{inbox_level = l; message_counter = n; payload} + ) + | None -> + if equal_history_proof inbox level then + return (Single_level {level; inc; message_proof}, None) + else + let target_index = Skip_list.index level + 1 in + let* inc = + option_to_result + "failed to find path to upper level" + (Lwt.return + (Skip_list.back_path ~deref ~cell_ptr ~target_index + |> Option.map (lift_ptr_path deref) + |> Option.join)) + in + let* upper = + option_to_result + "back_path returned empty list" + (Lwt.return (List.last_opt inc)) + in + let* upper_level_tree = + option_to_result + "could not find upper_level_tree in the inbox_context" + (P.lookup_tree ctxt (Skip_list.content upper)) + in + let* upper_message_proof, (payload_opt, upper_level_opt) = + option_to_result + "failed to produce message proof for upper_level_tree" + (P.produce_proof ctxt upper_level_tree (payload_and_level Z.zero)) + in + let* upper_level = + option_to_result + "upper_level_tree was misformed---could not find level" + (Lwt.return upper_level_opt) + in + return + ( Level_crossing + { + lower = level; + upper; + inc; + lower_message_proof = message_proof; + upper_message_proof; + upper_level; + }, + Option.map + (fun payload -> + Sc_rollup_PVM_sem. + { + inbox_level = upper_level; + message_counter = Z.zero; + payload; + }) + payload_opt ) + + let empty context rollup level = + let open Lwt_syntax in + let* initial_level = new_level_tree context level in + let initial_hash = hash_level_tree initial_level in + return + { + rollup; + level; + message_counter = Z.zero; + nb_available_messages = 0L; + nb_messages_in_commitment_period = 0L; + starting_level_of_current_commitment_period = level; + current_level_hash = (fun () -> initial_hash); + old_levels_messages = Skip_list.genesis (Hash.hash_bytes []); + } end include ( MakeHashingScheme (struct - include Context.Tree + module Tree = struct + include Context.Tree - type t = Context.t + type t = Context.t - type tree = Context.tree + type tree = Context.tree - type value = bytes + type value = bytes - type key = string list - end) : - MerkelizedOperations with type tree = Context.tree) + type key = string list + end -type inbox = t + type t = Context.t -module Proof = struct - type starting_point = {inbox_level : Raw_level_repr.t; message_counter : Z.t} + type tree = Context.tree - type t = { - skips : (inbox * inclusion_proof) list; - (* The [skips] value in this record makes it potentially unbounded - in size. There is an issue #2997 to deal with this problem. *) - level : inbox; - inc : inclusion_proof; - message_proof : Context.Proof.tree Context.Proof.t; - } + let commit_tree _ctxt _key _tree = + (* This is a no-op in the protocol inbox implementation *) + Lwt.return () - let pp fmt proof = - Format.fprintf fmt "Inbox proof with %d skips" (List.length proof.skips) + let lookup_tree _ctxt _hash = + (* We cannot find the tree without a full inbox_context *) + Lwt.return None - let encoding = - let open Data_encoding in - conv - (fun {skips; level; inc; message_proof} -> - (skips, level, inc, message_proof)) - (fun (skips, level, inc, message_proof) -> - {skips; level; inc; message_proof}) - (obj4 - (req "skips" (list (tup2 encoding inclusion_proof_encoding))) - (req "level" encoding) - (req "inc" inclusion_proof_encoding) - (req - "message_proof" - Context.Proof_encoding.V1.Tree32.tree_proof_encoding)) - - (* This function is for pattern matching on proofs based on whether - they involve multiple levels or if they only concern a single - level. - - [split_proof proof] is [None] in the case that [proof] is a - 'simple' inbox proof that only involves one level. In this case - [skips] is empty and we just check the single [level], [inc] - pair, and the [message_proof]. - - [split_proof proof] is [Some (level, inc, remaining_proof)] if - there are [skips]. In this case, we must check the [level] and - [inc] given, and then continue (recursively) on to the - [remaining_proof]. *) - let split_proof proof = - match proof.skips with - | [] -> None - | (level, inc) :: rest -> Some (level, inc, {proof with skips = rest}) - - (* A proof might include several sub-inboxes as evidence of different - levels being empty in the actual inbox snapshot. This returns the - _lowest_ such sub-inbox for a given proof. - - It's used with the function above in the recursive case of [valid]. - When [split_proof proof] gives [Some (level, inc, remaining_proof)] - we have to check that [inc] is an inclusion proof between [level] - and [bottom_level remaining_proof]. *) - let bottom_level proof = - match proof.skips with [] -> proof.level | (level, _) :: _ -> level - - (* The [message_proof] part of an inbox proof is a - [Context.tree_proof]. - - To validate this, we need a function of type - - [tree -> (tree, result) Lwt.t]. - - For a given [n], [message_payload n] is such a function: it takes a - [Context.tree] representing the messages in a single level of the - inbox and extracts the message payload at index [n], so [result] in - this case is [string]. (It also returns the tree just to satisfy - the function [Context.verify_tree_proof]). *) - let message_payload n tree = - let open Lwt_syntax in - let* r = get_message_payload tree n in - return (tree, r) + type proof = Context.Proof.tree Context.Proof.t - let check_hash hash kinded_hash = - match kinded_hash with - | `Node h -> Hash.(equal (of_context_hash h) hash) - | `Value h -> Hash.(equal (of_context_hash h) hash) + let proof_encoding = Context.Proof_encoding.V1.Tree32.tree_proof_encoding - type error += Inbox_proof_error of string + let proof_before proof = + match proof.Context.Proof.before with + | `Value hash | `Node hash -> Hash.of_context_hash hash - let proof_error reason = - let open Lwt_result_syntax in - fail (Inbox_proof_error reason) + let verify_proof p f = + Lwt.map Result.to_option (Context.verify_tree_proof p f) - let drop_error promise reason = - let open Lwt_tzresult_syntax in - let*! result = promise in - match result with Ok r -> return r | Error _ -> proof_error reason + let produce_proof _ _ _ = + (* We cannot produce a proof without full inbox_context *) + Lwt.return None + end) : + MerkelizedOperations + with type tree = Context.tree + and type inbox_context = Context.t) - let rec valid {inbox_level = l; message_counter = n} inbox proof = - assert (Z.(geq n zero)) ; - let open Lwt_result_syntax in - match split_proof proof with - | None -> - if - verify_inclusion_proof proof.inc proof.level inbox - && Raw_level_repr.equal (inbox_level proof.level) l - && check_hash - (proof.level.current_messages_hash ()) - proof.message_proof.before - then - let* (_ : Context.tree), payload = - drop_error - (Context.verify_tree_proof - proof.message_proof - (message_payload n)) - "message_proof invalid" - in - match payload with - | None -> - if equal proof.level inbox then return None - else proof_error "payload is None, inbox proof.level not top" - | Some msg -> - let payload = Sc_rollup_inbox_message_repr.unsafe_of_string msg in - return - @@ Some - Sc_rollup_PVM_sem. - {inbox_level = l; message_counter = n; payload} - else proof_error "Inbox proof parameters don't match (message level)" - | Some (level, inc, remaining_proof) -> - if - verify_inclusion_proof inc level (bottom_level remaining_proof) - && Raw_level_repr.equal (inbox_level level) l - && Z.equal level.message_counter n - then - valid - {inbox_level = Raw_level_repr.succ l; message_counter = Z.zero} - inbox - remaining_proof - else proof_error "Inbox proof parameters don't match (lower level)" - - (* TODO #2997 This needs to be implemented when the inbox structure is - improved. *) - let produce_proof _ _ = assert false -end +type inbox = t diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli index 4456130ed0f59601fa971570a5ffc177d5dbfd51..b477f0d13e9147c382301acb289ca861f0f98bad 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_repr.mli @@ -132,14 +132,48 @@ module V1 : sig val encoding : t Data_encoding.t - (** [empty level] is an inbox started at some given [level] with no - message at all. *) - val empty : Sc_rollup_repr.t -> Raw_level_repr.t -> t - (** [inbox_level inbox] returns the maximum level of message insertion in [inbox] or its initial level. *) val inbox_level : t -> Raw_level_repr.t + (** A [history_proof] is a [Skip_list.cell] that stores multiple + hashes. [Skip_list.content history_proof] gives the hash of the + level tree for this cell, while [Skip_list.back_pointers + history_proof] is an array of hashes of earlier [history_proof]s + in the inbox. + + On the one hand, we think of this type as representing the whole + Merkle structure of an inbox at a given level---it is the part of + {!t} above that can actually be used to prove things (it cannot be + forged by a malicious node because it much match the hash stored by + the L1). + + On the other hand, we think of this type as representing a single + proof-step back through the history of the inbox; given a hash that + appears at some point later in the inbox this type proves that that + hash points to this particular combination of a level tree and + further back-pointers. + + In terms of size, this type is a small set of hashes; one for the + current level tree and `O(log2(ix))` in the back-pointers, where + [ix] is the index of the cell in the skip list. That is, [ix] is the + number of non-empty levels between now and the origination level of + the rollup. + *) + type history_proof + + val pp_history_proof : Format.formatter -> history_proof -> unit + + val history_proof_encoding : history_proof Data_encoding.t + + val equal_history_proof : history_proof -> history_proof -> bool + + (** [old_levels_messages inbox] returns the skip list of the inbox + history. How much data there actually is depends on the context---in + the L1 most of the history is forgotten and just a root hash of the + skip list is kept. *) + val old_levels_messages : t -> history_proof + (** [number_of_available_messages inbox] returns the number of messages that can be consumed in [inbox]. *) val number_of_available_messages : t -> Z.t @@ -168,7 +202,19 @@ include Sc_rollup_data_version_sig.S with type t = V1.t include module type of V1 with type t = V1.t -module Hash : S.HASH +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 + preserve the laziness. *) +val current_level_hash : t -> Hash.t (** The following operations are subject to cross-validation between rollup nodes and the layer 1. *) @@ -176,79 +222,121 @@ module type MerkelizedOperations = sig (** The type for the Merkle trees used in this module. *) type tree - (** A merkelized message. *) - type message = tree - - (** A merkelized sequence of messages. *) - type messages = tree - - (** The history is a merkelized sequence of [messages], one per - level. The history is typically used by the rollup node to - produce inclusion proofs. The protocol only manipulates an empty - history as it does not remember previous messages and only keeps - a witness of the latest state of the history. *) + (** The context used by the trees. *) + type inbox_context + + (** Standard hashing function used for trees in this module. *) + val hash_level_tree : tree -> Hash.t + + (** Initialise a new level. [new_level_tree ctxt level] is a merkle + tree with no messages yet, but has the [level] stored so we can + check that in proofs. *) + val new_level_tree : inbox_context -> Raw_level_repr.t -> tree Lwt.t + + (** A [history] 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 + [Skip_list.back_path] or [Skip_list.search] to allow these + functions to construct valid paths back through the skip list. + + 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 [bound] parameter. In the L1 we use this with + [bound] 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. *) type history val history_encoding : history Data_encoding.t val pp_history : Format.formatter -> history -> unit - (** The beginning of the history is an empty sequence of [messages]. - Fail with {!Invalid_bound_on_history} if [bound] is not strictly - positive. *) + (** Construct an empty initial [history] with a given [bound]. If you + are running a rollup node, [bound] needs to be large enough to + remember any levels for which you may need to produce proofs. *) val history_at_genesis : bound:int64 -> history - (** [add_messages history inbox level payloads messages] inserts a list of - [payloads] as new messages in the [messages] of the current [level] of the - [inbox]. This function returns the new sequence of messages as well as - updated [inbox] and [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 + tree as well as updated [inbox] and [history]. - If the [inbox]'s level is older than [level], the [inbox] is updated - so that the messages of the levels older than [level] are archived. - To archive a sequence of [messages] for a given [level], we push - it at the end of the [history] and update the witness of this - history in the [inbox]. The [inbox]'s messages for the current - level are also emptied to insert the [payloads] in a fresh sequence - of [messages] for [level]. + If the [inbox]'s level is older than [level], the [inbox] is + updated so that the level trees of the levels older than [level] + are archived. To archive a [level_tree] for a given [level], we + push it at the end of the [history] and update the witness of this + history in the [inbox]. The [inbox]'s level tree for the current + level is emptied to insert the [payloads] in a fresh [level_tree] + for [level]. This function fails if [level] is older than [inbox]'s [level]. *) val add_messages : + inbox_context -> history -> t -> Raw_level_repr.t -> Sc_rollup_inbox_message_repr.serialized list -> - messages -> - (messages * history * t) tzresult Lwt.t + tree option -> + (tree * history * t) tzresult Lwt.t - (** [add_messages_no_history inbox level payloads messages] behaves as - {!add_messages} except that it does not remember the inbox history. *) + (** [add_messages_no_history ctxt inbox level payloads level_tree] behaves + as {!add_external_messages} except that it does not remember the inbox + history. *) val add_messages_no_history : + inbox_context -> t -> Raw_level_repr.t -> Sc_rollup_inbox_message_repr.serialized list -> - messages -> - (messages * t, error trace) result Lwt.t + tree option -> + (tree * t, error trace) result Lwt.t + + (** [get_message_payload level_tree idx] returns [Some payload] if the + [level_tree] has more than [idx] messages, and [payload] is at + position [idx]. Returns [None] otherwise. *) + val get_message_payload : + tree -> Z.t -> Sc_rollup_inbox_message_repr.serialized option Lwt.t + + (** [form_history_proof ctxt history inbox level_tree] creates the + skip list structure that includes the current inbox level, while + also updating the [history] and making sure the [level_tree] has + been committed to the [ctxt]. + + This is used in [archive_if_needed] to produce the + [old_levels_messages] value for the next level of the inbox. It is + also needed if you want to produce a fully-up-to-date skip list + for proof production. Just taking the skip list stored in the + inbox at [old_levels_messages] will not include the current level + (and that current level could be quite far back in terms of blocks + if the inbox hasn't been added to for a while). *) + val form_history_proof : + inbox_context -> + history -> + t -> + tree option -> + (history * history_proof) Lwt.t - (** [get_message messages idx] returns [Some message] if the - sequence of [messages] has a more than [idx] messages and - [message] is at position [idx] in this sequence. - Returns [None] otherwise. *) - val get_message : messages -> Z.t -> message option 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 + is remembered or the trees are committed in the context. Used at + the beginning of a refutation game to create the snapshot against + which proofs in that game must be valid. - (** [get_message_payload messages idx] returns [Some payload] if the - sequence of [messages] has a more than [idx] messages, - [message] is at position [idx] in this sequence, and is defined - by [payload]. Returns [None] otherwise. *) - val get_message_payload : messages -> Z.t -> string option Lwt.t + This will however produce a [history_proof] with exactly the same + hash as the one produced by [form_history_proof], run on a node + with a complete [inbox_context]. *) + val take_snapshot : t -> history_proof (** Given a inbox [A] at some level [L] and another inbox [B] at some level [L' >= L], an [inclusion_proof] guarantees that [A] is an older version of [B]. To be more precise, an [inclusion_proof] guarantees that the - previous levels messages of [A] are included in the previous - levels messages of [B]. The current messages of [A] and [B] + previous levels [level_tree]s of [A] are included in the previous + levels [level_tree]s of [B]. The current [level_tree] of [A] and [B] are not considered. The size of this proof is O(log_basis (L' - L)). *) @@ -261,35 +349,90 @@ module type MerkelizedOperations = sig (** [number_of_proof_steps proof] returns the length of [proof]. *) val number_of_proof_steps : inclusion_proof -> int - (** [produce_inclusion_proof history inboxA inboxB] exploits - [history] to produce a self-contained proof that [inboxA] is an - older version of [inboxB]. *) - val produce_inclusion_proof : history -> t -> t -> inclusion_proof option + (** [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 + + (** [verify_inclusion_proof proof a b] returns [true] iff [proof] is a + minimal and valid proof that [a] is included in [b]. *) + val verify_inclusion_proof : + inclusion_proof -> history_proof -> history_proof -> bool + + (** An inbox proof has three parameters: + + - the [starting_point], of type [Raw_level_repr.t * Z.t], specifying + a location in the inbox ; + + - the [message], of type [Sc_rollup_PVM_sem.input option] ; + + - and a reference [snapshot] inbox. - (** [verify_inclusion_proof proof inboxA inboxA] returns [true] iff - [proof] is a minimal and valid proof that [inboxA] is included in - [inboxB]. *) - val verify_inclusion_proof : inclusion_proof -> t -> t -> bool + A valid inbox proof implies the following semantics: beginning at + [starting_point] and reading forward through [snapshot], the first + message you reach will be [message]. + + Usually this is fairly simple because there will actually be a + message at the location specified by [starting_point]. But in some + cases [starting_point] is past the last message within a level, + and then the inbox proof must prove that and also provide another + proof about the message at the beginning of the next non-empty + level. *) + type proof + + val pp_proof : Format.formatter -> proof -> unit + + val proof_encoding : proof Data_encoding.t + + (** See the docstring for the [proof] type for details of proof semantics. + + [verify_proof starting_point inbox proof] will return the third + parameter of the proof, [message], iff the proof is valid. *) + val verify_proof : + Raw_level_repr.t * Z.t -> + history_proof -> + proof -> + Sc_rollup_PVM_sem.input option tzresult Lwt.t + + (** [produce_proof ctxt history inbox (level, counter)] creates an + inbox proof proving the first message after the index [counter] at + location [level]. This will fail if the [ctxt] given doesn't have + sufficient data (it needs to be run on an [inbox_context] with the + full history). *) + val produce_proof : + inbox_context -> + history -> + history_proof -> + Raw_level_repr.t * Z.t -> + (proof * Sc_rollup_PVM_sem.input option) tzresult Lwt.t + + (** [empty ctxt level] is an inbox started at some given [level] with no + message at all. *) + val empty : inbox_context -> Sc_rollup_repr.t -> Raw_level_repr.t -> t Lwt.t end -module type TREE = sig - type t +module type P = sig + module Tree : Context.TREE with type key = string list and type value = bytes - type tree + type tree = Tree.tree - type key = string list + type t = Tree.t - type value = bytes + val commit_tree : t -> string list -> tree -> unit Lwt.t - val find : tree -> key -> value option Lwt.t + val lookup_tree : t -> Hash.t -> tree option Lwt.t - val find_tree : tree -> key -> tree option Lwt.t + type proof - val add : tree -> key -> value -> tree Lwt.t + val proof_encoding : proof Data_encoding.t - val is_empty : tree -> bool + val proof_before : proof -> Hash.t - val hash : tree -> Context_hash.t + val verify_proof : + proof -> (tree -> (tree * 'a) Lwt.t) -> (tree * 'a) option Lwt.t + + val produce_proof : + Tree.t -> tree -> (tree -> (tree * 'a) Lwt.t) -> (proof * 'a) option Lwt.t end (** @@ -305,71 +448,12 @@ end implementation of the {!MerkelizedOperations}. *) -module MakeHashingScheme (Tree : TREE) : - MerkelizedOperations with type tree = Tree.tree +module MakeHashingScheme (P : P) : + MerkelizedOperations with type tree = P.tree and type inbox_context = P.t -include MerkelizedOperations with type tree = Context.tree +include + MerkelizedOperations + with type tree = Context.tree + and type inbox_context = Context.t type inbox = t - -(** The [Proof] module wraps the more specific proof types provided - earlier in this file into the inbox proof as it is required by a - refutation. *) -module Proof : sig - type starting_point = {inbox_level : Raw_level_repr.t; message_counter : Z.t} - - (** An inbox proof has three parameters: - - - the {!starting_point} specifying a location in the inbox ; - - - the [message], of type [Sc_rollup_PVM_sem.input option] ; - - - and a reference [inbox]. - - A valid inbox proof implies the following semantics: beginning at - [starting_point] and reading forward through [inbox], the first - message you reach will be [message]. - - Usually this is very simple because there will actually be a - message at the location specified by [starting_point]. But in some - cases [starting_point] is past the last message within a level, - and then the inbox proof must prove that and also provide another - proof starting at the beginning of the next level. This can in - theory happen across multiple levels if they are empty, which is - why we need a list [skips] of sub-inboxes. - - TODO #2997: an issue to fix the problem of unbounded inbox proofs - if the list below can be arbitrarily long (if there are many - consecutive empty levels). *) - type t = { - skips : (inbox * inclusion_proof) list; - level : inbox; - inc : inclusion_proof; - message_proof : Context.Proof.tree Context.Proof.t; - } - - val pp : Format.formatter -> t -> unit - - val encoding : t Data_encoding.t - - (** See the docstring for {t} for details of proof semantics. - - [valid starting_point inbox proof] will return the third parameter - of the proof, [message], iff the proof is valid. *) - val valid : - starting_point -> - inbox -> - t -> - (Sc_rollup_PVM_sem.input option, error) result Lwt.t - - (** TODO #2997 Currently a placeholder, needs implementation. - - [produce_proof inbox (level, counter)] creates an inbox proof - proving the first message after the index [counter] at location - [level]. This will fail if the inbox given doesn't have sufficient - data (it needs to be run on an inbox with the full history). *) - val produce_proof : - inbox -> - Raw_level_repr.t * Z.t -> - (t * Sc_rollup_PVM_sem.input option, error) result Lwt.t -end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml index 072255fdcba5b9ec1cfb99a3fc1fe8f2efd06081..993841019a8aa4cc9f21ac08ee2b23de0ea592ce 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_inbox_storage.ml @@ -133,6 +133,7 @@ let add_messages ctxt rollup messages = *) let* current_messages, inbox = Sc_rollup_inbox_repr.add_messages_no_history + (Raw_context.recover ctxt) inbox level messages 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 953f20e2b5f69a60c0d79fc27e0e38cb3b7e328f..85fe421af9e4591a61b9c6c59c64164770e6fe29 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.ml @@ -26,7 +26,7 @@ type t = { pvm_step : Sc_rollups.wrapped_proof; - inbox : Sc_rollup_inbox_repr.Proof.t option; + inbox : Sc_rollup_inbox_repr.proof option; } let encoding = @@ -36,7 +36,7 @@ let encoding = (fun (pvm_step, inbox) -> {pvm_step; inbox}) (obj2 (req "pvm_step" Sc_rollups.wrapped_proof_encoding) - (req "inbox" (option Sc_rollup_inbox_repr.Proof.encoding))) + (req "inbox" (option Sc_rollup_inbox_repr.proof_encoding))) let pp ppf _ = Format.fprintf ppf "Refutation game proof" @@ -62,16 +62,16 @@ let cut_at_level level input = type error += Sc_rollup_proof_check of string let proof_error reason = - let open Lwt_result_syntax in + let open Lwt_tzresult_syntax in fail (Sc_rollup_proof_check reason) let check p reason = - let open Lwt_result_syntax in + let open Lwt_tzresult_syntax in if p then return () else proof_error reason let valid snapshot commit_level ~pvm_name proof = let (module P) = Sc_rollups.wrapped_proof_module proof.pvm_step in - let open Lwt_result_syntax in + let open Lwt_tzresult_syntax in let* () = check (String.equal P.name pvm_name) "Incorrect PVM kind" in let input_requested = P.proof_input_requested P.proof in let input_given = P.proof_input_given P.proof in @@ -79,13 +79,13 @@ let valid snapshot commit_level ~pvm_name proof = match (input_requested, proof.inbox) with | Sc_rollup_PVM_sem.No_input_required, None -> return None | Sc_rollup_PVM_sem.Initial, Some inbox_proof -> - Sc_rollup_inbox_repr.Proof.valid - {inbox_level = Raw_level_repr.root; message_counter = Z.zero} + Sc_rollup_inbox_repr.verify_proof + (Raw_level_repr.root, Z.zero) snapshot inbox_proof | Sc_rollup_PVM_sem.First_after (level, counter), Some inbox_proof -> - Sc_rollup_inbox_repr.Proof.valid - {inbox_level = level; message_counter = Z.succ counter} + Sc_rollup_inbox_repr.verify_proof + (level, Z.succ counter) snapshot inbox_proof | _ -> @@ -94,10 +94,10 @@ let valid snapshot commit_level ~pvm_name proof = "input_requested is %a, inbox proof is %a" Sc_rollup_PVM_sem.pp_input_request input_requested - (Format.pp_print_option Sc_rollup_inbox_repr.Proof.pp) + (Format.pp_print_option Sc_rollup_inbox_repr.pp_proof) proof.inbox) in - let* _ = + let* () = check (Option.equal Sc_rollup_PVM_sem.input_equal @@ -115,8 +115,13 @@ module type PVM_with_context_and_state = sig val state : state end -let produce pvm_and_state inbox commit_level = - let open Lwt_result_syntax in +let of_lwt_result result = + let open Lwt_tzresult_syntax in + let*! r = result in + match r with Ok x -> return x | Error e -> fail e + +let produce pvm_and_state inbox_context inbox_history inbox commit_level = + let open Lwt_tzresult_syntax in let (module P : PVM_with_context_and_state) = pvm_and_state in let*! request = P.is_input_state P.state in let* inbox, input_given = @@ -124,17 +129,27 @@ let produce pvm_and_state inbox commit_level = | Sc_rollup_PVM_sem.No_input_required -> return (None, None) | Sc_rollup_PVM_sem.Initial -> let* p, i = - Sc_rollup_inbox_repr.Proof.produce_proof + Sc_rollup_inbox_repr.produce_proof + inbox_context + inbox_history inbox (Raw_level_repr.root, Z.zero) in return (Some p, i) | Sc_rollup_PVM_sem.First_after (l, n) -> - let* p, i = Sc_rollup_inbox_repr.Proof.produce_proof inbox (l, n) in + let* p, i = + Sc_rollup_inbox_repr.produce_proof + inbox_context + inbox_history + inbox + (l, n) + in return (Some p, i) in let input_given = Option.bind input_given (cut_at_level commit_level) in - let* pvm_step_proof = P.produce_proof P.context input_given P.state in + let* pvm_step_proof = + of_lwt_result (P.produce_proof P.context input_given P.state) + in let module P_with_proof = struct include P 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 bf87644baad239e5aa75cd645f086861442c6e23..2abb1f91753e4683604211c42d4f25ea597be44a 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_proof_repr.mli @@ -59,7 +59,7 @@ open Sc_rollup_repr match up with [pvm_step] to give a valid refutation proof. *) type t = { pvm_step : Sc_rollups.wrapped_proof; - inbox : Sc_rollup_inbox_repr.Proof.t option; + inbox : Sc_rollup_inbox_repr.proof option; } val encoding : t Data_encoding.t @@ -90,11 +90,11 @@ val stop : t -> State_hash.t option - the [pvm_name], used to check that the proof given has the right PVM kind. *) val valid : - Sc_rollup_inbox_repr.t -> + Sc_rollup_inbox_repr.history_proof -> Raw_level_repr.t -> pvm_name:string -> t -> - (bool, error) result Lwt.t + bool tzresult Lwt.t module type PVM_with_context_and_state = sig include Sc_rollups.PVM.S @@ -104,22 +104,25 @@ module type PVM_with_context_and_state = sig val state : state end -(** [produce pvm_and_state inbox commit_level] will construct a full - refutation game proof out of the [state] given in [pvm_and_state]. - It uses the [inbox] if necessary to provide input in the proof. If - the input is above or at [commit_level] it will block it, and - produce a proof that the PVM is blocked. +(** [produce pvm_and_state inbox_context inbox_history commit_level] + will construct a full refutation game proof out of the [state] given + in [pvm_and_state]. It uses the [inbox] if necessary to provide + input in the proof. If the input is above or at [commit_level] it + will block it, and produce a proof that the PVM is blocked. - This will fail if the [context] given doesn't have enough of the - [state] to make the proof. For example, the 'protocol - implementation' version of each PVM won't be able to run this - function. + This will fail if any of the [context], [inbox_context] or + [inbox_history] given don't have enough data to make the proof. For + example, the 'protocol implementation' version of each PVM won't be + able to run this function. Similarly, the version of the inbox + stored in the L1 won't be enough because it forgets old levels. This uses the [name] in the [pvm_and_state] module to produce an encodable [wrapped_proof] if possible. See the [wrap_proof] function in [Sc_rollups]. *) val produce : (module PVM_with_context_and_state) -> - Sc_rollup_inbox_repr.t -> + Sc_rollup_inbox_repr.inbox_context -> + Sc_rollup_inbox_repr.history -> + Sc_rollup_inbox_repr.history_proof -> Raw_level_repr.t -> - (t, error) result Lwt.t + t tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml index 330897dbe538b34eb1688ce58e7ca25dde8f8a12..1ea94c5e376d1bacfff4beed2b5ca6a177f94c6b 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_refutation_storage.ml @@ -229,7 +229,7 @@ let init_game ctxt rollup ~refuter ~defender = let* kind = Store.PVM_kind.get ctxt rollup in let game = Sc_rollup_game_repr.initial - inbox + (Sc_rollup_inbox_repr.take_snapshot inbox) ~pvm_name:(Sc_rollups.Kind.name_of kind) ~parent:parent_info ~child:child_info diff --git a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml index 46bc8adeeffb9488571c6b491c151e22de20a59d..a18abfafbea6fe66a95affdc87c54d9a61af96b7 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_storage.ml @@ -38,7 +38,8 @@ let originate ctxt ~kind ~boot_sector ~parameters_ty = Store.Boot_sector.add ctxt address boot_sector >>= fun ctxt -> Store.Parameters_type.add ctxt address parameters_ty >>=? fun (ctxt, param_ty_size_diff, _added) -> - let inbox = Sc_rollup_inbox_repr.empty address level.level in + Sc_rollup_inbox_repr.empty (Raw_context.recover ctxt) address level.level + >>= fun inbox -> Store.Inbox.init ctxt address inbox >>=? fun (ctxt, inbox_size_diff) -> Store.Last_cemented_commitment.init ctxt address Commitment_hash.zero >>=? fun (ctxt, lcc_size_diff) -> diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.ml b/src/proto_alpha/lib_protocol/skip_list_repr.ml index fc7c0077bd9cf96102e509dc5394061ed55ba9c4..e35606fd58b6e6aa0fd93bcfdce66e6a7353afc3 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.ml +++ b/src/proto_alpha/lib_protocol/skip_list_repr.ml @@ -74,6 +74,12 @@ module type S = sig target_ptr:'ptr -> 'ptr list -> bool + + val search : + deref:('ptr -> ('content, 'ptr) cell option) -> + compare:('content -> int Lwt.t) -> + cell_ptr:'ptr -> + 'ptr list option Lwt.t end module Make (Parameters : sig @@ -104,9 +110,9 @@ end) : S = struct also ask the client to provide the index of the cell to be built, which can be error-prone. - - The back pointers of a node are chosen from the back pointers of - its predecessor (except for the genesis node) and a pointer to this - predecessor. This locality makes the insertion of new nodes very + - The back pointers of a cell are chosen from the back pointers of + its predecessor (except for the genesis cell) and a pointer to this + predecessor. This locality makes the insertion of new cell very efficient in practice. *) @@ -274,4 +280,45 @@ end) : S = struct | [] -> false | first_cell_ptr :: path -> equal_ptr first_cell_ptr cell_ptr && valid_path cell_index cell_ptr path + + let search ~deref ~compare ~cell_ptr = + (* TODO: #3321 replace with Lwt_option_syntax when that's in the + environment V6 *) + let ( let*? ) x f = + match x with None -> Lwt.return None | Some y -> f y + in + let ( let*! ) = Lwt.bind in + let rec aux path ptr ix = + let*? cell = deref ptr in + let*? candidate_ptr = back_pointer cell ix in + let*? candidate_cell = deref candidate_ptr in + let*! comparison = compare candidate_cell.content in + if Compare.Int.(comparison = 0) then + (* In this case, we have reached our target cell. *) + Option.some_s (List.rev (candidate_ptr :: ptr :: path)) + else if Compare.Int.(comparison < 0) then + if Compare.Int.(ix = 0) then + (* If the first back pointer is 'too far' ([comparison < 0]), + that means we won't find a valid target cell. *) + Option.none_s + else + (* If a back pointer other than the first is 'too far' + we can then backtrack to the previous back pointer. *) + let*? new_ptr = back_pointer cell (ix - 1) in + aux (ptr :: path) new_ptr 0 + else if Compare.Int.(ix + 1 >= FallbackArray.length cell.back_pointers) + then + (* If we reach the final back pointer and still have + [comparison > 0], we should continue from that cell. *) + aux (ptr :: path) candidate_ptr 0 + else + (* Final case, we just try the next back pointer. *) + aux path ptr (ix + 1) + in + let*? cell = deref cell_ptr in + let*! comparison = compare cell.content in + (* We must check that we aren't already at the target cell before + starting the recursion. *) + if Compare.Int.(comparison = 0) then Option.some_s [cell_ptr] + else aux [] cell_ptr 0 end diff --git a/src/proto_alpha/lib_protocol/skip_list_repr.mli b/src/proto_alpha/lib_protocol/skip_list_repr.mli index 74d18e7dff3ab467b421bf26ba01309376446708..81deeb593a149b2812e5288626a10dab49ace90d 100644 --- a/src/proto_alpha/lib_protocol/skip_list_repr.mli +++ b/src/proto_alpha/lib_protocol/skip_list_repr.mli @@ -117,6 +117,22 @@ module type S = sig target_ptr:'ptr -> 'ptr list -> bool + + (** [search ~deref ~compare ~cell_ptr] is similar to {!back_path} except + that it will search through the skip list to find a cell at which + [compare content] is zero. This will only work if [compare] is a + function that returns a negative integer for cells before the + target and a positive integer for cells after the target. + + If [d] is the distance in the skip list between the original + [cell_ptr] and the final target cell, this function involves + [O(log_basis(d))] calls to [deref] and [compare] (the logarithm's + base is the [basis] parameter in the skip list). *) + val search : + deref:('ptr -> ('content, 'ptr) cell option) -> + compare:('content -> int Lwt.t) -> + cell_ptr:'ptr -> + 'ptr list option Lwt.t end module Make (_ : sig 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 220b24cac1278967b32ede655e86792a2c53cc20..eaf8eaae9efd602fe52c561094501e271977e11d 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 @@ -44,9 +44,6 @@ open Lib_test.Qcheck2_helpers *) -let zero_level = - Raw_level.of_int32 0l |> function Ok x -> x | _ -> assert false - let hash_state state number = Digest.bytes @@ Bytes.of_string @@ state ^ string_of_int number @@ -538,7 +535,9 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct (fun tick -> let hash = Lwt_main.run - @@ let* state, _ = state_at tick start_state start_tick in + @@ let* state, (_ : Tick.t) = + state_at tick start_state start_tick + in match state with | None -> return None | Some s -> @@ -570,8 +569,12 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct | Game.Alice -> if alice_is_refuter then Defender_wins else Refuter_wins let run ~inbox ~refuter_client ~defender_client = - let refuter, _, _ = Signature.generate_key () in - let defender, _, _ = Signature.generate_key () in + let refuter, (_ : public_key), (_ : Signature.secret_key) = + Signature.generate_key () + in + let defender, (_ : public_key), (_ : Signature.secret_key) = + Signature.generate_key () + in let alice_is_refuter = Staker.(refuter < defender) in let* start_hash = PVM.state_hash PVM.Utils.default_state in let* initial_data = defender_client.initial in @@ -615,7 +618,9 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct evaluation. *) let conflicting_section tick state = - let* new_state, _ = state_at tick PVM.Utils.default_state Tick.initial in + let* new_state, (_ : Tick.t) = + state_at tick PVM.Utils.default_state Tick.initial + in let* new_hash = match new_state with | None -> return None @@ -644,7 +649,7 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct | Some Game.{state_hash = Some s; tick = t} -> (s, t) | _ -> assert false in - let _, stop = + let (_ : State_hash.t option), stop = match List.nth d (x + 1) with | Some Game.{state_hash; tick} -> (state_hash, tick) | None -> assert false @@ -710,7 +715,7 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct match conflict with | Some ((_, start_tick), (_, next_tick)) -> - let* start_state, _ = + let* start_state, (_ : Tick.t) = state_at start_tick PVM.Utils.default_state Tick.initial in let* next_dissection = @@ -718,7 +723,7 @@ module Strategies (PVM : TestPVM with type hash = State_hash.t) = struct | None -> return None | Some s -> dissection_of_section start_tick s next_tick in - let* stop_state, _ = + let* stop_state, (_ : Tick.t) = match start_state with | None -> return (None, next_tick) | Some s -> state_at next_tick s start_tick @@ -823,7 +828,8 @@ let perfect_random (module P : TestPVM) inbox = (** This assembles a test from a RandomPVM and a function that chooses the type of strategies. *) -let testing_randomPVM (f : (module TestPVM) -> Inbox.t -> bool Lwt.t) name = +let testing_randomPVM + (f : (module TestPVM) -> Inbox.history_proof -> bool Lwt.t) name = let open QCheck2 in Test.make ~name @@ -831,32 +837,38 @@ let testing_randomPVM (f : (module TestPVM) -> Inbox.t -> bool Lwt.t) name = (fun initial_prog -> assume (initial_prog <> []) ; let rollup = Address.hash_string [""] in - let level = zero_level in - let inbox = Inbox.empty rollup level in + let level = Raw_level.root in + let context = Tezos_protocol_environment.Memory_context.empty in Lwt_main.run - @@ f + @@ let* inbox = Inbox.empty context rollup level in + let snapshot = Inbox.take_snapshot inbox in + f (module MakeRandomPVM (struct let initial_prog = initial_prog end)) - inbox) + snapshot) (** This assembles a test from a CountingPVM and a function that chooses the type of strategies *) -let testing_countPVM (f : (module TestPVM) -> Inbox.t -> bool Lwt.t) name = +let testing_countPVM (f : (module TestPVM) -> Inbox.history_proof -> bool Lwt.t) + name = let open QCheck2 in Test.make ~name Gen.small_int (fun target -> assume (target > 200) ; let rollup = Address.hash_string [""] in - let level = zero_level in - let inbox = Inbox.empty rollup level in + let level = Raw_level.root in + let context = Tezos_protocol_environment.Memory_context.empty in Lwt_main.run - @@ f + @@ let* inbox = Inbox.empty context rollup level in + let snapshot = Inbox.take_snapshot inbox in + f (module MakeCountingPVM (struct let target = target end)) - inbox) + snapshot) -let testing_arith (f : (module TestPVM) -> Inbox.t -> bool Lwt.t) name = +let testing_arith (f : (module TestPVM) -> Inbox.history_proof -> bool Lwt.t) + name = let open QCheck2 in Test.make ~name @@ -864,16 +876,18 @@ let testing_arith (f : (module TestPVM) -> Inbox.t -> bool Lwt.t) name = (fun (inputs, evals) -> assume (evals > 1 && evals < List.length inputs - 1) ; let rollup = Address.hash_string [""] in - let level = zero_level in - let inbox = Inbox.empty rollup level in + let level = Raw_level.root in + let context = Tezos_protocol_environment.Memory_context.empty in Lwt_main.run - @@ f + @@ let* inbox = Inbox.empty context rollup level in + let snapshot = Inbox.take_snapshot inbox in + f (module TestArith (struct let inputs = String.concat " " inputs let evals = evals end)) - inbox) + snapshot) let test_random_dissection (module P : TestPVM) start_at length = let open P in diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_encoding.ml b/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_encoding.ml index 43b83f5092342e4560689c73688e71fae185d09d..ccb0e9eb9fad7d7d7b2d63f98cc8ba78a8100529 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_encoding.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_encoding.ml @@ -90,38 +90,40 @@ let gen_versioned_commitment = let gen_player = Gen.oneofl Sc_rollup_game_repr.[Alice; Bob] -let gen_messages inbox level = +let gen_inbox rollup level = let open Gen in - let* payloads = small_list (small_string ~gen:printable) in - let messages = + let gen_msg = small_string ~gen:printable in + let* hd = gen_msg in + let* tail = small_list gen_msg in + let payloads = hd :: tail in + let level_tree_and_inbox = let open Lwt_result_syntax in let* ctxt = Context.default_raw_context () in + let inbox_ctxt = Raw_context.recover ctxt in + let*! empty_inbox = Sc_rollup_inbox_repr.empty inbox_ctxt rollup level in lift @@ let*? input_messages = List.map_e (fun msg -> Sc_rollup_inbox_message_repr.(serialize (External msg))) payloads in - let messages = - Environment.Context.Tree.empty (Raw_context.recover ctxt) - in Sc_rollup_inbox_repr.add_messages_no_history - inbox + inbox_ctxt + empty_inbox level input_messages - messages + None in return - @@ (Lwt_main.run messages |> function + @@ (Lwt_main.run level_tree_and_inbox |> function | Ok v -> snd v | Error e -> Stdlib.failwith (Format.asprintf "%a" Error_monad.pp_print_trace e)) -let gen_inbox rollup level = +let gen_inbox_history_proof rollup level = let open Gen in - let inbox = Sc_rollup_inbox_repr.empty rollup level in - let* inbox = gen_messages inbox level in - return inbox + let* inbox = gen_inbox rollup level in + return (Sc_rollup_inbox_repr.take_snapshot inbox) let gen_raw_level = let open Gen in @@ -151,7 +153,7 @@ let gen_game = let* turn = gen_player in let* level = gen_raw_level in let* rollup = gen_rollup in - let* inbox_snapshot = gen_inbox rollup level in + let* inbox_snapshot = gen_inbox_history_proof rollup level in let* pvm_name = gen_pvm_name in let* dissection = gen_dissection in let dissection = 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 e2bff61cdff72c85bed6d00d54e438b2e01a4f99..4fb773bb8fbdc6119abf59300d9eeec95716dd75 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 @@ -48,42 +48,46 @@ let create_context () = Context.init1 () >>=? fun (block, _contract) -> return block.context let test_empty () = - let inbox = empty rollup level in + create_context () >>=? fun ctxt -> + empty ctxt rollup level >>= fun inbox -> fail_unless Z.(equal (number_of_available_messages inbox) zero) (err "An empty inbox should have no available message.") let setup_inbox_with_messages list_of_payloads f = - let open Lwt_result_syntax in - let* ctxt = create_context () in - let empty_messages = Environment.Context.Tree.empty ctxt in - let inbox = empty rollup level in + let open Lwt_syntax in + create_context () >>=? fun ctxt -> + let* inbox = empty ctxt rollup level in let history = history_at_genesis ~bound:10000L in - let rec aux level history inbox inboxes messages = function - | [] -> return (messages, history, inbox, inboxes) + 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 -> - let*? payloads = - List.map_e - (fun payload -> - Sc_rollup_inbox_message_repr.(serialize @@ External payload)) - payloads - in - let* messages, history, inbox' = - add_messages history inbox level payloads messages - in + Lwt.return + (List.map_e + (fun payload -> + Sc_rollup_inbox_message_repr.(serialize @@ External payload)) + payloads) + >|= Environment.wrap_tzresult + >>=? fun payloads -> + 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) messages ps - in - let* messages, history, inbox, inboxes = - aux level history inbox [] empty_messages list_of_payloads - >|= Environment.wrap_tzresult + aux level history inbox' (inbox :: inboxes) (Some level_tree) ps in - f messages history inbox inboxes + aux 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 payloads = let nb_payloads = List.length payloads in setup_inbox_with_messages [payloads] - @@ fun _messages _history inbox _inboxes -> + @@ fun _ctxt _messages _history inbox _inboxes -> fail_unless Z.(equal (number_of_available_messages inbox) (of_int nb_payloads)) (err "Invalid number of available messages.") @@ -91,7 +95,7 @@ let test_add_messages payloads = let test_consume_messages (payloads, nb_consumed_messages) = let nb_payloads = List.length payloads |> Int32.of_int in setup_inbox_with_messages [payloads] - @@ fun _messages _history inbox _inboxes -> + @@ fun _ctxt _messages _history inbox _inboxes -> consume_n_messages nb_consumed_messages inbox |> Environment.wrap_tzresult >>?= function | Some inbox -> @@ -128,24 +132,15 @@ let check_payload messages external_message = (Bytes.to_string expected_payload) (Bytes.to_string payload))) -let test_get_message payloads = - setup_inbox_with_messages [payloads] - @@ fun messages _history _inbox _inboxes -> - List.iteri_es - (fun i payload -> - get_message messages (Z.of_int i) >>= function - | Some message -> check_payload message payload - | None -> fail (err (Printf.sprintf "No message number %d in messages" i))) - payloads - let test_get_message_payload payloads = setup_inbox_with_messages [payloads] - @@ fun messages _history _inbox _inboxes -> + @@ fun _ctxt messages _history _inbox _inboxes -> List.iteri_es (fun i message -> let expected_payload = encode_external_message message in get_message_payload messages (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)) @@ -156,10 +151,14 @@ let test_get_message_payload payloads = let test_inclusion_proof_production (list_of_payloads, n) = setup_inbox_with_messages list_of_payloads - @@ fun _messages history _inbox inboxes -> + @@ fun _ctxt _messages history _inbox inboxes -> let inbox = Stdlib.List.hd inboxes in let old_inbox = Stdlib.List.nth inboxes n in - produce_inclusion_proof history old_inbox inbox |> function + produce_inclusion_proof + history + (old_levels_messages old_inbox) + (old_levels_messages inbox) + |> function | None -> fail @@ err @@ -167,15 +166,22 @@ let test_inclusion_proof_production (list_of_payloads, n) = versions of the same inbox." | Some proof -> fail_unless - (verify_inclusion_proof proof old_inbox inbox) + (verify_inclusion_proof + proof + (old_levels_messages old_inbox) + (old_levels_messages inbox)) (err "The produced inclusion proof is invalid.") let test_inclusion_proof_verification (list_of_payloads, n) = setup_inbox_with_messages list_of_payloads - @@ fun _messages history _inbox inboxes -> + @@ fun _ctxt _messages history _inbox inboxes -> let inbox = Stdlib.List.hd inboxes in let old_inbox = Stdlib.List.nth inboxes n in - produce_inclusion_proof history old_inbox inbox |> function + produce_inclusion_proof + history + (old_levels_messages old_inbox) + (old_levels_messages inbox) + |> function | None -> fail @@ err @@ -185,11 +191,250 @@ let test_inclusion_proof_verification (list_of_payloads, n) = let old_inbox' = Stdlib.List.nth inboxes (Random.int (1 + n)) in fail_unless (equal old_inbox old_inbox' - || not (verify_inclusion_proof proof old_inbox' inbox)) + || not + (verify_inclusion_proof + proof + (old_levels_messages old_inbox') + (old_levels_messages inbox))) (err "Verification should rule out a valid proof which is not about the \ given inboxes.") +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* _ = 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_helpers.Context.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 = MakeHashingScheme (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 = + Data_encoding.Binary.( + to_bytes_exn Node.proof_encoding p |> of_bytes_exn proof_encoding) + +(** 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 rollup level in + let history = history_at_genesis ~bound:10000L in + let rec aux level history inbox inboxes level_tree = function + | [] -> return (ok (level_tree, history, inbox, inboxes)) + | payloads :: ps -> ( + Lwt.return + (List.map_e + (fun payload -> + Sc_rollup_inbox_message_repr.(serialize @@ External payload)) + payloads) + >|= Environment.wrap_tzresult + >>=? fun payloads -> + match payloads with + | [] -> + let level = Raw_level_repr.succ level in + aux level history inbox inboxes level_tree 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 [] 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 next_input ps l n = + let ( let* ) = Option.bind in + let* level = List.nth ps (level_to_int l) in + match List.nth level (Z.to_int n) with + | Some msg -> + let payload = payload_string msg in + Some Sc_rollup_PVM_sem.{inbox_level = l; message_counter = n; payload} + | None -> + let rec aux l = + let* payloads = List.nth ps l in + match List.hd payloads with + | Some msg -> + let payload = payload_string msg in + Some + Sc_rollup_PVM_sem. + { + inbox_level = level_of_int l; + message_counter = Z.zero; + payload; + } + | None -> aux (l + 1) + in + aux (level_to_int l + 1) + +let test_inbox_proof_production (list_of_payloads, l, n) = + (* We begin with a Node inbox so we can produce a proof. *) + 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* history, history_proof = + Node.form_history_proof ctxt history inbox (Some current_level_tree) + 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 + @@ 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 + 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") + +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* history, history_proof = + Node.form_history_proof ctxt history inbox (Some current_level_tree) + 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 + @@ fun _ctxt _current_level_tree _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 test_empty_inbox_proof (level, n) = + 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 = Node.empty ctxt rollup level in + let history = Node.history_at_genesis ~bound:10000L in + let* history, history_proof = + Node.form_history_proof ctxt history inbox None + in + let* result = Node.produce_proof ctxt history history_proof (level, n) 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 snapshot = take_snapshot inbox in + let proof = node_proof_to_protocol_proof proof in + let* verification = verify_proof (level, n) snapshot proof 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") + let tests = let msg_size = QCheck2.Gen.(0 -- 100) in let bounded_string = QCheck2.Gen.string_size msg_size in @@ -197,20 +442,16 @@ let tests = Tztest.tztest "Empty inbox" `Quick test_empty; Tztest.tztest_qcheck2 ~name:"Added messages are available." - QCheck2.Gen.(list bounded_string) + QCheck2.Gen.(list_size (1 -- 50) bounded_string) test_add_messages; - Tztest.tztest_qcheck2 - ~name:"Get message." - QCheck2.Gen.(list bounded_string) - test_get_message; Tztest.tztest_qcheck2 ~name:"Get message payload." - QCheck2.Gen.(list bounded_string) + QCheck2.Gen.(list_size (1 -- 50) bounded_string) test_get_message_payload; Tztest.tztest_qcheck2 ~name:"Consume only available messages." QCheck2.Gen.( - let* l = list_size small_int bounded_string in + let* l = list_size (1 -- 50) bounded_string in let* n = 0 -- ((List.length l * 2) + 1) in return (l, Int32.of_int n)) test_consume_messages; @@ -226,6 +467,17 @@ let tests = let* n = 0 -- (List.length l - 2) in return (l, n)) in + let gen_proof_inputs = + QCheck2.Gen.( + let small = 0 -- 5 in + let* level = 0 -- 8 in + let* before = list_size (return level) (list_size small bounded_string) in + let* at = list_size (2 -- 6) bounded_string in + let* after = list_size small (list_size small bounded_string) in + let payloads = List.append before (at :: after) in + let* n = 0 -- (List.length at + 3) in + return (payloads, level_of_int level, Z.of_int n)) + in [ Tztest.tztest_qcheck2 ~name:"Produce inclusion proof between two related inboxes." @@ -235,4 +487,21 @@ let tests = ~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 + ~name:"An empty inbox is still able to produce proofs that return None" + QCheck2.Gen.( + let* n = 0 -- 2000 in + let* m = 0 -- 1000 in + return (level_of_int n, Z.of_int m)) + test_empty_inbox_proof; ] diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml index e689883dbeb95db0c26fe967814d4538c90cce10..3558afea81ad3c00dd143800b2f98bf4d121be39 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -2358,7 +2358,12 @@ let test_carbonated_memory_inbox_set_messages () = let* current_messages, _ = lift @@ Sc_rollup_inbox_repr.( - add_messages_no_history inbox level messages_to_add current_messages) + add_messages_no_history + (Raw_context.recover ctxt) + inbox + level + messages_to_add + current_messages) in let*? ctxt' = Environment.wrap_tzresult 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 c1e67cb7200de6ace5b4b1407b94d48095cff8c2..23ba6ae38e28dbd63787f45f710ebb352a14e6bb 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 @@ -44,7 +44,7 @@ struct open Parameters include Skip_list_repr.Make (Parameters) - type t = {size : int; cells : (int * (unit, int) cell) list} + type t = {size : int; cells : (int * (int, int) cell) list} let rec deref list i = List.assoc ~equal:Compare.Int.equal i list.cells @@ -72,16 +72,23 @@ struct let head list = match List.hd list.cells with None -> assert false | Some h -> h - let zero = {size = 1; cells = [(0, genesis ())]} + let zero = {size = 1; cells = [(0, genesis 0)]} let succ list = let prev_cell_ptr, prev_cell = head list in - let cell = next ~prev_cell ~prev_cell_ptr () in + let cell = next ~prev_cell ~prev_cell_ptr (2 * list.size) in {size = list.size + 1; cells = (list.size, cell) :: list.cells} let back_path list start stop = back_path ~deref:(deref list) ~cell_ptr:start ~target_index:stop + let search list start stop = + Lwt_main.run + (search + ~deref:(deref list) + ~compare:(fun x -> Lwt.return Compare.Int.(compare x stop)) + ~cell_ptr:start) + let valid_back_path list start stop path = valid_back_path ~equal_ptr:( = ) @@ -92,11 +99,11 @@ struct let rec nlist basis n = if n = 0 then zero else succ (nlist basis (n - 1)) - let check_path i j = + let check_path i j back_path_fn = let l = nlist basis i in if i <= j then return () else - match back_path l i j with + match back_path_fn l i j with | None -> fail (err (Printf.sprintf "There must be path from %d to %d" i j)) | Some path -> @@ -124,7 +131,8 @@ struct (valid_back_path l i j path) (err (Printf.sprintf - "The path %s does not connect %d to %d" + "The path %s does not connect %d to %d (or is \ + invalid/non-minimal)" (show_path path) i j)) @@ -134,7 +142,7 @@ struct let rec aux j = if i <= j then return () else - match back_path l j i with + (match back_path l j i with | None -> return () | Some _path -> fail @@ -142,21 +150,39 @@ struct (Printf.sprintf "There should be no path connecting %d to %d" j - i)) - >>=? fun () -> aux (j + 1) + i))) + >>=? fun () -> aux (j + 1) + in + aux 0 + + let check_invalid_search_paths i = + let l = nlist basis i in + let rec aux j = + if i <= j then return () + else + let t = (2 * j) + 1 in + (match search l i t with + | None -> return () + | Some _path -> + fail + (err + (Printf.sprintf + "There should be no search path connecting %d to a node \ + with content %d" + i + t))) + >>=? fun () -> aux (j + 1) in aux 0 end let test_skip_list_nat_check_path (basis, i, j) = - let basis = 2 + basis in let module M = TestNat (struct let basis = basis end) in - M.check_path i j + M.check_path i j M.back_path let test_skip_list_nat_check_invalid_path (basis, i) = - let basis = 2 + basis in let module M = TestNat (struct let basis = basis end) in @@ -195,22 +221,34 @@ let test_minimal_back_path () = (M.back_path l start target, expected_path)) cases) +let test_skip_list_nat_check_path_with_search (basis, i, j) = + let module M = TestNat (struct + let basis = basis + end) in + M.check_path i j (fun l i j -> M.search l i (j * 2)) + +let test_skip_list_nat_check_invalid_path_with_search (basis, i) = + let module M = TestNat (struct + let basis = basis + end) in + M.check_invalid_search_paths i + let tests = [ Tztest.tztest_qcheck2 - ~name:"Skip list: check produced paths for multiple basis." + ~name:"Skip list: produce paths with `back_path` and check" ~count:10 QCheck2.Gen.( - let* basis = 2 -- 73 in + 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_path; Tztest.tztest_qcheck2 - ~name:"Skip list: reject invalid paths for multiple basis." + ~name:"Skip list: `back_path` won't produce invalid paths" ~count:10 QCheck2.Gen.( - let* basis = 2 -- 73 in + let* basis = frequency [(5, pure 2); (1, 2 -- 73)] in let* i = 0 -- 100 in return (basis, i)) test_skip_list_nat_check_invalid_path; @@ -218,4 +256,21 @@ let tests = "Skip list: check if the back_path is minimal" `Quick test_minimal_back_path; + Tztest.tztest_qcheck2 + ~name:"Skip list: produce paths with `search` 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_path_with_search; + Tztest.tztest_qcheck2 + ~name:"Skip list: `search` won't produce invalid paths" + ~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_path_with_search; ] diff --git a/src/proto_alpha/lib_protocol/validate_operation.ml b/src/proto_alpha/lib_protocol/validate_operation.ml index 0f40584fb8f9ebbee48a241865e4507a80350984..da2638afc1acb79f735b8f658256a295dd5a938e 100644 --- a/src/proto_alpha/lib_protocol/validate_operation.ml +++ b/src/proto_alpha/lib_protocol/validate_operation.ml @@ -406,6 +406,11 @@ module Manager = struct let assert_dal_feature_enabled vi = error_unless (Constants.dal_enable vi.ctxt) Dal_errors.Dal_feature_disabled + let assert_not_zero_messages messages = + match messages with + | [] -> error Sc_rollup_errors.Sc_rollup_add_zero_messages + | _ -> ok () + let consume_decoding_gas ctxt lexpr = record_trace Gas_quota_exceeded_init_deserialize @@ (* Fail early if the operation does not have enough gas to @@ -560,11 +565,15 @@ module Manager = struct | Tx_rollup_rejection _ -> let* () = validate_tx_rollup_rejection vi operation in return remaining_gas - | Sc_rollup_originate _ | Sc_rollup_add_messages _ | Sc_rollup_cement _ - | Sc_rollup_publish _ | Sc_rollup_refute _ | Sc_rollup_timeout _ + | Sc_rollup_originate _ | Sc_rollup_cement _ | Sc_rollup_publish _ + | Sc_rollup_refute _ | Sc_rollup_timeout _ | Sc_rollup_execute_outbox_message _ -> let* () = assert_sc_rollup_feature_enabled vi in return remaining_gas + | Sc_rollup_add_messages {messages; _} -> + let* () = assert_sc_rollup_feature_enabled vi in + let* () = assert_not_zero_messages messages in + return remaining_gas | Sc_rollup_recover_bond _ -> (* TODO: https://gitlab.com/tezos/tezos/-/issues/3063 Should we successfully precheck Sc_rollup_recover_bond and any diff --git a/tezt/tests/expected/sc_rollup.ml/Alpha- observing the correct handling of commitments in the rollup node (handles.out b/tezt/tests/expected/sc_rollup.ml/Alpha- observing the correct handling of commitments in the rollup node (handles.out index 01ac44becab389856e5c3e025ec90c443afc9f22..69f68065c141e3c4977a290ed30f3bedd81b5863 100644 --- a/tezt/tests/expected/sc_rollup.ml/Alpha- observing the correct handling of commitments in the rollup node (handles.out +++ b/tezt/tests/expected/sc_rollup.ml/Alpha- observing the correct handling of commitments in the rollup node (handles.out @@ -34,7 +34,7 @@ This sequence of operations was run: ./tezos-client --wait none send sc rollup message 'text:["CAFEBABE"]' from bootstrap1 to '[SC_ROLLUP_HASH]' Node is bootstrapped. -Estimated gas: 1652.338 units (will add 100 for safety) +Estimated gas: 1651.826 units (will add 100 for safety) Estimated storage: no bytes added Operation successfully injected in the node. Operation hash is '[OPERATION_HASH]' @@ -47,14 +47,14 @@ This sequence of operations was run: From: [PUBLIC_KEY_HASH] Fee to the baker: ꜩ0.000457 Expected counter: 2 - Gas limit: 1753 + Gas limit: 1752 Storage limit: 0 bytes Balance updates: [PUBLIC_KEY_HASH] ... -ꜩ0.000457 payload fees(the block proposer) ....... +ꜩ0.000457 Add a message to the inbox of the smart contract rollup at address [SC_ROLLUP_HASH] This smart contract rollup messages submission was successfully applied - Consumed gas: 1652.338 + Consumed gas: 1651.826 Resulting inbox state: rollup = [SC_ROLLUP_HASH] level = 32 @@ -65,12 +65,8 @@ This sequence of operations was run: message_counter = 1 old_levels_messages = content = [SC_ROLLUP_INBOX_HASH] - index = 30 + index = 1 back_pointers = [SC_ROLLUP_INBOX_HASH] - [SC_ROLLUP_INBOX_HASH] - [SC_ROLLUP_INBOX_HASH] - [SC_ROLLUP_INBOX_HASH] - [SC_ROLLUP_INBOX_HASH] diff --git a/tezt/tests/expected/sc_rollup.ml/Alpha- pushing messages in the inbox - current messages hash.out b/tezt/tests/expected/sc_rollup.ml/Alpha- pushing messages in the inbox - current messages hash.out index bd483ad81bf58a9ac8977fcd478d482507bef556..848b9881474c5d9ff5721e83c82a5de693ece0ef 100644 --- a/tezt/tests/expected/sc_rollup.ml/Alpha- pushing messages in the inbox - current messages hash.out +++ b/tezt/tests/expected/sc_rollup.ml/Alpha- pushing messages in the inbox - current messages hash.out @@ -107,43 +107,3 @@ This sequence of operations was run: - -./tezos-client --wait none send sc rollup message 'text:[]' from bootstrap1 to '[SC_ROLLUP_HASH]' -Node is bootstrapped. -Estimated gas: 1651.531 units (will add 100 for safety) -Estimated storage: no bytes added -Operation successfully injected in the node. -Operation hash is '[OPERATION_HASH]' -NOT waiting for the operation to be included. -Use command - tezos-client wait for [OPERATION_HASH] to be included --confirmations 1 --branch [BLOCK_HASH] -and/or an external block explorer to make sure that it has been included. -This sequence of operations was run: - Manager signed operations: - From: [PUBLIC_KEY_HASH] - Fee to the baker: ꜩ0.000445 - Expected counter: 4 - Gas limit: 1752 - Storage limit: 0 bytes - Balance updates: - [PUBLIC_KEY_HASH] ... -ꜩ0.000445 - payload fees(the block proposer) ....... +ꜩ0.000445 - Add a message to the inbox of the smart contract rollup at address [SC_ROLLUP_HASH] - This smart contract rollup messages submission was successfully applied - Consumed gas: 1651.531 - Resulting inbox state: - rollup = [SC_ROLLUP_HASH] - level = 5 - current messages hash = [SC_ROLLUP_INBOX_HASH] - nb_available_messages = 11 - nb_messages_in_commitment_period = 11 - starting_level_of_current_commitment_period = 2 - message_counter = 0 - old_levels_messages = - content = [SC_ROLLUP_INBOX_HASH] - index = 3 - back_pointers = [SC_ROLLUP_INBOX_HASH] - [SC_ROLLUP_INBOX_HASH] - - - diff --git a/tezt/tests/sc_rollup.ml b/tezt/tests/sc_rollup.ml index 05e958c4c613de5d58ebc5f1096a3b1bc046dbad..5622e90a16f5311af269e35b02c4c46b4b3f0805 100644 --- a/tezt/tests/sc_rollup.ml +++ b/tezt/tests/sc_rollup.ml @@ -529,7 +529,7 @@ let parse_inbox json = let go () = let inbox = JSON.as_object json in return - ( List.assoc "current_messages_hash" inbox |> JSON.as_string, + ( List.assoc "current_level_hash" inbox |> JSON.as_string, List.assoc "nb_available_messages" inbox |> JSON.as_int ) in Lwt.catch go @@ fun exn -> @@ -606,22 +606,28 @@ module Sc_rollup_inbox = struct | message :: rest -> let key = Data_encoding.Binary.to_string_exn Data_encoding.z counter in let payload = encode_external_message message in - let* tree = add tree [key; "payload"] payload in + let* tree = add tree ["message"; key] payload in build_current_messages_tree (Z.succ counter) tree rest - let predict_current_messages_hash = - Tezos_protocol_alpha.Protocol.Alpha_context.Sc_rollup.( - function - | [] -> return @@ Inbox.Hash.hash_bytes [] - | current_messages -> - let open Lwt.Syntax in - let* tree = - build_current_messages_tree Z.zero (empty ()) current_messages - in - let context_hash = hash tree in - Inbox.Hash.hash_bytes - [Tezos_crypto.Context_hash.to_bytes context_hash] - |> return) + module P = Tezos_protocol_alpha.Protocol + + let predict_current_messages_hash level current_messages = + let open P.Alpha_context.Sc_rollup in + let open Lwt.Syntax in + let level_bytes = + Data_encoding.Binary.to_bytes_exn + P.Raw_level_repr.encoding + (P.Raw_level_repr.of_int32_exn level) + in + let* tree = add (empty ()) ["level"] level_bytes in + let* tree = build_current_messages_tree Z.zero tree current_messages in + let context_hash = hash tree in + let test = + Data_encoding.Binary.to_bytes_exn + Tezos_base.TzPervasives.Context_hash.encoding + context_hash + in + return (Inbox.Hash.of_bytes_exn test) end let fetch_messages_from_block sc_rollup_address client = @@ -662,15 +668,19 @@ let test_rollup_inbox_current_messages_hash = in let open Tezos_protocol_alpha.Protocol.Alpha_context.Sc_rollup in (* no messages have been sent *) - let* pristine_hash, _ = + let* pristine_hash, nb_available_messages = get_inbox_from_tezos_node sc_rollup_address client in - let* expected = Sc_rollup_inbox.predict_current_messages_hash [] in + let () = + Check.((nb_available_messages = 0) int) + ~error_msg:"0 messages expected in the inbox" + in + let* expected = Sc_rollup_inbox.predict_current_messages_hash 2l [] in let () = Check.( (Inbox.Hash.to_b58check expected = pristine_hash) string - ~error_msg:"expected pristine hash %L, got %R") + ~error_msg:"FIRST: expected pristine hash %L, got %R") in (* send messages, and assert that @@ -692,13 +702,13 @@ let test_rollup_inbox_current_messages_hash = "expected current messages hash to change when messages sent") in let* expected = - Sc_rollup_inbox.predict_current_messages_hash fst_batch + Sc_rollup_inbox.predict_current_messages_hash 3l fst_batch in let () = Check.( (Inbox.Hash.to_b58check expected = fst_batch_hash) string - ~error_msg:"expected first batch hash %L, got %R") + ~error_msg:"2 expected first batch hash %L, got %R") in (* send more messages, and assert that @@ -720,7 +730,7 @@ let test_rollup_inbox_current_messages_hash = get_inbox_from_tezos_node sc_rollup_address client in let* expected = - Sc_rollup_inbox.predict_current_messages_hash snd_batch + Sc_rollup_inbox.predict_current_messages_hash 4l snd_batch in let () = Check.( @@ -728,21 +738,7 @@ let test_rollup_inbox_current_messages_hash = string ~error_msg:"expected second batch hash %L, got %R") in - (* - send an empty list of messages, and assert that - - the hash matches the 'pristine' hash: a.k.a there are no 'current messages' - *) - let* () = send_message client sc_rollup_address @@ prepare_batch [] in - let* empty_batch_hash, _ = - get_inbox_from_tezos_node sc_rollup_address client - in - let () = - Check.( - (pristine_hash = empty_batch_hash) - string - ~error_msg:"expected empty batch hash %L, got %R") - in - return () ) + unit ) node client) @@ -794,7 +790,10 @@ let basic_scenario _protocol sc_rollup_node sc_rollup_address _node client = 4 in let* () = Sc_rollup_node.run sc_rollup_node in + Log.info "before sending messages\n" ; let* () = send_messages num_messages sc_rollup_address client in + let* level = Client.level client in + Log.info "level: %d\n" level ; let* _ = Sc_rollup_node.wait_for_level sc_rollup_node expected_level in return ()