From 60f3394a29d48a2a77d4bf6fd63abd4bea999d46 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 18:49:28 +0200 Subject: [PATCH 01/13] SCORU/Node: remove dependency of pvm on node_context --- .../lib_sc_rollup_node/RPC_server.ml | 5 ++- .../lib_sc_rollup_node/arith_pvm.ml | 4 -- .../lib_sc_rollup_node/node_context.ml | 8 ++++ .../lib_sc_rollup_node/node_context.mli | 1 + src/proto_alpha/lib_sc_rollup_node/pvm.ml | 6 +-- src/proto_alpha/lib_sc_rollup_node/pvm_rpc.ml | 40 +++++++++++++++++++ .../lib_sc_rollup_node/wasm_2_0_0_pvm.ml | 29 ++++++++++++-- .../lib_sc_rollup_node/wasm_2_0_0_rpc.ml | 25 ++---------- 8 files changed, 83 insertions(+), 35 deletions(-) create mode 100644 src/proto_alpha/lib_sc_rollup_node/pvm_rpc.ml diff --git a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml index 993c887ba690..92a1d46da14e 100644 --- a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml +++ b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml @@ -500,7 +500,8 @@ module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct return status - let register node_ctxt = + let register (node_ctxt : _ Node_context.t) = + let module PVM = (val Pvm_rpc.of_kind node_ctxt.kind) in List.fold_left (fun dir f -> Tezos_rpc.Directory.merge dir (f node_ctxt)) Tezos_rpc.Directory.empty @@ -510,7 +511,7 @@ module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct Block_directory.build_directory; Proof_helpers_directory.build_directory; Outbox_directory.build_directory; - PVM.RPC.build_directory; + PVM.build_directory; ] let start node_ctxt configuration = diff --git a/src/proto_alpha/lib_sc_rollup_node/arith_pvm.ml b/src/proto_alpha/lib_sc_rollup_node/arith_pvm.ml index c7684ea50e50..0d35862d09d1 100644 --- a/src/proto_alpha/lib_sc_rollup_node/arith_pvm.ml +++ b/src/proto_alpha/lib_sc_rollup_node/arith_pvm.ml @@ -52,10 +52,6 @@ module Impl : Pvm.S = struct module State = Context.PVMState - module RPC = struct - let build_directory _node_ctxt = Tezos_rpc.Directory.empty - end - let new_dissection = Game_helpers.default_new_dissection let string_of_status status = diff --git a/src/proto_alpha/lib_sc_rollup_node/node_context.ml b/src/proto_alpha/lib_sc_rollup_node/node_context.ml index 504e27f36ab1..733d325c437d 100644 --- a/src/proto_alpha/lib_sc_rollup_node/node_context.ml +++ b/src/proto_alpha/lib_sc_rollup_node/node_context.ml @@ -47,6 +47,7 @@ type 'a t = { injector_retention_period : int; block_finality_time : int; kind : Sc_rollup.Kind.t; + pvm : (module Pvm.S); fee_parameters : Configuration.fee_parameters; protocol_constants : Constants.t; loser_mode : Loser_mode.t; @@ -168,6 +169,11 @@ let make_kernel_logger ?log_kernel_debug_file data_dir = in Lwt_io.of_fd ~close:(fun () -> Lwt_unix.close fd) ~mode:Lwt_io.Output fd +let pvm_of_kind : Protocol.Alpha_context.Sc_rollup.Kind.t -> (module Pvm.S) = + function + | Example_arith -> (module Arith_pvm) + | Wasm_2_0_0 -> (module Wasm_2_0_0_pvm) + let check_fee_parameters Configuration.{fee_parameters; _} = let check_value purpose name compare to_string mempool_default value = if compare mempool_default value > 0 then @@ -358,6 +364,7 @@ let init (cctxt : Protocol_client_context.full) ~data_dir ?log_kernel_debug_file lcc = Reference.new_ lcc; lpc = Reference.new_ lpc; kind; + pvm = pvm_of_kind kind; injector_retention_period = 0; block_finality_time = 2; fee_parameters; @@ -979,6 +986,7 @@ module Internal_for_tests = struct lcc; lpc; kind; + pvm = pvm_of_kind kind; injector_retention_period = 0; block_finality_time = 2; fee_parameters = Configuration.default_fee_parameters; diff --git a/src/proto_alpha/lib_sc_rollup_node/node_context.mli b/src/proto_alpha/lib_sc_rollup_node/node_context.mli index addf262fad5c..4478dae14e0d 100644 --- a/src/proto_alpha/lib_sc_rollup_node/node_context.mli +++ b/src/proto_alpha/lib_sc_rollup_node/node_context.mli @@ -63,6 +63,7 @@ type 'a t = { block_finality_time : int; (** Deterministic block finality time for the layer 1 protocol. *) kind : Sc_rollup.Kind.t; (** Kind of the smart rollup. *) + pvm : (module Pvm.S); (** The PVM used by the smart rollup. *) fee_parameters : Configuration.fee_parameters; (** Fee parameters to use when injecting operations in layer 1. *) protocol_constants : Constants.t; diff --git a/src/proto_alpha/lib_sc_rollup_node/pvm.ml b/src/proto_alpha/lib_sc_rollup_node/pvm.ml index 90a3c81f2fa2..2d9a7542e1b4 100644 --- a/src/proto_alpha/lib_sc_rollup_node/pvm.ml +++ b/src/proto_alpha/lib_sc_rollup_node/pvm.ml @@ -32,6 +32,7 @@ module type S = sig include Sc_rollup.PVM.S with type context = Context.rw_index + and type state = Context.tree and type hash = Sc_rollup.State_hash.t (** Kind of the PVM. *) @@ -69,11 +70,6 @@ module type S = sig our_stop_chunk:Sc_rollup.Dissection_chunk.t -> Sc_rollup.Tick.t list - module RPC : sig - (** Build RPC directory of the PVM *) - val build_directory : Node_context.rw -> unit Environment.RPC_directory.t - end - (** State storage for this PVM. *) module State : sig (** [empty ()] is the empty state. *) diff --git a/src/proto_alpha/lib_sc_rollup_node/pvm_rpc.ml b/src/proto_alpha/lib_sc_rollup_node/pvm_rpc.ml new file mode 100644 index 000000000000..06c5c60b5e51 --- /dev/null +++ b/src/proto_alpha/lib_sc_rollup_node/pvm_rpc.ml @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2023 Functori, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +module type S = sig + (** Build RPC directory of the PVM *) + val build_directory : Node_context.rw -> unit Environment.RPC_directory.t +end + +module No_rpc = struct + let build_directory _node_ctxt = Tezos_rpc.Directory.empty +end + +let no_rpc = (module No_rpc : S) + +let of_kind = function + | Protocol.Alpha_context.Sc_rollup.Kind.Example_arith -> no_rpc + | Wasm_2_0_0 -> + (module Wasm_2_0_0_rpc.Make_RPC (Wasm_2_0_0_pvm.Durable_state) : S) diff --git a/src/proto_alpha/lib_sc_rollup_node/wasm_2_0_0_pvm.ml b/src/proto_alpha/lib_sc_rollup_node/wasm_2_0_0_pvm.ml index cec950da0239..2ab19c30d8e3 100644 --- a/src/proto_alpha/lib_sc_rollup_node/wasm_2_0_0_pvm.ml +++ b/src/proto_alpha/lib_sc_rollup_node/wasm_2_0_0_pvm.ml @@ -65,9 +65,27 @@ end module Make_backend (Tree : TreeS) = Tezos_scoru_wasm_fast.Pvm.Make (Make_wrapped_tree (Tree)) +(** Durable part of the storage of this PVM. *) +module type Durable_state = sig + type state + + (** [value_length state key] returns the length of data stored + for the [key] in the durable storage of the PVM state [state], if any. *) + val value_length : state -> string -> int64 option Lwt.t + + (** [lookup state key] returns the data stored + for the [key] in the durable storage of the PVM state [state], if any. *) + val lookup : state -> string -> bytes option Lwt.t + + (** [subtrees state key] returns subtrees + for the [key] in the durable storage of the PVM state [state]. + Empty list in case if path doesn't exist. *) + val list : state -> string -> string list Lwt.t +end + module Make_durable_state (T : Tezos_tree_encoding.TREE with type tree = Context.tree) : - Wasm_2_0_0_rpc.Durable_state with type state = T.tree = struct + Durable_state with type state = T.tree = struct module Tree_encoding_runner = Tezos_tree_encoding.Runner.Make (T) type state = T.tree @@ -102,7 +120,13 @@ module Make_durable_state Tezos_scoru_wasm.Durable.list durable key end -module Impl : Pvm.S = struct +module type S = sig + module Durable_state : Durable_state with type state = Context.tree + + include Pvm.S +end + +module Impl : S = struct module PVM = Sc_rollup.Wasm_2_0_0PVM.Make (Make_backend) (Wasm_2_0_0_proof_format) include PVM @@ -114,7 +138,6 @@ module Impl : Pvm.S = struct module State = Context.PVMState module Durable_state = Make_durable_state (Make_wrapped_tree (Wasm_2_0_0_proof_format.Tree)) - module RPC = Wasm_2_0_0_rpc.Make_RPC (Durable_state) let string_of_status : status -> string = function | Waiting_for_input_message -> "Waiting for input message" diff --git a/src/proto_alpha/lib_sc_rollup_node/wasm_2_0_0_rpc.ml b/src/proto_alpha/lib_sc_rollup_node/wasm_2_0_0_rpc.ml index 8f410c55049e..c5a2210f19fa 100644 --- a/src/proto_alpha/lib_sc_rollup_node/wasm_2_0_0_rpc.ml +++ b/src/proto_alpha/lib_sc_rollup_node/wasm_2_0_0_rpc.ml @@ -26,25 +26,8 @@ open RPC_directory_helpers -(** Durable part of the storage of this PVM. *) -module type Durable_state = sig - type state - - (** [value_length state key] returns the length of data stored - for the [key] in the durable storage of the PVM state [state], if any. *) - val value_length : state -> string -> int64 option Lwt.t - - (** [lookup state key] returns the data stored - for the [key] in the durable storage of the PVM state [state], if any. *) - val lookup : state -> string -> bytes option Lwt.t - - (** [subtrees state key] returns subtrees - for the [key] in the durable storage of the PVM state [state]. - Empty list in case if path doesn't exist. *) - val list : state -> string -> string list Lwt.t -end - -module Make_RPC (Durable_state : Durable_state with type state = Context.tree) = +module Make_RPC + (Durable_state : Wasm_2_0_0_pvm.Durable_state with type state = Context.tree) = struct module Block_directory = Make_directory (struct include Sc_rollup_services.Global.Block @@ -89,7 +72,7 @@ struct let*! subkeys = Durable_state.list state key in return subkeys - let build_directory = + let build_directory node_ctxt = register () ; - Block_directory.build_directory + Block_directory.build_directory node_ctxt end -- GitLab From 91c912bd66e03b3e2ff08c15cc10a1ab082843f9 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 18:55:11 +0200 Subject: [PATCH 02/13] SCORU/Node: defunctorize Fueled_pvm --- .../lib_sc_rollup_node/RPC_server.ml | 1 - .../lib_sc_rollup_node/fueled_pvm.ml | 804 +++++++++--------- .../lib_sc_rollup_node/interpreter.ml | 11 +- .../lib_sc_rollup_node/interpreter.mli | 10 +- .../lib_sc_rollup_node/refutation_game.ml | 6 +- .../lib_sc_rollup_node/simulation.ml | 4 +- .../lib_sc_rollup_node/simulation.mli | 2 +- 7 files changed, 413 insertions(+), 425 deletions(-) diff --git a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml index 92a1d46da14e..d80fbbc30c05 100644 --- a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml +++ b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml @@ -57,7 +57,6 @@ module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct module PVM = Simulation.PVM module Interpreter = Simulation.Interpreter module Outbox = Outbox.Make (PVM) - module Free_pvm = Interpreter.Free_pvm module Global_directory = Make_directory (struct include Sc_rollup_services.Global diff --git a/src/proto_alpha/lib_sc_rollup_node/fueled_pvm.ml b/src/proto_alpha/lib_sc_rollup_node/fueled_pvm.ml index 325df99539fe..21c7444784e2 100644 --- a/src/proto_alpha/lib_sc_rollup_node/fueled_pvm.ml +++ b/src/proto_alpha/lib_sc_rollup_node/fueled_pvm.ml @@ -30,14 +30,14 @@ open Protocol open Alpha_context module type S = sig - module PVM : Pvm.S - type fuel + type pvm_state = Context.tree + (** Evaluation state for the PVM. *) type eval_state = { - state : PVM.state; (** The actual PVM state. *) - state_hash : PVM.hash; (** Hash of [state]. *) + state : pvm_state; (** The actual PVM state. *) + state_hash : Sc_rollup.State_hash.t; (** Hash of [state]. *) tick : Sc_rollup.Tick.t; (** Tick of [state]. *) inbox_level : Raw_level.t; (** Inbox level in which messages are evaluated. *) @@ -62,7 +62,7 @@ module type S = sig fuel:fuel -> _ Node_context.t -> Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> - PVM.state -> + pvm_state -> eval_result Node_context.delayed_write tzresult Lwt.t (** [eval_messages ?reveal_map ~fuel node_ctxt ~message_counter_offset state @@ -81,397 +81,268 @@ module type S = sig eval_result Node_context.delayed_write tzresult Lwt.t end -module Make (PVM : Pvm.S) = struct - module Make_fueled (F : Fuel.S) : - S with module PVM = PVM and type fuel = F.t = struct - module PVM = PVM +module Make_fueled (F : Fuel.S) : S with type fuel = F.t = struct + type fuel = F.t - type fuel = F.t + type pvm_state = Context.tree - type eval_state = { - state : PVM.state; - state_hash : PVM.hash; - tick : Sc_rollup.Tick.t; - inbox_level : Raw_level.t; - message_counter_offset : int; - remaining_fuel : fuel; - remaining_messages : Sc_rollup.Inbox_message.t list; - } + type eval_state = { + state : pvm_state; + state_hash : Sc_rollup.State_hash.t; + tick : Sc_rollup.Tick.t; + inbox_level : Raw_level.t; + message_counter_offset : int; + remaining_fuel : fuel; + remaining_messages : Sc_rollup.Inbox_message.t list; + } - type eval_result = {state : eval_state; num_ticks : Z.t; num_messages : int} + type eval_result = {state : eval_state; num_ticks : Z.t; num_messages : int} - let get_reveal ?dac_client ~data_dir reveal_map hash = - let found_in_map = - match reveal_map with - | None -> None - | Some map -> Sc_rollup_reveal_hash.Map.find_opt hash map - in - match found_in_map with - | Some data -> return data - | None -> Reveals.get ?dac_client ~data_dir ~pvm_kind:PVM.kind hash + let get_reveal ?dac_client ~data_dir ~pvm_kind reveal_map hash = + let found_in_map = + match reveal_map with + | None -> None + | Some map -> Sc_rollup_reveal_hash.Map.find_opt hash map + in + match found_in_map with + | Some data -> return data + | None -> Reveals.get ?dac_client ~data_dir ~pvm_kind hash - type eval_completion = - | Aborted of {state : PVM.state; fuel : fuel; current_tick : int64} - | Completed of { - state : PVM.state; - fuel : fuel; - current_tick : int64; - failing_ticks : int64 list; - } + type eval_completion = + | Aborted of {state : pvm_state; fuel : fuel; current_tick : int64} + | Completed of { + state : pvm_state; + fuel : fuel; + current_tick : int64; + failing_ticks : int64 list; + } - exception Error_wrapper of tztrace + exception Error_wrapper of tztrace - (** [eval_until_input node_ctxt reveal_map level message_index ~fuel + (** [eval_until_input node_ctxt reveal_map level message_index ~fuel start_tick failing_ticks state] advances a PVM [state] until it wants more inputs or there are no more [fuel] (if [Some fuel] is specified). The evaluation is running under the processing of some [message_index] at a given [level] and this is the [start_tick] of this message processing. If some [failing_ticks] are planned by the loser mode, they will be made. *) - let eval_until_input node_ctxt reveal_map level message_index ~fuel - start_tick failing_ticks state = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let metadata = Node_context.metadata node_ctxt in - let dal_attestation_lag = - node_ctxt.protocol_constants.parametric.dal.attestation_lag - in - let reveal_builtins = - Tezos_scoru_wasm.Builtins. - { - reveal_preimage = - (fun hash -> - let*! data = - let*? hash = - (* The payload represents the encoded [Sc_rollup_reveal_hash.t]. We must - decode it properly, instead of converting it byte-for-byte. *) - Result.bind_error - (Data_encoding.Binary.of_string - Sc_rollup_reveal_hash.encoding - hash) - (error_with - "Bad reveal hash '%a': %a" - Hex.pp - (Hex.of_string hash) - Data_encoding.Binary.pp_read_error) - in - get_reveal - ?dac_client:node_ctxt.dac_client - ~data_dir:node_ctxt.data_dir - reveal_map - hash + let eval_until_input (node_ctxt : _ Node_context.t) reveal_map level + message_index ~fuel start_tick failing_ticks state = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let metadata = Node_context.metadata node_ctxt in + let dal_attestation_lag = + node_ctxt.protocol_constants.parametric.dal.attestation_lag + in + let reveal_builtins = + Tezos_scoru_wasm.Builtins. + { + reveal_preimage = + (fun hash -> + let*! data = + let*? hash = + (* The payload represents the encoded [Sc_rollup_reveal_hash.t]. We must + decode it properly, instead of converting it byte-for-byte. *) + Result.bind_error + (Data_encoding.Binary.of_string + Sc_rollup_reveal_hash.encoding + hash) + (error_with + "Bad reveal hash '%a': %a" + Hex.pp + (Hex.of_string hash) + Data_encoding.Binary.pp_read_error) in - match data with - | Error error -> - (* The [Error_wrapper] must be caught upstream and converted into a - tzresult. *) - Lwt.fail (Error_wrapper error) - | Ok data -> Lwt.return data); - reveal_metadata = - (fun () -> - Lwt.return - (Data_encoding.Binary.to_string_exn - Sc_rollup.Metadata.encoding - metadata)); - } - in - let eval_tick fuel failing_ticks state = - let max_steps = F.max_ticks fuel in - let normal_eval ?(max_steps = max_steps) state = - Lwt.catch - (fun () -> - let*! state, executed_ticks = - PVM.eval_many - ~reveal_builtins - ~write_debug:(Printer node_ctxt.kernel_debug_logger) - ~max_steps - state - in - return (state, executed_ticks, failing_ticks)) - (function - | Error_wrapper error -> Lwt.return (Error error) - | exn -> raise exn) - in - let failure_insertion_eval state tick failing_ticks' = - let*! () = - Interpreter_event.intended_failure - ~level - ~message_index - ~message_tick:tick - ~internal:true - in - let*! state = PVM.Internal_for_tests.insert_failure state in - return (state, 1L, failing_ticks') - in - match failing_ticks with - | xtick :: failing_ticks' -> - let jump = Int64.(max 0L (pred xtick)) in - if Compare.Int64.(jump = 0L) then - (* Insert the failure in the first tick. *) - failure_insertion_eval state xtick failing_ticks' - else - (* Jump just before the tick where we'll insert a failure. - Nevertheless, we don't execute more than [max_steps]. *) - let max_steps = Int64.max 0L max_steps |> Int64.min max_steps in - let open Delayed_write_monad.Lwt_result_syntax in - let>* state, executed_ticks, _failing_ticks = - normal_eval ~max_steps state - in - (* Insert the failure. *) - let>* state, executed_ticks', failing_ticks' = - failure_insertion_eval state xtick failing_ticks' + get_reveal + ?dac_client:node_ctxt.dac_client + ~data_dir:node_ctxt.data_dir + ~pvm_kind:node_ctxt.kind + reveal_map + hash in - let executed_ticks = Int64.add executed_ticks executed_ticks' in - return (state, executed_ticks, failing_ticks') - | _ -> normal_eval state - in - let abort state fuel current_tick = - return (Aborted {state; fuel; current_tick}) + match data with + | Error error -> + (* The [Error_wrapper] must be caught upstream and converted into a + tzresult. *) + Lwt.fail (Error_wrapper error) + | Ok data -> Lwt.return data); + reveal_metadata = + (fun () -> + Lwt.return + (Data_encoding.Binary.to_string_exn + Sc_rollup.Metadata.encoding + metadata)); + } + in + let eval_tick fuel failing_ticks state = + let max_steps = F.max_ticks fuel in + let normal_eval ?(max_steps = max_steps) state = + Lwt.catch + (fun () -> + let*! state, executed_ticks = + PVM.eval_many + ~reveal_builtins + ~write_debug:(Printer node_ctxt.kernel_debug_logger) + ~max_steps + state + in + return (state, executed_ticks, failing_ticks)) + (function + | Error_wrapper error -> Lwt.return (Error error) | exn -> raise exn) in - let complete state fuel current_tick failing_ticks = - return (Completed {state; fuel; current_tick; failing_ticks}) + let failure_insertion_eval state tick failing_ticks' = + let*! () = + Interpreter_event.intended_failure + ~level + ~message_index + ~message_tick:tick + ~internal:true + in + let*! state = PVM.Internal_for_tests.insert_failure state in + return (state, 1L, failing_ticks') in - let rec go (fuel : fuel) current_tick failing_ticks state = - let*! input_request = PVM.is_input_state state in - match input_request with - | No_input_required when F.is_empty fuel -> - abort state fuel current_tick - | No_input_required -> ( - let>* next_state, executed_ticks, failing_ticks = - eval_tick fuel failing_ticks state + match failing_ticks with + | xtick :: failing_ticks' -> + let jump = Int64.(max 0L (pred xtick)) in + if Compare.Int64.(jump = 0L) then + (* Insert the failure in the first tick. *) + failure_insertion_eval state xtick failing_ticks' + else + (* Jump just before the tick where we'll insert a failure. + Nevertheless, we don't execute more than [max_steps]. *) + let max_steps = Int64.max 0L max_steps |> Int64.min max_steps in + let open Delayed_write_monad.Lwt_result_syntax in + let>* state, executed_ticks, _failing_ticks = + normal_eval ~max_steps state in - let fuel_executed = F.of_ticks executed_ticks in - match F.consume fuel_executed fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go - fuel - (Int64.add current_tick executed_ticks) - failing_ticks - next_state) - | Needs_reveal (Reveal_raw_data hash) -> ( - let* data = - get_reveal ~data_dir:node_ctxt.data_dir reveal_map hash - in - let*! next_state = PVM.set_input (Reveal (Raw_data data)) state in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Needs_reveal Reveal_metadata -> ( - let*! next_state = - PVM.set_input (Reveal (Metadata metadata)) state - in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Needs_reveal (Request_dal_page page_id) -> ( - let* content_opt = - Dal_pages_request.page_content - ~dal_attestation_lag - node_ctxt - page_id - in - let*! next_state = - PVM.set_input (Reveal (Dal_page content_opt)) state + (* Insert the failure. *) + let>* state, executed_ticks', failing_ticks' = + failure_insertion_eval state xtick failing_ticks' in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Initial | First_after _ -> - complete state fuel current_tick failing_ticks - in - go fuel start_tick failing_ticks state + let executed_ticks = Int64.add executed_ticks executed_ticks' in + return (state, executed_ticks, failing_ticks') + | _ -> normal_eval state + in + let abort state fuel current_tick = + return (Aborted {state; fuel; current_tick}) + in + let complete state fuel current_tick failing_ticks = + return (Completed {state; fuel; current_tick; failing_ticks}) + in + let rec go (fuel : fuel) current_tick failing_ticks state = + let*! input_request = PVM.is_input_state state in + match input_request with + | No_input_required when F.is_empty fuel -> abort state fuel current_tick + | No_input_required -> ( + let>* next_state, executed_ticks, failing_ticks = + eval_tick fuel failing_ticks state + in + let fuel_executed = F.of_ticks executed_ticks in + match F.consume fuel_executed fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go + fuel + (Int64.add current_tick executed_ticks) + failing_ticks + next_state) + | Needs_reveal (Reveal_raw_data hash) -> ( + let* data = + get_reveal + ~data_dir:node_ctxt.data_dir + ~pvm_kind:node_ctxt.kind + reveal_map + hash + in + let*! next_state = PVM.set_input (Reveal (Raw_data data)) state in + match F.consume F.one_tick_consumption fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go fuel (Int64.succ current_tick) failing_ticks next_state) + | Needs_reveal Reveal_metadata -> ( + let*! next_state = PVM.set_input (Reveal (Metadata metadata)) state in + match F.consume F.one_tick_consumption fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go fuel (Int64.succ current_tick) failing_ticks next_state) + | Needs_reveal (Request_dal_page page_id) -> ( + let* content_opt = + Dal_pages_request.page_content + ~dal_attestation_lag + node_ctxt + page_id + in + let*! next_state = + PVM.set_input (Reveal (Dal_page content_opt)) state + in + match F.consume F.one_tick_consumption fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go fuel (Int64.succ current_tick) failing_ticks next_state) + | Initial | First_after _ -> + complete state fuel current_tick failing_ticks + in + go fuel start_tick failing_ticks state - (** [mutate input] corrupts the payload of [input] for testing purposes. *) - let mutate input = - let payload = - Sc_rollup.Inbox_message.unsafe_of_string - "\001to the cheater we promise pain and misery" - in - {input with Sc_rollup.payload} + (** [mutate input] corrupts the payload of [input] for testing purposes. *) + let mutate input = + let payload = + Sc_rollup.Inbox_message.unsafe_of_string + "\001to the cheater we promise pain and misery" + in + {input with Sc_rollup.payload} - type feed_input_completion = - | Feed_input_aborted of {state : PVM.state; fuel : fuel; fed_input : bool} - | Feed_input_completed of {state : PVM.state; fuel : fuel} + type feed_input_completion = + | Feed_input_aborted of {state : pvm_state; fuel : fuel; fed_input : bool} + | Feed_input_completed of {state : pvm_state; fuel : fuel} - (** [feed_input node_ctxt reveal_map level message_index ~fuel + (** [feed_input node_ctxt reveal_map level message_index ~fuel ~failing_ticks state input] feeds [input] (that has a given [message_index] in inbox of [level]) to the PVM in order to advance [state] to the next step that requires an input. This function is controlled by some [fuel] and may introduce intended failures at some given [failing_ticks]. *) - let feed_input node_ctxt reveal_map level message_index ~fuel ~failing_ticks - state input = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let>* res = - eval_until_input - node_ctxt - reveal_map - level - message_index - ~fuel - 0L - failing_ticks - state - in - match res with - | Aborted {state; fuel; _} -> - return (Feed_input_aborted {state; fuel; fed_input = false}) - | Completed {state; fuel; current_tick = tick; failing_ticks} -> ( - let open Delayed_write_monad.Lwt_result_syntax in - match F.consume F.one_tick_consumption fuel with - | None -> return (Feed_input_aborted {state; fuel; fed_input = false}) - | Some fuel -> ( - let>* input, failing_ticks = - match failing_ticks with - | xtick :: failing_ticks' -> - if xtick = tick then - let*! () = - Interpreter_event.intended_failure - ~level - ~message_index - ~message_tick:tick - ~internal:false - in - return (mutate input, failing_ticks') - else return (input, failing_ticks) - | [] -> return (input, failing_ticks) - in - let*! state = PVM.set_input (Inbox_message input) state in - let>* res = - eval_until_input - node_ctxt - reveal_map - level - message_index - ~fuel - tick - failing_ticks - state - in - match res with - | Aborted {state; fuel; _} -> - return (Feed_input_aborted {state; fuel; fed_input = true}) - | Completed {state; fuel; _} -> - return (Feed_input_completed {state; fuel}))) - - let eval_messages ~reveal_map ~fuel node_ctxt ~message_counter_offset state - inbox_level messages = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let level = Raw_level.to_int32 inbox_level |> Int32.to_int in - (* Iterate the PVM state with all the messages. *) - let rec feed_messages (state, fuel) message_index = function - | [] -> - (* Fed all messages *) - return (state, fuel, message_index - message_counter_offset, []) - | messages when F.is_empty fuel -> - (* Consumed all fuel *) - return - (state, fuel, message_index - message_counter_offset, messages) - | message :: messages -> ( - let*? payload = - Sc_rollup.Inbox_message.( - message |> serialize |> Environment.wrap_tzresult) - in - let message_counter = Z.of_int message_index in - let input = Sc_rollup.{inbox_level; message_counter; payload} in - let failing_ticks = - Loser_mode.is_failure - node_ctxt.Node_context.loser_mode - ~level - ~message_index - in - let>* res = - feed_input - node_ctxt - reveal_map - level - message_index - ~fuel - ~failing_ticks - state - input - in - match res with - | Feed_input_completed {state; fuel} -> - feed_messages (state, fuel) (message_index + 1) messages - | Feed_input_aborted {state; fuel; fed_input = false} -> - return - ( state, - fuel, - message_index - message_counter_offset, - message :: messages ) - | Feed_input_aborted {state; fuel; fed_input = true} -> - return - ( state, - fuel, - message_index + 1 - message_counter_offset, - messages )) - in - (feed_messages [@tailcall]) (state, fuel) message_counter_offset messages - - let eval_block_inbox ~fuel node_ctxt (inbox, messages) (state : PVM.state) : - eval_result Node_context.delayed_write tzresult Lwt.t = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - (* Obtain inbox and its messages for this block. *) - let inbox_level = Inbox.inbox_level inbox in - let*! initial_tick = PVM.get_tick state in - (* Evaluate all the messages for this level. *) - let>* state, remaining_fuel, num_messages, remaining_messages = - eval_messages - ~reveal_map:None - ~fuel - node_ctxt - ~message_counter_offset:0 - state - inbox_level - messages - in - let*! final_tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in - let eval_state = - { - state; - state_hash; - tick = final_tick; - inbox_level; - message_counter_offset = num_messages; - remaining_fuel; - remaining_messages; - } - in - return {state = eval_state; num_ticks; num_messages} - - let eval_messages ?reveal_map node_ctxt - { - state; - tick = initial_tick; - inbox_level; - message_counter_offset; - remaining_fuel = fuel; - remaining_messages = messages; - _; - } = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let>* state, remaining_fuel, num_messages, remaining_messages = - match messages with - | [] -> - let level = Raw_level.to_int32 inbox_level |> Int32.to_int in - let message_index = message_counter_offset - 1 in - let failing_ticks = - Loser_mode.is_failure - node_ctxt.Node_context.loser_mode - ~level - ~message_index + let feed_input (node_ctxt : _ Node_context.t) reveal_map level message_index + ~fuel ~failing_ticks state input = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let>* res = + eval_until_input + node_ctxt + reveal_map + level + message_index + ~fuel + 0L + failing_ticks + state + in + match res with + | Aborted {state; fuel; _} -> + return (Feed_input_aborted {state; fuel; fed_input = false}) + | Completed {state; fuel; current_tick = tick; failing_ticks} -> ( + let open Delayed_write_monad.Lwt_result_syntax in + match F.consume F.one_tick_consumption fuel with + | None -> return (Feed_input_aborted {state; fuel; fed_input = false}) + | Some fuel -> ( + let>* input, failing_ticks = + match failing_ticks with + | xtick :: failing_ticks' -> + if xtick = tick then + let*! () = + Interpreter_event.intended_failure + ~level + ~message_index + ~message_tick:tick + ~internal:false + in + return (mutate input, failing_ticks') + else return (input, failing_ticks) + | [] -> return (input, failing_ticks) in + let*! state = PVM.set_input (Inbox_message input) state in let>* res = eval_until_input node_ctxt @@ -479,43 +350,174 @@ module Make (PVM : Pvm.S) = struct level message_index ~fuel - 0L + tick failing_ticks state in - let state, remaining_fuel = - match res with - | Aborted {state; fuel; _} | Completed {state; fuel; _} -> - (state, fuel) - in - return (state, remaining_fuel, 0, []) - | _ -> - eval_messages - ~reveal_map - ~fuel + match res with + | Aborted {state; fuel; _} -> + return (Feed_input_aborted {state; fuel; fed_input = true}) + | Completed {state; fuel; _} -> + return (Feed_input_completed {state; fuel}))) + + let eval_messages ~reveal_map ~fuel node_ctxt ~message_counter_offset state + inbox_level messages = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let level = Raw_level.to_int32 inbox_level |> Int32.to_int in + (* Iterate the PVM state with all the messages. *) + let rec feed_messages (state, fuel) message_index = function + | [] -> + (* Fed all messages *) + return (state, fuel, message_index - message_counter_offset, []) + | messages when F.is_empty fuel -> + (* Consumed all fuel *) + return (state, fuel, message_index - message_counter_offset, messages) + | message :: messages -> ( + let*? payload = + Sc_rollup.Inbox_message.( + message |> serialize |> Environment.wrap_tzresult) + in + let message_counter = Z.of_int message_index in + let input = Sc_rollup.{inbox_level; message_counter; payload} in + let failing_ticks = + Loser_mode.is_failure + node_ctxt.Node_context.loser_mode + ~level + ~message_index + in + let>* res = + feed_input node_ctxt - ~message_counter_offset + reveal_map + level + message_index + ~fuel + ~failing_ticks state - inbox_level - messages - in - let*! final_tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in - let eval_state = - { - state; - state_hash; - tick = final_tick; - inbox_level; - message_counter_offset = message_counter_offset + num_messages; - remaining_fuel; - remaining_messages; - } - in - return {state = eval_state; num_ticks; num_messages} - end + input + in + match res with + | Feed_input_completed {state; fuel} -> + feed_messages (state, fuel) (message_index + 1) messages + | Feed_input_aborted {state; fuel; fed_input = false} -> + return + ( state, + fuel, + message_index - message_counter_offset, + message :: messages ) + | Feed_input_aborted {state; fuel; fed_input = true} -> + return + ( state, + fuel, + message_index + 1 - message_counter_offset, + messages )) + in + (feed_messages [@tailcall]) (state, fuel) message_counter_offset messages + + let eval_block_inbox ~fuel (node_ctxt : _ Node_context.t) (inbox, messages) + (state : pvm_state) : + eval_result Node_context.delayed_write tzresult Lwt.t = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + (* Obtain inbox and its messages for this block. *) + let inbox_level = Inbox.inbox_level inbox in + let*! initial_tick = PVM.get_tick state in + (* Evaluate all the messages for this level. *) + let>* state, remaining_fuel, num_messages, remaining_messages = + eval_messages + ~reveal_map:None + ~fuel + node_ctxt + ~message_counter_offset:0 + state + inbox_level + messages + in + let*! final_tick = PVM.get_tick state in + let*! state_hash = PVM.state_hash state in + let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in + let eval_state = + { + state; + state_hash; + tick = final_tick; + inbox_level; + message_counter_offset = num_messages; + remaining_fuel; + remaining_messages; + } + in + return {state = eval_state; num_ticks; num_messages} - module Free = Make_fueled (Fuel.Free) - module Accounted = Make_fueled (Fuel.Accounted) + let eval_messages ?reveal_map (node_ctxt : _ Node_context.t) + { + state; + tick = initial_tick; + inbox_level; + message_counter_offset; + remaining_fuel = fuel; + remaining_messages = messages; + _; + } = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let>* state, remaining_fuel, num_messages, remaining_messages = + match messages with + | [] -> + let level = Raw_level.to_int32 inbox_level |> Int32.to_int in + let message_index = message_counter_offset - 1 in + let failing_ticks = + Loser_mode.is_failure + node_ctxt.Node_context.loser_mode + ~level + ~message_index + in + let>* res = + eval_until_input + node_ctxt + reveal_map + level + message_index + ~fuel + 0L + failing_ticks + state + in + let state, remaining_fuel = + match res with + | Aborted {state; fuel; _} | Completed {state; fuel; _} -> + (state, fuel) + in + return (state, remaining_fuel, 0, []) + | _ -> + eval_messages + ~reveal_map + ~fuel + node_ctxt + ~message_counter_offset + state + inbox_level + messages + in + let*! final_tick = PVM.get_tick state in + let*! state_hash = PVM.state_hash state in + let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in + let eval_state = + { + state; + state_hash; + tick = final_tick; + inbox_level; + message_counter_offset = message_counter_offset + num_messages; + remaining_fuel; + remaining_messages; + } + in + return {state = eval_state; num_ticks; num_messages} end + +module Free = Make_fueled (Fuel.Free) +module Accounted = Make_fueled (Fuel.Accounted) diff --git a/src/proto_alpha/lib_sc_rollup_node/interpreter.ml b/src/proto_alpha/lib_sc_rollup_node/interpreter.ml index a9ff8c1cab3c..5d1b9cca9837 100644 --- a/src/proto_alpha/lib_sc_rollup_node/interpreter.ml +++ b/src/proto_alpha/lib_sc_rollup_node/interpreter.ml @@ -29,12 +29,6 @@ open Alpha_context module type S = sig module PVM : Pvm.S - module Accounted_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Accounted.t - - module Free_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Free.t - val process_head : Node_context.rw -> 'a Context.t -> @@ -45,10 +39,10 @@ module type S = sig val state_of_tick : _ Node_context.t -> - ?start_state:Accounted_pvm.eval_state -> + ?start_state:Fueled_pvm.Accounted.eval_state -> Sc_rollup.Tick.t -> Raw_level.t -> - Accounted_pvm.eval_state option tzresult Lwt.t + Fueled_pvm.Accounted.eval_state option tzresult Lwt.t val state_of_head : 'a Node_context.t -> @@ -59,7 +53,6 @@ end module Make (PVM : Pvm.S) : S with module PVM = PVM = struct module PVM = PVM - module Fueled_pvm = Fueled_pvm.Make (PVM) module Accounted_pvm = Fueled_pvm.Accounted module Free_pvm = Fueled_pvm.Free diff --git a/src/proto_alpha/lib_sc_rollup_node/interpreter.mli b/src/proto_alpha/lib_sc_rollup_node/interpreter.mli index 99dd231a3ab9..92b3636c5816 100644 --- a/src/proto_alpha/lib_sc_rollup_node/interpreter.mli +++ b/src/proto_alpha/lib_sc_rollup_node/interpreter.mli @@ -28,12 +28,6 @@ open Protocol.Alpha_context module type S = sig module PVM : Pvm.S - module Accounted_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Accounted.t - - module Free_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Free.t - (** [process_head node_ctxt ~predecessor head (inbox, messages)] interprets the [messages] associated with a [head] (where [predecessor] is the predecessor of [head] in the L1 chain). This requires the [inbox] to be @@ -56,10 +50,10 @@ module type S = sig from [start_state]. *) val state_of_tick : _ Node_context.t -> - ?start_state:Accounted_pvm.eval_state -> + ?start_state:Fueled_pvm.Accounted.eval_state -> Sc_rollup.Tick.t -> Raw_level.t -> - Accounted_pvm.eval_state option tzresult Lwt.t + Fueled_pvm.Accounted.eval_state option tzresult Lwt.t (** [state_of_head node_ctxt ctxt head] returns the state corresponding to the block [head], or the state at rollup genesis if the block is before the diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml b/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml index 9809d63b7cbc..6901924122d4 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml @@ -315,7 +315,7 @@ module Make (Interpreter : Interpreter.S) : type pvm_intermediate_state = | Hash of PVM.hash - | Evaluated of Interpreter.Accounted_pvm.eval_state + | Evaluated of Fueled_pvm.Accounted.eval_state let new_dissection ~opponent ~default_number_of_sections node_ctxt last_level ok our_view = @@ -323,7 +323,7 @@ module Make (Interpreter : Interpreter.S) : let state_of_tick ?start_state tick = Interpreter.state_of_tick node_ctxt ?start_state tick last_level in - let state_hash_of_eval_state Interpreter.Accounted_pvm.{state_hash; _} = + let state_hash_of_eval_state Fueled_pvm.Accounted.{state_hash; _} = state_hash in let start_hash, start_tick, start_state = @@ -339,7 +339,7 @@ module Make (Interpreter : Interpreter.S) : let our_state, our_tick = our_view in let our_state_hash = Option.map - (fun Interpreter.Accounted_pvm.{state_hash; _} -> state_hash) + (fun Fueled_pvm.Accounted.{state_hash; _} -> state_hash) our_state in let our_stop_chunk = diff --git a/src/proto_alpha/lib_sc_rollup_node/simulation.ml b/src/proto_alpha/lib_sc_rollup_node/simulation.ml index 58d0fbdebe06..e0135e31b6e0 100644 --- a/src/proto_alpha/lib_sc_rollup_node/simulation.ml +++ b/src/proto_alpha/lib_sc_rollup_node/simulation.ml @@ -30,7 +30,7 @@ module type S = sig module Interpreter : Interpreter.S module PVM = Interpreter.PVM - module Fueled_pvm = Interpreter.Free_pvm + module Fueled_pvm = Fueled_pvm.Free type level_position = Start | Middle | End @@ -68,7 +68,7 @@ module Make (Interpreter : Interpreter.S) : S with module Interpreter = Interpreter = struct module Interpreter = Interpreter module PVM = Interpreter.PVM - module Fueled_pvm = Interpreter.Free_pvm + module Fueled_pvm = Fueled_pvm.Free type level_position = Start | Middle | End diff --git a/src/proto_alpha/lib_sc_rollup_node/simulation.mli b/src/proto_alpha/lib_sc_rollup_node/simulation.mli index ad4faaedfd0e..5e9e6a680f8f 100644 --- a/src/proto_alpha/lib_sc_rollup_node/simulation.mli +++ b/src/proto_alpha/lib_sc_rollup_node/simulation.mli @@ -30,7 +30,7 @@ module type S = sig module Interpreter : Interpreter.S module PVM = Interpreter.PVM - module Fueled_pvm = Interpreter.Free_pvm + module Fueled_pvm = Fueled_pvm.Free type level_position = Start | Middle | End -- GitLab From 24e470949de05c4b36a73a7882485ca12fec11c8 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 19:05:28 +0200 Subject: [PATCH 03/13] SCORU/Node: defunctorize Interpreter --- .../lib_sc_rollup_node/RPC_server.ml | 1 - .../lib_sc_rollup_node/components.ml | 5 +- src/proto_alpha/lib_sc_rollup_node/daemon.ml | 4 +- .../lib_sc_rollup_node/interpreter.ml | 523 ++++++++---------- .../lib_sc_rollup_node/interpreter.mli | 73 ++- .../refutation_coordinator.ml | 6 +- .../refutation_coordinator.mli | 2 +- .../lib_sc_rollup_node/refutation_game.ml | 5 +- .../lib_sc_rollup_node/refutation_game.mli | 2 +- .../lib_sc_rollup_node/refutation_player.ml | 4 +- .../lib_sc_rollup_node/refutation_player.mli | 2 +- .../lib_sc_rollup_node/simulation.ml | 9 +- .../lib_sc_rollup_node/simulation.mli | 8 +- 13 files changed, 295 insertions(+), 349 deletions(-) diff --git a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml index d80fbbc30c05..14a10056c520 100644 --- a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml +++ b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml @@ -55,7 +55,6 @@ let get_dal_processed_slots node_ctxt block = module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct module PVM = Simulation.PVM - module Interpreter = Simulation.Interpreter module Outbox = Outbox.Make (PVM) module Global_directory = Make_directory (struct diff --git a/src/proto_alpha/lib_sc_rollup_node/components.ml b/src/proto_alpha/lib_sc_rollup_node/components.ml index 1d5b8c0984fa..3d456ec7fa93 100644 --- a/src/proto_alpha/lib_sc_rollup_node/components.ml +++ b/src/proto_alpha/lib_sc_rollup_node/components.ml @@ -26,10 +26,9 @@ module Make (PVM : Pvm.S) = struct module PVM = PVM - module Interpreter = Interpreter.Make (PVM) module Commitment = Commitment.Make (PVM) - module Simulation = Simulation.Make (Interpreter) - module Refutation_coordinator = Refutation_coordinator.Make (Interpreter) + module Simulation = Simulation.Make (PVM) + module Refutation_coordinator = Refutation_coordinator.Make (PVM) module Batcher = Batcher.Make (Simulation) module RPC_server = RPC_server.Make (Simulation) (Batcher) end diff --git a/src/proto_alpha/lib_sc_rollup_node/daemon.ml b/src/proto_alpha/lib_sc_rollup_node/daemon.ml index 09fa40360b95..f5aaf14562ff 100644 --- a/src/proto_alpha/lib_sc_rollup_node/daemon.ml +++ b/src/proto_alpha/lib_sc_rollup_node/daemon.ml @@ -328,7 +328,7 @@ module Make (PVM : Pvm.S) = struct (* Avoid triggering the pvm execution if this has been done before for this head. *) let* ctxt, _num_messages, num_ticks, initial_tick = - Components.Interpreter.process_head + Interpreter.process_head node_ctxt ctxt ~predecessor @@ -604,7 +604,7 @@ module Make (PVM : Pvm.S) = struct messages in let* ctxt, _num_messages, num_ticks, initial_tick = - Components.Interpreter.process_head + Interpreter.process_head node_ctxt ctxt ~predecessor diff --git a/src/proto_alpha/lib_sc_rollup_node/interpreter.ml b/src/proto_alpha/lib_sc_rollup_node/interpreter.ml index 5d1b9cca9837..f46643c31026 100644 --- a/src/proto_alpha/lib_sc_rollup_node/interpreter.ml +++ b/src/proto_alpha/lib_sc_rollup_node/interpreter.ml @@ -26,301 +26,262 @@ open Protocol open Alpha_context -module type S = sig - module PVM : Pvm.S +(** [get_boot_sector block_hash node_ctxt] fetches the operations in the + [block_hash] and looks for the bootsector used to originate the rollup we're + following. It must be called with [block_hash.level] = + [node_ctxt.genesis_info.level]. *) +let get_boot_sector block_hash (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let exception Found_boot_sector of string in + let* block = Layer1.fetch_tezos_block node_ctxt.cctxt block_hash in + let missing_boot_sector () = + failwith "Boot sector not found in Tezos block %a" Block_hash.pp block_hash + in + Lwt.catch + (fun () -> + let apply (type kind) accu ~source:_ (operation : kind manager_operation) + (result : kind Apply_results.successful_manager_operation_result) = + match (operation, result) with + | ( Sc_rollup_originate {kind; boot_sector; _}, + Sc_rollup_originate_result {address; _} ) + when node_ctxt.rollup_address = address && node_ctxt.kind = kind -> + raise (Found_boot_sector boot_sector) + | _ -> accu + in + let apply_internal (type kind) accu ~source:_ + (_operation : kind Apply_internal_results.internal_operation) + (_result : + kind Apply_internal_results.successful_internal_operation_result) = + accu + in + let*? () = + Layer1_services.( + process_applied_manager_operations + (Ok ()) + block.operations + {apply; apply_internal}) + in + missing_boot_sector ()) + (function + | Found_boot_sector boot_sector -> return boot_sector + | _ -> missing_boot_sector ()) - val process_head : - Node_context.rw -> - 'a Context.t -> - predecessor:Layer1.header -> - Layer1.header -> - Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> - ('a Context.t * int * int64 * Sc_rollup.Tick.t) tzresult Lwt.t +let get_boot_sector block_hash (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + match node_ctxt.boot_sector_file with + | None -> get_boot_sector block_hash node_ctxt + | Some boot_sector_file -> + let module PVM = (val node_ctxt.pvm) in + let*! boot_sector = Lwt_utils_unix.read_file boot_sector_file in + let*? boot_sector = + Option.value_e + ~error: + [ + Sc_rollup_node_errors.Unparsable_boot_sector + {path = boot_sector_file}; + ] + (PVM.parse_boot_sector boot_sector) + in + return boot_sector - val state_of_tick : - _ Node_context.t -> - ?start_state:Fueled_pvm.Accounted.eval_state -> - Sc_rollup.Tick.t -> - Raw_level.t -> - Fueled_pvm.Accounted.eval_state option tzresult Lwt.t +let genesis_state block_hash node_ctxt ctxt = + let open Lwt_result_syntax in + let* boot_sector = get_boot_sector block_hash node_ctxt in + let module PVM = (val node_ctxt.pvm) in + let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in + let*! genesis_state = PVM.install_boot_sector initial_state boot_sector in + let*! ctxt = PVM.State.set ctxt genesis_state in + return (ctxt, genesis_state) - val state_of_head : - 'a Node_context.t -> - 'a Context.t -> - Layer1.head -> - ('a Context.t * PVM.state) tzresult Lwt.t -end +let state_of_head node_ctxt ctxt Layer1.{hash; level} = + let open Lwt_result_syntax in + let*! state = Context.PVMState.find ctxt in + match state with + | None -> + let genesis_level = + Raw_level.to_int32 node_ctxt.Node_context.genesis_info.level + in + if level = genesis_level then genesis_state hash node_ctxt ctxt + else tzfail (Sc_rollup_node_errors.Missing_PVM_state (hash, level)) + | Some state -> return (ctxt, state) -module Make (PVM : Pvm.S) : S with module PVM = PVM = struct - module PVM = PVM - module Accounted_pvm = Fueled_pvm.Accounted - module Free_pvm = Fueled_pvm.Free +(** [transition_pvm node_ctxt predecessor head] runs a PVM at the previous state + from block [predecessor] by consuming as many messages as possible from + block [head]. *) +let transition_pvm node_ctxt ctxt predecessor Layer1.{hash = _; _} + inbox_messages = + let open Lwt_result_syntax in + (* Retrieve the previous PVM state from store. *) + let* ctxt, predecessor_state = state_of_head node_ctxt ctxt predecessor in + let* eval_result = + Fueled_pvm.Free.eval_block_inbox + ~fuel:(Fuel.Free.of_ticks 0L) + node_ctxt + inbox_messages + predecessor_state + in + let* { + state = {state; state_hash; inbox_level; tick; _}; + num_messages; + num_ticks; + } = + Delayed_write_monad.apply node_ctxt eval_result + in + let module PVM = (val node_ctxt.pvm) in + let*! ctxt = PVM.State.set ctxt state in + let*! initial_tick = PVM.get_tick predecessor_state in + (* Produce events. *) + let*! () = + Interpreter_event.transitioned_pvm inbox_level state_hash tick num_messages + in + return (ctxt, num_messages, Z.to_int64 num_ticks, initial_tick) - (** [get_boot_sector block_hash node_ctxt] fetches the operations in the - [block_hash] and looks for the bootsector used to originate the rollup - we're following. - It must be called with [block_hash.level] = [node_ctxt.genesis_info.level]. - *) - let get_boot_sector block_hash (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - let exception Found_boot_sector of string in - let* block = Layer1.fetch_tezos_block node_ctxt.cctxt block_hash in - let missing_boot_sector () = - failwith - "Boot sector not found in Tezos block %a" - Block_hash.pp - block_hash - in - Lwt.catch - (fun () -> - let apply (type kind) accu ~source:_ - (operation : kind manager_operation) - (result : kind Apply_results.successful_manager_operation_result) = - match (operation, result) with - | ( Sc_rollup_originate {kind; boot_sector; _}, - Sc_rollup_originate_result {address; _} ) - when node_ctxt.rollup_address = address && node_ctxt.kind = kind -> - raise (Found_boot_sector boot_sector) - | _ -> accu - in - let apply_internal (type kind) accu ~source:_ - (_operation : kind Apply_internal_results.internal_operation) - (_result : - kind Apply_internal_results.successful_internal_operation_result) - = - accu - in - let*? () = - Layer1_services.( - process_applied_manager_operations - (Ok ()) - block.operations - {apply; apply_internal}) - in - missing_boot_sector ()) - (function - | Found_boot_sector boot_sector -> return boot_sector - | _ -> missing_boot_sector ()) +(** [process_head node_ctxt ctxt ~predecessor head] runs the PVM for the given + head. *) +let process_head (node_ctxt : _ Node_context.t) ctxt + ~(predecessor : Layer1.header) (head : Layer1.header) inbox_messages = + let open Lwt_result_syntax in + let first_inbox_level = + Raw_level.to_int32 node_ctxt.genesis_info.level |> Int32.succ + in + if head.Layer1.level >= first_inbox_level then + transition_pvm + node_ctxt + ctxt + (Layer1.head_of_header predecessor) + (Layer1.head_of_header head) + inbox_messages + else if head.Layer1.level = Raw_level.to_int32 node_ctxt.genesis_info.level + then + let* ctxt, state = genesis_state head.hash node_ctxt ctxt in + let*! ctxt = Context.PVMState.set ctxt state in + return (ctxt, 0, 0L, Sc_rollup.Tick.initial) + else return (ctxt, 0, 0L, Sc_rollup.Tick.initial) - let get_boot_sector block_hash (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - match node_ctxt.boot_sector_file with - | None -> get_boot_sector block_hash node_ctxt - | Some boot_sector_file -> - let*! boot_sector = Lwt_utils_unix.read_file boot_sector_file in - let*? boot_sector = - Option.value_e - ~error: - [ - Sc_rollup_node_errors.Unparsable_boot_sector - {path = boot_sector_file}; - ] - (PVM.parse_boot_sector boot_sector) - in - return boot_sector +(** Returns the starting evaluation before the evaluation of the block. It + contains the PVM state at the end of the execution of the previous block and + the messages the block ([remaining_messages]). *) +let start_state_of_block node_ctxt (block : Sc_rollup_block.t) = + let open Lwt_result_syntax in + let pred_level = Raw_level.to_int32 block.header.level |> Int32.pred in + let* ctxt = + Node_context.checkout_context node_ctxt block.header.predecessor + in + let* _ctxt, state = + state_of_head + node_ctxt + ctxt + Layer1.{hash = block.header.predecessor; level = pred_level} + in + let* inbox = Node_context.get_inbox node_ctxt block.header.inbox_hash in + let* {is_first_block; predecessor; predecessor_timestamp; messages} = + Node_context.get_messages node_ctxt block.header.inbox_witness + in + let inbox_level = Sc_rollup.Inbox.inbox_level inbox in + let module PVM = (val node_ctxt.pvm) in + let*! tick = PVM.get_tick state in + let*! state_hash = PVM.state_hash state in + let messages = + let open Sc_rollup.Inbox_message in + Internal Start_of_level + :: + (if is_first_block then + [Internal Sc_rollup.Inbox_message.protocol_migration_internal_message] + else []) + @ Internal (Info_per_level {predecessor; predecessor_timestamp}) + :: messages + @ [Internal End_of_level] + in + return + Fueled_pvm.Accounted. + { + state; + state_hash; + inbox_level; + tick; + message_counter_offset = 0; + remaining_fuel = Fuel.Accounted.of_ticks 0L; + remaining_messages = messages; + } - let genesis_state block_hash node_ctxt ctxt = - let open Lwt_result_syntax in - let* boot_sector = get_boot_sector block_hash node_ctxt in - let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! genesis_state = PVM.install_boot_sector initial_state boot_sector in - let*! ctxt = PVM.State.set ctxt genesis_state in - return (ctxt, genesis_state) - - let state_of_head node_ctxt ctxt Layer1.{hash; level} = - let open Lwt_result_syntax in - let*! state = PVM.State.find ctxt in - match state with - | None -> - let genesis_level = - Raw_level.to_int32 node_ctxt.Node_context.genesis_info.level - in - if level = genesis_level then genesis_state hash node_ctxt ctxt - else tzfail (Sc_rollup_node_errors.Missing_PVM_state (hash, level)) - | Some state -> return (ctxt, state) - - (** [transition_pvm node_ctxt predecessor head] runs a PVM at the - previous state from block [predecessor] by consuming as many messages - as possible from block [head]. *) - let transition_pvm node_ctxt ctxt predecessor Layer1.{hash = _; _} - inbox_messages = - let open Lwt_result_syntax in - (* Retrieve the previous PVM state from store. *) - let* ctxt, predecessor_state = state_of_head node_ctxt ctxt predecessor in - let* eval_result = - Free_pvm.eval_block_inbox - ~fuel:(Fuel.Free.of_ticks 0L) - node_ctxt - inbox_messages - predecessor_state - in - let* { - state = {state; state_hash; inbox_level; tick; _}; - num_messages; - num_ticks; - } = - Delayed_write_monad.apply node_ctxt eval_result - in - let*! ctxt = PVM.State.set ctxt state in - let*! initial_tick = PVM.get_tick predecessor_state in - (* Produce events. *) - let*! () = - Interpreter_event.transitioned_pvm - inbox_level - state_hash - tick - num_messages - in - return (ctxt, num_messages, Z.to_int64 num_ticks, initial_tick) - - (** [process_head node_ctxt ctxt ~predecessor head] runs the PVM for the given - head. *) - let process_head (node_ctxt : _ Node_context.t) ctxt - ~(predecessor : Layer1.header) (head : Layer1.header) inbox_messages = - let open Lwt_result_syntax in - let first_inbox_level = - Raw_level.to_int32 node_ctxt.genesis_info.level |> Int32.succ - in - if head.Layer1.level >= first_inbox_level then - transition_pvm - node_ctxt - ctxt - (Layer1.head_of_header predecessor) - (Layer1.head_of_header head) - inbox_messages - else if head.Layer1.level = Raw_level.to_int32 node_ctxt.genesis_info.level - then - let* ctxt, state = genesis_state head.hash node_ctxt ctxt in - let*! ctxt = PVM.State.set ctxt state in - return (ctxt, 0, 0L, Sc_rollup.Tick.initial) - else return (ctxt, 0, 0L, Sc_rollup.Tick.initial) - - (** Returns the starting evaluation before the evaluation of the block. It - contains the PVM state at the end of the execution of the previous block - and the messages the block ([remaining_messages]). *) - let start_state_of_block node_ctxt (block : Sc_rollup_block.t) = - let open Lwt_result_syntax in - let pred_level = Raw_level.to_int32 block.header.level |> Int32.pred in - let* ctxt = - Node_context.checkout_context node_ctxt block.header.predecessor - in - let* _ctxt, state = - state_of_head - node_ctxt - ctxt - Layer1.{hash = block.header.predecessor; level = pred_level} - in - let* inbox = Node_context.get_inbox node_ctxt block.header.inbox_hash in - let* {is_first_block; predecessor; predecessor_timestamp; messages} = - Node_context.get_messages node_ctxt block.header.inbox_witness - in - let inbox_level = Sc_rollup.Inbox.inbox_level inbox in - let*! tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let messages = - let open Sc_rollup.Inbox_message in - Internal Start_of_level - :: - (if is_first_block then - [Internal Sc_rollup.Inbox_message.protocol_migration_internal_message] - else []) - @ Internal (Info_per_level {predecessor; predecessor_timestamp}) - :: messages - @ [Internal End_of_level] - in - return - Accounted_pvm. - { - state; - state_hash; - inbox_level; - tick; - message_counter_offset = 0; - remaining_fuel = Fuel.Accounted.of_ticks 0L; - remaining_messages = messages; - } - - (** [run_for_ticks node_ctxt start_state tick_distance] starts the evaluation +(** [run_for_ticks node_ctxt start_state tick_distance] starts the evaluation of messages in the [start_state] for at most [tick_distance]. *) - let run_to_tick node_ctxt start_state tick = - let open Delayed_write_monad.Lwt_result_syntax in - let tick_distance = - Sc_rollup.Tick.distance tick start_state.Accounted_pvm.tick |> Z.to_int64 - in - let>+ eval_result = - Accounted_pvm.eval_messages - node_ctxt - { - start_state with - remaining_fuel = Fuel.Accounted.of_ticks tick_distance; - } - in - eval_result.state +let run_to_tick node_ctxt start_state tick = + let open Delayed_write_monad.Lwt_result_syntax in + let tick_distance = + Sc_rollup.Tick.distance tick start_state.Fueled_pvm.Accounted.tick + |> Z.to_int64 + in + let>+ eval_result = + Fueled_pvm.Accounted.eval_messages + node_ctxt + {start_state with remaining_fuel = Fuel.Accounted.of_ticks tick_distance} + in + eval_result.state - let state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) tick - = - let open Lwt_result_syntax in - let* start_state = - match start_state with - | Some start_state - when Raw_level.( - start_state.Accounted_pvm.inbox_level = event.header.level) -> - return start_state - | _ -> - (* Recompute start state on level change or if we don't have a - starting state on hand. *) - start_state_of_block node_ctxt event - in - (* TODO: #3384 - We should test that we always have enough blocks to find the tick - because [state_of_tick] is a critical function. *) - let* result_state = run_to_tick node_ctxt start_state tick in - let result_state = Delayed_write_monad.ignore result_state in - return result_state +let state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) tick = + let open Lwt_result_syntax in + let* start_state = + match start_state with + | Some start_state + when Raw_level.( + start_state.Fueled_pvm.Accounted.inbox_level = event.header.level) + -> + return start_state + | _ -> + (* Recompute start state on level change or if we don't have a + starting state on hand. *) + start_state_of_block node_ctxt event + in + (* TODO: #3384 + We should test that we always have enough blocks to find the tick + because [state_of_tick] is a critical function. *) + let* result_state = run_to_tick node_ctxt start_state tick in + let result_state = Delayed_write_monad.ignore result_state in + return result_state - (* The cache allows cache intermediate states of the PVM in e.g. dissections. *) - module Tick_state_cache = - Aches_lwt.Lache.Make - (Aches.Rache.Transfer - (Aches.Rache.LRU) - (struct - type t = Sc_rollup.Tick.t * Block_hash.t +(* The cache allows cache intermediate states of the PVM in e.g. dissections. *) +module Tick_state_cache = + Aches_lwt.Lache.Make + (Aches.Rache.Transfer + (Aches.Rache.LRU) + (struct + type t = Sc_rollup.Tick.t * Block_hash.t - let equal (t1, b1) (t2, b2) = - Sc_rollup.Tick.(t1 = t2) && Block_hash.(b1 = b2) + let equal (t1, b1) (t2, b2) = + Sc_rollup.Tick.(t1 = t2) && Block_hash.(b1 = b2) - let hash (tick, block) = - ((Sc_rollup.Tick.to_z tick |> Z.hash) * 13) + Block_hash.hash block - end)) + let hash (tick, block) = + ((Sc_rollup.Tick.to_z tick |> Z.hash) * 13) + Block_hash.hash block + end)) - let tick_state_cache = Tick_state_cache.create 64 (* size of 2 dissections *) +let tick_state_cache = Tick_state_cache.create 64 (* size of 2 dissections *) - (* Memoized version of [state_of_tick_aux]. *) - let memo_state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) - tick = - Tick_state_cache.bind_or_put - tick_state_cache - (tick, event.header.block_hash) - (fun (tick, _hash) -> state_of_tick_aux node_ctxt ~start_state event tick) - Lwt.return +(* Memoized version of [state_of_tick_aux]. *) +let memo_state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) + tick = + Tick_state_cache.bind_or_put + tick_state_cache + (tick, event.header.block_hash) + (fun (tick, _hash) -> state_of_tick_aux node_ctxt ~start_state event tick) + Lwt.return - (** [state_of_tick node_ctxt ?start_state tick level] returns [Some end_state] +(** [state_of_tick node_ctxt ?start_state tick level] returns [Some end_state] for a given [tick] if this [tick] happened before [level]. Otherwise, returns [None].*) - let state_of_tick node_ctxt ?start_state tick level = - let open Lwt_result_syntax in - let* event = Node_context.block_with_tick node_ctxt ~max_level:level tick in - match event with - | None -> return_none - | Some event -> - assert (Raw_level.(event.header.level <= level)) ; - let* result_state = - if Node_context.is_loser node_ctxt then - (* TODO: https://gitlab.com/tezos/tezos/-/issues/5253 - The failures/loser mode does not work properly when restarting - from intermediate states. *) - state_of_tick_aux node_ctxt ~start_state:None event tick - else memo_state_of_tick_aux node_ctxt ~start_state event tick - in - return_some result_state -end +let state_of_tick node_ctxt ?start_state tick level = + let open Lwt_result_syntax in + let* event = Node_context.block_with_tick node_ctxt ~max_level:level tick in + match event with + | None -> return_none + | Some event -> + assert (Raw_level.(event.header.level <= level)) ; + let* result_state = + if Node_context.is_loser node_ctxt then + (* TODO: https://gitlab.com/tezos/tezos/-/issues/5253 + The failures/loser mode does not work properly when restarting + from intermediate states. *) + state_of_tick_aux node_ctxt ~start_state:None event tick + else memo_state_of_tick_aux node_ctxt ~start_state event tick + in + return_some result_state diff --git a/src/proto_alpha/lib_sc_rollup_node/interpreter.mli b/src/proto_alpha/lib_sc_rollup_node/interpreter.mli index 92b3636c5816..44cabfbbab1e 100644 --- a/src/proto_alpha/lib_sc_rollup_node/interpreter.mli +++ b/src/proto_alpha/lib_sc_rollup_node/interpreter.mli @@ -25,45 +25,38 @@ open Protocol.Alpha_context -module type S = sig - module PVM : Pvm.S +(** [process_head node_ctxt ~predecessor head (inbox, messages)] interprets the + [messages] associated with a [head] (where [predecessor] is the predecessor + of [head] in the L1 chain). This requires the [inbox] to be updated + beforehand. It returns [(ctxt, num_messages, num_ticks, tick)] where [ctxt] + is the updated layer 2 context (with the new PVM state), [num_messages] is + the number of [messages], [num_ticks] is the number of ticks taken by the + PVM for the evaluation and [tick] is the tick reached by the PVM after the + evaluation. *) +val process_head : + Node_context.rw -> + 'a Context.t -> + predecessor:Layer1.header -> + Layer1.header -> + Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> + ('a Context.t * int * int64 * Sc_rollup.Tick.t) tzresult Lwt.t - (** [process_head node_ctxt ~predecessor head (inbox, messages)] interprets - the [messages] associated with a [head] (where [predecessor] is the - predecessor of [head] in the L1 chain). This requires the [inbox] to be - updated beforehand. It returns [(ctxt, num_messages, num_ticks, tick)] - where [ctxt] is the updated layer 2 context (with the new PVM state), - [num_messages] is the number of [messages], [num_ticks] is the number of - ticks taken by the PVM for the evaluation and [tick] is the tick reached - by the PVM after the evaluation. *) - val process_head : - Node_context.rw -> - 'a Context.t -> - predecessor:Layer1.header -> - Layer1.header -> - Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> - ('a Context.t * int * int64 * Sc_rollup.Tick.t) tzresult Lwt.t +(** [state_of_tick node_ctxt ?start_state tick level] returns [Some (state, + hash)] for a given [tick] if this [tick] happened before [level]. Otherwise, + returns [None]. If provided, the evaluation is resumed from + [start_state]. *) +val state_of_tick : + _ Node_context.t -> + ?start_state:Fueled_pvm.Accounted.eval_state -> + Sc_rollup.Tick.t -> + Raw_level.t -> + Fueled_pvm.Accounted.eval_state option tzresult Lwt.t - (** [state_of_tick node_ctxt ?start_state tick level] returns [Some (state, - hash)] for a given [tick] if this [tick] happened before - [level]. Otherwise, returns [None]. If provided, the evaluation is resumed - from [start_state]. *) - val state_of_tick : - _ Node_context.t -> - ?start_state:Fueled_pvm.Accounted.eval_state -> - Sc_rollup.Tick.t -> - Raw_level.t -> - Fueled_pvm.Accounted.eval_state option tzresult Lwt.t - - (** [state_of_head node_ctxt ctxt head] returns the state corresponding to the - block [head], or the state at rollup genesis if the block is before the - rollup origination. *) - val state_of_head : - 'a Node_context.t -> - 'a Context.t -> - Layer1.head -> - ('a Context.t * PVM.state) tzresult Lwt.t -end - -(** Functor to construct an interpreter for a given PVM. *) -module Make (PVM : Pvm.S) : S with module PVM = PVM +(** [state_of_head node_ctxt ctxt head] returns the state corresponding to the + block [head], or the state at rollup genesis if the block is before the + rollup origination. *) +val state_of_head : + 'a Node_context.t -> + 'a Context.t -> + Layer1.head -> + ('a Context.t * Context.tree) tzresult Lwt.t diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.ml b/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.ml index 183553ddda91..754f5f0ba713 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.ml +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.ml @@ -41,9 +41,9 @@ end worker events without conflicts. *) let instances_count = ref 0 -module Make (Interpreter : Interpreter.S) = struct - include Refutation_game.Make (Interpreter) - module Player = Refutation_player.Make (Interpreter) +module Make (PVM : Pvm.S) = struct + include Refutation_game.Make (PVM) + module Player = Refutation_player.Make (PVM) module Pkh_map = Signature.Public_key_hash.Map module Pkh_table = Signature.Public_key_hash.Table diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.mli b/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.mli index ca17d1eb19ab..1b38f1f48b1c 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.mli +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.mli @@ -50,4 +50,4 @@ module type S = sig val shutdown : unit -> unit Lwt.t end -module Make (Interpreter : Interpreter.S) : S +module Make (PVM : Pvm.S) : S diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml b/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml index 6901924122d4..e9c2ce1e9d75 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml @@ -63,9 +63,8 @@ module type S = sig (unit, tztrace) result Lwt.t end -module Make (Interpreter : Interpreter.S) : - S with module PVM = Interpreter.PVM = struct - module PVM = Interpreter.PVM +module Make (PVM : Pvm.S) : S with module PVM = PVM = struct + module PVM = PVM open Sc_rollup.Game let node_role ~self Sc_rollup.Game.Index.{alice; bob} = diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_game.mli b/src/proto_alpha/lib_sc_rollup_node/refutation_game.mli index 89399c86ae0a..e0196859df79 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_game.mli +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_game.mli @@ -49,4 +49,4 @@ module type S = sig (unit, tztrace) result Lwt.t end -module Make (Interpreter : Interpreter.S) : S with module PVM = Interpreter.PVM +module Make (PVM : Pvm.S) : S with module PVM = PVM diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_player.ml b/src/proto_alpha/lib_sc_rollup_node/refutation_player.ml index e5c51eecfb46..30a086b8b75c 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_player.ml +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_player.ml @@ -70,8 +70,8 @@ module type S = sig val current_games : unit -> (public_key_hash * worker) list end -module Make (Interpreter : Interpreter.S) : S = struct - open Refutation_game.Make (Interpreter) +module Make (PVM : Pvm.S) : S = struct + open Refutation_game.Make (PVM) let on_play game Types.{node_ctxt; self; opponent; _} = play node_ctxt ~self game opponent diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_player.mli b/src/proto_alpha/lib_sc_rollup_node/refutation_player.mli index 1c6bbed96676..7eae3b74cb01 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_player.mli +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_player.mli @@ -65,4 +65,4 @@ module type S = sig val current_games : unit -> (public_key_hash * worker) list end -module Make (Interpreter : Interpreter.S) : S +module Make (Interpreter : Pvm.S) : S diff --git a/src/proto_alpha/lib_sc_rollup_node/simulation.ml b/src/proto_alpha/lib_sc_rollup_node/simulation.ml index e0135e31b6e0..7f74c4ad9523 100644 --- a/src/proto_alpha/lib_sc_rollup_node/simulation.ml +++ b/src/proto_alpha/lib_sc_rollup_node/simulation.ml @@ -27,9 +27,8 @@ open Protocol open Alpha_context module type S = sig - module Interpreter : Interpreter.S + module PVM : Pvm.S - module PVM = Interpreter.PVM module Fueled_pvm = Fueled_pvm.Free type level_position = Start | Middle | End @@ -64,10 +63,8 @@ module type S = sig val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t end -module Make (Interpreter : Interpreter.S) : - S with module Interpreter = Interpreter = struct - module Interpreter = Interpreter - module PVM = Interpreter.PVM +module Make (PVM : Pvm.S) : S with module PVM = PVM = struct + module PVM = PVM module Fueled_pvm = Fueled_pvm.Free type level_position = Start | Middle | End diff --git a/src/proto_alpha/lib_sc_rollup_node/simulation.mli b/src/proto_alpha/lib_sc_rollup_node/simulation.mli index 5e9e6a680f8f..23378f7ccc02 100644 --- a/src/proto_alpha/lib_sc_rollup_node/simulation.mli +++ b/src/proto_alpha/lib_sc_rollup_node/simulation.mli @@ -27,9 +27,8 @@ open Protocol open Protocol.Alpha_context module type S = sig - module Interpreter : Interpreter.S + module PVM : Pvm.S - module PVM = Interpreter.PVM module Fueled_pvm = Fueled_pvm.Free type level_position = Start | Middle | End @@ -73,6 +72,5 @@ module type S = sig val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t end -(** Functor to construct a simulator for a given PVM with interpreter. *) -module Make (Interpreter : Interpreter.S) : - S with module Interpreter = Interpreter +(** Functor to construct a simulator for a given PVM. *) +module Make (PVM : Pvm.S) : S with module PVM = PVM -- GitLab From ac3c6bdd6e77223f516342787f41767a624b7f9c Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Fri, 26 May 2023 10:29:31 +0200 Subject: [PATCH 04/13] SCORU/Node: rename Commitment component to Publisher --- .../lib_sc_rollup_node/commitment_sig.ml | 17 +- .../lib_sc_rollup_node/components.ml | 2 +- src/proto_alpha/lib_sc_rollup_node/daemon.ml | 16 +- .../{commitment.ml => publisher.ml} | 199 +++++++++--------- .../{commitment.mli => publisher.mli} | 0 5 files changed, 115 insertions(+), 119 deletions(-) rename src/proto_alpha/lib_sc_rollup_node/{commitment.ml => publisher.ml} (84%) rename src/proto_alpha/lib_sc_rollup_node/{commitment.mli => publisher.mli} (100%) diff --git a/src/proto_alpha/lib_sc_rollup_node/commitment_sig.ml b/src/proto_alpha/lib_sc_rollup_node/commitment_sig.ml index fccdc19b1854..af79ffb90c90 100644 --- a/src/proto_alpha/lib_sc_rollup_node/commitment_sig.ml +++ b/src/proto_alpha/lib_sc_rollup_node/commitment_sig.ml @@ -63,21 +63,20 @@ module type S = sig Protocol.Alpha_context.Sc_rollup.Commitment.t -> unit tzresult Lwt.t - (** Worker for publishing and cementing commitments. *) - module Publisher : sig - val init : _ Node_context.t -> unit tzresult Lwt.t + (** Initialize worker for publishing and cementing commitments. *) + val init : _ Node_context.t -> unit tzresult Lwt.t - (** [publish_commitments node_ctxt] publishes the commitments that were not + (** [publish_commitments node_ctxt] publishes the commitments that were not yet published up to the finalized head and which are after the last cemented commitment. *) - val publish_commitments : unit -> unit tzresult Lwt.t + val publish_commitments : unit -> unit tzresult Lwt.t - (** [cement_commitments node_ctxt] cements the commitments that can be + (** [cement_commitments node_ctxt] cements the commitments that can be cemented, i.e. the commitments that are after the current last cemented commitment and which have [sc_rollup_challenge_period] levels on top of them since they were originally published. *) - val cement_commitments : unit -> unit tzresult Lwt.t + val cement_commitments : unit -> unit tzresult Lwt.t - val shutdown : unit -> unit Lwt.t - end + (** Stop worker for publishing and cementing commitments. *) + val shutdown : unit -> unit Lwt.t end diff --git a/src/proto_alpha/lib_sc_rollup_node/components.ml b/src/proto_alpha/lib_sc_rollup_node/components.ml index 3d456ec7fa93..2a6dc5e13ddd 100644 --- a/src/proto_alpha/lib_sc_rollup_node/components.ml +++ b/src/proto_alpha/lib_sc_rollup_node/components.ml @@ -26,7 +26,7 @@ module Make (PVM : Pvm.S) = struct module PVM = PVM - module Commitment = Commitment.Make (PVM) + module Publisher = Publisher.Make (PVM) module Simulation = Simulation.Make (PVM) module Refutation_coordinator = Refutation_coordinator.Make (PVM) module Batcher = Batcher.Make (Simulation) diff --git a/src/proto_alpha/lib_sc_rollup_node/daemon.ml b/src/proto_alpha/lib_sc_rollup_node/daemon.ml index f5aaf14562ff..32e9955b5570 100644 --- a/src/proto_alpha/lib_sc_rollup_node/daemon.ml +++ b/src/proto_alpha/lib_sc_rollup_node/daemon.ml @@ -78,7 +78,7 @@ module Make (PVM : Pvm.S) = struct ~other in assert (Sc_rollup.Address.(node_ctxt.rollup_address = rollup)) ; - Components.Commitment.publish_single_commitment node_ctxt our_commitment + Components.Publisher.publish_single_commitment node_ctxt our_commitment (** Process an L1 SCORU operation (for the node's rollup) which is included for the first time. {b Note}: this function does not process inboxes for @@ -337,7 +337,7 @@ module Make (PVM : Pvm.S) = struct in let*! context_hash = Context.commit ctxt in let* commitment_hash = - Components.Commitment.process_head + Components.Publisher.process_head node_ctxt ~predecessor:predecessor.hash head @@ -437,8 +437,8 @@ module Make (PVM : Pvm.S) = struct process_head node_ctxt header) reorg.new_chain in - let* () = Components.Commitment.Publisher.publish_commitments () in - let* () = Components.Commitment.Publisher.cement_commitments () in + let* () = Components.Publisher.publish_commitments () in + let* () = Components.Publisher.cement_commitments () in let*! () = Daemon_event.new_heads_processed reorg.new_chain in let* () = Components.Refutation_coordinator.process stripped_head in let* () = Components.Batcher.batch () in @@ -456,7 +456,7 @@ module Make (PVM : Pvm.S) = struct let*! () = message "Shutting down Batcher@." in let*! () = Components.Batcher.shutdown () in let*! () = message "Shutting down Commitment Publisher@." in - let*! () = Components.Commitment.Publisher.shutdown () in + let*! () = Components.Publisher.shutdown () in Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> let* () = Components.Refutation_coordinator.process (Layer1.head_of_header head) @@ -475,7 +475,7 @@ module Make (PVM : Pvm.S) = struct let* () = message "Shutting down Batcher@." in let* () = Components.Batcher.shutdown () in let* () = message "Shutting down Commitment Publisher@." in - let* () = Components.Commitment.Publisher.shutdown () in + let* () = Components.Publisher.shutdown () in let* () = message "Shutting down Refutation Coordinator@." in let* () = Components.Refutation_coordinator.shutdown () in let* (_ : unit tzresult) = Node_context.close node_ctxt in @@ -530,7 +530,7 @@ module Make (PVM : Pvm.S) = struct in (operator, strategy, purposes)) in - let* () = Components.Commitment.Publisher.init node_ctxt in + let* () = Components.Publisher.init node_ctxt in let* () = Components.Refutation_coordinator.init node_ctxt in let* () = unless (signers = []) @@ fun () -> @@ -613,7 +613,7 @@ module Make (PVM : Pvm.S) = struct in let*! context_hash = Context.commit ctxt in let* commitment_hash = - Components.Commitment.process_head + Components.Publisher.process_head node_ctxt ~predecessor:predecessor.Layer1.hash head diff --git a/src/proto_alpha/lib_sc_rollup_node/commitment.ml b/src/proto_alpha/lib_sc_rollup_node/publisher.ml similarity index 84% rename from src/proto_alpha/lib_sc_rollup_node/commitment.ml rename to src/proto_alpha/lib_sc_rollup_node/publisher.ml index d82c08e76da2..43f22d0f54b0 100644 --- a/src/proto_alpha/lib_sc_rollup_node/commitment.ml +++ b/src/proto_alpha/lib_sc_rollup_node/publisher.ml @@ -434,115 +434,112 @@ module Make (PVM : Pvm.S) : Commitment_sig.S with module PVM = PVM = struct (cement_commitment node_ctxt ~source) cementable_commitments - module Publisher = struct - module Types = struct - type nonrec state = state - - type parameters = {node_ctxt : Node_context.ro} - end - - module Name = struct - (* We only have a single committer in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Commitment_event.section - @ [ - ("publisher" - ^ - if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Publish -> protect @@ fun () -> on_publish_commitments state - | Request.Cement -> protect @@ fun () -> on_cement_commitments state - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt} = return node_ctxt - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Commitment_event.Publisher.request_failed request_view st errs - in - return_unit - in - match r with - | Request.Publish -> emit_and_return_errors errs - | Request.Cement -> emit_and_return_errors errs + module Types = struct + type nonrec state = state - let on_completion _w r _ st = - Commitment_event.Publisher.request_completed (Request.view r) st + type parameters = {node_ctxt : Node_context.ro} + end - let on_no_request _ = Lwt.return_unit + module Name = struct + (* We only have a single committer in the node *) + type t = unit - let on_close _w = Lwt.return_unit - end + let encoding = Data_encoding.unit - let table = Worker.create_table Queue + let base = + (* But we can have multiple instances in the unit tests. This is just to + avoid conflicts in the events declarations. *) + Commitment_event.section + @ [ + ("publisher" + ^ if !instances_count = 1 then "" else string_of_int !instances_count + ); + ] - let worker_promise, worker_waker = Lwt.task () + let pp _ _ = () - let init node_ctxt = - let open Lwt_result_syntax in - let*! () = Commitment_event.starting () in - let node_ctxt = Node_context.readonly node_ctxt in - let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in - Lwt.wakeup worker_waker worker - - (* This is a publisher worker for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_publisher) - - let publish_commitments () = - let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w Request.Publish in - return_unit + let equal () () = true + end - let cement_commitments () = + module Worker = Worker.MakeSingle (Name) (Request) (Types) + + type worker = Worker.infinite Worker.queue Worker.t + + module Handlers = struct + type self = worker + + let on_request : + type r request_error. + worker -> + (r, request_error) Request.t -> + (r, request_error) result Lwt.t = + fun w request -> + let state = Worker.state w in + match request with + | Request.Publish -> protect @@ fun () -> on_publish_commitments state + | Request.Cement -> protect @@ fun () -> on_cement_commitments state + + type launch_error = error trace + + let on_launch _w () Types.{node_ctxt} = return node_ctxt + + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w Request.Cement in - return_unit + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Commitment_event.Publisher.request_failed request_view st errs + in + return_unit + in + match r with + | Request.Publish -> emit_and_return_errors errs + | Request.Cement -> emit_and_return_errors errs + + let on_completion _w r _ st = + Commitment_event.Publisher.request_completed (Request.view r) st - let shutdown () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no publisher, nothing to do *) - Lwt.return_unit - | Ok w -> Worker.shutdown w + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit end + + let table = Worker.create_table Queue + + let worker_promise, worker_waker = Lwt.task () + + let init node_ctxt = + let open Lwt_result_syntax in + let*! () = Commitment_event.starting () in + let node_ctxt = Node_context.readonly node_ctxt in + let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in + Lwt.wakeup worker_waker worker + + (* This is a publisher worker for a single scoru *) + let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_publisher) + + let publish_commitments () = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w Request.Publish in + return_unit + + let cement_commitments () = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w Request.Cement in + return_unit + + let shutdown () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no publisher, nothing to do *) + Lwt.return_unit + | Ok w -> Worker.shutdown w end diff --git a/src/proto_alpha/lib_sc_rollup_node/commitment.mli b/src/proto_alpha/lib_sc_rollup_node/publisher.mli similarity index 100% rename from src/proto_alpha/lib_sc_rollup_node/commitment.mli rename to src/proto_alpha/lib_sc_rollup_node/publisher.mli -- GitLab From 73fd3d32b9571ac722ad2aad4b3aa83db8773a74 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Fri, 26 May 2023 10:48:32 +0200 Subject: [PATCH 05/13] SCORU/Node: defunctorize Commitment publisher --- .../lib_sc_rollup_node/components.ml | 1 - src/proto_alpha/lib_sc_rollup_node/daemon.ml | 16 +- .../lib_sc_rollup_node/publisher.ml | 824 +++++++++--------- .../lib_sc_rollup_node/publisher.mli | 45 +- 4 files changed, 449 insertions(+), 437 deletions(-) diff --git a/src/proto_alpha/lib_sc_rollup_node/components.ml b/src/proto_alpha/lib_sc_rollup_node/components.ml index 2a6dc5e13ddd..9a2cd5b539b4 100644 --- a/src/proto_alpha/lib_sc_rollup_node/components.ml +++ b/src/proto_alpha/lib_sc_rollup_node/components.ml @@ -26,7 +26,6 @@ module Make (PVM : Pvm.S) = struct module PVM = PVM - module Publisher = Publisher.Make (PVM) module Simulation = Simulation.Make (PVM) module Refutation_coordinator = Refutation_coordinator.Make (PVM) module Batcher = Batcher.Make (Simulation) diff --git a/src/proto_alpha/lib_sc_rollup_node/daemon.ml b/src/proto_alpha/lib_sc_rollup_node/daemon.ml index 32e9955b5570..5669cf80f462 100644 --- a/src/proto_alpha/lib_sc_rollup_node/daemon.ml +++ b/src/proto_alpha/lib_sc_rollup_node/daemon.ml @@ -78,7 +78,7 @@ module Make (PVM : Pvm.S) = struct ~other in assert (Sc_rollup.Address.(node_ctxt.rollup_address = rollup)) ; - Components.Publisher.publish_single_commitment node_ctxt our_commitment + Publisher.publish_single_commitment node_ctxt our_commitment (** Process an L1 SCORU operation (for the node's rollup) which is included for the first time. {b Note}: this function does not process inboxes for @@ -337,7 +337,7 @@ module Make (PVM : Pvm.S) = struct in let*! context_hash = Context.commit ctxt in let* commitment_hash = - Components.Publisher.process_head + Publisher.process_head node_ctxt ~predecessor:predecessor.hash head @@ -437,8 +437,8 @@ module Make (PVM : Pvm.S) = struct process_head node_ctxt header) reorg.new_chain in - let* () = Components.Publisher.publish_commitments () in - let* () = Components.Publisher.cement_commitments () in + let* () = Publisher.publish_commitments () in + let* () = Publisher.cement_commitments () in let*! () = Daemon_event.new_heads_processed reorg.new_chain in let* () = Components.Refutation_coordinator.process stripped_head in let* () = Components.Batcher.batch () in @@ -456,7 +456,7 @@ module Make (PVM : Pvm.S) = struct let*! () = message "Shutting down Batcher@." in let*! () = Components.Batcher.shutdown () in let*! () = message "Shutting down Commitment Publisher@." in - let*! () = Components.Publisher.shutdown () in + let*! () = Publisher.shutdown () in Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> let* () = Components.Refutation_coordinator.process (Layer1.head_of_header head) @@ -475,7 +475,7 @@ module Make (PVM : Pvm.S) = struct let* () = message "Shutting down Batcher@." in let* () = Components.Batcher.shutdown () in let* () = message "Shutting down Commitment Publisher@." in - let* () = Components.Publisher.shutdown () in + let* () = Publisher.shutdown () in let* () = message "Shutting down Refutation Coordinator@." in let* () = Components.Refutation_coordinator.shutdown () in let* (_ : unit tzresult) = Node_context.close node_ctxt in @@ -530,7 +530,7 @@ module Make (PVM : Pvm.S) = struct in (operator, strategy, purposes)) in - let* () = Components.Publisher.init node_ctxt in + let* () = Publisher.init node_ctxt in let* () = Components.Refutation_coordinator.init node_ctxt in let* () = unless (signers = []) @@ fun () -> @@ -613,7 +613,7 @@ module Make (PVM : Pvm.S) = struct in let*! context_hash = Context.commit ctxt in let* commitment_hash = - Components.Publisher.process_head + Publisher.process_head node_ctxt ~predecessor:predecessor.Layer1.hash head diff --git a/src/proto_alpha/lib_sc_rollup_node/publisher.ml b/src/proto_alpha/lib_sc_rollup_node/publisher.ml index 43f22d0f54b0..7265d13488f5 100644 --- a/src/proto_alpha/lib_sc_rollup_node/publisher.ml +++ b/src/proto_alpha/lib_sc_rollup_node/publisher.ml @@ -81,254 +81,244 @@ let sc_rollup_challenge_window node_ctxt = let next_commitment_level node_ctxt last_commitment_level = add_level last_commitment_level (sc_rollup_commitment_period node_ctxt) -(* Count instances of the commitment functor to allow for multiple worker events - without conflicts. *) -let instances_count = ref 0 - -module Make (PVM : Pvm.S) : Commitment_sig.S with module PVM = PVM = struct - let () = incr instances_count - - module PVM = PVM - - type state = Node_context.ro - - let tick_of_level (node_ctxt : _ Node_context.t) inbox_level = - let open Lwt_result_syntax in - let* block = - Node_context.get_l2_block_by_level - node_ctxt - (Raw_level.to_int32 inbox_level) - in - return (Sc_rollup_block.final_tick block) - - let build_commitment (node_ctxt : _ Node_context.t) - (prev_commitment : Sc_rollup.Commitment.Hash.t) ~prev_commitment_level - ~inbox_level ctxt = - let open Lwt_result_syntax in - let*! pvm_state = PVM.State.find ctxt in - let*? pvm_state = - match pvm_state with - | Some pvm_state -> Ok pvm_state - | None -> - error_with - "PVM state for commitment at level %a is not available" - Raw_level.pp - inbox_level - in - let*! compressed_state = PVM.state_hash pvm_state in - let*! tick = PVM.get_tick pvm_state in - let* prev_commitment_tick = tick_of_level node_ctxt prev_commitment_level in - let number_of_ticks = - Sc_rollup.Tick.distance tick prev_commitment_tick - |> Z.to_int64 |> Sc_rollup.Number_of_ticks.of_value - in - let*? number_of_ticks = - match number_of_ticks with - | Some number_of_ticks -> - if number_of_ticks = Sc_rollup.Number_of_ticks.zero then - error_with "A 0-tick commitment is impossible" - else Ok number_of_ticks - | None -> error_with "Invalid number of ticks for commitment" - in - return - Sc_rollup.Commitment. - { - predecessor = prev_commitment; - inbox_level; - number_of_ticks; - compressed_state; - } - - let genesis_commitment (node_ctxt : _ Node_context.t) ctxt = - let open Lwt_result_syntax in - let*! pvm_state = PVM.State.find ctxt in - let*? pvm_state = - match pvm_state with - | Some pvm_state -> Ok pvm_state - | None -> error_with "PVM state for genesis commitment is not available" +type state = Node_context.ro + +let tick_of_level (node_ctxt : _ Node_context.t) inbox_level = + let open Lwt_result_syntax in + let* block = + Node_context.get_l2_block_by_level + node_ctxt + (Raw_level.to_int32 inbox_level) + in + return (Sc_rollup_block.final_tick block) + +let build_commitment (node_ctxt : _ Node_context.t) + (prev_commitment : Sc_rollup.Commitment.Hash.t) ~prev_commitment_level + ~inbox_level ctxt = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! pvm_state = PVM.State.find ctxt in + let*? pvm_state = + match pvm_state with + | Some pvm_state -> Ok pvm_state + | None -> + error_with + "PVM state for commitment at level %a is not available" + Raw_level.pp + inbox_level + in + let*! compressed_state = PVM.state_hash pvm_state in + let*! tick = PVM.get_tick pvm_state in + let* prev_commitment_tick = tick_of_level node_ctxt prev_commitment_level in + let number_of_ticks = + Sc_rollup.Tick.distance tick prev_commitment_tick + |> Z.to_int64 |> Sc_rollup.Number_of_ticks.of_value + in + let*? number_of_ticks = + match number_of_ticks with + | Some number_of_ticks -> + if number_of_ticks = Sc_rollup.Number_of_ticks.zero then + error_with "A 0-tick commitment is impossible" + else Ok number_of_ticks + | None -> error_with "Invalid number of ticks for commitment" + in + return + Sc_rollup.Commitment. + { + predecessor = prev_commitment; + inbox_level; + number_of_ticks; + compressed_state; + } + +let genesis_commitment (node_ctxt : _ Node_context.t) ctxt = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! pvm_state = PVM.State.find ctxt in + let*? pvm_state = + match pvm_state with + | Some pvm_state -> Ok pvm_state + | None -> error_with "PVM state for genesis commitment is not available" + in + let*! compressed_state = PVM.state_hash pvm_state in + let commitment = + Sc_rollup.Commitment. + { + predecessor = Hash.zero; + inbox_level = node_ctxt.genesis_info.level; + number_of_ticks = Sc_rollup.Number_of_ticks.zero; + compressed_state; + } + in + (* Ensure the initial state corresponds to the one of the rollup's in the + protocol. A mismatch is possible if a wrong external boot sector was + provided. *) + let commitment_hash = Sc_rollup.Commitment.hash_uncarbonated commitment in + let+ () = + fail_unless + Sc_rollup.Commitment.Hash.( + commitment_hash = node_ctxt.genesis_info.commitment_hash) + (Sc_rollup_node_errors.Invalid_genesis_state + { + expected = node_ctxt.genesis_info.commitment_hash; + actual = commitment_hash; + }) + in + commitment + +let create_commitment_if_necessary (node_ctxt : _ Node_context.t) ~predecessor + current_level ctxt = + let open Lwt_result_syntax in + if Raw_level.(current_level = node_ctxt.genesis_info.level) then + let*! () = Commitment_event.compute_commitment current_level in + let+ genesis_commitment = genesis_commitment node_ctxt ctxt in + Some genesis_commitment + else + let* last_commitment_hash = + let+ pred = Node_context.get_l2_block node_ctxt predecessor in + Sc_rollup_block.most_recent_commitment pred.header in - let*! compressed_state = PVM.state_hash pvm_state in - let commitment = - Sc_rollup.Commitment. - { - predecessor = Hash.zero; - inbox_level = node_ctxt.genesis_info.level; - number_of_ticks = Sc_rollup.Number_of_ticks.zero; - compressed_state; - } + let* last_commitment = + Node_context.get_commitment node_ctxt last_commitment_hash in - (* Ensure the initial state corresponds to the one of the rollup's in the - protocol. A mismatch is possible if a wrong external boot sector was - provided. *) - let commitment_hash = Sc_rollup.Commitment.hash_uncarbonated commitment in - let+ () = - fail_unless - Sc_rollup.Commitment.Hash.( - commitment_hash = node_ctxt.genesis_info.commitment_hash) - (Sc_rollup_node_errors.Invalid_genesis_state - { - expected = node_ctxt.genesis_info.commitment_hash; - actual = commitment_hash; - }) + let next_commitment_level = + next_commitment_level node_ctxt last_commitment.inbox_level in - commitment - - let create_commitment_if_necessary (node_ctxt : _ Node_context.t) ~predecessor - current_level ctxt = - let open Lwt_result_syntax in - if Raw_level.(current_level = node_ctxt.genesis_info.level) then + if Raw_level.(current_level = next_commitment_level) then let*! () = Commitment_event.compute_commitment current_level in - let+ genesis_commitment = genesis_commitment node_ctxt ctxt in - Some genesis_commitment - else - let* last_commitment_hash = - let+ pred = Node_context.get_l2_block node_ctxt predecessor in - Sc_rollup_block.most_recent_commitment pred.header - in - let* last_commitment = - Node_context.get_commitment node_ctxt last_commitment_hash + let+ commitment = + build_commitment + node_ctxt + last_commitment_hash + ~prev_commitment_level:last_commitment.inbox_level + ~inbox_level:current_level + ctxt in - let next_commitment_level = - next_commitment_level node_ctxt last_commitment.inbox_level + Some commitment + else return_none + +let process_head (node_ctxt : _ Node_context.t) ~predecessor + Layer1.{level; header = _; _} ctxt = + let open Lwt_result_syntax in + let current_level = Raw_level.of_int32_exn level in + let* commitment = + create_commitment_if_necessary node_ctxt ~predecessor current_level ctxt + in + match commitment with + | None -> return_none + | Some commitment -> + let* commitment_hash = + Node_context.save_commitment node_ctxt commitment in - if Raw_level.(current_level = next_commitment_level) then - let*! () = Commitment_event.compute_commitment current_level in - let+ commitment = - build_commitment - node_ctxt - last_commitment_hash - ~prev_commitment_level:last_commitment.inbox_level - ~inbox_level:current_level - ctxt - in - Some commitment - else return_none - - let process_head (node_ctxt : _ Node_context.t) ~predecessor - Layer1.{level; header = _; _} ctxt = - let open Lwt_result_syntax in - let current_level = Raw_level.of_int32_exn level in - let* commitment = - create_commitment_if_necessary node_ctxt ~predecessor current_level ctxt - in + return_some commitment_hash + +let missing_commitments (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let lpc_level = + match Reference.get node_ctxt.lpc with + | None -> node_ctxt.genesis_info.level + | Some lpc -> lpc.inbox_level + in + let* head = Node_context.last_processed_head_opt node_ctxt in + let next_head_level = + Option.map + (fun (b : Sc_rollup_block.t) -> Raw_level.succ b.header.level) + head + in + let sc_rollup_challenge_window_int32 = + sc_rollup_challenge_window node_ctxt |> Int32.of_int + in + let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = + let* commitment = Node_context.find_commitment node_ctxt commitment_hash in + let lcc = Reference.get node_ctxt.lcc in match commitment with - | None -> return_none + | None -> return acc + | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> + (* Commitment is before or at the LCC, we have reached the end. *) + return acc + | Some commitment when Raw_level.(commitment.inbox_level <= lpc_level) -> + (* Commitment is before the last published one, we have also reached + the end because we only publish commitments that are for the inbox + of a finalized L1 block. *) + return acc | Some commitment -> - let* commitment_hash = - Node_context.save_commitment node_ctxt commitment + let* published_info = + Node_context.commitment_published_at_level node_ctxt commitment_hash in - return_some commitment_hash - - let missing_commitments (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - let lpc_level = - match Reference.get node_ctxt.lpc with - | None -> node_ctxt.genesis_info.level - | Some lpc -> lpc.inbox_level - in - let* head = Node_context.last_processed_head_opt node_ctxt in - let next_head_level = - Option.map - (fun (b : Sc_rollup_block.t) -> Raw_level.succ b.header.level) - head - in - let sc_rollup_challenge_window_int32 = - sc_rollup_challenge_window node_ctxt |> Int32.of_int - in - let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = - let* commitment = - Node_context.find_commitment node_ctxt commitment_hash - in - let lcc = Reference.get node_ctxt.lcc in - match commitment with - | None -> return acc - | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> - (* Commitment is before or at the LCC, we have reached the end. *) - return acc - | Some commitment when Raw_level.(commitment.inbox_level <= lpc_level) -> - (* Commitment is before the last published one, we have also reached - the end because we only publish commitments that are for the inbox - of a finalized L1 block. *) - return acc - | Some commitment -> - let* published_info = - Node_context.commitment_published_at_level node_ctxt commitment_hash - in - let past_curfew = - match (published_info, next_head_level) with - | None, _ | _, None -> false - | Some {first_published_at_level; _}, Some next_head_level -> - Raw_level.diff next_head_level first_published_at_level - > sc_rollup_challenge_window_int32 - in - let acc = if past_curfew then acc else commitment :: acc in - (* We keep the commitment and go back to the previous one. *) - gather acc commitment.predecessor - in - let* finalized_block = Node_context.get_finalized_head_opt node_ctxt in - match finalized_block with - | None -> return_nil - | Some finalized -> - (* Start from finalized block's most recent commitment and gather all - commitments that are missing. *) - let commitment = - Sc_rollup_block.most_recent_commitment finalized.header + let past_curfew = + match (published_info, next_head_level) with + | None, _ | _, None -> false + | Some {first_published_at_level; _}, Some next_head_level -> + Raw_level.diff next_head_level first_published_at_level + > sc_rollup_challenge_window_int32 in - gather [] commitment - - let publish_commitment (node_ctxt : _ Node_context.t) ~source - (commitment : Sc_rollup.Commitment.t) = - let open Lwt_result_syntax in - let publish_operation = - L1_operation.Publish {rollup = node_ctxt.rollup_address; commitment} - in - let*! () = - Commitment_event.publish_commitment - (Sc_rollup.Commitment.hash_uncarbonated commitment) - commitment.inbox_level - in - let* _hash = Injector.add_pending_operation ~source publish_operation in + let acc = if past_curfew then acc else commitment :: acc in + (* We keep the commitment and go back to the previous one. *) + gather acc commitment.predecessor + in + let* finalized_block = Node_context.get_finalized_head_opt node_ctxt in + match finalized_block with + | None -> return_nil + | Some finalized -> + (* Start from finalized block's most recent commitment and gather all + commitments that are missing. *) + let commitment = + Sc_rollup_block.most_recent_commitment finalized.header + in + gather [] commitment + +let publish_commitment (node_ctxt : _ Node_context.t) ~source + (commitment : Sc_rollup.Commitment.t) = + let open Lwt_result_syntax in + let publish_operation = + L1_operation.Publish {rollup = node_ctxt.rollup_address; commitment} + in + let*! () = + Commitment_event.publish_commitment + (Sc_rollup.Commitment.hash_uncarbonated commitment) + commitment.inbox_level + in + let* _hash = Injector.add_pending_operation ~source publish_operation in + return_unit + +let on_publish_commitments (node_ctxt : state) = + let open Lwt_result_syntax in + let operator = Node_context.get_operator node_ctxt Publish in + if Node_context.is_accuser node_ctxt then + (* Accuser does not publish all commitments *) return_unit - - let on_publish_commitments (node_ctxt : state) = - let open Lwt_result_syntax in - let operator = Node_context.get_operator node_ctxt Publish in - if Node_context.is_accuser node_ctxt then - (* Accuser does not publish all commitments *) - return_unit - else - match operator with - | None -> - (* Configured to not publish commitments *) - return_unit - | Some source -> - let* commitments = missing_commitments node_ctxt in - List.iter_es (publish_commitment node_ctxt ~source) commitments - - let publish_single_commitment node_ctxt (commitment : Sc_rollup.Commitment.t) - = - let open Lwt_result_syntax in - let operator = Node_context.get_operator node_ctxt Publish in - let lcc = Reference.get node_ctxt.lcc in + else match operator with | None -> (* Configured to not publish commitments *) return_unit | Some source -> - when_ (commitment.inbox_level > lcc.level) @@ fun () -> - publish_commitment node_ctxt ~source commitment - - (* Commitments can only be cemented after [sc_rollup_challenge_window] has - passed since they were first published. *) - let earliest_cementing_level node_ctxt commitment_hash = - let open Lwt_result_option_syntax in - let** {first_published_at_level; _} = - Node_context.commitment_published_at_level node_ctxt commitment_hash - in - return_some - @@ add_level first_published_at_level (sc_rollup_challenge_window node_ctxt) - - (** [latest_cementable_commitment node_ctxt head] is the most recent commitment + let* commitments = missing_commitments node_ctxt in + List.iter_es (publish_commitment node_ctxt ~source) commitments + +let publish_single_commitment node_ctxt (commitment : Sc_rollup.Commitment.t) = + let open Lwt_result_syntax in + let operator = Node_context.get_operator node_ctxt Publish in + let lcc = Reference.get node_ctxt.lcc in + match operator with + | None -> + (* Configured to not publish commitments *) + return_unit + | Some source -> + when_ (commitment.inbox_level > lcc.level) @@ fun () -> + publish_commitment node_ctxt ~source commitment + +(* Commitments can only be cemented after [sc_rollup_challenge_window] has + passed since they were first published. *) +let earliest_cementing_level node_ctxt commitment_hash = + let open Lwt_result_option_syntax in + let** {first_published_at_level; _} = + Node_context.commitment_published_at_level node_ctxt commitment_hash + in + return_some + @@ add_level first_published_at_level (sc_rollup_challenge_window node_ctxt) + +(** [latest_cementable_commitment node_ctxt head] is the most recent commitment hash that could be cemented in [head]'s successor if: - all its predecessors were cemented @@ -336,210 +326,196 @@ module Make (PVM : Pvm.S) : Commitment_sig.S with module PVM = PVM = struct It does not need to be exact but it must be an upper bound on which we can start the search for cementable commitments. *) - let latest_cementable_commitment (node_ctxt : _ Node_context.t) - (head : Sc_rollup_block.t) = - let open Lwt_result_option_syntax in - let commitment_hash = Sc_rollup_block.most_recent_commitment head.header in - let** commitment = Node_context.find_commitment node_ctxt commitment_hash in - let** cementable_level_bound = - return - @@ sub_level commitment.inbox_level (sc_rollup_challenge_window node_ctxt) - in - let lcc = Reference.get node_ctxt.lcc in - if Raw_level.(cementable_level_bound <= lcc.level) then return_none - else - let** cementable_bound_block = - Node_context.find_l2_block_by_level - node_ctxt - (Raw_level.to_int32 cementable_level_bound) - in - let cementable_commitment = - Sc_rollup_block.most_recent_commitment cementable_bound_block.header - in - return_some cementable_commitment - - let cementable_commitments (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - let open Lwt_result_option_list_syntax in - let*& head = Node_context.last_processed_head_opt node_ctxt in - let head_level = head.header.level in - let lcc = Reference.get node_ctxt.lcc in - let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = - let* commitment = - Node_context.find_commitment node_ctxt commitment_hash - in - match commitment with - | None -> return acc - | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> - (* If we have moved backward passed or at the current LCC then we have - reached the end. *) - return acc - | Some commitment -> - let* earliest_cementing_level = - earliest_cementing_level node_ctxt commitment_hash - in - let acc = - match earliest_cementing_level with - | None -> acc - | Some earliest_cementing_level -> - if Raw_level.(earliest_cementing_level > head_level) then - (* Commitments whose cementing level are after the head's - successor won't be cementable in the next block. *) - acc - else commitment_hash :: acc - in - gather acc commitment.predecessor +let latest_cementable_commitment (node_ctxt : _ Node_context.t) + (head : Sc_rollup_block.t) = + let open Lwt_result_option_syntax in + let commitment_hash = Sc_rollup_block.most_recent_commitment head.header in + let** commitment = Node_context.find_commitment node_ctxt commitment_hash in + let** cementable_level_bound = + return + @@ sub_level commitment.inbox_level (sc_rollup_challenge_window node_ctxt) + in + let lcc = Reference.get node_ctxt.lcc in + if Raw_level.(cementable_level_bound <= lcc.level) then return_none + else + let** cementable_bound_block = + Node_context.find_l2_block_by_level + node_ctxt + (Raw_level.to_int32 cementable_level_bound) in - (* We start our search from the last possible cementable commitment. This is - to avoid iterating over a large number of commitments - ([challenge_window_in_blocks / commitment_period_in_blocks], in the order - of 10^3 on mainnet). *) - let*& latest_cementable_commitment = - latest_cementable_commitment node_ctxt head + let cementable_commitment = + Sc_rollup_block.most_recent_commitment cementable_bound_block.header in - let* cementable = gather [] latest_cementable_commitment in - match cementable with - | [] -> return_nil - | first_cementable :: _ -> - (* Make sure that the first commitment can be cemented according to the - Layer 1 node as a failsafe. *) - let* green_light = - Plugin.RPC.Sc_rollup.can_be_cemented - node_ctxt.cctxt - (node_ctxt.cctxt#chain, `Head 0) - node_ctxt.rollup_address - first_cementable + return_some cementable_commitment + +let cementable_commitments (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let open Lwt_result_option_list_syntax in + let*& head = Node_context.last_processed_head_opt node_ctxt in + let head_level = head.header.level in + let lcc = Reference.get node_ctxt.lcc in + let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = + let* commitment = Node_context.find_commitment node_ctxt commitment_hash in + match commitment with + | None -> return acc + | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> + (* If we have moved backward passed or at the current LCC then we have + reached the end. *) + return acc + | Some commitment -> + let* earliest_cementing_level = + earliest_cementing_level node_ctxt commitment_hash in - if green_light then return cementable else return_nil - - let cement_commitment (node_ctxt : _ Node_context.t) ~source commitment_hash = - let open Lwt_result_syntax in - let cement_operation = - L1_operation.Cement - {rollup = node_ctxt.rollup_address; commitment = commitment_hash} - in - let* _hash = Injector.add_pending_operation ~source cement_operation in - return_unit - - let on_cement_commitments (node_ctxt : state) = - let open Lwt_result_syntax in - let operator = Node_context.get_operator node_ctxt Cement in - match operator with - | None -> - (* Configured to not cement commitments *) - return_unit - | Some source -> - let* cementable_commitments = cementable_commitments node_ctxt in - List.iter_es - (cement_commitment node_ctxt ~source) - cementable_commitments - - module Types = struct - type nonrec state = state - - type parameters = {node_ctxt : Node_context.ro} - end - - module Name = struct - (* We only have a single committer in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Commitment_event.section - @ [ - ("publisher" - ^ if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Publish -> protect @@ fun () -> on_publish_commitments state - | Request.Cement -> protect @@ fun () -> on_cement_commitments state - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt} = return node_ctxt - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Commitment_event.Publisher.request_failed request_view st errs + let acc = + match earliest_cementing_level with + | None -> acc + | Some earliest_cementing_level -> + if Raw_level.(earliest_cementing_level > head_level) then + (* Commitments whose cementing level are after the head's + successor won't be cementable in the next block. *) + acc + else commitment_hash :: acc in - return_unit + gather acc commitment.predecessor + in + (* We start our search from the last possible cementable commitment. This is + to avoid iterating over a large number of commitments + ([challenge_window_in_blocks / commitment_period_in_blocks], in the order + of 10^3 on mainnet). *) + let*& latest_cementable_commitment = + latest_cementable_commitment node_ctxt head + in + let* cementable = gather [] latest_cementable_commitment in + match cementable with + | [] -> return_nil + | first_cementable :: _ -> + (* Make sure that the first commitment can be cemented according to the + Layer 1 node as a failsafe. *) + let* green_light = + Plugin.RPC.Sc_rollup.can_be_cemented + node_ctxt.cctxt + (node_ctxt.cctxt#chain, `Head 0) + node_ctxt.rollup_address + first_cementable in - match r with - | Request.Publish -> emit_and_return_errors errs - | Request.Cement -> emit_and_return_errors errs + if green_light then return cementable else return_nil + +let cement_commitment (node_ctxt : _ Node_context.t) ~source commitment_hash = + let open Lwt_result_syntax in + let cement_operation = + L1_operation.Cement + {rollup = node_ctxt.rollup_address; commitment = commitment_hash} + in + let* _hash = Injector.add_pending_operation ~source cement_operation in + return_unit + +let on_cement_commitments (node_ctxt : state) = + let open Lwt_result_syntax in + let operator = Node_context.get_operator node_ctxt Cement in + match operator with + | None -> + (* Configured to not cement commitments *) + return_unit + | Some source -> + let* cementable_commitments = cementable_commitments node_ctxt in + List.iter_es (cement_commitment node_ctxt ~source) cementable_commitments - let on_completion _w r _ st = - Commitment_event.Publisher.request_completed (Request.view r) st +module Types = struct + type nonrec state = state - let on_no_request _ = Lwt.return_unit + type parameters = {node_ctxt : Node_context.ro} +end - let on_close _w = Lwt.return_unit - end +module Name = struct + (* We only have a single committer in the node *) + type t = unit - let table = Worker.create_table Queue + let encoding = Data_encoding.unit - let worker_promise, worker_waker = Lwt.task () + let base = Commitment_event.section @ ["publisher"] - let init node_ctxt = - let open Lwt_result_syntax in - let*! () = Commitment_event.starting () in - let node_ctxt = Node_context.readonly node_ctxt in - let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in - Lwt.wakeup worker_waker worker - - (* This is a publisher worker for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_publisher) - - let publish_commitments () = - let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w Request.Publish in - return_unit + let pp _ _ = () + + let equal () () = true +end + +module Worker = Worker.MakeSingle (Name) (Request) (Types) + +type worker = Worker.infinite Worker.queue Worker.t + +module Handlers = struct + type self = worker - let cement_commitments () = + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with + | Request.Publish -> protect @@ fun () -> on_publish_commitments state + | Request.Cement -> protect @@ fun () -> on_cement_commitments state + + type launch_error = error trace + + let on_launch _w () Types.{node_ctxt} = return node_ctxt + + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w Request.Cement in - return_unit + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Commitment_event.Publisher.request_failed request_view st errs + in + return_unit + in + match r with + | Request.Publish -> emit_and_return_errors errs + | Request.Cement -> emit_and_return_errors errs + + let on_completion _w r _ st = + Commitment_event.Publisher.request_completed (Request.view r) st - let shutdown () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no publisher, nothing to do *) - Lwt.return_unit - | Ok w -> Worker.shutdown w + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit end + +let table = Worker.create_table Queue + +let worker_promise, worker_waker = Lwt.task () + +let init node_ctxt = + let open Lwt_result_syntax in + let*! () = Commitment_event.starting () in + let node_ctxt = Node_context.readonly node_ctxt in + let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in + Lwt.wakeup worker_waker worker + +(* This is a publisher worker for a single scoru *) +let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_publisher) + +let publish_commitments () = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w Request.Publish in + return_unit + +let cement_commitments () = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w Request.Cement in + return_unit + +let shutdown () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no publisher, nothing to do *) + Lwt.return_unit + | Ok w -> Worker.shutdown w diff --git a/src/proto_alpha/lib_sc_rollup_node/publisher.mli b/src/proto_alpha/lib_sc_rollup_node/publisher.mli index cb6c364d87cd..79990b2198ad 100644 --- a/src/proto_alpha/lib_sc_rollup_node/publisher.mli +++ b/src/proto_alpha/lib_sc_rollup_node/publisher.mli @@ -24,12 +24,13 @@ (*****************************************************************************) (** The rollup node stores and publishes commitments for the PVM - every 20 levels. + every `Commitment.sc_rollup_commitment_period` levels. Every time a finalized block is processed by the rollup node, the latter determines whether the last commitment that the node - has produced referred to 20 blocks earlier. In this case, it - computes and stores a new commitment in a level-indexed map. + has produced referred to `Commitment.sc_rollup_commitment_period` blocks + earlier. In this case, it computes and stores a new commitment in a + level-indexed map. Stored commitments are signed by the rollup node operator and published on the layer1 chain. To ensure that commitments @@ -39,4 +40,40 @@ commitment that was not published already. *) -module Make (PVM : Pvm.S) : Commitment_sig.S with module PVM = PVM +(** [process_head node_ctxt ~predecessor head ctxt] builds a new commitment if + needed, by looking at the level of [head] and checking whether it is a + multiple of `Commitment.sc_rollup_commitment_period` levels away from + [node_ctxt.initial_level]. It uses the functionalities of [PVM] to compute + the hash of to be included in the commitment. *) +val process_head : + Node_context.rw -> + predecessor:Block_hash.t -> + Layer1.header -> + Context.rw -> + Protocol.Alpha_context.Sc_rollup.Commitment.Hash.t option tzresult Lwt.t + +(** [publish_single_commitment node_ctxt commitment] publishes a single + [commitment] if it is missing. This function is meant to be used by the {e + accuser} mode to sparingly publish commitments when it detects a + conflict. *) +val publish_single_commitment : + _ Node_context.t -> + Protocol.Alpha_context.Sc_rollup.Commitment.t -> + unit tzresult Lwt.t + +(** Initialize worker for publishing and cementing commitments. *) +val init : _ Node_context.t -> unit tzresult Lwt.t + +(** [publish_commitments node_ctxt] publishes the commitments that were not yet + published up to the finalized head and which are after the last cemented + commitment. *) +val publish_commitments : unit -> unit tzresult Lwt.t + +(** [cement_commitments node_ctxt] cements the commitments that can be cemented, + i.e. the commitments that are after the current last cemented commitment and + which have [sc_rollup_challenge_period] levels on top of them since they + were originally published. *) +val cement_commitments : unit -> unit tzresult Lwt.t + +(** Stop worker for publishing and cementing commitments. *) +val shutdown : unit -> unit Lwt.t -- GitLab From 5af6bf184fd2c20043cc7a5d74d338303aa55933 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 19:29:33 +0200 Subject: [PATCH 06/13] SCORU/Node: defunctorize refutation games --- .../lib_sc_rollup_node/components.ml | 1 - src/proto_alpha/lib_sc_rollup_node/daemon.ml | 10 +- .../refutation_coordinator.ml | 384 ++++---- .../refutation_coordinator.mli | 32 +- .../lib_sc_rollup_node/refutation_game.ml | 885 +++++++++--------- .../lib_sc_rollup_node/refutation_game.mli | 38 +- .../lib_sc_rollup_node/refutation_player.ml | 251 +++-- .../lib_sc_rollup_node/refutation_player.mli | 51 +- 8 files changed, 774 insertions(+), 878 deletions(-) diff --git a/src/proto_alpha/lib_sc_rollup_node/components.ml b/src/proto_alpha/lib_sc_rollup_node/components.ml index 9a2cd5b539b4..5fdb127a1175 100644 --- a/src/proto_alpha/lib_sc_rollup_node/components.ml +++ b/src/proto_alpha/lib_sc_rollup_node/components.ml @@ -27,7 +27,6 @@ module Make (PVM : Pvm.S) = struct module PVM = PVM module Simulation = Simulation.Make (PVM) - module Refutation_coordinator = Refutation_coordinator.Make (PVM) module Batcher = Batcher.Make (Simulation) module RPC_server = RPC_server.Make (Simulation) (Batcher) end diff --git a/src/proto_alpha/lib_sc_rollup_node/daemon.ml b/src/proto_alpha/lib_sc_rollup_node/daemon.ml index 5669cf80f462..a5ca10e7215c 100644 --- a/src/proto_alpha/lib_sc_rollup_node/daemon.ml +++ b/src/proto_alpha/lib_sc_rollup_node/daemon.ml @@ -440,7 +440,7 @@ module Make (PVM : Pvm.S) = struct let* () = Publisher.publish_commitments () in let* () = Publisher.cement_commitments () in let*! () = Daemon_event.new_heads_processed reorg.new_chain in - let* () = Components.Refutation_coordinator.process stripped_head in + let* () = Refutation_coordinator.process stripped_head in let* () = Components.Batcher.batch () in let* () = Components.Batcher.new_head stripped_head in let*! () = Injector.inject ~header:head.header () in @@ -458,9 +458,7 @@ module Make (PVM : Pvm.S) = struct let*! () = message "Shutting down Commitment Publisher@." in let*! () = Publisher.shutdown () in Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> - let* () = - Components.Refutation_coordinator.process (Layer1.head_of_header head) - in + let* () = Refutation_coordinator.process (Layer1.head_of_header head) in let*! () = Injector.inject () in return_unit @@ -477,7 +475,7 @@ module Make (PVM : Pvm.S) = struct let* () = message "Shutting down Commitment Publisher@." in let* () = Publisher.shutdown () in let* () = message "Shutting down Refutation Coordinator@." in - let* () = Components.Refutation_coordinator.shutdown () in + let* () = Refutation_coordinator.shutdown () in let* (_ : unit tzresult) = Node_context.close node_ctxt in let* () = Event.shutdown_node exit_status in Tezos_base_unix.Internal_event_unix.close () @@ -531,7 +529,7 @@ module Make (PVM : Pvm.S) = struct (operator, strategy, purposes)) in let* () = Publisher.init node_ctxt in - let* () = Components.Refutation_coordinator.init node_ctxt in + let* () = Refutation_coordinator.init node_ctxt in let* () = unless (signers = []) @@ fun () -> Injector.init diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.ml b/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.ml index 754f5f0ba713..b841d2e7353c 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.ml +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.ml @@ -26,223 +26,195 @@ open Protocol open Alpha_context open Refutation_coordinator_types +include Refutation_game +module Player = Refutation_player +module Pkh_map = Signature.Public_key_hash.Map +module Pkh_table = Signature.Public_key_hash.Table + +type state = {node_ctxt : Node_context.rw; pending_opponents : unit Pkh_table.t} + +let get_conflicts cctxt head_block = + Plugin.RPC.Sc_rollup.conflicts cctxt (cctxt#chain, head_block) + +let get_ongoing_games cctxt head_block = + Plugin.RPC.Sc_rollup.ongoing_refutation_games cctxt (cctxt#chain, head_block) + +let untracked_conflicts opponent_players conflicts = + List.filter + (fun conflict -> + not + @@ Pkh_map.mem + conflict.Sc_rollup.Refutation_storage.other + opponent_players) + conflicts + +(* Transform the list of ongoing games [(Game.t * pkh * pkh) list] + into a mapping from opponents' pkhs to their corresponding game + state. +*) +let make_game_map self ongoing_games = + List.fold_left + (fun acc (game, alice, bob) -> + let opponent_pkh = + if Signature.Public_key_hash.equal self alice then bob else alice + in + Pkh_map.add opponent_pkh game acc) + Pkh_map.empty + ongoing_games + +let on_process Layer1.{hash; level} state = + let node_ctxt = state.node_ctxt in + let head_block = `Hash (hash, 0) in + let open Lwt_result_syntax in + let refute_signer = Node_context.get_operator node_ctxt Refute in + match refute_signer with + | None -> + (* Not injecting refutations, don't play refutation games *) + return_unit + | Some self -> + let Node_context.{rollup_address; cctxt; _} = node_ctxt in + (* Current conflicts in L1 *) + let* conflicts = get_conflicts cctxt head_block rollup_address self in + (* Map of opponents the node is playing against to the corresponding + player worker *) + let opponent_players = + Pkh_map.of_seq @@ List.to_seq @@ Player.current_games () + in + (* Conflicts for which we need to start new refutation players. + Some of these might be ongoing. *) + let new_conflicts = untracked_conflicts opponent_players conflicts in + (* L1 ongoing games *) + let* ongoing_games = + get_ongoing_games cctxt head_block rollup_address self + in + (* Map between opponents and their corresponding games *) + let ongoing_game_map = make_game_map self ongoing_games in + (* Launch new players for new conflicts, and play one step *) + let* () = + List.iter_ep + (fun conflict -> + let other = conflict.Sc_rollup.Refutation_storage.other in + Pkh_table.replace state.pending_opponents other () ; + let game = Pkh_map.find_opt other ongoing_game_map in + Player.init_and_play node_ctxt ~self ~conflict ~game ~level) + new_conflicts + in + let*! () = + (* Play one step of the refutation game in every remaining player *) + Pkh_map.iter_p + (fun opponent worker -> + match Pkh_map.find opponent ongoing_game_map with + | Some game -> + Pkh_table.remove state.pending_opponents opponent ; + Player.play worker game ~level + | None -> + (* Kill finished players: those who don't aren't + playing against pending opponents that don't have + ongoing games in the L1 *) + if not @@ Pkh_table.mem state.pending_opponents opponent then + Player.shutdown worker + else Lwt.return_unit) + opponent_players + in + return_unit + +module Types = struct + type nonrec state = state + + type parameters = {node_ctxt : Node_context.rw} +end + +module Name = struct + (* We only have a single coordinator in the node *) + type t = unit -module type S = sig - module PVM : Pvm.S + let encoding = Data_encoding.unit - val init : Node_context.rw -> unit tzresult Lwt.t + let base = + (* But we can have multiple instances in the unit tests. This is just to + avoid conflicts in the events declarations. *) + Refutation_game_event.Coordinator.section @ ["worker"] - val process : Layer1.head -> unit tzresult Lwt.t + let pp _ _ = () - val shutdown : unit -> unit Lwt.t + let equal () () = true end -(* Count instances of the coordinator functor to allow for multiple - worker events without conflicts. *) -let instances_count = ref 0 - -module Make (PVM : Pvm.S) = struct - include Refutation_game.Make (PVM) - module Player = Refutation_player.Make (PVM) - module Pkh_map = Signature.Public_key_hash.Map - module Pkh_table = Signature.Public_key_hash.Table - - let () = incr instances_count - - type state = { - node_ctxt : Node_context.rw; - pending_opponents : unit Pkh_table.t; - } - - let get_conflicts cctxt head_block = - Plugin.RPC.Sc_rollup.conflicts cctxt (cctxt#chain, head_block) - - let get_ongoing_games cctxt head_block = - Plugin.RPC.Sc_rollup.ongoing_refutation_games cctxt (cctxt#chain, head_block) - - let untracked_conflicts opponent_players conflicts = - List.filter - (fun conflict -> - not - @@ Pkh_map.mem - conflict.Sc_rollup.Refutation_storage.other - opponent_players) - conflicts - - (* Transform the list of ongoing games [(Game.t * pkh * pkh) list] - into a mapping from opponents' pkhs to their corresponding game - state. - *) - let make_game_map self ongoing_games = - List.fold_left - (fun acc (game, alice, bob) -> - let opponent_pkh = - if Signature.Public_key_hash.equal self alice then bob else alice - in - Pkh_map.add opponent_pkh game acc) - Pkh_map.empty - ongoing_games - - let on_process Layer1.{hash; level} state = - let node_ctxt = state.node_ctxt in - let head_block = `Hash (hash, 0) in - let open Lwt_result_syntax in - let refute_signer = Node_context.get_operator node_ctxt Refute in - match refute_signer with - | None -> - (* Not injecting refutations, don't play refutation games *) - return_unit - | Some self -> - let Node_context.{rollup_address; cctxt; _} = node_ctxt in - (* Current conflicts in L1 *) - let* conflicts = get_conflicts cctxt head_block rollup_address self in - (* Map of opponents the node is playing against to the corresponding - player worker *) - let opponent_players = - Pkh_map.of_seq @@ List.to_seq @@ Player.current_games () - in - (* Conflicts for which we need to start new refutation players. - Some of these might be ongoing. *) - let new_conflicts = untracked_conflicts opponent_players conflicts in - (* L1 ongoing games *) - let* ongoing_games = - get_ongoing_games cctxt head_block rollup_address self - in - (* Map between opponents and their corresponding games *) - let ongoing_game_map = make_game_map self ongoing_games in - (* Launch new players for new conflicts, and play one step *) - let* () = - List.iter_ep - (fun conflict -> - let other = conflict.Sc_rollup.Refutation_storage.other in - Pkh_table.replace state.pending_opponents other () ; - let game = Pkh_map.find_opt other ongoing_game_map in - Player.init_and_play node_ctxt ~self ~conflict ~game ~level) - new_conflicts - in - let*! () = - (* Play one step of the refutation game in every remaining player *) - Pkh_map.iter_p - (fun opponent worker -> - match Pkh_map.find opponent ongoing_game_map with - | Some game -> - Pkh_table.remove state.pending_opponents opponent ; - Player.play worker game ~level - | None -> - (* Kill finished players: those who don't aren't - playing against pending opponents that don't have - ongoing games in the L1 *) - if not @@ Pkh_table.mem state.pending_opponents opponent then - Player.shutdown worker - else Lwt.return_unit) - opponent_players - in - return_unit - - module Types = struct - type nonrec state = state - - type parameters = {node_ctxt : Node_context.rw} - end - - module Name = struct - (* We only have a single coordinator in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Refutation_game_event.Coordinator.section - @ [ - ("worker" - ^ if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with Request.Process b -> on_process b state - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt} = - return {node_ctxt; pending_opponents = Pkh_table.create 5} - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Refutation_game_event.Coordinator.request_failed request_view st errs - in - return_unit - in - match r with Request.Process _ -> emit_and_return_errors errs +module Worker = Worker.MakeSingle (Name) (Request) (Types) - let on_completion _w r _ st = - Refutation_game_event.Coordinator.request_completed (Request.view r) st +type worker = Worker.infinite Worker.queue Worker.t - let on_no_request _ = Lwt.return_unit +module Handlers = struct + type self = worker - let on_close _w = Lwt.return_unit - end + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with Request.Process b -> on_process b state - let table = Worker.create_table Queue + type launch_error = error trace - let worker_promise, worker_waker = Lwt.task () + let on_launch _w () Types.{node_ctxt} = + return {node_ctxt; pending_opponents = Pkh_table.create 5} - let init node_ctxt = - let open Lwt_result_syntax in - let*! () = Refutation_game_event.Coordinator.starting () in - let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in - Lwt.wakeup worker_waker worker - - (* This is a refutation coordinator for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> - error Sc_rollup_node_errors.No_refutation_coordinator) - - let process b = + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w (Request.Process b) in - return_unit - - let shutdown () = - let open Lwt_syntax in - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no refutation coordinator, nothing to do *) - Lwt.return_unit - | Ok w -> - (* Shut down all current refutation players *) - let games = Player.current_games () in - let* () = - List.iter_s (fun (_opponent, player) -> Player.shutdown player) games - in - Worker.shutdown w + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Refutation_game_event.Coordinator.request_failed request_view st errs + in + return_unit + in + match r with Request.Process _ -> emit_and_return_errors errs + + let on_completion _w r _ st = + Refutation_game_event.Coordinator.request_completed (Request.view r) st + + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit end + +let table = Worker.create_table Queue + +let worker_promise, worker_waker = Lwt.task () + +let init node_ctxt = + let open Lwt_result_syntax in + let*! () = Refutation_game_event.Coordinator.starting () in + let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in + Lwt.wakeup worker_waker worker + +(* This is a refutation coordinator for a single scoru *) +let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> + error Sc_rollup_node_errors.No_refutation_coordinator) + +let process b = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w (Request.Process b) in + return_unit + +let shutdown () = + let open Lwt_syntax in + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no refutation coordinator, nothing to do *) + Lwt.return_unit + | Ok w -> + (* Shut down all current refutation players *) + let games = Player.current_games () in + let* () = + List.iter_s (fun (_opponent, player) -> Player.shutdown player) games + in + Worker.shutdown w diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.mli b/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.mli index 1b38f1f48b1c..12a35582b9b2 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.mli +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_coordinator.mli @@ -29,25 +29,19 @@ the refutation game players. (See {!Refutation_player}). *) -module type S = sig - module PVM : Pvm.S +(** Initiatilize the refuation coordinator. *) +val init : Node_context.rw -> unit tzresult Lwt.t - (** Initiatilize the refuation coordinator. *) - val init : Node_context.rw -> unit tzresult Lwt.t - - (** Process a new l1 head. This means that the coordinator will: - {ol - {li Gather all existing conflicts} - {li Launch new refutation players for each conflict that doesn't - have a player in this node} - {li Kill all players whose conflict has disappeared from L1} - {li Make all players play a step in the refutation} - } +(** Process a new l1 head. This means that the coordinator will: + {ol + {li Gather all existing conflicts} + {li Launch new refutation players for each conflict that doesn't + have a player in this node} + {li Kill all players whose conflict has disappeared from L1} + {li Make all players play a step in the refutation} + } *) - val process : Layer1.head -> unit tzresult Lwt.t - - (** Shutdown the refutation coordinator. *) - val shutdown : unit -> unit Lwt.t -end +val process : Layer1.head -> unit tzresult Lwt.t -module Make (PVM : Pvm.S) : S +(** Shutdown the refutation coordinator. *) +val shutdown : unit -> unit Lwt.t diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml b/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml index e9c2ce1e9d75..da0ffe658032 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_game.ml @@ -45,86 +45,66 @@ open Protocol open Alpha_context +open Sc_rollup.Game -module type S = sig - module PVM : Pvm.S - - val play_opening_move : - [< `Read | `Write > `Read] Node_context.t -> - public_key_hash -> - Sc_rollup.Refutation_storage.conflict -> - (unit, tztrace) result Lwt.t - - val play : - Node_context.rw -> - self:public_key_hash -> - Sc_rollup.Game.t -> - public_key_hash -> - (unit, tztrace) result Lwt.t -end - -module Make (PVM : Pvm.S) : S with module PVM = PVM = struct - module PVM = PVM - open Sc_rollup.Game - - let node_role ~self Sc_rollup.Game.Index.{alice; bob} = - if Sc_rollup.Staker.equal alice self then Alice - else if Sc_rollup.Staker.equal bob self then Bob - else (* By validity of [ongoing_game] RPC. *) - assert false - - type role = Our_turn of {opponent : public_key_hash} | Their_turn - - let turn ~self game players = - let Sc_rollup.Game.Index.{alice; bob} = players in - match (node_role ~self players, game.turn) with - | Alice, Alice -> Our_turn {opponent = bob} - | Bob, Bob -> Our_turn {opponent = alice} - | Alice, Bob -> Their_turn - | Bob, Alice -> Their_turn - - (** [inject_next_move node_ctxt source ~refutation ~opponent ~commitment +let node_role ~self Sc_rollup.Game.Index.{alice; bob} = + if Sc_rollup.Staker.equal alice self then Alice + else if Sc_rollup.Staker.equal bob self then Bob + else (* By validity of [ongoing_game] RPC. *) + assert false + +type role = Our_turn of {opponent : public_key_hash} | Their_turn + +let turn ~self game players = + let Sc_rollup.Game.Index.{alice; bob} = players in + match (node_role ~self players, game.turn) with + | Alice, Alice -> Our_turn {opponent = bob} + | Bob, Bob -> Our_turn {opponent = alice} + | Alice, Bob -> Their_turn + | Bob, Alice -> Their_turn + +(** [inject_next_move node_ctxt source ~refutation ~opponent ~commitment ~opponent_commitment] submits an L1 operation (signed by [source]) to issue the next move in the refutation game. *) - let inject_next_move node_ctxt source ~refutation ~opponent = - let open Lwt_result_syntax in - let refute_operation = - L1_operation.Refute - {rollup = node_ctxt.Node_context.rollup_address; refutation; opponent} - in - let* _hash = Injector.add_pending_operation ~source refute_operation in - return_unit - - (** This function computes the inclusion/membership proof of the page +let inject_next_move node_ctxt source ~refutation ~opponent = + let open Lwt_result_syntax in + let refute_operation = + L1_operation.Refute + {rollup = node_ctxt.Node_context.rollup_address; refutation; opponent} + in + let* _hash = Injector.add_pending_operation ~source refute_operation in + return_unit + +(** This function computes the inclusion/membership proof of the page identified by [page_id] in the slot whose data are provided in [slot_data]. *) - let page_membership_proof params page_index slot_data = - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4048 - Rely on DAL node to compute page membership proof and drop - the dal-crypto dependency from the rollup node. *) - let proof = - let open Result_syntax in - (* The computation of the page's proof below can be a bit costly. In fact, - it involves initialising a cryptobox environment and some non-trivial - crypto processing. *) - let* dal = Cryptobox.make params in - let* polynomial = Cryptobox.polynomial_from_slot dal slot_data in - Cryptobox.prove_page dal polynomial page_index - in - let open Lwt_result_syntax in - match proof with - | Ok proof -> return proof - | Error e -> - failwith - "%s" - (match e with - | `Fail s -> "Fail " ^ s - | `Page_index_out_of_range -> "Page_index_out_of_range" - | `Slot_wrong_size s -> "Slot_wrong_size: " ^ s - | `Invalid_degree_strictly_less_than_expected _ as commit_error -> - Cryptobox.string_of_commit_error commit_error) - - (** When the PVM is waiting for a Dal page input, this function attempts to +let page_membership_proof params page_index slot_data = + (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4048 + Rely on DAL node to compute page membership proof and drop + the dal-crypto dependency from the rollup node. *) + let proof = + let open Result_syntax in + (* The computation of the page's proof below can be a bit costly. In fact, + it involves initialising a cryptobox environment and some non-trivial + crypto processing. *) + let* dal = Cryptobox.make params in + let* polynomial = Cryptobox.polynomial_from_slot dal slot_data in + Cryptobox.prove_page dal polynomial page_index + in + let open Lwt_result_syntax in + match proof with + | Ok proof -> return proof + | Error e -> + failwith + "%s" + (match e with + | `Fail s -> "Fail " ^ s + | `Page_index_out_of_range -> "Page_index_out_of_range" + | `Slot_wrong_size s -> "Slot_wrong_size: " ^ s + | `Invalid_degree_strictly_less_than_expected _ as commit_error -> + Cryptobox.string_of_commit_error commit_error) + +(** When the PVM is waiting for a Dal page input, this function attempts to retrieve the page's content from the store, the data of its slot. Then it computes the proof that the page is part of the slot and returns the content along with the proof. @@ -133,404 +113,393 @@ module Make (PVM : Pvm.S) : S with module PVM = PVM = struct be unconfirmed on L1, this function returns [None]. If the data of the slot are not saved to the store, the function returns a failure in the error monad. *) - let page_info_from_pvm_state node_ctxt ~dal_attestation_lag - (dal_params : Dal.parameters) start_state = - let open Lwt_result_syntax in - let*! input_request = PVM.is_input_state start_state in - match input_request with - | Sc_rollup.(Needs_reveal (Request_dal_page page_id)) -> ( - let Dal.Page.{slot_id; page_index} = page_id in - let* pages = - Dal_pages_request.slot_pages ~dal_attestation_lag node_ctxt slot_id - in - match pages with - | None -> return_none (* The slot is not confirmed. *) - | Some pages -> ( - let pages_per_slot = dal_params.slot_size / dal_params.page_size in - (* check invariant that pages' length is correct. *) - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4031 - It's better to do the check when the slots are saved into disk. *) - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997 - This check is not resilient to dal parameters change. *) - match List.nth_opt pages page_index with - | Some content -> - let* page_proof = - page_membership_proof dal_params page_index - @@ Bytes.concat Bytes.empty pages - in - return_some (content, page_proof) - | None -> - failwith - "Page index %d too big or negative.\n\ - Number of pages in a slot is %d." - page_index - pages_per_slot)) - | _ -> return_none - - let generate_proof node_ctxt game start_state = - let open Lwt_result_syntax in - let snapshot = game.inbox_snapshot in - (* NOTE: [snapshot_level_int32] below refers to the level of the snapshotted - inbox (from the skip list) which also matches [game.start_level - 1]. *) - let snapshot_level_int32 = - Raw_level.to_int32 (Sc_rollup.Inbox.Skip_list.content snapshot).level - in - let get_snapshot_head () = - let+ hash = Node_context.hash_of_level node_ctxt snapshot_level_int32 in - Layer1.{hash; level = snapshot_level_int32} - in - let* context = - let* start_hash = - Node_context.hash_of_level - node_ctxt - (Raw_level.to_int32 game.inbox_level) +let page_info_from_pvm_state (node_ctxt : _ Node_context.t) ~dal_attestation_lag + (dal_params : Dal.parameters) start_state = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! input_request = PVM.is_input_state start_state in + match input_request with + | Sc_rollup.(Needs_reveal (Request_dal_page page_id)) -> ( + let Dal.Page.{slot_id; page_index} = page_id in + let* pages = + Dal_pages_request.slot_pages ~dal_attestation_lag node_ctxt slot_id in - let+ context = Node_context.checkout_context node_ctxt start_hash in - Context.index context - in - let* dal_slots_history = - if Node_context.dal_supported node_ctxt then - let* snapshot_head = get_snapshot_head () in - Dal_slots_tracker.slots_history_of_hash node_ctxt snapshot_head - else return Dal.Slots_history.genesis - in - let* dal_slots_history_cache = - if Node_context.dal_supported node_ctxt then - let* snapshot_head = get_snapshot_head () in - Dal_slots_tracker.slots_history_cache_of_hash node_ctxt snapshot_head - else return (Dal.Slots_history.History_cache.empty ~capacity:0L) - in - (* We fetch the value of protocol constants at block snapshot level - where the game started. *) - let* parametric_constants = - let cctxt = node_ctxt.cctxt in - Protocol.Constants_services.parametric - cctxt - (cctxt#chain, `Level snapshot_level_int32) + match pages with + | None -> return_none (* The slot is not confirmed. *) + | Some pages -> ( + let pages_per_slot = dal_params.slot_size / dal_params.page_size in + (* check invariant that pages' length is correct. *) + (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4031 + It's better to do the check when the slots are saved into disk. *) + (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997 + This check is not resilient to dal parameters change. *) + match List.nth_opt pages page_index with + | Some content -> + let* page_proof = + page_membership_proof dal_params page_index + @@ Bytes.concat Bytes.empty pages + in + return_some (content, page_proof) + | None -> + failwith + "Page index %d too big or negative.\n\ + Number of pages in a slot is %d." + page_index + pages_per_slot)) + | _ -> return_none + +let generate_proof (node_ctxt : _ Node_context.t) game start_state = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let snapshot = game.inbox_snapshot in + (* NOTE: [snapshot_level_int32] below refers to the level of the snapshotted + inbox (from the skip list) which also matches [game.start_level - 1]. *) + let snapshot_level_int32 = + Raw_level.to_int32 (Sc_rollup.Inbox.Skip_list.content snapshot).level + in + let get_snapshot_head () = + let+ hash = Node_context.hash_of_level node_ctxt snapshot_level_int32 in + Layer1.{hash; level = snapshot_level_int32} + in + let* context = + let* start_hash = + Node_context.hash_of_level node_ctxt (Raw_level.to_int32 game.inbox_level) in - let dal_l1_parameters = parametric_constants.dal in - let dal_parameters = dal_l1_parameters.cryptobox_parameters in - let dal_attestation_lag = dal_l1_parameters.attestation_lag in - - let* page_info = - page_info_from_pvm_state - ~dal_attestation_lag - node_ctxt - dal_parameters - start_state - in - let module P = struct - include PVM - - let context = context + let+ context = Node_context.checkout_context node_ctxt start_hash in + Context.index context + in + let* dal_slots_history = + if Node_context.dal_supported node_ctxt then + let* snapshot_head = get_snapshot_head () in + Dal_slots_tracker.slots_history_of_hash node_ctxt snapshot_head + else return Dal.Slots_history.genesis + in + let* dal_slots_history_cache = + if Node_context.dal_supported node_ctxt then + let* snapshot_head = get_snapshot_head () in + Dal_slots_tracker.slots_history_cache_of_hash node_ctxt snapshot_head + else return (Dal.Slots_history.History_cache.empty ~capacity:0L) + in + (* We fetch the value of protocol constants at block snapshot level + where the game started. *) + let* parametric_constants = + let cctxt = node_ctxt.cctxt in + Protocol.Constants_services.parametric + cctxt + (cctxt#chain, `Level snapshot_level_int32) + in + let dal_l1_parameters = parametric_constants.dal in + let dal_parameters = dal_l1_parameters.cryptobox_parameters in + let dal_attestation_lag = dal_l1_parameters.attestation_lag in + + let* page_info = + page_info_from_pvm_state + ~dal_attestation_lag + node_ctxt + dal_parameters + start_state + in + let module P = struct + include PVM + + let context = context + + let state = start_state + + let reveal hash = + let open Lwt_syntax in + let* res = + Reveals.get + ?dac_client:node_ctxt.dac_client + ~data_dir:node_ctxt.data_dir + ~pvm_kind:PVM.kind + hash + in + match res with Ok data -> return @@ Some data | Error _ -> return None - let state = start_state + module Inbox_with_history = struct + let inbox = snapshot - let reveal hash = + let get_history inbox_hash = let open Lwt_syntax in - let* res = - Reveals.get - ?dac_client:node_ctxt.dac_client - ~data_dir:node_ctxt.data_dir - ~pvm_kind:PVM.kind - hash + let+ inbox = Node_context.find_inbox node_ctxt inbox_hash in + match inbox with + | Error err -> + Format.kasprintf + Stdlib.failwith + "Refutation game: Cannot get inbox history for %a, %a" + Sc_rollup.Inbox.Hash.pp + inbox_hash + pp_print_trace + err + | Ok inbox -> Option.map Sc_rollup.Inbox.take_snapshot inbox + + let get_payloads_history witness = + Lwt.map + (WithExceptions.Result.to_exn_f + ~error:(Format.kasprintf Stdlib.failwith "%a" pp_print_trace)) + @@ + let open Lwt_result_syntax in + let* {is_first_block; predecessor; predecessor_timestamp; messages} = + Node_context.get_messages node_ctxt witness in - match res with Ok data -> return @@ Some data | Error _ -> return None - - module Inbox_with_history = struct - let inbox = snapshot - - let get_history inbox_hash = - let open Lwt_syntax in - let+ inbox = Node_context.find_inbox node_ctxt inbox_hash in - match inbox with - | Error err -> - Format.kasprintf - Stdlib.failwith - "Refutation game: Cannot get inbox history for %a, %a" - Sc_rollup.Inbox.Hash.pp - inbox_hash - pp_print_trace - err - | Ok inbox -> Option.map Sc_rollup.Inbox.take_snapshot inbox - - let get_payloads_history witness = - Lwt.map - (WithExceptions.Result.to_exn_f - ~error:(Format.kasprintf Stdlib.failwith "%a" pp_print_trace)) - @@ - let open Lwt_result_syntax in - let* {is_first_block; predecessor; predecessor_timestamp; messages} = - Node_context.get_messages node_ctxt witness - in - let*? hist = - Inbox.payloads_history_of_messages - ~is_first_block - ~predecessor - ~predecessor_timestamp - messages - in - return hist - end - - module Dal_with_history = struct - let confirmed_slots_history = dal_slots_history - - let get_history ptr = - Dal.Slots_history.History_cache.find ptr dal_slots_history_cache - |> Lwt.return - - let dal_attestation_lag = dal_attestation_lag - - let dal_parameters = dal_parameters - - let page_info = page_info - end - end in - let metadata = Node_context.metadata node_ctxt in - let* proof = - trace (Sc_rollup_node_errors.Cannot_produce_proof game) - @@ (Sc_rollup.Proof.produce ~metadata (module P) game.inbox_level - >|= Environment.wrap_tzresult) - in - let*? pvm_step = - Sc_rollup.Proof.unserialize_pvm_step ~pvm:(module PVM) proof.pvm_step - |> Environment.wrap_tzresult - in - let proof = {proof with pvm_step} in - let*! res = - Sc_rollup.Proof.valid - ~metadata - snapshot - game.inbox_level - dal_slots_history - dal_parameters - ~dal_attestation_lag - ~pvm:(module PVM) - proof - >|= Environment.wrap_tzresult - in - if Result.is_ok res then return proof else assert false - - type pvm_intermediate_state = - | Hash of PVM.hash - | Evaluated of Fueled_pvm.Accounted.eval_state - - let new_dissection ~opponent ~default_number_of_sections node_ctxt last_level - ok our_view = - let open Lwt_result_syntax in - let state_of_tick ?start_state tick = - Interpreter.state_of_tick node_ctxt ?start_state tick last_level - in - let state_hash_of_eval_state Fueled_pvm.Accounted.{state_hash; _} = - state_hash - in - let start_hash, start_tick, start_state = - match ok with - | Hash hash, tick -> (hash, tick, None) - | Evaluated ({state_hash; _} as state), tick -> - (state_hash, tick, Some state) - in - let start_chunk = - Sc_rollup.Dissection_chunk. - {state_hash = Some start_hash; tick = start_tick} - in - let our_state, our_tick = our_view in - let our_state_hash = - Option.map - (fun Fueled_pvm.Accounted.{state_hash; _} -> state_hash) - our_state - in - let our_stop_chunk = - Sc_rollup.Dissection_chunk.{state_hash = our_state_hash; tick = our_tick} - in - let* dissection = - Game_helpers.make_dissection - ~state_of_tick - ~state_hash_of_eval_state - ?start_state - ~start_chunk - ~our_stop_chunk - @@ PVM.new_dissection - ~start_chunk - ~our_stop_chunk - ~default_number_of_sections - in - let*! () = - Refutation_game_event.computed_dissection - ~opponent - ~start_tick - ~end_tick:our_tick - dissection - in - return dissection - - (** [generate_from_dissection ~default_number_of_sections node_ctxt game + let*? hist = + Inbox.payloads_history_of_messages + ~is_first_block + ~predecessor + ~predecessor_timestamp + messages + in + return hist + end + + module Dal_with_history = struct + let confirmed_slots_history = dal_slots_history + + let get_history ptr = + Dal.Slots_history.History_cache.find ptr dal_slots_history_cache + |> Lwt.return + + let dal_attestation_lag = dal_attestation_lag + + let dal_parameters = dal_parameters + + let page_info = page_info + end + end in + let metadata = Node_context.metadata node_ctxt in + let* proof = + trace (Sc_rollup_node_errors.Cannot_produce_proof game) + @@ (Sc_rollup.Proof.produce ~metadata (module P) game.inbox_level + >|= Environment.wrap_tzresult) + in + let*? pvm_step = + Sc_rollup.Proof.unserialize_pvm_step ~pvm:(module PVM) proof.pvm_step + |> Environment.wrap_tzresult + in + let unserialized_proof = {proof with pvm_step} in + let*! res = + Sc_rollup.Proof.valid + ~metadata + snapshot + game.inbox_level + dal_slots_history + dal_parameters + ~dal_attestation_lag + ~pvm:(module PVM) + unserialized_proof + >|= Environment.wrap_tzresult + in + if Result.is_ok res then return proof else assert false + +type pvm_intermediate_state = + | Hash of Sc_rollup.State_hash.t + | Evaluated of Fueled_pvm.Accounted.eval_state + +let new_dissection ~opponent ~default_number_of_sections node_ctxt last_level ok + our_view = + let open Lwt_result_syntax in + let state_of_tick ?start_state tick = + Interpreter.state_of_tick node_ctxt ?start_state tick last_level + in + let state_hash_of_eval_state Fueled_pvm.Accounted.{state_hash; _} = + state_hash + in + let start_hash, start_tick, start_state = + match ok with + | Hash hash, tick -> (hash, tick, None) + | Evaluated ({state_hash; _} as state), tick -> + (state_hash, tick, Some state) + in + let start_chunk = + Sc_rollup.Dissection_chunk.{state_hash = Some start_hash; tick = start_tick} + in + let our_state, our_tick = our_view in + let our_state_hash = + Option.map + (fun Fueled_pvm.Accounted.{state_hash; _} -> state_hash) + our_state + in + let our_stop_chunk = + Sc_rollup.Dissection_chunk.{state_hash = our_state_hash; tick = our_tick} + in + let module PVM = (val node_ctxt.pvm) in + let* dissection = + Game_helpers.make_dissection + ~state_of_tick + ~state_hash_of_eval_state + ?start_state + ~start_chunk + ~our_stop_chunk + @@ PVM.new_dissection + ~start_chunk + ~our_stop_chunk + ~default_number_of_sections + in + let*! () = + Refutation_game_event.computed_dissection + ~opponent + ~start_tick + ~end_tick:our_tick + dissection + in + return dissection + +(** [generate_from_dissection ~default_number_of_sections node_ctxt game dissection] traverses the current [dissection] and returns a move which performs a new dissection of the execution trace or provides a refutation proof to serve as the next move of the [game]. *) - let generate_next_dissection ~default_number_of_sections node_ctxt ~opponent - game dissection = - let open Lwt_result_syntax in - let rec traverse ok = function - | [] -> - (* The game invariant states that the dissection from the - opponent must contain a tick we disagree with. If the - retrieved game does not respect this, we cannot trust the - Tezos node we are connected to and prefer to stop here. *) - tzfail - Sc_rollup_node_errors - .Unreliable_tezos_node_returning_inconsistent_game - | Sc_rollup.Dissection_chunk.{state_hash = their_hash; tick} :: dissection - -> ( - let start_state = - match ok with - | Hash _, _ -> None - | Evaluated ok_state, _ -> Some ok_state - in - let* our = - Interpreter.state_of_tick - node_ctxt - ?start_state - tick - game.inbox_level - in - match (their_hash, our) with - | None, None -> - (* This case is absurd since: [None] can only occur at the - end and the two players disagree about the end. *) - assert false - | Some _, None | None, Some _ -> return (ok, (our, tick)) - | Some their_hash, Some ({state_hash = our_hash; _} as our_state) -> - if Sc_rollup.State_hash.equal our_hash their_hash then - traverse (Evaluated our_state, tick) dissection - else return (ok, (our, tick))) - in - match dissection with - | Sc_rollup.Dissection_chunk.{state_hash = Some hash; tick} :: dissection -> - let* ok, ko = traverse (Hash hash, tick) dissection in - let* dissection = - new_dissection - ~opponent - ~default_number_of_sections - node_ctxt - game.inbox_level - ok - ko +let generate_next_dissection ~default_number_of_sections node_ctxt ~opponent + game dissection = + let open Lwt_result_syntax in + let rec traverse ok = function + | [] -> + (* The game invariant states that the dissection from the + opponent must contain a tick we disagree with. If the + retrieved game does not respect this, we cannot trust the + Tezos node we are connected to and prefer to stop here. *) + tzfail + Sc_rollup_node_errors + .Unreliable_tezos_node_returning_inconsistent_game + | Sc_rollup.Dissection_chunk.{state_hash = their_hash; tick} :: dissection + -> ( + let start_state = + match ok with + | Hash _, _ -> None + | Evaluated ok_state, _ -> Some ok_state + in + let* our = + Interpreter.state_of_tick node_ctxt ?start_state tick game.inbox_level in - let _, choice = ok in - let _, ko_tick = ko in - let chosen_section_len = Sc_rollup.Tick.distance ko_tick choice in - return (choice, chosen_section_len, dissection) - | [] | {state_hash = None; _} :: _ -> - (* + match (their_hash, our) with + | None, None -> + (* This case is absurd since: [None] can only occur at the + end and the two players disagree about the end. *) + assert false + | Some _, None | None, Some _ -> return (ok, (our, tick)) + | Some their_hash, Some ({state_hash = our_hash; _} as our_state) -> + if Sc_rollup.State_hash.equal our_hash their_hash then + traverse (Evaluated our_state, tick) dissection + else return (ok, (our, tick))) + in + match dissection with + | Sc_rollup.Dissection_chunk.{state_hash = Some hash; tick} :: dissection -> + let* ok, ko = traverse (Hash hash, tick) dissection in + let* dissection = + new_dissection + ~opponent + ~default_number_of_sections + node_ctxt + game.inbox_level + ok + ko + in + let _, choice = ok in + let _, ko_tick = ko in + let chosen_section_len = Sc_rollup.Tick.distance ko_tick choice in + return (choice, chosen_section_len, dissection) + | [] | {state_hash = None; _} :: _ -> + (* By wellformedness of dissection. A dissection always starts with a tick of the form [(Some hash, tick)]. A dissection always contains strictly more than one element. *) + tzfail + Sc_rollup_node_errors.Unreliable_tezos_node_returning_inconsistent_game + +let next_move node_ctxt ~opponent game = + let open Lwt_result_syntax in + let final_move start_tick = + let* start_state = + Interpreter.state_of_tick node_ctxt start_tick game.inbox_level + in + match start_state with + | None -> tzfail Sc_rollup_node_errors .Unreliable_tezos_node_returning_inconsistent_game - - let next_move node_ctxt ~opponent game = - let open Lwt_result_syntax in - let final_move start_tick = - let* start_state = - Interpreter.state_of_tick node_ctxt start_tick game.inbox_level + | Some {state = start_state; _} -> + let* proof = generate_proof node_ctxt game start_state in + let choice = start_tick in + return (Move {choice; step = Proof proof}) + in + + match game.game_state with + | Dissecting {dissection; default_number_of_sections} -> + let* choice, chosen_section_len, dissection = + generate_next_dissection + ~default_number_of_sections + node_ctxt + ~opponent + game + dissection in - match start_state with - | None -> - tzfail - Sc_rollup_node_errors - .Unreliable_tezos_node_returning_inconsistent_game - | Some {state = start_state; _} -> - let* proof = generate_proof node_ctxt game start_state in - let*? pvm_step = - Sc_rollup.Proof.serialize_pvm_step ~pvm:(module PVM) proof.pvm_step - |> Environment.wrap_tzresult - in - let step = Proof {proof with pvm_step} in - let choice = start_tick in - return (Move {choice; step}) - in - - match game.game_state with - | Dissecting {dissection; default_number_of_sections} -> - let* choice, chosen_section_len, dissection = - generate_next_dissection - ~default_number_of_sections - node_ctxt - ~opponent - game - dissection - in - if Z.(equal chosen_section_len one) then final_move choice - else return (Move {choice; step = Dissection dissection}) - | Final_move {agreed_start_chunk; refuted_stop_chunk = _} -> - let choice = agreed_start_chunk.tick in - final_move choice - - let play_next_move node_ctxt game self opponent = - let open Lwt_result_syntax in - let* refutation = next_move node_ctxt ~opponent game in - inject_next_move node_ctxt self ~refutation ~opponent - - let play_timeout (node_ctxt : _ Node_context.t) self stakers = - let open Lwt_result_syntax in - let timeout_operation = - L1_operation.Timeout {rollup = node_ctxt.rollup_address; stakers} - in - let source = - Node_context.get_operator node_ctxt Timeout |> Option.value ~default:self - (* We fallback on the [Refute] operator if none is provided for [Timeout] *) - in - let* _hash = Injector.add_pending_operation ~source timeout_operation in - return_unit - - let timeout_reached ~self head_block node_ctxt staker1 staker2 = - let open Lwt_result_syntax in - let Node_context.{rollup_address; cctxt; _} = node_ctxt in - let* game_result = - Plugin.RPC.Sc_rollup.timeout_reached - cctxt - (cctxt#chain, head_block) - rollup_address - staker1 - staker2 - in - let open Sc_rollup.Game in - match game_result with - | Some (Loser {loser; _}) -> - let is_it_me = Signature.Public_key_hash.(self = loser) in - if is_it_me then return_none else return (Some loser) - | _ -> return_none - - let play node_ctxt ~self game opponent = - let open Lwt_result_syntax in - let index = Sc_rollup.Game.Index.make self opponent in - let head_block = `Head 0 in - match turn ~self game index with - | Our_turn {opponent} -> play_next_move node_ctxt game self opponent - | Their_turn -> ( - let* timeout_reached = - timeout_reached ~self head_block node_ctxt self opponent - in - match timeout_reached with - | Some opponent -> - let*! () = Refutation_game_event.timeout_detected opponent in - play_timeout node_ctxt self index - | None -> return_unit) - - let play_opening_move node_ctxt self conflict = - let open Lwt_syntax in - let open Sc_rollup.Refutation_storage in - let* () = Refutation_game_event.conflict_detected conflict in - let player_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated conflict.our_commitment - in - let opponent_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated conflict.their_commitment - in - let refutation = Start {player_commitment_hash; opponent_commitment_hash} in - inject_next_move node_ctxt self ~refutation ~opponent:conflict.other -end + if Z.(equal chosen_section_len one) then final_move choice + else return (Move {choice; step = Dissection dissection}) + | Final_move {agreed_start_chunk; refuted_stop_chunk = _} -> + let choice = agreed_start_chunk.tick in + final_move choice + +let play_next_move node_ctxt game self opponent = + let open Lwt_result_syntax in + let* refutation = next_move node_ctxt ~opponent game in + inject_next_move node_ctxt self ~refutation ~opponent + +let play_timeout (node_ctxt : _ Node_context.t) self stakers = + let open Lwt_result_syntax in + let timeout_operation = + L1_operation.Timeout {rollup = node_ctxt.rollup_address; stakers} + in + let source = + Node_context.get_operator node_ctxt Timeout |> Option.value ~default:self + (* We fallback on the [Refute] operator if none is provided for [Timeout] *) + in + let* _hash = Injector.add_pending_operation ~source timeout_operation in + return_unit + +let timeout_reached ~self head_block node_ctxt staker1 staker2 = + let open Lwt_result_syntax in + let Node_context.{rollup_address; cctxt; _} = node_ctxt in + let* game_result = + Plugin.RPC.Sc_rollup.timeout_reached + cctxt + (cctxt#chain, head_block) + rollup_address + staker1 + staker2 + in + let open Sc_rollup.Game in + match game_result with + | Some (Loser {loser; _}) -> + let is_it_me = Signature.Public_key_hash.(self = loser) in + if is_it_me then return_none else return (Some loser) + | _ -> return_none + +let play node_ctxt ~self game opponent = + let open Lwt_result_syntax in + let index = Sc_rollup.Game.Index.make self opponent in + let head_block = `Head 0 in + match turn ~self game index with + | Our_turn {opponent} -> play_next_move node_ctxt game self opponent + | Their_turn -> ( + let* timeout_reached = + timeout_reached ~self head_block node_ctxt self opponent + in + match timeout_reached with + | Some opponent -> + let*! () = Refutation_game_event.timeout_detected opponent in + play_timeout node_ctxt self index + | None -> return_unit) + +let play_opening_move node_ctxt self conflict = + let open Lwt_syntax in + let open Sc_rollup.Refutation_storage in + let* () = Refutation_game_event.conflict_detected conflict in + let player_commitment_hash = + Sc_rollup.Commitment.hash_uncarbonated conflict.our_commitment + in + let opponent_commitment_hash = + Sc_rollup.Commitment.hash_uncarbonated conflict.their_commitment + in + let refutation = Start {player_commitment_hash; opponent_commitment_hash} in + inject_next_move node_ctxt self ~refutation ~opponent:conflict.other diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_game.mli b/src/proto_alpha/lib_sc_rollup_node/refutation_game.mli index e0196859df79..3229857d1aa7 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_game.mli +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_game.mli @@ -26,27 +26,21 @@ open Protocol open Alpha_context -(** This module implements the refutation game logic of the rollup - node. *) -module type S = sig - module PVM : Pvm.S +(** This module implements the refutation game logic of the rollup node. *) - (** [play_opening_move node_ctxt self conflict] injects the opening - refutation game move for [conflict]. *) - val play_opening_move : - [< `Read | `Write > `Read] Node_context.t -> - public_key_hash -> - Sc_rollup.Refutation_storage.conflict -> - (unit, tztrace) result Lwt.t +(** [play_opening_move node_ctxt self conflict] injects the opening refutation + game move for [conflict]. *) +val play_opening_move : + [< `Read | `Write > `Read] Node_context.t -> + public_key_hash -> + Sc_rollup.Refutation_storage.conflict -> + (unit, tztrace) result Lwt.t - (** [play head_block node_ctxt ~self game opponent] injects the next - move in the refutation [game] played by [self] and [opponent]. *) - val play : - Node_context.rw -> - self:public_key_hash -> - Sc_rollup.Game.t -> - public_key_hash -> - (unit, tztrace) result Lwt.t -end - -module Make (PVM : Pvm.S) : S with module PVM = PVM +(** [play head_block node_ctxt ~self game opponent] injects the next move in the + refutation [game] played by [self] and [opponent]. *) +val play : + Node_context.rw -> + self:public_key_hash -> + Sc_rollup.Game.t -> + public_key_hash -> + (unit, tztrace) result Lwt.t diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_player.ml b/src/proto_alpha/lib_sc_rollup_node/refutation_player.ml index 30a086b8b75c..72901a452bf2 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_player.ml +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_player.ml @@ -26,6 +26,7 @@ open Protocol open Alpha_context open Refutation_player_types +open Refutation_game module Types = struct type state = { @@ -54,151 +55,129 @@ type worker = Worker.infinite Worker.queue Worker.t let table = Worker.create_table Queue -module type S = sig - val init_and_play : - Node_context.rw -> - self:public_key_hash -> - conflict:Sc_rollup.Refutation_storage.conflict -> - game:Sc_rollup.Game.t option -> - level:int32 -> - unit tzresult Lwt.t +let on_play game Types.{node_ctxt; self; opponent; _} = + play node_ctxt ~self game opponent - val play : worker -> Sc_rollup.Game.t -> level:int32 -> unit Lwt.t +let on_play_opening conflict (Types.{node_ctxt; self; _} : Types.state) = + play_opening_move node_ctxt self conflict - val shutdown : worker -> unit Lwt.t +module Handlers = struct + type self = worker - val current_games : unit -> (public_key_hash * worker) list -end - -module Make (PVM : Pvm.S) : S = struct - open Refutation_game.Make (PVM) - - let on_play game Types.{node_ctxt; self; opponent; _} = - play node_ctxt ~self game opponent - - let on_play_opening conflict (Types.{node_ctxt; self; _} : Types.state) = - play_opening_move node_ctxt self conflict - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Play game -> on_play game state - | Request.Play_opening conflict -> on_play_opening conflict state - - type launch_error = error trace - - let on_launch _w _name Types.{node_ctxt; self; conflict} = - return - Types. - {node_ctxt; self; opponent = conflict.other; last_move_cache = None} - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Refutation_game_event.Player.request_failed request_view st errs - in - return_unit - in - match r with - | Request.Play _ -> emit_and_return_errors errs - | Request.Play_opening _ -> emit_and_return_errors errs - - let on_completion _w r _ st = - Refutation_game_event.Player.request_completed (Request.view r) st + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with + | Request.Play game -> on_play game state + | Request.Play_opening conflict -> on_play_opening conflict state - let on_no_request _ = Lwt.return_unit + type launch_error = error trace - let on_close w = - let open Lwt_syntax in - let state = Worker.state w in - let* () = Refutation_game_event.Player.stopped state.opponent in - return_unit - end + let on_launch _w _name Types.{node_ctxt; self; conflict} = + return + Types.{node_ctxt; self; opponent = conflict.other; last_move_cache = None} - let init node_ctxt ~self ~conflict = + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let*! () = - Refutation_game_event.Player.started - conflict.Sc_rollup.Refutation_storage.other - conflict.Sc_rollup.Refutation_storage.our_commitment - in - let worker_promise, worker_waker = Lwt.task () in - let* worker = - trace Sc_rollup_node_errors.Refutation_player_failed_to_start - @@ Worker.launch - table - conflict.other - {node_ctxt; self; conflict} - (module Handlers) - in - let () = Lwt.wakeup worker_waker worker in - let worker = - match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> - error Sc_rollup_node_errors.Refutation_player_failed_to_start - in - Lwt.return worker - - (* Play if: - - There's a new game state to play against or - - The current level is past the buffer for re-playing in the - same game state. - *) - let should_move ~level game last_move_cache = - match last_move_cache with - | None -> true - | Some (last_move_game_state, last_move_level) -> - (not - (Sc_rollup.Game.game_state_equal - game.Sc_rollup.Game.game_state - last_move_game_state)) - || Int32.( - sub level last_move_level - > of_int Configuration.refutation_player_buffer_levels) - - let play w game ~(level : int32) = - let open Lwt_syntax in - let state = Worker.state w in - if should_move ~level game state.last_move_cache then ( - let* pushed = Worker.Queue.push_request w (Request.Play game) in - if pushed then - state.last_move_cache <- Some (game.Sc_rollup.Game.game_state, level) ; - return_unit) - else return_unit - - let play_opening w conflict = - let open Lwt_syntax in - let* (_pushed : bool) = - Worker.Queue.push_request w (Request.Play_opening conflict) + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Refutation_game_event.Player.request_failed request_view st errs + in + return_unit in - return_unit + match r with + | Request.Play _ -> emit_and_return_errors errs + | Request.Play_opening _ -> emit_and_return_errors errs - let init_and_play node_ctxt ~self ~conflict ~game ~level = - let open Lwt_result_syntax in - let* worker = init node_ctxt ~self ~conflict in - let*! () = - match game with - | None -> play_opening worker conflict - | Some game -> play worker game ~level - in - return_unit + let on_completion _w r _ st = + Refutation_game_event.Player.request_completed (Request.view r) st - let current_games () = - List.map - (fun (_name, worker) -> ((Worker.state worker).opponent, worker)) - (Worker.list table) + let on_no_request _ = Lwt.return_unit - let shutdown = Worker.shutdown + let on_close w = + let open Lwt_syntax in + let state = Worker.state w in + let* () = Refutation_game_event.Player.stopped state.opponent in + return_unit end + +let init node_ctxt ~self ~conflict = + let open Lwt_result_syntax in + let*! () = + Refutation_game_event.Player.started + conflict.Sc_rollup.Refutation_storage.other + conflict.Sc_rollup.Refutation_storage.our_commitment + in + let worker_promise, worker_waker = Lwt.task () in + let* worker = + trace Sc_rollup_node_errors.Refutation_player_failed_to_start + @@ Worker.launch + table + conflict.other + {node_ctxt; self; conflict} + (module Handlers) + in + let () = Lwt.wakeup worker_waker worker in + let worker = + match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> + error Sc_rollup_node_errors.Refutation_player_failed_to_start + in + Lwt.return worker + +(* Play if: + - There's a new game state to play against or + - The current level is past the buffer for re-playing in the + same game state. +*) +let should_move ~level game last_move_cache = + match last_move_cache with + | None -> true + | Some (last_move_game_state, last_move_level) -> + (not + (Sc_rollup.Game.game_state_equal + game.Sc_rollup.Game.game_state + last_move_game_state)) + || Int32.( + sub level last_move_level + > of_int Configuration.refutation_player_buffer_levels) + +let play w game ~(level : int32) = + let open Lwt_syntax in + let state = Worker.state w in + if should_move ~level game state.last_move_cache then ( + let* pushed = Worker.Queue.push_request w (Request.Play game) in + if pushed then + state.last_move_cache <- Some (game.Sc_rollup.Game.game_state, level) ; + return_unit) + else return_unit + +let play_opening w conflict = + let open Lwt_syntax in + let* (_pushed : bool) = + Worker.Queue.push_request w (Request.Play_opening conflict) + in + return_unit + +let init_and_play node_ctxt ~self ~conflict ~game ~level = + let open Lwt_result_syntax in + let* worker = init node_ctxt ~self ~conflict in + let*! () = + match game with + | None -> play_opening worker conflict + | Some game -> play worker game ~level + in + return_unit + +let current_games () = + List.map + (fun (_name, worker) -> ((Worker.state worker).opponent, worker)) + (Worker.list table) + +let shutdown = Worker.shutdown diff --git a/src/proto_alpha/lib_sc_rollup_node/refutation_player.mli b/src/proto_alpha/lib_sc_rollup_node/refutation_player.mli index 7eae3b74cb01..92592e7c7cc5 100644 --- a/src/proto_alpha/lib_sc_rollup_node/refutation_player.mli +++ b/src/proto_alpha/lib_sc_rollup_node/refutation_player.mli @@ -26,43 +26,34 @@ open Protocol open Alpha_context -(** Worker module for a signle refutation game player. - The node's refutation coordinator will spawn a new refutation player - for each refutation game. +(** Worker module for a single refutation game player. The node's refutation + coordinator will spawn a new refutation player for each refutation game. *) module Worker : Worker.T (** Type for a refutation game player. *) type worker = Worker.infinite Worker.queue Worker.t -module type S = sig - (** [init_and_play node_ctxt ~self ~conflict ~game ~level] - initializes a new refutation game player for signer [self]. - After initizialization, the worker will play the next move - depending on the [game] state. - If no [game] is passed, the worker will play the opening - move for [conflict]. - *) - val init_and_play : - Node_context.rw -> - self:public_key_hash -> - conflict:Sc_rollup.Refutation_storage.conflict -> - game:Sc_rollup.Game.t option -> - level:int32 -> - unit tzresult Lwt.t - - (** [play worker game ~level] makes the [worker] play the next move depending +(** [init_and_play node_ctxt ~self ~conflict ~game ~level] initializes a new + refutation game player for signer [self]. After initizialization, the + worker will play the next move depending on the [game] state. If no [game] + is passed, the worker will play the opening move for [conflict]. *) +val init_and_play : + Node_context.rw -> + self:public_key_hash -> + conflict:Sc_rollup.Refutation_storage.conflict -> + game:Sc_rollup.Game.t option -> + level:int32 -> + unit tzresult Lwt.t + +(** [play worker game ~level] makes the [worker] play the next move depending on the [game] state for their conflict. *) - val play : worker -> Sc_rollup.Game.t -> level:int32 -> unit Lwt.t - - (** Shutdown a refutaiton game player. *) - val shutdown : worker -> unit Lwt.t +val play : worker -> Sc_rollup.Game.t -> level:int32 -> unit Lwt.t - (** [current_games ()] lists the opponents' this node is playing - refutation games against, alongside the worker that takes care - of each game. *) - val current_games : unit -> (public_key_hash * worker) list -end +(** Shutdown a refutaiton game player. *) +val shutdown : worker -> unit Lwt.t -module Make (Interpreter : Pvm.S) : S +(** [current_games ()] lists the opponents' this node is playing refutation + games against, alongside the worker that takes care of each game. *) +val current_games : unit -> (public_key_hash * worker) list -- GitLab From 9640ae9e9f0c49437c2a7a0dd2cc82ce0a79b3bf Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Thu, 20 Apr 2023 18:44:26 +0200 Subject: [PATCH 07/13] SCORU/Node: defunctorize simulation and batcher --- .../lib_sc_rollup_node/RPC_server.ml | 3 +- .../lib_sc_rollup_node/RPC_server.mli | 2 +- src/proto_alpha/lib_sc_rollup_node/batcher.ml | 777 ++++++++---------- .../lib_sc_rollup_node/batcher.mli | 82 +- .../lib_sc_rollup_node/components.ml | 4 +- src/proto_alpha/lib_sc_rollup_node/daemon.ml | 11 +- .../lib_sc_rollup_node/simulation.ml | 296 +++---- .../lib_sc_rollup_node/simulation.mli | 78 +- 8 files changed, 575 insertions(+), 678 deletions(-) diff --git a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml index 14a10056c520..509eaf6f7791 100644 --- a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml +++ b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml @@ -53,8 +53,7 @@ end let get_dal_processed_slots node_ctxt block = Node_context.list_slots_statuses node_ctxt ~confirmed_in_block_hash:block -module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct - module PVM = Simulation.PVM +module Make (PVM : Pvm.S) = struct module Outbox = Outbox.Make (PVM) module Global_directory = Make_directory (struct diff --git a/src/proto_alpha/lib_sc_rollup_node/RPC_server.mli b/src/proto_alpha/lib_sc_rollup_node/RPC_server.mli index a5ead51ff6bf..7de28ecef022 100644 --- a/src/proto_alpha/lib_sc_rollup_node/RPC_server.mli +++ b/src/proto_alpha/lib_sc_rollup_node/RPC_server.mli @@ -26,7 +26,7 @@ open Tezos_rpc_http_server (** Functor to construct an RPC server for a given PVM with simulation. *) -module Make (Simulation : Simulation.S) (Batcher : Batcher.S) : sig +module Make (PVM : Pvm.S) : sig (** [start node_ctxt config] starts an RPC server listening for requests on the port [config.rpc_port] and address [config.rpc_addr]. *) val start : diff --git a/src/proto_alpha/lib_sc_rollup_node/batcher.ml b/src/proto_alpha/lib_sc_rollup_node/batcher.ml index d317880cb45d..f267a359dab2 100644 --- a/src/proto_alpha/lib_sc_rollup_node/batcher.ml +++ b/src/proto_alpha/lib_sc_rollup_node/batcher.ml @@ -34,435 +34,388 @@ end module Batched_messages = Hash_queue.Make (L2_message.Hash) (L2_batched_message) -(* Count instances of the batcher functor to allow for multiple worker events - without conflicts. *) -let instances_count = ref 0 - -module type S = sig - type status = Pending_batch | Batched of Injector.Inj_operation.hash - - val init : - Configuration.batcher -> - signer:public_key_hash -> - _ Node_context.t -> - unit tzresult Lwt.t - - val active : unit -> bool +type status = Pending_batch | Batched of Injector.Inj_operation.hash + +(* Same as {!Configuration.batcher} with max_batch_size non optional. *) +type conf = { + simulate : bool; + min_batch_elements : int; + min_batch_size : int; + max_batch_elements : int; + max_batch_size : int; +} + +type state = { + node_ctxt : Node_context.ro; + signer : Signature.public_key_hash; + conf : conf; + messages : Message_queue.t; + batched : Batched_messages.t; + mutable simulation_ctxt : Simulation.t option; +} + +let message_size s = + (* Encoded as length of s on 4 bytes + s *) + 4 + String.length s + +let inject_batch state (l2_messages : L2_message.t list) = + let open Lwt_result_syntax in + let messages = List.map L2_message.content l2_messages in + let operation = L1_operation.Add_messages {messages} in + let+ l1_hash = + Injector.add_pending_operation ~source:state.signer operation + in + List.iter + (fun msg -> + let content = L2_message.content msg in + let hash = L2_message.hash msg in + Batched_messages.replace state.batched hash {content; l1_hash}) + l2_messages + +let inject_batches state = List.iter_es (inject_batch state) + +let get_batches state ~only_full = + let ( current_rev_batch, + current_batch_size, + current_batch_elements, + full_batches ) = + Message_queue.fold + (fun msg_hash + message + ( current_rev_batch, + current_batch_size, + current_batch_elements, + full_batches ) -> + let size = message_size (L2_message.content message) in + let new_batch_size = current_batch_size + size in + let new_batch_elements = current_batch_elements + 1 in + if + new_batch_size <= state.conf.max_batch_size + && new_batch_elements <= state.conf.max_batch_elements + then + (* We can add the message to the current batch because we are still + within the bounds. *) + ( (msg_hash, message) :: current_rev_batch, + new_batch_size, + new_batch_elements, + full_batches ) + else + (* The batch augmented with the message would be too big but it is + below the limit without it. We finalize the current batch and + create a new one for the message. NOTE: Messages in the queue are + always < [state.conf.max_batch_size] because {!on_register} only + accepts those. *) + let batch = List.rev current_rev_batch in + ([(msg_hash, message)], size, 1, batch :: full_batches)) + state.messages + ([], 0, 0, []) + in + let batches = + if + (not only_full) + || current_batch_size >= state.conf.min_batch_size + && current_batch_elements >= state.conf.min_batch_elements + then + (* We have enough to make a batch with the last non-full batch. *) + List.rev current_rev_batch :: full_batches + else full_batches + in + List.fold_left + (fun (batches, to_remove) -> function + | [] -> (batches, to_remove) + | batch -> + let msg_hashes, batch = List.split batch in + let to_remove = List.rev_append msg_hashes to_remove in + (batch :: batches, to_remove)) + ([], []) + batches + +let produce_batches state ~only_full = + let open Lwt_result_syntax in + let batches, to_remove = get_batches state ~only_full in + match batches with + | [] -> return_unit + | _ -> + let* () = inject_batches state batches in + let*! () = + Batcher_events.(emit batched) + (List.length batches, List.length to_remove) + in + List.iter + (fun tr_hash -> Message_queue.remove state.messages tr_hash) + to_remove ; + return_unit + +let on_batch state = produce_batches state ~only_full:false + +let simulate node_ctxt simulation_ctxt (messages : L2_message.t list) = + let open Lwt_result_syntax in + let ext_messages = + List.map + (fun m -> Sc_rollup.Inbox_message.External (L2_message.content m)) + messages + in + let+ simulation_ctxt, _ticks = + Simulation.simulate_messages node_ctxt simulation_ctxt ext_messages + in + simulation_ctxt + +let on_register state (messages : string list) = + let open Lwt_result_syntax in + let max_size_msg = + min + (Protocol.Constants_repr.sc_rollup_message_size_limit + + 4 (* We add 4 because [message_size] adds 4. *)) + state.conf.max_batch_size + in + let*? messages = + List.mapi_e + (fun i message -> + if message_size message > max_size_msg then + error_with "Message %d is too large (max size is %d)" i max_size_msg + else Ok (L2_message.make message)) + messages + in + let* () = + if not state.conf.simulate then return_unit + else + match state.simulation_ctxt with + | None -> failwith "Simulation context of batcher not initialized" + | Some simulation_ctxt -> + let+ simulation_ctxt = + simulate state.node_ctxt simulation_ctxt messages + in + state.simulation_ctxt <- Some simulation_ctxt + in + let*! () = Batcher_events.(emit queue) (List.length messages) in + let hashes = + List.map + (fun message -> + let msg_hash = L2_message.hash message in + Message_queue.replace state.messages msg_hash message ; + msg_hash) + messages + in + let+ () = produce_batches state ~only_full:true in + hashes + +let on_new_head state head = + let open Lwt_result_syntax in + let* simulation_ctxt = + Simulation.start_simulation ~reveal_map:None state.node_ctxt head + in + (* TODO: https://gitlab.com/tezos/tezos/-/issues/4224 + Replay with simulation may be too expensive *) + let+ simulation_ctxt, failing = + if not state.conf.simulate then return (simulation_ctxt, []) + else + (* Re-simulate one by one *) + Message_queue.fold_es + (fun msg_hash msg (simulation_ctxt, failing) -> + let*! result = simulate state.node_ctxt simulation_ctxt [msg] in + match result with + | Ok simulation_ctxt -> return (simulation_ctxt, failing) + | Error _ -> return (simulation_ctxt, msg_hash :: failing)) + state.messages + (simulation_ctxt, []) + in + state.simulation_ctxt <- Some simulation_ctxt ; + (* Forget failing messages *) + List.iter (Message_queue.remove state.messages) failing + +let init_batcher_state node_ctxt ~signer (conf : Configuration.batcher) = + let open Lwt_syntax in + let conf = + { + simulate = conf.simulate; + min_batch_elements = conf.min_batch_elements; + min_batch_size = conf.min_batch_size; + max_batch_elements = conf.max_batch_elements; + max_batch_size = + Option.value + conf.max_batch_size + ~default:Node_context.protocol_max_batch_size; + } + in + return + { + node_ctxt; + signer; + conf; + messages = Message_queue.create 100_000 (* ~ 400MB *); + batched = Batched_messages.create 100_000 (* ~ 400MB *); + simulation_ctxt = None; + } - val find_message : L2_message.hash -> L2_message.t option tzresult +module Types = struct + type nonrec state = state - val get_queue : unit -> (L2_message.hash * L2_message.t) list tzresult + type parameters = { + node_ctxt : Node_context.ro; + signer : Signature.public_key_hash; + conf : Configuration.batcher; + } +end - val register_messages : string list -> L2_message.hash list tzresult Lwt.t +module Name = struct + (* We only have a single batcher in the node *) + type t = unit - val batch : unit -> unit tzresult Lwt.t + let encoding = Data_encoding.unit - val new_head : Layer1.head -> unit tzresult Lwt.t + let base = Batcher_events.Worker.section @ ["worker"] - val shutdown : unit -> unit Lwt.t + let pp _ _ = () - val message_status : L2_message.hash -> (status * string) option tzresult + let equal () () = true end -module Make (Simulation : Simulation.S) : S = struct - let () = incr instances_count - - module PVM = Simulation.PVM +module Worker = Worker.MakeSingle (Name) (Request) (Types) - type status = Pending_batch | Batched of Injector.Inj_operation.hash +type worker = Worker.infinite Worker.queue Worker.t - (* Same as {!Configuration.batcher} with max_batch_size non optional. *) - type conf = { - simulate : bool; - min_batch_elements : int; - min_batch_size : int; - max_batch_elements : int; - max_batch_size : int; - } +module Handlers = struct + type self = worker - type state = { - node_ctxt : Node_context.ro; - signer : Signature.public_key_hash; - conf : conf; - messages : Message_queue.t; - batched : Batched_messages.t; - mutable simulation_ctxt : Simulation.t option; - } - - let message_size s = - (* Encoded as length of s on 4 bytes + s *) - 4 + String.length s + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with + | Request.Register messages -> + protect @@ fun () -> on_register state messages + | Request.Batch -> protect @@ fun () -> on_batch state + | Request.New_head head -> protect @@ fun () -> on_new_head state head - let inject_batch state (l2_messages : L2_message.t list) = - let open Lwt_result_syntax in - let messages = List.map L2_message.content l2_messages in - let operation = L1_operation.Add_messages {messages} in - let+ l1_hash = - Injector.add_pending_operation ~source:state.signer operation - in - List.iter - (fun msg -> - let content = L2_message.content msg in - let hash = L2_message.hash msg in - Batched_messages.replace state.batched hash {content; l1_hash}) - l2_messages - - let inject_batches state = List.iter_es (inject_batch state) - - let get_batches state ~only_full = - let ( current_rev_batch, - current_batch_size, - current_batch_elements, - full_batches ) = - Message_queue.fold - (fun msg_hash - message - ( current_rev_batch, - current_batch_size, - current_batch_elements, - full_batches ) -> - let size = message_size (L2_message.content message) in - let new_batch_size = current_batch_size + size in - let new_batch_elements = current_batch_elements + 1 in - if - new_batch_size <= state.conf.max_batch_size - && new_batch_elements <= state.conf.max_batch_elements - then - (* We can add the message to the current batch because we are still - within the bounds. *) - ( (msg_hash, message) :: current_rev_batch, - new_batch_size, - new_batch_elements, - full_batches ) - else - (* The batch augmented with the message would be too big but it is - below the limit without it. We finalize the current batch and - create a new one for the message. NOTE: Messages in the queue are - always < [state.conf.max_batch_size] because {!on_register} only - accepts those. *) - let batch = List.rev current_rev_batch in - ([(msg_hash, message)], size, 1, batch :: full_batches)) - state.messages - ([], 0, 0, []) - in - let batches = - if - (not only_full) - || current_batch_size >= state.conf.min_batch_size - && current_batch_elements >= state.conf.min_batch_elements - then - (* We have enough to make a batch with the last non-full batch. *) - List.rev current_rev_batch :: full_batches - else full_batches - in - List.fold_left - (fun (batches, to_remove) -> function - | [] -> (batches, to_remove) - | batch -> - let msg_hashes, batch = List.split batch in - let to_remove = List.rev_append msg_hashes to_remove in - (batch :: batches, to_remove)) - ([], []) - batches - - let produce_batches state ~only_full = - let open Lwt_result_syntax in - let batches, to_remove = get_batches state ~only_full in - match batches with - | [] -> return_unit - | _ -> - let* () = inject_batches state batches in - let*! () = - Batcher_events.(emit batched) - (List.length batches, List.length to_remove) - in - List.iter - (fun tr_hash -> Message_queue.remove state.messages tr_hash) - to_remove ; - return_unit - - let on_batch state = produce_batches state ~only_full:false - - let simulate node_ctxt simulation_ctxt (messages : L2_message.t list) = - let open Lwt_result_syntax in - let ext_messages = - List.map - (fun m -> Sc_rollup.Inbox_message.External (L2_message.content m)) - messages - in - let+ simulation_ctxt, _ticks = - Simulation.simulate_messages node_ctxt simulation_ctxt ext_messages - in - simulation_ctxt + type launch_error = error trace - let on_register state (messages : string list) = + let on_launch _w () Types.{node_ctxt; signer; conf} = let open Lwt_result_syntax in - let max_size_msg = - min - (Protocol.Constants_repr.sc_rollup_message_size_limit - + 4 (* We add 4 because [message_size] adds 4. *)) - state.conf.max_batch_size - in - let*? messages = - List.mapi_e - (fun i message -> - if message_size message > max_size_msg then - error_with "Message %d is too large (max size is %d)" i max_size_msg - else Ok (L2_message.make message)) - messages - in - let* () = - if not state.conf.simulate then return_unit - else - match state.simulation_ctxt with - | None -> failwith "Simulation context of batcher not initialized" - | Some simulation_ctxt -> - let+ simulation_ctxt = - simulate state.node_ctxt simulation_ctxt messages - in - state.simulation_ctxt <- Some simulation_ctxt - in - let*! () = Batcher_events.(emit queue) (List.length messages) in - let hashes = - List.map - (fun message -> - let msg_hash = L2_message.hash message in - Message_queue.replace state.messages msg_hash message ; - msg_hash) - messages - in - let+ () = produce_batches state ~only_full:true in - hashes + let*! state = init_batcher_state node_ctxt ~signer conf in + return state - let on_new_head state head = + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let* simulation_ctxt = - Simulation.start_simulation ~reveal_map:None state.node_ctxt head - in - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4224 - Replay with simulation may be too expensive *) - let+ simulation_ctxt, failing = - if not state.conf.simulate then return (simulation_ctxt, []) - else - (* Re-simulate one by one *) - Message_queue.fold_es - (fun msg_hash msg (simulation_ctxt, failing) -> - let*! result = simulate state.node_ctxt simulation_ctxt [msg] in - match result with - | Ok simulation_ctxt -> return (simulation_ctxt, failing) - | Error _ -> return (simulation_ctxt, msg_hash :: failing)) - state.messages - (simulation_ctxt, []) - in - state.simulation_ctxt <- Some simulation_ctxt ; - (* Forget failing messages *) - List.iter (Message_queue.remove state.messages) failing - - let init_batcher_state node_ctxt ~signer (conf : Configuration.batcher) = - let open Lwt_syntax in - let conf = - { - simulate = conf.simulate; - min_batch_elements = conf.min_batch_elements; - min_batch_size = conf.min_batch_size; - max_batch_elements = conf.max_batch_elements; - max_batch_size = - Option.value - conf.max_batch_size - ~default:Node_context.protocol_max_batch_size; - } - in - return - { - node_ctxt; - signer; - conf; - messages = Message_queue.create 100_000 (* ~ 400MB *); - batched = Batched_messages.create 100_000 (* ~ 400MB *); - simulation_ctxt = None; - } - - module Types = struct - type nonrec state = state - - type parameters = { - node_ctxt : Node_context.ro; - signer : Signature.public_key_hash; - conf : Configuration.batcher; - } - end - - module Name = struct - (* We only have a single batcher in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Batcher_events.Worker.section - @ [ - ("worker" - ^ if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Register messages -> - protect @@ fun () -> on_register state messages - | Request.Batch -> protect @@ fun () -> on_batch state - | Request.New_head head -> protect @@ fun () -> on_new_head state head - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt; signer; conf} = - let open Lwt_result_syntax in - let*! state = init_batcher_state node_ctxt ~signer conf in - return state - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Batcher_events.(emit Worker.request_failed) (request_view, st, errs) - in - return_unit + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Batcher_events.(emit Worker.request_failed) (request_view, st, errs) in - match r with - | Request.Register _ -> emit_and_return_errors errs - | Request.Batch -> emit_and_return_errors errs - | Request.New_head _ -> emit_and_return_errors errs - - let on_completion _w r _ st = - match Request.view r with - | Request.View (Register _ | New_head _) -> - Batcher_events.(emit Worker.request_completed_debug) - (Request.view r, st) - | View Batch -> - Batcher_events.(emit Worker.request_completed_notice) - (Request.view r, st) - - let on_no_request _ = Lwt.return_unit - - let on_close _w = Lwt.return_unit - end - - let table = Worker.create_table Queue - - let worker_promise, worker_waker = Lwt.task () - - let init conf ~signer node_ctxt = - let open Lwt_result_syntax in - let node_ctxt = Node_context.readonly node_ctxt in - let+ worker = - Worker.launch table () {node_ctxt; signer; conf} (module Handlers) + return_unit in - Lwt.wakeup worker_waker worker - - (* This is a batcher worker for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_batcher) - - let active () = - match Lwt.state worker_promise with - | Lwt.Return _ -> true - | Lwt.Fail _ | Lwt.Sleep -> false - - let find_message hash = - let open Result_syntax in - let+ w = Lazy.force worker in - let state = Worker.state w in - Message_queue.find_opt state.messages hash - - let get_queue () = - let open Result_syntax in - let+ w = Lazy.force worker in - let state = Worker.state w in - Message_queue.bindings state.messages - - let handle_request_error rq = - let open Lwt_syntax in - let* rq in - match rq with - | Ok res -> return_ok res - | Error (Worker.Request_error errs) -> Lwt.return_error errs - | Error (Closed None) -> Lwt.return_error [Worker_types.Terminated] - | Error (Closed (Some errs)) -> Lwt.return_error errs - | Error (Any exn) -> Lwt.return_error [Exn exn] - - let register_messages messages = - let open Lwt_result_syntax in - let*? w = Lazy.force worker in - Worker.Queue.push_request_and_wait w (Request.Register messages) - |> handle_request_error - - let batch () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no batcher, nothing to do *) - return_unit - | Ok w -> - Worker.Queue.push_request_and_wait w Request.Batch - |> handle_request_error - - let new_head b = - let open Lwt_result_syntax in - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no batcher, nothing to do *) - return_unit - | Ok w -> - let*! (_pushed : bool) = - Worker.Queue.push_request w (Request.New_head b) - in - return_unit - - let shutdown () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no batcher, nothing to do *) - Lwt.return_unit - | Ok w -> Worker.shutdown w - - let message_status state msg_hash = - match Message_queue.find_opt state.messages msg_hash with - | Some msg -> Some (Pending_batch, L2_message.content msg) - | None -> ( - match Batched_messages.find_opt state.batched msg_hash with - | Some {content; l1_hash} -> Some (Batched l1_hash, content) - | None -> None) - - let message_status msg_hash = - let open Result_syntax in - let+ w = Lazy.force worker in - let state = Worker.state w in - message_status state msg_hash + match r with + | Request.Register _ -> emit_and_return_errors errs + | Request.Batch -> emit_and_return_errors errs + | Request.New_head _ -> emit_and_return_errors errs + + let on_completion _w r _ st = + match Request.view r with + | Request.View (Register _ | New_head _) -> + Batcher_events.(emit Worker.request_completed_debug) (Request.view r, st) + | View Batch -> + Batcher_events.(emit Worker.request_completed_notice) + (Request.view r, st) + + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit end + +let table = Worker.create_table Queue + +let worker_promise, worker_waker = Lwt.task () + +let init conf ~signer node_ctxt = + let open Lwt_result_syntax in + let node_ctxt = Node_context.readonly node_ctxt in + let+ worker = + Worker.launch table () {node_ctxt; signer; conf} (module Handlers) + in + Lwt.wakeup worker_waker worker + +(* This is a batcher worker for a single scoru *) +let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_batcher) + +let active () = + match Lwt.state worker_promise with + | Lwt.Return _ -> true + | Lwt.Fail _ | Lwt.Sleep -> false + +let find_message hash = + let open Result_syntax in + let+ w = Lazy.force worker in + let state = Worker.state w in + Message_queue.find_opt state.messages hash + +let get_queue () = + let open Result_syntax in + let+ w = Lazy.force worker in + let state = Worker.state w in + Message_queue.bindings state.messages + +let handle_request_error rq = + let open Lwt_syntax in + let* rq in + match rq with + | Ok res -> return_ok res + | Error (Worker.Request_error errs) -> Lwt.return_error errs + | Error (Closed None) -> Lwt.return_error [Worker_types.Terminated] + | Error (Closed (Some errs)) -> Lwt.return_error errs + | Error (Any exn) -> Lwt.return_error [Exn exn] + +let register_messages messages = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + Worker.Queue.push_request_and_wait w (Request.Register messages) + |> handle_request_error + +let batch () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no batcher, nothing to do *) + return_unit + | Ok w -> + Worker.Queue.push_request_and_wait w Request.Batch |> handle_request_error + +let new_head b = + let open Lwt_result_syntax in + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no batcher, nothing to do *) + return_unit + | Ok w -> + let*! (_pushed : bool) = + Worker.Queue.push_request w (Request.New_head b) + in + return_unit + +let shutdown () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no batcher, nothing to do *) + Lwt.return_unit + | Ok w -> Worker.shutdown w + +let message_status state msg_hash = + match Message_queue.find_opt state.messages msg_hash with + | Some msg -> Some (Pending_batch, L2_message.content msg) + | None -> ( + match Batched_messages.find_opt state.batched msg_hash with + | Some {content; l1_hash} -> Some (Batched l1_hash, content) + | None -> None) + +let message_status msg_hash = + let open Result_syntax in + let+ w = Lazy.force worker in + let state = Worker.state w in + message_status state msg_hash diff --git a/src/proto_alpha/lib_sc_rollup_node/batcher.mli b/src/proto_alpha/lib_sc_rollup_node/batcher.mli index a6618f27bdc9..f4e9e223a647 100644 --- a/src/proto_alpha/lib_sc_rollup_node/batcher.mli +++ b/src/proto_alpha/lib_sc_rollup_node/batcher.mli @@ -26,55 +26,51 @@ open Protocol open Alpha_context -module type S = sig - (** The type for the status of messages in the batcher. *) - type status = - | Pending_batch (** The message is in the queue of the batcher. *) - | Batched of Injector.Inj_operation.hash - (** The message has already been batched and sent to the injector in an - L1 operation whose hash is given. *) +(** The type for the status of messages in the batcher. *) +type status = + | Pending_batch (** The message is in the queue of the batcher. *) + | Batched of Injector.Inj_operation.hash + (** The message has already been batched and sent to the injector in an L1 + operation whose hash is given. *) - (** [init config ~signer node_ctxt] initializes and starts the batcher for - [signer]. If [config.simulation] is [true] (the default), messages added - to the batcher are simulated in an incremental simulation context. *) - val init : - Configuration.batcher -> - signer:public_key_hash -> - _ Node_context.t -> - unit tzresult Lwt.t +(** [init config ~signer node_ctxt] initializes and starts the batcher for + [signer]. If [config.simulation] is [true] (the default), messages added to + the batcher are simulated in an incremental simulation context. *) +val init : + Configuration.batcher -> + signer:public_key_hash -> + _ Node_context.t -> + unit tzresult Lwt.t - (** Return [true] if the batcher was started for this node. *) - val active : unit -> bool +(** Return [true] if the batcher was started for this node. *) +val active : unit -> bool - (** Retrieve an L2 message from the queue. *) - val find_message : L2_message.hash -> L2_message.t option tzresult +(** Retrieve an L2 message from the queue. *) +val find_message : L2_message.hash -> L2_message.t option tzresult - (** List all queued messages in the order they appear in the queue, i.e. the - message that were added first to the queue are at the end of list. *) - val get_queue : unit -> (L2_message.hash * L2_message.t) list tzresult +(** List all queued messages in the order they appear in the queue, i.e. the + message that were added first to the queue are at the end of list. *) +val get_queue : unit -> (L2_message.hash * L2_message.t) list tzresult - (** [register_messages messages] registers new L2 [messages] in the queue of - the batcher for future injection on L1. If the batcher was initialized - with [simualte = true], the messages are evaluated the batcher's - incremental simulation context. In this case, when the application fails, - the messages are not queued. *) - val register_messages : string list -> L2_message.hash list tzresult Lwt.t +(** [register_messages messages] registers new L2 [messages] in the queue of the + batcher for future injection on L1. If the batcher was initialized with + [simualte = true], the messages are evaluated the batcher's incremental + simulation context. In this case, when the application fails, the messages + are not queued. *) +val register_messages : string list -> L2_message.hash list tzresult Lwt.t - (** Create L2 batches of operations from the queue and pack them in an L1 - batch operation. The batch operation is queued in the injector for - injection on the Tezos node. *) - val batch : unit -> unit tzresult Lwt.t +(** Create L2 batches of operations from the queue and pack them in an L1 batch + operation. The batch operation is queued in the injector for injection on + the Tezos node. *) +val batch : unit -> unit tzresult Lwt.t - (** Notify a new L2 head to the batcher worker. *) - val new_head : Layer1.head -> unit tzresult Lwt.t +(** Notify a new L2 head to the batcher worker. *) +val new_head : Layer1.head -> unit tzresult Lwt.t - (** Shutdown the batcher, waiting for the ongoing request to be processed. *) - val shutdown : unit -> unit Lwt.t +(** Shutdown the batcher, waiting for the ongoing request to be processed. *) +val shutdown : unit -> unit Lwt.t - (** The status of a message in the batcher. Returns [None] if the message is - not known by the batcher (the batcher only keeps the batched status of the - last 500000 messages). *) - val message_status : L2_message.hash -> (status * string) option tzresult -end - -module Make (Simulation : Simulation.S) : S +(** The status of a message in the batcher. Returns [None] if the message is not + known by the batcher (the batcher only keeps the batched status of the last + 500000 messages). *) +val message_status : L2_message.hash -> (status * string) option tzresult diff --git a/src/proto_alpha/lib_sc_rollup_node/components.ml b/src/proto_alpha/lib_sc_rollup_node/components.ml index 5fdb127a1175..e16320e8bf6d 100644 --- a/src/proto_alpha/lib_sc_rollup_node/components.ml +++ b/src/proto_alpha/lib_sc_rollup_node/components.ml @@ -26,9 +26,7 @@ module Make (PVM : Pvm.S) = struct module PVM = PVM - module Simulation = Simulation.Make (PVM) - module Batcher = Batcher.Make (Simulation) - module RPC_server = RPC_server.Make (Simulation) (Batcher) + module RPC_server = RPC_server.Make (PVM) end let pvm_of_kind : Protocol.Alpha_context.Sc_rollup.Kind.t -> (module Pvm.S) = diff --git a/src/proto_alpha/lib_sc_rollup_node/daemon.ml b/src/proto_alpha/lib_sc_rollup_node/daemon.ml index a5ca10e7215c..40705bd09388 100644 --- a/src/proto_alpha/lib_sc_rollup_node/daemon.ml +++ b/src/proto_alpha/lib_sc_rollup_node/daemon.ml @@ -441,8 +441,8 @@ module Make (PVM : Pvm.S) = struct let* () = Publisher.cement_commitments () in let*! () = Daemon_event.new_heads_processed reorg.new_chain in let* () = Refutation_coordinator.process stripped_head in - let* () = Components.Batcher.batch () in - let* () = Components.Batcher.new_head stripped_head in + let* () = Batcher.batch () in + let* () = Batcher.new_head stripped_head in let*! () = Injector.inject ~header:head.header () in return_unit @@ -454,7 +454,7 @@ module Make (PVM : Pvm.S) = struct let*! () = Daemon_event.degraded_mode () in let message = node_ctxt.Node_context.cctxt#message in let*! () = message "Shutting down Batcher@." in - let*! () = Components.Batcher.shutdown () in + let*! () = Batcher.shutdown () in let*! () = message "Shutting down Commitment Publisher@." in let*! () = Publisher.shutdown () in Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> @@ -471,7 +471,7 @@ module Make (PVM : Pvm.S) = struct let* () = message "Shutting down Injector@." in let* () = Injector.shutdown () in let* () = message "Shutting down Batcher@." in - let* () = Components.Batcher.shutdown () in + let* () = Batcher.shutdown () in let* () = message "Shutting down Commitment Publisher@." in let* () = Publisher.shutdown () in let* () = message "Shutting down Refutation Coordinator@." in @@ -547,8 +547,7 @@ module Make (PVM : Pvm.S) = struct node_ctxt.operators with | None -> return_unit - | Some signer -> - Components.Batcher.init configuration.batcher ~signer node_ctxt + | Some signer -> Batcher.init configuration.batcher ~signer node_ctxt in Lwt.dont_wait (fun () -> diff --git a/src/proto_alpha/lib_sc_rollup_node/simulation.ml b/src/proto_alpha/lib_sc_rollup_node/simulation.ml index 7f74c4ad9523..3070ab805392 100644 --- a/src/proto_alpha/lib_sc_rollup_node/simulation.ml +++ b/src/proto_alpha/lib_sc_rollup_node/simulation.ml @@ -25,173 +25,133 @@ open Protocol open Alpha_context - -module type S = sig - module PVM : Pvm.S - - module Fueled_pvm = Fueled_pvm.Free - - type level_position = Start | Middle | End - - type info_per_level = { - predecessor_timestamp : Timestamp.time; - predecessor : Block_hash.t; - } - - type t = { - ctxt : Context.ro; - inbox_level : Raw_level.t; - state : PVM.state; - reveal_map : string Sc_rollup_reveal_hash.Map.t option; - nb_messages_inbox : int; - level_position : level_position; - info_per_level : info_per_level; +module Fueled_pvm = Fueled_pvm.Free + +type level_position = Start | Middle | End + +type info_per_level = { + predecessor_timestamp : Timestamp.time; + predecessor : Block_hash.t; +} + +type t = { + ctxt : Context.ro; + inbox_level : Raw_level.t; + state : Context.tree; + reveal_map : string Sc_rollup_reveal_hash.Map.t option; + nb_messages_inbox : int; + level_position : level_position; + info_per_level : info_per_level; +} + +let simulate_info_per_level (node_ctxt : [`Read] Node_context.t) predecessor = + let open Lwt_result_syntax in + let* block_info = Layer1.fetch_tezos_block node_ctxt.cctxt predecessor in + let predecessor_timestamp = block_info.header.shell.timestamp in + return {predecessor_timestamp; predecessor} + +let start_simulation node_ctxt ~reveal_map (Layer1.{hash; level} as head) = + let open Lwt_result_syntax in + let*? level = Environment.wrap_tzresult @@ Raw_level.of_int32 level in + let*? () = + error_unless + Raw_level.(level >= node_ctxt.Node_context.genesis_info.level) + (Exn (Failure "Cannot simulate before origination level")) + in + let first_inbox_level = Raw_level.succ node_ctxt.genesis_info.level in + let* ctxt = + if Raw_level.(level < first_inbox_level) then + (* This is before we have interpreted the boot sector, so we start + with an empty context in genesis *) + return (Context.empty node_ctxt.context) + else Node_context.checkout_context node_ctxt hash + in + let* ctxt, state = Interpreter.state_of_head node_ctxt ctxt head in + let+ info_per_level = simulate_info_per_level node_ctxt hash in + let inbox_level = Raw_level.succ level in + { + ctxt; + inbox_level; + state; + reveal_map; + nb_messages_inbox = 0; + level_position = Start; + info_per_level; } - val start_simulation : - Node_context.ro -> - reveal_map:string Sc_rollup_reveal_hash.Map.t option -> - Layer1.head -> - t tzresult Lwt.t - - val simulate_messages : - Node_context.ro -> - t -> - Sc_rollup.Inbox_message.t list -> - (t * Z.t) tzresult Lwt.t - - val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t -end - -module Make (PVM : Pvm.S) : S with module PVM = PVM = struct - module PVM = PVM - module Fueled_pvm = Fueled_pvm.Free - - type level_position = Start | Middle | End - - type info_per_level = { - predecessor_timestamp : Timestamp.time; - predecessor : Block_hash.t; - } - - type t = { - ctxt : Context.ro; - inbox_level : Raw_level.t; - state : PVM.state; - reveal_map : string Sc_rollup_reveal_hash.Map.t option; - nb_messages_inbox : int; - level_position : level_position; - info_per_level : info_per_level; - } - - let simulate_info_per_level (node_ctxt : [`Read] Node_context.t) predecessor = - let open Lwt_result_syntax in - let* block_info = Layer1.fetch_tezos_block node_ctxt.cctxt predecessor in - let predecessor_timestamp = block_info.header.shell.timestamp in - return {predecessor_timestamp; predecessor} - - let start_simulation node_ctxt ~reveal_map (Layer1.{hash; level} as head) = - let open Lwt_result_syntax in - let*? level = Environment.wrap_tzresult @@ Raw_level.of_int32 level in - let*? () = - error_unless - Raw_level.(level >= node_ctxt.Node_context.genesis_info.level) - (Exn (Failure "Cannot simulate before origination level")) - in - let first_inbox_level = Raw_level.succ node_ctxt.genesis_info.level in - let* ctxt = - if Raw_level.(level < first_inbox_level) then - (* This is before we have interpreted the boot sector, so we start - with an empty context in genesis *) - return (Context.empty node_ctxt.context) - else Node_context.checkout_context node_ctxt hash - in - let* ctxt, state = Interpreter.state_of_head node_ctxt ctxt head in - let+ info_per_level = simulate_info_per_level node_ctxt hash in - let inbox_level = Raw_level.succ level in - { - ctxt; - inbox_level; - state; - reveal_map; - nb_messages_inbox = 0; - level_position = Start; - info_per_level; - } - - let simulate_messages_no_checks (node_ctxt : Node_context.ro) - ({ - ctxt; - state; - inbox_level; - reveal_map; - nb_messages_inbox; - level_position = _; - info_per_level = _; - } as sim) messages = - let open Lwt_result_syntax in - let*! state_hash = PVM.state_hash state in - let*! tick = PVM.get_tick state in - let eval_state = - Fueled_pvm. - { - state; - state_hash; - tick; - inbox_level; - message_counter_offset = nb_messages_inbox; - remaining_fuel = Fuel.Free.of_ticks 0L; - remaining_messages = messages; - } - in - (* Build new state *) - let* eval_result = - Fueled_pvm.eval_messages ?reveal_map node_ctxt eval_state - in - let Fueled_pvm.{state = {state; _}; num_ticks; num_messages; _} = - Delayed_write_monad.ignore eval_result - in - let*! ctxt = PVM.State.set ctxt state in - let nb_messages_inbox = nb_messages_inbox + num_messages in - return ({sim with ctxt; state; nb_messages_inbox}, num_ticks) - - let simulate_messages (node_ctxt : Node_context.ro) sim messages = - let open Lwt_result_syntax in - (* Build new inbox *) - let*? () = - error_when - (sim.level_position = End) - (Exn (Failure "Level for simulation is ended")) - in - let*? () = - error_when - (messages = []) - (Environment.wrap_tzerror Sc_rollup_errors.Sc_rollup_add_zero_messages) - in - let messages = - if sim.level_position = Start then - let {predecessor_timestamp; predecessor} = sim.info_per_level in - let open Sc_rollup.Inbox_message in - Internal Start_of_level - :: Internal (Info_per_level {predecessor_timestamp; predecessor}) - :: messages - else messages - in - let+ sim, num_ticks = simulate_messages_no_checks node_ctxt sim messages in - ({sim with level_position = Middle}, num_ticks) - - let end_simulation node_ctxt sim = - let open Lwt_result_syntax in - let*? () = - error_when - (sim.level_position = End) - (Exn (Failure "Level for simulation is ended")) - in - let+ sim, num_ticks = - simulate_messages_no_checks - node_ctxt - sim - [Sc_rollup.Inbox_message.Internal End_of_level] - in - ({sim with level_position = End}, num_ticks) -end +let simulate_messages_no_checks (node_ctxt : Node_context.ro) + ({ + ctxt; + state; + inbox_level; + reveal_map; + nb_messages_inbox; + level_position = _; + info_per_level = _; + } as sim) messages = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! state_hash = PVM.state_hash state in + let*! tick = PVM.get_tick state in + let eval_state = + Fueled_pvm. + { + state; + state_hash; + tick; + inbox_level; + message_counter_offset = nb_messages_inbox; + remaining_fuel = Fuel.Free.of_ticks 0L; + remaining_messages = messages; + } + in + (* Build new state *) + let* eval_result = + Fueled_pvm.eval_messages ?reveal_map node_ctxt eval_state + in + let Fueled_pvm.{state = {state; _}; num_ticks; num_messages; _} = + Delayed_write_monad.ignore eval_result + in + let*! ctxt = PVM.State.set ctxt state in + let nb_messages_inbox = nb_messages_inbox + num_messages in + return ({sim with ctxt; state; nb_messages_inbox}, num_ticks) + +let simulate_messages (node_ctxt : Node_context.ro) sim messages = + let open Lwt_result_syntax in + (* Build new inbox *) + let*? () = + error_when + (sim.level_position = End) + (Exn (Failure "Level for simulation is ended")) + in + let*? () = + error_when + (messages = []) + (Environment.wrap_tzerror Sc_rollup_errors.Sc_rollup_add_zero_messages) + in + let messages = + if sim.level_position = Start then + let {predecessor_timestamp; predecessor} = sim.info_per_level in + let open Sc_rollup.Inbox_message in + Internal Start_of_level + :: Internal (Info_per_level {predecessor_timestamp; predecessor}) + :: messages + else messages + in + let+ sim, num_ticks = simulate_messages_no_checks node_ctxt sim messages in + ({sim with level_position = Middle}, num_ticks) + +let end_simulation node_ctxt sim = + let open Lwt_result_syntax in + let*? () = + error_when + (sim.level_position = End) + (Exn (Failure "Level for simulation is ended")) + in + let+ sim, num_ticks = + simulate_messages_no_checks + node_ctxt + sim + [Sc_rollup.Inbox_message.Internal End_of_level] + in + ({sim with level_position = End}, num_ticks) diff --git a/src/proto_alpha/lib_sc_rollup_node/simulation.mli b/src/proto_alpha/lib_sc_rollup_node/simulation.mli index 23378f7ccc02..317a8809e097 100644 --- a/src/proto_alpha/lib_sc_rollup_node/simulation.mli +++ b/src/proto_alpha/lib_sc_rollup_node/simulation.mli @@ -25,52 +25,44 @@ open Protocol open Protocol.Alpha_context +module Fueled_pvm = Fueled_pvm.Free -module type S = sig - module PVM : Pvm.S +type level_position = Start | Middle | End - module Fueled_pvm = Fueled_pvm.Free +type info_per_level = { + predecessor_timestamp : Timestamp.time; + predecessor : Block_hash.t; +} - type level_position = Start | Middle | End +(** Type of the state for a simulation. *) +type t = { + ctxt : Context.ro; + inbox_level : Raw_level.t; + state : Context.tree; + reveal_map : string Sc_rollup_reveal_hash.Map.t option; + nb_messages_inbox : int; + level_position : level_position; + info_per_level : info_per_level; +} - type info_per_level = { - predecessor_timestamp : Timestamp.time; - predecessor : Block_hash.t; - } +(** [start_simulation node_ctxt reveal_source block] starts a new simulation {e + on top} of [block], i.e. for an hypothetical new inbox (level). *) +val start_simulation : + Node_context.ro -> + reveal_map:string Sc_rollup_reveal_hash.Map.t option -> + Layer1.head -> + t tzresult Lwt.t - (** Type of the state for a simulation. *) - type t = { - ctxt : Context.ro; - inbox_level : Raw_level.t; - state : PVM.state; - reveal_map : string Sc_rollup_reveal_hash.Map.t option; - nb_messages_inbox : int; - level_position : level_position; - info_per_level : info_per_level; - } +(** [simulate_messages node_ctxt sim messages] runs a simulation of new + [messages] in the given simulation (state) [sim] and returns a new + simulation state, the remaining fuel (when [?fuel] is provided) and the + number of ticks that happened. *) +val simulate_messages : + Node_context.ro -> + t -> + Sc_rollup.Inbox_message.t list -> + (t * Z.t) tzresult Lwt.t - (** [start_simulation node_ctxt reveal_source block] starts a new simulation - {e on top} of [block], i.e. for an hypothetical new inbox (level). *) - val start_simulation : - Node_context.ro -> - reveal_map:string Sc_rollup_reveal_hash.Map.t option -> - Layer1.head -> - t tzresult Lwt.t - - (** [simulate_messages node_ctxt sim messages] runs a simulation of new - [messages] in the given simulation (state) [sim] and returns a new - simulation state, the remaining fuel (when [?fuel] is provided) and the - number of ticks that happened. *) - val simulate_messages : - Node_context.ro -> - t -> - Sc_rollup.Inbox_message.t list -> - (t * Z.t) tzresult Lwt.t - - (** [end_simulation node_ctxt sim] adds and [End_of_level] message and marks - the simulation as ended. *) - val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t -end - -(** Functor to construct a simulator for a given PVM. *) -module Make (PVM : Pvm.S) : S with module PVM = PVM +(** [end_simulation node_ctxt sim] adds and [End_of_level] message and marks the + simulation as ended. *) +val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t -- GitLab From 1c6367f0c9e3643ae680404b66318d5068a0ddf7 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 19:39:42 +0200 Subject: [PATCH 08/13] SCORU/Node: defunctorize outbox --- .../lib_sc_rollup_node/RPC_server.ml | 2 - src/proto_alpha/lib_sc_rollup_node/outbox.ml | 63 +++++++++---------- src/proto_alpha/lib_sc_rollup_node/outbox.mli | 14 ++--- 3 files changed, 37 insertions(+), 42 deletions(-) diff --git a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml index 509eaf6f7791..5e068d86589d 100644 --- a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml +++ b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml @@ -54,8 +54,6 @@ let get_dal_processed_slots node_ctxt block = Node_context.list_slots_statuses node_ctxt ~confirmed_in_block_hash:block module Make (PVM : Pvm.S) = struct - module Outbox = Outbox.Make (PVM) - module Global_directory = Make_directory (struct include Sc_rollup_services.Global diff --git a/src/proto_alpha/lib_sc_rollup_node/outbox.ml b/src/proto_alpha/lib_sc_rollup_node/outbox.ml index 8b539af74ef6..a76f94397d5e 100644 --- a/src/proto_alpha/lib_sc_rollup_node/outbox.ml +++ b/src/proto_alpha/lib_sc_rollup_node/outbox.ml @@ -26,39 +26,38 @@ open Node_context open Protocol.Alpha_context -module Make (PVM : Pvm.S) = struct - let get_state_of_lcc node_ctxt = - let open Lwt_result_syntax in - let lcc = Reference.get node_ctxt.lcc in - let* block_hash = - Node_context.hash_of_level node_ctxt (Raw_level.to_int32 lcc.level) - in - let* ctxt = Node_context.checkout_context node_ctxt block_hash in - let*! state = PVM.State.find ctxt in - return state +let get_state_of_lcc node_ctxt = + let open Lwt_result_syntax in + let lcc = Reference.get node_ctxt.lcc in + let* block_hash = + Node_context.hash_of_level node_ctxt (Raw_level.to_int32 lcc.level) + in + let* ctxt = Node_context.checkout_context node_ctxt block_hash in + let*! state = Context.PVMState.find ctxt in + return state - let proof_of_output node_ctxt output = - let open Lwt_result_syntax in - let* state = get_state_of_lcc node_ctxt in - let lcc = Reference.get node_ctxt.lcc in - match state with - | None -> - (* +let proof_of_output node_ctxt output = + let open Lwt_result_syntax in + let* state = get_state_of_lcc node_ctxt in + let lcc = Reference.get node_ctxt.lcc in + match state with + | None -> + (* This case should never happen as origination creates an LCC which must have been considered by the rollup node at startup time. *) - failwith "Error producing outbox proof (no cemented state in the node)" - | Some state -> ( - let*! proof = PVM.produce_output_proof node_ctxt.context state output in - match proof with - | Ok proof -> - let serialized_proof = - Data_encoding.Binary.to_string_exn PVM.output_proof_encoding proof - in - return @@ (lcc.commitment, serialized_proof) - | Error err -> - failwith - "Error producing outbox proof (%a)" - Environment.Error_monad.pp - err) -end + failwith "Error producing outbox proof (no cemented state in the node)" + | Some state -> ( + let module PVM = (val node_ctxt.pvm) in + let*! proof = PVM.produce_output_proof node_ctxt.context state output in + match proof with + | Ok proof -> + let serialized_proof = + Data_encoding.Binary.to_string_exn PVM.output_proof_encoding proof + in + return @@ (lcc.commitment, serialized_proof) + | Error err -> + failwith + "Error producing outbox proof (%a)" + Environment.Error_monad.pp + err) diff --git a/src/proto_alpha/lib_sc_rollup_node/outbox.mli b/src/proto_alpha/lib_sc_rollup_node/outbox.mli index 613661e456a7..71e8c4a1f28d 100644 --- a/src/proto_alpha/lib_sc_rollup_node/outbox.mli +++ b/src/proto_alpha/lib_sc_rollup_node/outbox.mli @@ -27,11 +27,9 @@ open Protocol.Alpha_context -module Make (PVM : Pvm.S) : sig - (** [proof_of_output node_ctxt output] returns the last cemented commitment - hash and the proof of the output in the LCC. *) - val proof_of_output : - Node_context.rw -> - Sc_rollup.output -> - (Sc_rollup.Commitment.Hash.t * string) tzresult Lwt.t -end +(** [proof_of_output node_ctxt output] returns the last cemented commitment hash + and the proof of the output in the LCC. *) +val proof_of_output : + Node_context.rw -> + Sc_rollup.output -> + (Sc_rollup.Commitment.Hash.t * string) tzresult Lwt.t -- GitLab From e2f94ebe40daaaa7880c014a4fe204a7d36b5c01 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 19:43:04 +0200 Subject: [PATCH 09/13] SCORU/Node: defunctorize RPC server --- .../lib_sc_rollup_node/RPC_server.ml | 842 +++++++++--------- .../lib_sc_rollup_node/RPC_server.mli | 17 +- .../lib_sc_rollup_node/components.ml | 1 - src/proto_alpha/lib_sc_rollup_node/daemon.ml | 4 +- 4 files changed, 427 insertions(+), 437 deletions(-) diff --git a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml index 5e068d86589d..ad948a1a6d6a 100644 --- a/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml +++ b/src/proto_alpha/lib_sc_rollup_node/RPC_server.ml @@ -53,292 +53,290 @@ end let get_dal_processed_slots node_ctxt block = Node_context.list_slots_statuses node_ctxt ~confirmed_in_block_hash:block -module Make (PVM : Pvm.S) = struct - module Global_directory = Make_directory (struct - include Sc_rollup_services.Global +module Global_directory = Make_directory (struct + include Sc_rollup_services.Global - type context = Node_context.ro + type context = Node_context.ro - let context_of_prefix node_ctxt () = - return (Node_context.readonly node_ctxt) - end) + let context_of_prefix node_ctxt () = return (Node_context.readonly node_ctxt) +end) - module Proof_helpers_directory = Make_directory (struct - include Sc_rollup_services.Global.Helpers +module Proof_helpers_directory = Make_directory (struct + include Sc_rollup_services.Global.Helpers - (* The context needs to be accessed with write permissions because we need to - commit on disk to generate the proofs. *) - type context = Node_context.rw + (* The context needs to be accessed with write permissions because we need to + commit on disk to generate the proofs. *) + type context = Node_context.rw - let context_of_prefix node_ctxt () = return node_ctxt - end) + let context_of_prefix node_ctxt () = return node_ctxt +end) - module Local_directory = Make_directory (struct - include Sc_rollup_services.Local +module Local_directory = Make_directory (struct + include Sc_rollup_services.Local - type context = Node_context.ro + type context = Node_context.ro - let context_of_prefix node_ctxt () = - return (Node_context.readonly node_ctxt) - end) + let context_of_prefix node_ctxt () = return (Node_context.readonly node_ctxt) +end) - module Block_directory = Make_directory (struct - include Sc_rollup_services.Global.Block +module Block_directory = Make_directory (struct + include Sc_rollup_services.Global.Block - type context = Node_context.ro * Block_hash.t + type context = Node_context.ro * Block_hash.t - let context_of_prefix node_ctxt (((), block) : prefix) = - let open Lwt_result_syntax in - let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in - (Node_context.readonly node_ctxt, block) - end) - - module Outbox_directory = Make_directory (struct - include Sc_rollup_services.Global.Block.Outbox - - type context = Node_context.ro * Block_hash.t * Alpha_context.Raw_level.t + let context_of_prefix node_ctxt (((), block) : prefix) = + let open Lwt_result_syntax in + let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in + (Node_context.readonly node_ctxt, block) +end) - let context_of_prefix node_ctxt (((), block), level) = - let open Lwt_result_syntax in - let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in - (Node_context.readonly node_ctxt, block, level) - end) +module Outbox_directory = Make_directory (struct + include Sc_rollup_services.Global.Block.Outbox - module Common = struct - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.block - @@ fun (node_ctxt, block) () () -> - Node_context.get_full_l2_block node_ctxt block + type context = Node_context.ro * Block_hash.t * Alpha_context.Raw_level.t - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.num_messages - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* l2_block = Node_context.get_l2_block node_ctxt block in - let+ num_messages = - Node_context.get_num_messages node_ctxt l2_block.header.inbox_witness - in - Z.of_int num_messages - - let () = - Global_directory.register0 Sc_rollup_services.Global.sc_rollup_address - @@ fun node_ctxt () () -> return @@ node_ctxt.rollup_address - - let () = - Global_directory.register0 Sc_rollup_services.Global.current_tezos_head - @@ fun node_ctxt () () -> get_head_hash_opt node_ctxt - - let () = - Global_directory.register0 Sc_rollup_services.Global.current_tezos_level - @@ fun node_ctxt () () -> get_head_level_opt node_ctxt - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.hash - @@ fun (_node_ctxt, block) () () -> return block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.level - @@ fun (node_ctxt, block) () () -> - Node_context.level_of_hash node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.inbox - @@ fun (node_ctxt, block) () () -> - Node_context.get_inbox_by_block_hash node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.ticks - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let+ l2_block = Node_context.get_l2_block node_ctxt block in - Z.of_int64 l2_block.num_ticks - end - - let get_state (node_ctxt : _ Node_context.t) block_hash = + let context_of_prefix node_ctxt (((), block), level) = let open Lwt_result_syntax in - let* ctxt = Node_context.checkout_context node_ctxt block_hash in - let*! state = PVM.State.find ctxt in - match state with None -> failwith "No state" | Some state -> return state - - let simulate_messages (node_ctxt : Node_context.ro) block ~reveal_pages - messages = - let open Lwt_result_syntax in - let open Alpha_context in - let reveal_map = - match reveal_pages with - | Some pages -> - let map = - List.fold_left - (fun map page -> - let hash = - Sc_rollup_reveal_hash.(hash_string ~scheme:Blake2B [page]) - in - Sc_rollup_reveal_hash.Map.add hash page map) - Sc_rollup_reveal_hash.Map.empty - pages - in - Some map - | None -> None - in - let* level = Node_context.level_of_hash node_ctxt block in - let* sim = - Simulation.start_simulation - node_ctxt - ~reveal_map - Layer1.{hash = block; level} - in - let messages = - List.map (fun m -> Sc_rollup.Inbox_message.External m) messages - in - let* sim, num_ticks_0 = - Simulation.simulate_messages node_ctxt sim messages - in - let* {state; inbox_level; _}, num_ticks_end = - Simulation.end_simulation node_ctxt sim - in - let num_ticks = Z.(num_ticks_0 + num_ticks_end) in - let*! outbox = PVM.get_outbox inbox_level state in - let output = - List.filter - (fun Sc_rollup.{outbox_level; _} -> outbox_level = inbox_level) - outbox - in - let*! state_hash = PVM.state_hash state in - let*! status = PVM.get_status state in - let status = PVM.string_of_status status in - return - Sc_rollup_services.{state_hash; status; output; inbox_level; num_ticks} + let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in + (Node_context.readonly node_ctxt, block, level) +end) +module Common = struct let () = - Block_directory.register0 Sc_rollup_services.Global.Block.total_ticks + Block_directory.register0 Sc_rollup_services.Global.Block.block @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! tick = PVM.get_tick state in - return tick + Node_context.get_full_l2_block node_ctxt block let () = - Block_directory.register0 Sc_rollup_services.Global.Block.state_hash + Block_directory.register0 Sc_rollup_services.Global.Block.num_messages @@ fun (node_ctxt, block) () () -> let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! hash = PVM.state_hash state in - return hash + let* l2_block = Node_context.get_l2_block node_ctxt block in + let+ num_messages = + Node_context.get_num_messages node_ctxt l2_block.header.inbox_witness + in + Z.of_int num_messages let () = - Block_directory.register0 - Sc_rollup_services.Global.Block.state_current_level - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! current_level = PVM.get_current_level state in - return current_level + Global_directory.register0 Sc_rollup_services.Global.sc_rollup_address + @@ fun node_ctxt () () -> return @@ node_ctxt.rollup_address let () = - Block_directory.register0 Sc_rollup_services.Global.Block.state_value - @@ fun (node_ctxt, block) {key} () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let path = String.split_on_char '/' key in - let*! value = PVM.State.lookup state path in - match value with - | None -> failwith "No such key in PVM state" - | Some value -> - Format.eprintf "Encoded %S\n@.%!" (Bytes.to_string value) ; - return value + Global_directory.register0 Sc_rollup_services.Global.current_tezos_head + @@ fun node_ctxt () () -> get_head_hash_opt node_ctxt let () = - Global_directory.register0 Sc_rollup_services.Global.last_stored_commitment - @@ fun node_ctxt () () -> - let open Lwt_result_syntax in - let* head = Node_context.last_processed_head_opt node_ctxt in - match head with - | None -> return_none - | Some head -> - let commitment_hash = - Sc_rollup_block.most_recent_commitment head.header - in - let+ commitment = - Node_context.find_commitment node_ctxt commitment_hash - in - Option.map (fun c -> (c, commitment_hash)) commitment + Global_directory.register0 Sc_rollup_services.Global.current_tezos_level + @@ fun node_ctxt () () -> get_head_level_opt node_ctxt let () = - Local_directory.register0 Sc_rollup_services.Local.last_published_commitment - @@ fun node_ctxt () () -> - let open Lwt_result_syntax in - match Reference.get node_ctxt.lpc with - | None -> return_none - | Some commitment -> - let hash = - Alpha_context.Sc_rollup.Commitment.hash_uncarbonated commitment - in - (* The corresponding level in Store.Commitments.published_at_level is - available only when the commitment has been published and included - in a block. *) - let* published_at_level_info = - Node_context.commitment_published_at_level node_ctxt hash - in - let first_published, published = - match published_at_level_info with - | None -> (None, None) - | Some {first_published_at_level; published_at_level} -> - (Some first_published_at_level, published_at_level) - in - return_some (commitment, hash, first_published, published) + Block_directory.register0 Sc_rollup_services.Global.Block.hash + @@ fun (_node_ctxt, block) () () -> return block let () = - Block_directory.register0 Sc_rollup_services.Global.Block.status + Block_directory.register0 Sc_rollup_services.Global.Block.level @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! status = PVM.get_status state in - return (PVM.string_of_status status) + Node_context.level_of_hash node_ctxt block let () = - Block_directory.register0 Sc_rollup_services.Global.Block.dal_slots + Block_directory.register0 Sc_rollup_services.Global.Block.inbox @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* slots = - Node_context.get_all_slot_headers node_ctxt ~published_in_block_hash:block - in - return slots + Node_context.get_inbox_by_block_hash node_ctxt block let () = - Block_directory.register0 - Sc_rollup_services.Global.Block.dal_processed_slots - @@ fun (node_ctxt, block) () () -> get_dal_processed_slots node_ctxt block - - let () = - Outbox_directory.register0 Sc_rollup_services.Global.Block.Outbox.messages - @@ fun (node_ctxt, block, outbox_level) () () -> + Block_directory.register0 Sc_rollup_services.Global.Block.ticks + @@ fun (node_ctxt, block) () () -> let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! outbox = PVM.get_outbox outbox_level state in - return outbox + let+ l2_block = Node_context.get_l2_block node_ctxt block in + Z.of_int64 l2_block.num_ticks +end - let () = - Proof_helpers_directory.register0 - Sc_rollup_services.Global.Helpers.outbox_proof - @@ fun node_ctxt output () -> Outbox.proof_of_output node_ctxt output +let get_state (node_ctxt : _ Node_context.t) block_hash = + let open Lwt_result_syntax in + let* ctxt = Node_context.checkout_context node_ctxt block_hash in + let*! state = Context.PVMState.find ctxt in + match state with None -> failwith "No state" | Some state -> return state - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.simulate - @@ fun (node_ctxt, block) () {messages; reveal_pages} -> - simulate_messages node_ctxt block ~reveal_pages messages +let simulate_messages (node_ctxt : Node_context.ro) block ~reveal_pages messages + = + let open Lwt_result_syntax in + let open Alpha_context in + let module PVM = (val node_ctxt.pvm) in + let reveal_map = + match reveal_pages with + | Some pages -> + let map = + List.fold_left + (fun map page -> + let hash = + Sc_rollup_reveal_hash.(hash_string ~scheme:Blake2B [page]) + in + Sc_rollup_reveal_hash.Map.add hash page map) + Sc_rollup_reveal_hash.Map.empty + pages + in + Some map + | None -> None + in + let* level = Node_context.level_of_hash node_ctxt block in + let* sim = + Simulation.start_simulation + node_ctxt + ~reveal_map + Layer1.{hash = block; level} + in + let messages = + List.map (fun m -> Sc_rollup.Inbox_message.External m) messages + in + let* sim, num_ticks_0 = Simulation.simulate_messages node_ctxt sim messages in + let* {state; inbox_level; _}, num_ticks_end = + Simulation.end_simulation node_ctxt sim + in + let num_ticks = Z.(num_ticks_0 + num_ticks_end) in + let*! outbox = PVM.get_outbox inbox_level state in + let output = + List.filter + (fun Sc_rollup.{outbox_level; _} -> outbox_level = inbox_level) + outbox + in + let*! state_hash = PVM.state_hash state in + let*! status = PVM.get_status state in + let status = PVM.string_of_status status in + return Sc_rollup_services.{state_hash; status; output; inbox_level; num_ticks} + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.total_ticks + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! tick = PVM.get_tick state in + return tick + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.state_hash + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! hash = PVM.state_hash state in + return hash + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.state_current_level + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! current_level = PVM.get_current_level state in + return current_level + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.state_value + @@ fun (node_ctxt, block) {key} () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let path = String.split_on_char '/' key in + let*! value = Context.PVMState.lookup state path in + match value with + | None -> failwith "No such key in PVM state" + | Some value -> + Format.eprintf "Encoded %S\n@.%!" (Bytes.to_string value) ; + return value + +let () = + Global_directory.register0 Sc_rollup_services.Global.last_stored_commitment + @@ fun node_ctxt () () -> + let open Lwt_result_syntax in + let* head = Node_context.last_processed_head_opt node_ctxt in + match head with + | None -> return_none + | Some head -> + let commitment_hash = + Sc_rollup_block.most_recent_commitment head.header + in + let+ commitment = + Node_context.find_commitment node_ctxt commitment_hash + in + Option.map (fun c -> (c, commitment_hash)) commitment - let () = - Local_directory.register0 Sc_rollup_services.Local.injection - @@ fun _node_ctxt () messages -> Batcher.register_messages messages +let () = + Local_directory.register0 Sc_rollup_services.Local.last_published_commitment + @@ fun node_ctxt () () -> + let open Lwt_result_syntax in + match Reference.get node_ctxt.lpc with + | None -> return_none + | Some commitment -> + let hash = + Alpha_context.Sc_rollup.Commitment.hash_uncarbonated commitment + in + (* The corresponding level in Store.Commitments.published_at_level is + available only when the commitment has been published and included + in a block. *) + let* published_at_level_info = + Node_context.commitment_published_at_level node_ctxt hash + in + let first_published, published = + match published_at_level_info with + | None -> (None, None) + | Some {first_published_at_level; published_at_level} -> + (Some first_published_at_level, published_at_level) + in + return_some (commitment, hash, first_published, published) - let () = - Local_directory.register0 Sc_rollup_services.Local.batcher_queue - @@ fun _node_ctxt () () -> - let open Lwt_result_syntax in - let*? queue = Batcher.get_queue () in - return queue +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.status + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! status = PVM.get_status state in + return (PVM.string_of_status status) + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.dal_slots + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* slots = + Node_context.get_all_slot_headers node_ctxt ~published_in_block_hash:block + in + return slots + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.dal_processed_slots + @@ fun (node_ctxt, block) () () -> get_dal_processed_slots node_ctxt block + +let () = + Outbox_directory.register0 Sc_rollup_services.Global.Block.Outbox.messages + @@ fun (node_ctxt, block, outbox_level) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! outbox = PVM.get_outbox outbox_level state in + return outbox + +let () = + Proof_helpers_directory.register0 + Sc_rollup_services.Global.Helpers.outbox_proof + @@ fun node_ctxt output () -> Outbox.proof_of_output node_ctxt output + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.simulate + @@ fun (node_ctxt, block) () {messages; reveal_pages} -> + simulate_messages node_ctxt block ~reveal_pages messages + +let () = + Local_directory.register0 Sc_rollup_services.Local.injection + @@ fun _node_ctxt () messages -> Batcher.register_messages messages + +let () = + Local_directory.register0 Sc_rollup_services.Local.batcher_queue + @@ fun _node_ctxt () () -> + let open Lwt_result_syntax in + let*? queue = Batcher.get_queue () in + return queue - (** [commitment_level_of_inbox_level node_ctxt inbox_level] returns the level +(** [commitment_level_of_inbox_level node_ctxt inbox_level] returns the level of the commitment which should include the inbox of level [inbox_level]. @@ -350,185 +348,181 @@ module Make (PVM : Pvm.S) = struct * commitment_period) v} *) - let commitment_level_of_inbox_level (node_ctxt : _ Node_context.t) inbox_level - = - let open Alpha_context in - let open Option_syntax in - let+ last_published_commitment = Reference.get node_ctxt.lpc in - let commitment_period = - Int32.of_int - node_ctxt.protocol_constants.parametric.sc_rollup - .commitment_period_in_blocks - in - let last_published = - Raw_level.to_int32 last_published_commitment.inbox_level - in - let open Int32 in - div (sub last_published inbox_level) commitment_period - |> mul commitment_period |> sub last_published |> Raw_level.of_int32_exn - - let inbox_info_of_level (node_ctxt : _ Node_context.t) inbox_level = - let open Alpha_context in - let open Lwt_result_syntax in - let+ finalized_level = Node_context.get_finalized_level node_ctxt in - let finalized = Compare.Int32.(inbox_level <= finalized_level) in - let lcc = Reference.get node_ctxt.lcc in - let cemented = - Compare.Int32.(inbox_level <= Raw_level.to_int32 lcc.level) - in - (finalized, cemented) - - let () = - Local_directory.register1 Sc_rollup_services.Local.batcher_message - @@ fun node_ctxt hash () () -> - let open Lwt_result_syntax in - let*? batch_status = Batcher.message_status hash in - let* status = - match batch_status with - | None -> return (None, Sc_rollup_services.Unknown) - | Some (batch_status, msg) -> ( - let return status = return (Some msg, status) in - match batch_status with - | Pending_batch -> return Sc_rollup_services.Pending_batch - | Batched l1_hash -> ( - match Injector.operation_status l1_hash with - | None -> return Sc_rollup_services.Unknown - | Some (Pending op) -> - return (Sc_rollup_services.Pending_injection op) - | Some (Injected {op; oph; op_index}) -> - return - (Sc_rollup_services.Injected - {op = op.operation; oph; op_index}) - | Some (Included {op; oph; op_index; l1_block; l1_level}) -> ( - let* finalized, cemented = - inbox_info_of_level node_ctxt l1_level - in - let commitment_level = - commitment_level_of_inbox_level node_ctxt l1_level - in - match commitment_level with - | None -> - return - (Sc_rollup_services.Included - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - }) - | Some commitment_level -> ( - let* block = - Node_context.find_l2_block_by_level - node_ctxt - (Alpha_context.Raw_level.to_int32 commitment_level) - in - match block with - | None -> - (* Commitment not computed yet for inbox *) - return - (Sc_rollup_services.Included - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - }) - | Some block -> ( - let commitment_hash = - WithExceptions.Option.get - ~loc:__LOC__ - block.header.commitment_hash - in - (* Commitment computed *) - let* published_at = - Node_context.commitment_published_at_level - node_ctxt - commitment_hash - in - match published_at with - | None | Some {published_at_level = None; _} -> - (* Commitment not published yet *) - return - (Sc_rollup_services.Included - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - }) - | Some - { - first_published_at_level; - published_at_level = Some published_at_level; - } -> - (* Commitment published *) - let* commitment = - Node_context.get_commitment - node_ctxt - commitment_hash - in - return - (Sc_rollup_services.Committed - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - commitment; - commitment_hash; - first_published_at_level; - published_at_level; - })))))) - in - - return status - - let register (node_ctxt : _ Node_context.t) = - let module PVM = (val Pvm_rpc.of_kind node_ctxt.kind) in - List.fold_left - (fun dir f -> Tezos_rpc.Directory.merge dir (f node_ctxt)) - Tezos_rpc.Directory.empty - [ - Global_directory.build_directory; - Local_directory.build_directory; - Block_directory.build_directory; - Proof_helpers_directory.build_directory; - Outbox_directory.build_directory; - PVM.build_directory; - ] - - let start node_ctxt configuration = - let open Lwt_result_syntax in - let Configuration.{rpc_addr; rpc_port; _} = configuration in - let rpc_addr = P2p_addr.of_string_exn rpc_addr in - let host = Ipaddr.V6.to_string rpc_addr in - let node = `TCP (`Port rpc_port) in - let acl = RPC_server.Acl.allow_all in - let dir = register node_ctxt in - let server = - RPC_server.init_server dir ~acl ~media_types:Media_type.all_media_types - in - protect @@ fun () -> - let*! () = - RPC_server.launch - ~host - server - ~callback:(RPC_server.resto_callback server) - node - in - return server - - let shutdown = RPC_server.shutdown -end +let commitment_level_of_inbox_level (node_ctxt : _ Node_context.t) inbox_level = + let open Alpha_context in + let open Option_syntax in + let+ last_published_commitment = Reference.get node_ctxt.lpc in + let commitment_period = + Int32.of_int + node_ctxt.protocol_constants.parametric.sc_rollup + .commitment_period_in_blocks + in + let last_published = + Raw_level.to_int32 last_published_commitment.inbox_level + in + let open Int32 in + div (sub last_published inbox_level) commitment_period + |> mul commitment_period |> sub last_published |> Raw_level.of_int32_exn + +let inbox_info_of_level (node_ctxt : _ Node_context.t) inbox_level = + let open Alpha_context in + let open Lwt_result_syntax in + let+ finalized_level = Node_context.get_finalized_level node_ctxt in + let finalized = Compare.Int32.(inbox_level <= finalized_level) in + let lcc = Reference.get node_ctxt.lcc in + let cemented = Compare.Int32.(inbox_level <= Raw_level.to_int32 lcc.level) in + (finalized, cemented) + +let () = + Local_directory.register1 Sc_rollup_services.Local.batcher_message + @@ fun node_ctxt hash () () -> + let open Lwt_result_syntax in + let*? batch_status = Batcher.message_status hash in + let* status = + match batch_status with + | None -> return (None, Sc_rollup_services.Unknown) + | Some (batch_status, msg) -> ( + let return status = return (Some msg, status) in + match batch_status with + | Pending_batch -> return Sc_rollup_services.Pending_batch + | Batched l1_hash -> ( + match Injector.operation_status l1_hash with + | None -> return Sc_rollup_services.Unknown + | Some (Pending op) -> + return (Sc_rollup_services.Pending_injection op) + | Some (Injected {op; oph; op_index}) -> + return + (Sc_rollup_services.Injected + {op = op.operation; oph; op_index}) + | Some (Included {op; oph; op_index; l1_block; l1_level}) -> ( + let* finalized, cemented = + inbox_info_of_level node_ctxt l1_level + in + let commitment_level = + commitment_level_of_inbox_level node_ctxt l1_level + in + match commitment_level with + | None -> + return + (Sc_rollup_services.Included + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + }) + | Some commitment_level -> ( + let* block = + Node_context.find_l2_block_by_level + node_ctxt + (Alpha_context.Raw_level.to_int32 commitment_level) + in + match block with + | None -> + (* Commitment not computed yet for inbox *) + return + (Sc_rollup_services.Included + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + }) + | Some block -> ( + let commitment_hash = + WithExceptions.Option.get + ~loc:__LOC__ + block.header.commitment_hash + in + (* Commitment computed *) + let* published_at = + Node_context.commitment_published_at_level + node_ctxt + commitment_hash + in + match published_at with + | None | Some {published_at_level = None; _} -> + (* Commitment not published yet *) + return + (Sc_rollup_services.Included + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + }) + | Some + { + first_published_at_level; + published_at_level = Some published_at_level; + } -> + (* Commitment published *) + let* commitment = + Node_context.get_commitment + node_ctxt + commitment_hash + in + return + (Sc_rollup_services.Committed + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + commitment; + commitment_hash; + first_published_at_level; + published_at_level; + })))))) + in + + return status + +let register (node_ctxt : _ Node_context.t) = + let module PVM = (val Pvm_rpc.of_kind node_ctxt.kind) in + List.fold_left + (fun dir f -> Tezos_rpc.Directory.merge dir (f node_ctxt)) + Tezos_rpc.Directory.empty + [ + Global_directory.build_directory; + Local_directory.build_directory; + Block_directory.build_directory; + Proof_helpers_directory.build_directory; + Outbox_directory.build_directory; + PVM.build_directory; + ] + +let start node_ctxt configuration = + let open Lwt_result_syntax in + let Configuration.{rpc_addr; rpc_port; _} = configuration in + let rpc_addr = P2p_addr.of_string_exn rpc_addr in + let host = Ipaddr.V6.to_string rpc_addr in + let node = `TCP (`Port rpc_port) in + let acl = RPC_server.Acl.allow_all in + let dir = register node_ctxt in + let server = + RPC_server.init_server dir ~acl ~media_types:Media_type.all_media_types + in + protect @@ fun () -> + let*! () = + RPC_server.launch + ~host + server + ~callback:(RPC_server.resto_callback server) + node + in + return server + +let shutdown = RPC_server.shutdown diff --git a/src/proto_alpha/lib_sc_rollup_node/RPC_server.mli b/src/proto_alpha/lib_sc_rollup_node/RPC_server.mli index 7de28ecef022..7830dad2505f 100644 --- a/src/proto_alpha/lib_sc_rollup_node/RPC_server.mli +++ b/src/proto_alpha/lib_sc_rollup_node/RPC_server.mli @@ -25,14 +25,11 @@ open Tezos_rpc_http_server -(** Functor to construct an RPC server for a given PVM with simulation. *) -module Make (PVM : Pvm.S) : sig - (** [start node_ctxt config] starts an RPC server listening for requests on - the port [config.rpc_port] and address [config.rpc_addr]. *) - val start : - Node_context.rw -> Configuration.t -> RPC_server.server tzresult Lwt.t +(** [start node_ctxt config] starts an RPC server listening for requests on the + port [config.rpc_port] and address [config.rpc_addr]. *) +val start : + Node_context.rw -> Configuration.t -> RPC_server.server tzresult Lwt.t - (** Shutdown a running RPC server. When this function is called, the rollup - node will stop listening to incoming requests. *) - val shutdown : RPC_server.server -> unit Lwt.t -end +(** Shutdown a running RPC server. When this function is called, the rollup node + will stop listening to incoming requests. *) +val shutdown : RPC_server.server -> unit Lwt.t diff --git a/src/proto_alpha/lib_sc_rollup_node/components.ml b/src/proto_alpha/lib_sc_rollup_node/components.ml index e16320e8bf6d..141cfdb25e71 100644 --- a/src/proto_alpha/lib_sc_rollup_node/components.ml +++ b/src/proto_alpha/lib_sc_rollup_node/components.ml @@ -26,7 +26,6 @@ module Make (PVM : Pvm.S) = struct module PVM = PVM - module RPC_server = RPC_server.Make (PVM) end let pvm_of_kind : Protocol.Alpha_context.Sc_rollup.Kind.t -> (module Pvm.S) = diff --git a/src/proto_alpha/lib_sc_rollup_node/daemon.ml b/src/proto_alpha/lib_sc_rollup_node/daemon.ml index 40705bd09388..290739bedf7e 100644 --- a/src/proto_alpha/lib_sc_rollup_node/daemon.ml +++ b/src/proto_alpha/lib_sc_rollup_node/daemon.ml @@ -467,7 +467,7 @@ module Make (PVM : Pvm.S) = struct Lwt_exit.register_clean_up_callback ~loc:__LOC__ @@ fun exit_status -> let message = node_ctxt.Node_context.cctxt#message in let* () = message "Shutting down RPC server@." in - let* () = Components.RPC_server.shutdown rpc_server in + let* () = RPC_server.shutdown rpc_server in let* () = message "Shutting down Injector@." in let* () = Injector.shutdown () in let* () = message "Shutting down Batcher@." in @@ -502,7 +502,7 @@ module Make (PVM : Pvm.S) = struct let run node_ctxt configuration = let open Lwt_result_syntax in let* () = check_initial_state_hash node_ctxt in - let* rpc_server = Components.RPC_server.start node_ctxt configuration in + let* rpc_server = RPC_server.start node_ctxt configuration in let (_ : Lwt_exit.clean_up_callback_id) = install_finalizer node_ctxt rpc_server in -- GitLab From 31c880eb036ab60b6e2dddea3f847ace743e4daa Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 19:45:11 +0200 Subject: [PATCH 10/13] SCORU/Node: defunctorize daemon --- .../lib_sc_rollup_node/components.ml | 34 - src/proto_alpha/lib_sc_rollup_node/daemon.ml | 1097 ++++++++--------- 2 files changed, 538 insertions(+), 593 deletions(-) delete mode 100644 src/proto_alpha/lib_sc_rollup_node/components.ml diff --git a/src/proto_alpha/lib_sc_rollup_node/components.ml b/src/proto_alpha/lib_sc_rollup_node/components.ml deleted file mode 100644 index 141cfdb25e71..000000000000 --- a/src/proto_alpha/lib_sc_rollup_node/components.ml +++ /dev/null @@ -1,34 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* Copyright (c) 2022 Trili Tech, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -module Make (PVM : Pvm.S) = struct - module PVM = PVM -end - -let pvm_of_kind : Protocol.Alpha_context.Sc_rollup.Kind.t -> (module Pvm.S) = - function - | Example_arith -> (module Arith_pvm) - | Wasm_2_0_0 -> (module Wasm_2_0_0_pvm) diff --git a/src/proto_alpha/lib_sc_rollup_node/daemon.ml b/src/proto_alpha/lib_sc_rollup_node/daemon.ml index 290739bedf7e..082adf54406b 100644 --- a/src/proto_alpha/lib_sc_rollup_node/daemon.ml +++ b/src/proto_alpha/lib_sc_rollup_node/daemon.ml @@ -25,581 +25,301 @@ (* *) (*****************************************************************************) -module Make (PVM : Pvm.S) = struct - module Components = Components.Make (PVM) - open Protocol - open Alpha_context - open Apply_results +open Protocol +open Alpha_context +open Apply_results - (** Returns [Some c] if [their_commitment] is refutable where [c] is our +(** Returns [Some c] if [their_commitment] is refutable where [c] is our commitment for the same inbox level. *) - let is_refutable_commitment node_ctxt - (their_commitment : Sc_rollup.Commitment.t) their_commitment_hash = - let open Lwt_result_syntax in - let* l2_block = - Node_context.get_l2_block_by_level - node_ctxt - (Raw_level.to_int32 their_commitment.inbox_level) - in - let* our_commitment_and_hash = - Option.filter_map_es - (fun hash -> - let+ commitment = Node_context.find_commitment node_ctxt hash in - Option.map (fun c -> (c, hash)) commitment) - l2_block.header.commitment_hash - in - match our_commitment_and_hash with - | Some (our_commitment, our_commitment_hash) - when Sc_rollup.Commitment.Hash.( - their_commitment_hash <> our_commitment_hash - && their_commitment.predecessor = our_commitment.predecessor) -> - return our_commitment_and_hash - | _ -> return_none +let is_refutable_commitment node_ctxt + (their_commitment : Sc_rollup.Commitment.t) their_commitment_hash = + let open Lwt_result_syntax in + let* l2_block = + Node_context.get_l2_block_by_level + node_ctxt + (Raw_level.to_int32 their_commitment.inbox_level) + in + let* our_commitment_and_hash = + Option.filter_map_es + (fun hash -> + let+ commitment = Node_context.find_commitment node_ctxt hash in + Option.map (fun c -> (c, hash)) commitment) + l2_block.header.commitment_hash + in + match our_commitment_and_hash with + | Some (our_commitment, our_commitment_hash) + when Sc_rollup.Commitment.Hash.( + their_commitment_hash <> our_commitment_hash + && their_commitment.predecessor = our_commitment.predecessor) -> + return our_commitment_and_hash + | _ -> return_none - (** Publish a commitment when an accuser node sees a refutable commitment. *) - let accuser_publish_commitment_when_refutable node_ctxt ~other rollup - their_commitment their_commitment_hash = - let open Lwt_result_syntax in - when_ (Node_context.is_accuser node_ctxt) @@ fun () -> - (* We are seeing a commitment from someone else. We check if we agree - with it, otherwise the accuser publishes our commitment in order to - play the refutation game. *) - let* refutable = - is_refutable_commitment node_ctxt their_commitment their_commitment_hash - in - match refutable with - | None -> return_unit - | Some (our_commitment, our_commitment_hash) -> - let*! () = - Refutation_game_event.potential_conflict_detected - ~our_commitment_hash - ~their_commitment_hash - ~level:their_commitment.inbox_level - ~other - in - assert (Sc_rollup.Address.(node_ctxt.rollup_address = rollup)) ; - Publisher.publish_single_commitment node_ctxt our_commitment +(** Publish a commitment when an accuser node sees a refutable commitment. *) +let accuser_publish_commitment_when_refutable node_ctxt ~other rollup + their_commitment their_commitment_hash = + let open Lwt_result_syntax in + when_ (Node_context.is_accuser node_ctxt) @@ fun () -> + (* We are seeing a commitment from someone else. We check if we agree + with it, otherwise the accuser publishes our commitment in order to + play the refutation game. *) + let* refutable = + is_refutable_commitment node_ctxt their_commitment their_commitment_hash + in + match refutable with + | None -> return_unit + | Some (our_commitment, our_commitment_hash) -> + let*! () = + Refutation_game_event.potential_conflict_detected + ~our_commitment_hash + ~their_commitment_hash + ~level:their_commitment.inbox_level + ~other + in + assert (Sc_rollup.Address.(node_ctxt.rollup_address = rollup)) ; + Publisher.publish_single_commitment node_ctxt our_commitment - (** Process an L1 SCORU operation (for the node's rollup) which is included +(** Process an L1 SCORU operation (for the node's rollup) which is included for the first time. {b Note}: this function does not process inboxes for the rollup, which is done instead by {!Inbox.process_head}. *) - let process_included_l1_operation (type kind) (node_ctxt : Node_context.rw) - (head : Layer1.header) ~source (operation : kind manager_operation) - (result : kind successful_manager_operation_result) = - let open Lwt_result_syntax in - match (operation, result) with - | ( Sc_rollup_publish {commitment; _}, - Sc_rollup_publish_result {published_at_level; _} ) - when Node_context.is_operator node_ctxt source -> - (* Published commitment --------------------------------------------- *) - let save_lpc = - match Reference.get node_ctxt.lpc with - | None -> true - | Some lpc -> Raw_level.(commitment.inbox_level >= lpc.inbox_level) - in - if save_lpc then Reference.set node_ctxt.lpc (Some commitment) ; - let commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated commitment - in - let* () = - Node_context.set_commitment_published_at_level - node_ctxt - commitment_hash - { - first_published_at_level = published_at_level; - published_at_level = - Some (Raw_level.of_int32_exn head.Layer1.level); - } - in - let*! () = - Commitment_event.last_published_commitment_updated - commitment_hash - (Raw_level.of_int32_exn head.Layer1.level) - in - return_unit - | ( Sc_rollup_publish {commitment = their_commitment; rollup}, - Sc_rollup_publish_result - {published_at_level; staked_hash = their_commitment_hash; _} ) -> - (* Commitment published by someone else *) - (* We first register the publication information *) - let* known_commitment = - Node_context.commitment_exists node_ctxt their_commitment_hash - in - let* () = - if not known_commitment then return_unit +let process_included_l1_operation (type kind) (node_ctxt : Node_context.rw) + (head : Layer1.header) ~source (operation : kind manager_operation) + (result : kind successful_manager_operation_result) = + let open Lwt_result_syntax in + match (operation, result) with + | ( Sc_rollup_publish {commitment; _}, + Sc_rollup_publish_result {published_at_level; _} ) + when Node_context.is_operator node_ctxt source -> + (* Published commitment --------------------------------------------- *) + let save_lpc = + match Reference.get node_ctxt.lpc with + | None -> true + | Some lpc -> Raw_level.(commitment.inbox_level >= lpc.inbox_level) + in + if save_lpc then Reference.set node_ctxt.lpc (Some commitment) ; + let commitment_hash = Sc_rollup.Commitment.hash_uncarbonated commitment in + let* () = + Node_context.set_commitment_published_at_level + node_ctxt + commitment_hash + { + first_published_at_level = published_at_level; + published_at_level = Some (Raw_level.of_int32_exn head.Layer1.level); + } + in + let*! () = + Commitment_event.last_published_commitment_updated + commitment_hash + (Raw_level.of_int32_exn head.Layer1.level) + in + return_unit + | ( Sc_rollup_publish {commitment = their_commitment; rollup}, + Sc_rollup_publish_result + {published_at_level; staked_hash = their_commitment_hash; _} ) -> + (* Commitment published by someone else *) + (* We first register the publication information *) + let* known_commitment = + Node_context.commitment_exists node_ctxt their_commitment_hash + in + let* () = + if not known_commitment then return_unit + else + let* republication = + Node_context.commitment_was_published + node_ctxt + ~source:Anyone + their_commitment_hash + in + if republication then return_unit else - let* republication = - Node_context.commitment_was_published + let* () = + Node_context.set_commitment_published_at_level node_ctxt - ~source:Anyone their_commitment_hash + { + first_published_at_level = published_at_level; + published_at_level = None; + } in - if republication then return_unit - else - let* () = - Node_context.set_commitment_published_at_level - node_ctxt - their_commitment_hash - { - first_published_at_level = published_at_level; - published_at_level = None; - } - in - return_unit - in - (* An accuser node will publish its commitment if the other one is - refutable. *) - accuser_publish_commitment_when_refutable - node_ctxt - ~other:source - rollup - their_commitment - their_commitment_hash - | ( Sc_rollup_cement _, - Sc_rollup_cement_result {inbox_level; commitment_hash; _} ) -> - (* Cemented commitment ---------------------------------------------- *) - let* inbox_block = - Node_context.get_l2_block_by_level - node_ctxt - (Raw_level.to_int32 inbox_level) - in - let*? () = - (* We stop the node if we disagree with a cemented commitment *) - error_unless - (Option.equal - Sc_rollup.Commitment.Hash.( = ) - inbox_block.header.commitment_hash - (Some commitment_hash)) - (Sc_rollup_node_errors.Disagree_with_cemented - { - inbox_level; - ours = inbox_block.header.commitment_hash; - on_l1 = commitment_hash; - }) - in - let lcc = Reference.get node_ctxt.lcc in - let*! () = - if Raw_level.(inbox_level > lcc.level) then ( - Reference.set - node_ctxt.lcc - {commitment = commitment_hash; level = inbox_level} ; - Commitment_event.last_cemented_commitment_updated - commitment_hash - inbox_level) - else Lwt.return_unit - in - return_unit - | ( Sc_rollup_refute _, - Sc_rollup_refute_result {game_status = Ended end_status; _} ) - | ( Sc_rollup_timeout _, - Sc_rollup_timeout_result {game_status = Ended end_status; _} ) -> ( - match end_status with - | Loser {loser; _} when Node_context.is_operator node_ctxt loser -> - tzfail (Sc_rollup_node_errors.Lost_game end_status) - | Loser _ -> - (* Other player lost *) return_unit - | Draw -> - let stakers = - match operation with - | Sc_rollup_refute {opponent; _} -> [source; opponent] - | Sc_rollup_timeout {stakers = {alice; bob}; _} -> [alice; bob] - | _ -> assert false - in - fail_when - (List.exists (Node_context.is_operator node_ctxt) stakers) - (Sc_rollup_node_errors.Lost_game end_status)) - | Dal_publish_slot_header _, Dal_publish_slot_header_result {slot_header; _} - when Node_context.dal_supported node_ctxt -> - let* () = - Node_context.save_slot_header - node_ctxt - ~published_in_block_hash:head.Layer1.hash - slot_header - in - return_unit - | _, _ -> - (* Other manager operations *) - return_unit - - let process_l1_operation (type kind) node_ctxt (head : Layer1.header) ~source - (operation : kind manager_operation) - (result : kind Apply_results.manager_operation_result) = - let open Lwt_result_syntax in - let is_for_my_rollup : type kind. kind manager_operation -> bool = function - | Sc_rollup_add_messages _ -> true - | Sc_rollup_cement {rollup; _} - | Sc_rollup_publish {rollup; _} - | Sc_rollup_refute {rollup; _} - | Sc_rollup_timeout {rollup; _} - | Sc_rollup_execute_outbox_message {rollup; _} - | Sc_rollup_recover_bond {sc_rollup = rollup; staker = _} -> - Sc_rollup.Address.(rollup = node_ctxt.Node_context.rollup_address) - | Dal_publish_slot_header _ -> true - | Reveal _ | Transaction _ | Origination _ | Delegation _ - | Update_consensus_key _ | Register_global_constant _ - | Set_deposits_limit _ | Increase_paid_storage _ | Transfer_ticket _ - | Sc_rollup_originate _ | Zk_rollup_origination _ | Zk_rollup_publish _ - | Zk_rollup_update _ -> - false - in - if not (is_for_my_rollup operation) then return_unit - else - (* Only look at operations that are for the node's rollup *) - let*! () = Daemon_event.included_operation operation result in - match result with - | Applied success_result -> - process_included_l1_operation - node_ctxt - head - ~source - operation - success_result - | _ -> - (* No action for non successful operations *) + in + (* An accuser node will publish its commitment if the other one is + refutable. *) + accuser_publish_commitment_when_refutable + node_ctxt + ~other:source + rollup + their_commitment + their_commitment_hash + | ( Sc_rollup_cement _, + Sc_rollup_cement_result {inbox_level; commitment_hash; _} ) -> + (* Cemented commitment ---------------------------------------------- *) + let* inbox_block = + Node_context.get_l2_block_by_level + node_ctxt + (Raw_level.to_int32 inbox_level) + in + let*? () = + (* We stop the node if we disagree with a cemented commitment *) + error_unless + (Option.equal + Sc_rollup.Commitment.Hash.( = ) + inbox_block.header.commitment_hash + (Some commitment_hash)) + (Sc_rollup_node_errors.Disagree_with_cemented + { + inbox_level; + ours = inbox_block.header.commitment_hash; + on_l1 = commitment_hash; + }) + in + let lcc = Reference.get node_ctxt.lcc in + let*! () = + if Raw_level.(inbox_level > lcc.level) then ( + Reference.set + node_ctxt.lcc + {commitment = commitment_hash; level = inbox_level} ; + Commitment_event.last_cemented_commitment_updated + commitment_hash + inbox_level) + else Lwt.return_unit + in + return_unit + | ( Sc_rollup_refute _, + Sc_rollup_refute_result {game_status = Ended end_status; _} ) + | ( Sc_rollup_timeout _, + Sc_rollup_timeout_result {game_status = Ended end_status; _} ) -> ( + match end_status with + | Loser {loser; _} when Node_context.is_operator node_ctxt loser -> + tzfail (Sc_rollup_node_errors.Lost_game end_status) + | Loser _ -> + (* Other player lost *) return_unit + | Draw -> + let stakers = + match operation with + | Sc_rollup_refute {opponent; _} -> [source; opponent] + | Sc_rollup_timeout {stakers = {alice; bob}; _} -> [alice; bob] + | _ -> assert false + in + fail_when + (List.exists (Node_context.is_operator node_ctxt) stakers) + (Sc_rollup_node_errors.Lost_game end_status)) + | Dal_publish_slot_header _, Dal_publish_slot_header_result {slot_header; _} + when Node_context.dal_supported node_ctxt -> + let* () = + Node_context.save_slot_header + node_ctxt + ~published_in_block_hash:head.Layer1.hash + slot_header + in + return_unit + | _, _ -> + (* Other manager operations *) + return_unit - let process_l1_block_operations node_ctxt (head : Layer1.header) = - let open Lwt_result_syntax in - let* block = - Layer1.fetch_tezos_block node_ctxt.Node_context.cctxt head.hash - in - let apply (type kind) accu ~source (operation : kind manager_operation) - result = - let open Lwt_result_syntax in - let* () = accu in - process_l1_operation node_ctxt head ~source operation result - in - let apply_internal (type kind) accu ~source:_ - (_operation : kind Apply_internal_results.internal_operation) - (_result : kind Apply_internal_results.internal_operation_result) = - accu - in - let* () = - Layer1_services.process_manager_operations +let process_l1_operation (type kind) node_ctxt (head : Layer1.header) ~source + (operation : kind manager_operation) + (result : kind Apply_results.manager_operation_result) = + let open Lwt_result_syntax in + let is_for_my_rollup : type kind. kind manager_operation -> bool = function + | Sc_rollup_add_messages _ -> true + | Sc_rollup_cement {rollup; _} + | Sc_rollup_publish {rollup; _} + | Sc_rollup_refute {rollup; _} + | Sc_rollup_timeout {rollup; _} + | Sc_rollup_execute_outbox_message {rollup; _} + | Sc_rollup_recover_bond {sc_rollup = rollup; staker = _} -> + Sc_rollup.Address.(rollup = node_ctxt.Node_context.rollup_address) + | Dal_publish_slot_header _ -> true + | Reveal _ | Transaction _ | Origination _ | Delegation _ + | Update_consensus_key _ | Register_global_constant _ | Set_deposits_limit _ + | Increase_paid_storage _ | Transfer_ticket _ | Sc_rollup_originate _ + | Zk_rollup_origination _ | Zk_rollup_publish _ | Zk_rollup_update _ -> + false + in + if not (is_for_my_rollup operation) then return_unit + else + (* Only look at operations that are for the node's rollup *) + let*! () = Daemon_event.included_operation operation result in + match result with + | Applied success_result -> + process_included_l1_operation + node_ctxt + head + ~source + operation + success_result + | _ -> + (* No action for non successful operations *) return_unit - block.operations - {apply; apply_internal} - in - return_unit - let before_origination (node_ctxt : _ Node_context.t) (header : Layer1.header) +let process_l1_block_operations node_ctxt (head : Layer1.header) = + let open Lwt_result_syntax in + let* block = + Layer1.fetch_tezos_block node_ctxt.Node_context.cctxt head.hash + in + let apply (type kind) accu ~source (operation : kind manager_operation) result = - let origination_level = Raw_level.to_int32 node_ctxt.genesis_info.level in - header.level < origination_level - - let previous_context (node_ctxt : _ Node_context.t) - ~(predecessor : Layer1.header) = - let open Lwt_result_syntax in - if predecessor.level < Raw_level.to_int32 node_ctxt.genesis_info.level then - (* This is before we have interpreted the boot sector, so we start - with an empty context in genesis *) - return (Context.empty node_ctxt.context) - else Node_context.checkout_context node_ctxt predecessor.Layer1.hash - - let rec process_head (node_ctxt : _ Node_context.t) (head : Layer1.header) = - let open Lwt_result_syntax in - let* already_processed = Node_context.is_processed node_ctxt head.hash in - unless (already_processed || before_origination node_ctxt head) @@ fun () -> - let*! () = Daemon_event.head_processing head.hash head.level in - let* predecessor = Node_context.get_predecessor_header_opt node_ctxt head in - match predecessor with - | None -> - (* Predecessor not available on the L1, which means the block does not - exist in the chain. *) - return_unit - | Some predecessor -> - let* () = process_head node_ctxt predecessor in - let* ctxt = previous_context node_ctxt ~predecessor in - let* () = - Node_context.save_level - node_ctxt - {Layer1.hash = head.hash; level = head.level} - in - let* inbox_hash, inbox, inbox_witness, messages = - Inbox.process_head node_ctxt ~predecessor head - in - let* () = - when_ (Node_context.dal_supported node_ctxt) @@ fun () -> - Dal_slots_tracker.process_head node_ctxt (Layer1.head_of_header head) - in - let* () = process_l1_block_operations node_ctxt head in - (* Avoid storing and publishing commitments if the head is not final. *) - (* Avoid triggering the pvm execution if this has been done before for - this head. *) - let* ctxt, _num_messages, num_ticks, initial_tick = - Interpreter.process_head - node_ctxt - ctxt - ~predecessor - head - (inbox, messages) - in - let*! context_hash = Context.commit ctxt in - let* commitment_hash = - Publisher.process_head - node_ctxt - ~predecessor:predecessor.hash - head - ctxt - in - let level = Raw_level.of_int32_exn head.level in - let* previous_commitment_hash = - if level = node_ctxt.genesis_info.Sc_rollup.Commitment.level then - (* Previous commitment for rollup genesis is itself. *) - return node_ctxt.genesis_info.Sc_rollup.Commitment.commitment_hash - else - let+ pred = Node_context.get_l2_block node_ctxt predecessor.hash in - Sc_rollup_block.most_recent_commitment pred.header - in - let header = - Sc_rollup_block. - { - block_hash = head.hash; - level; - predecessor = predecessor.hash; - commitment_hash; - previous_commitment_hash; - context = context_hash; - inbox_witness; - inbox_hash; - } - in - let l2_block = - Sc_rollup_block.{header; content = (); num_ticks; initial_tick} - in - let* () = - Node_context.mark_finalized_level - node_ctxt - Int32.(sub head.level (of_int node_ctxt.block_finality_time)) - in - let* () = Node_context.save_l2_head node_ctxt l2_block in - let*! () = Daemon_event.new_head_processed head.hash head.level in - return_unit - - (* [on_layer_1_head node_ctxt head] processes a new head from the L1. It - also processes any missing blocks that were not processed. *) - let on_layer_1_head node_ctxt (head : Layer1.header) = - let open Lwt_result_syntax in - let* old_head = Node_context.last_processed_head_opt node_ctxt in - let old_head = - match old_head with - | Some h -> - `Head - Layer1. - { - hash = h.header.block_hash; - level = Raw_level.to_int32 h.header.level; - } - | None -> - (* if no head has been processed yet, we want to handle all blocks - since, and including, the rollup origination. *) - let origination_level = - Raw_level.to_int32 node_ctxt.genesis_info.level - in - `Level (Int32.pred origination_level) - in - let stripped_head = Layer1.head_of_header head in - let*! reorg = - Node_context.get_tezos_reorg_for_new_head node_ctxt old_head stripped_head - in - let*? reorg = - match reorg with - | Error trace - when TzTrace.fold - (fun yes error -> - yes - || - match error with - | Octez_crawler.Layer_1.Cannot_find_predecessor _ -> true - | _ -> false) - false - trace -> - (* The reorganization could not be computed entirely because of missing - info on the Layer 1. We fallback to a recursive process_head. *) - Ok {Reorg.no_reorg with new_chain = [stripped_head]} - | _ -> reorg - in - (* TODO: https://gitlab.com/tezos/tezos/-/issues/3348 - Rollback state information on reorganization, i.e. for - reorg.old_chain. *) - let*! () = Daemon_event.processing_heads_iteration reorg.new_chain in - let get_header Layer1.{hash; level} = - if Block_hash.equal hash head.hash then return head - else - let+ header = Layer1.fetch_tezos_shell_header node_ctxt.cctxt hash in - {Layer1.hash; level; header} - in - let* () = - List.iter_es - (fun block -> - let* header = get_header block in - process_head node_ctxt header) - reorg.new_chain - in - let* () = Publisher.publish_commitments () in - let* () = Publisher.cement_commitments () in - let*! () = Daemon_event.new_heads_processed reorg.new_chain in - let* () = Refutation_coordinator.process stripped_head in - let* () = Batcher.batch () in - let* () = Batcher.new_head stripped_head in - let*! () = Injector.inject ~header:head.header () in - return_unit - - let daemonize (node_ctxt : _ Node_context.t) = - Layer1.iter_heads node_ctxt.l1_ctxt (on_layer_1_head node_ctxt) - - let degraded_refutation_mode (node_ctxt : _ Node_context.t) = let open Lwt_result_syntax in - let*! () = Daemon_event.degraded_mode () in - let message = node_ctxt.Node_context.cctxt#message in - let*! () = message "Shutting down Batcher@." in - let*! () = Batcher.shutdown () in - let*! () = message "Shutting down Commitment Publisher@." in - let*! () = Publisher.shutdown () in - Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> - let* () = Refutation_coordinator.process (Layer1.head_of_header head) in - let*! () = Injector.inject () in - return_unit - - let install_finalizer node_ctxt rpc_server = - let open Lwt_syntax in - Lwt_exit.register_clean_up_callback ~loc:__LOC__ @@ fun exit_status -> - let message = node_ctxt.Node_context.cctxt#message in - let* () = message "Shutting down RPC server@." in - let* () = RPC_server.shutdown rpc_server in - let* () = message "Shutting down Injector@." in - let* () = Injector.shutdown () in - let* () = message "Shutting down Batcher@." in - let* () = Batcher.shutdown () in - let* () = message "Shutting down Commitment Publisher@." in - let* () = Publisher.shutdown () in - let* () = message "Shutting down Refutation Coordinator@." in - let* () = Refutation_coordinator.shutdown () in - let* (_ : unit tzresult) = Node_context.close node_ctxt in - let* () = Event.shutdown_node exit_status in - Tezos_base_unix.Internal_event_unix.close () + let* () = accu in + process_l1_operation node_ctxt head ~source operation result + in + let apply_internal (type kind) accu ~source:_ + (_operation : kind Apply_internal_results.internal_operation) + (_result : kind Apply_internal_results.internal_operation_result) = + accu + in + let* () = + Layer1_services.process_manager_operations + return_unit + block.operations + {apply; apply_internal} + in + return_unit - let check_initial_state_hash {Node_context.cctxt; rollup_address; _} = - let open Lwt_result_syntax in - let* l1_reference_initial_state_hash = - RPC.Sc_rollup.initial_pvm_state_hash - cctxt - (cctxt#chain, cctxt#block) - rollup_address - in - let*! s = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! l2_initial_state_hash = PVM.state_hash s in - fail_unless - Sc_rollup.State_hash.( - l1_reference_initial_state_hash = l2_initial_state_hash) - (Sc_rollup_node_errors.Wrong_initial_pvm_state - { - initial_state_hash = l2_initial_state_hash; - expected_state_hash = l1_reference_initial_state_hash; - }) +let before_origination (node_ctxt : _ Node_context.t) (header : Layer1.header) = + let origination_level = Raw_level.to_int32 node_ctxt.genesis_info.level in + header.level < origination_level - let run node_ctxt configuration = - let open Lwt_result_syntax in - let* () = check_initial_state_hash node_ctxt in - let* rpc_server = RPC_server.start node_ctxt configuration in - let (_ : Lwt_exit.clean_up_callback_id) = - install_finalizer node_ctxt rpc_server - in - let start () = - let*! () = Inbox.start () in - let signers = - Configuration.Operator_purpose_map.bindings node_ctxt.operators - |> List.fold_left - (fun acc (purpose, operator) -> - let purposes = - match Signature.Public_key_hash.Map.find operator acc with - | None -> [purpose] - | Some ps -> purpose :: ps - in - Signature.Public_key_hash.Map.add operator purposes acc) - Signature.Public_key_hash.Map.empty - |> Signature.Public_key_hash.Map.bindings - |> List.map (fun (operator, purposes) -> - let strategy = - match purposes with - | [Configuration.Add_messages] -> `Delay_block 0.5 - | _ -> `Each_block - in - (operator, strategy, purposes)) - in - let* () = Publisher.init node_ctxt in - let* () = Refutation_coordinator.init node_ctxt in - let* () = - unless (signers = []) @@ fun () -> - Injector.init - node_ctxt.cctxt - (Node_context.readonly node_ctxt) - ~data_dir:node_ctxt.data_dir - ~signers - ~retention_period:configuration.injector.retention_period - ~allowed_attempts:configuration.injector.attempts - in - let* () = - match - Configuration.Operator_purpose_map.find - Add_messages - node_ctxt.operators - with - | None -> return_unit - | Some signer -> Batcher.init configuration.batcher ~signer node_ctxt - in - Lwt.dont_wait - (fun () -> - let*! r = Metrics.metrics_serve configuration.metrics_addr in - match r with - | Ok () -> Lwt.return_unit - | Error err -> - Event.(metrics_ended (Format.asprintf "%a" pp_print_trace err))) - (fun exn -> Event.(metrics_ended_dont_wait (Printexc.to_string exn))) ; - - let*! () = - Event.node_is_ready - ~rpc_addr:configuration.rpc_addr - ~rpc_port:configuration.rpc_port - in - daemonize node_ctxt - in - Metrics.Info.init_rollup_node_info - ~id:configuration.sc_rollup_address - ~mode:configuration.mode - ~genesis_level:(Raw_level.to_int32 node_ctxt.genesis_info.level) - ~pvm_kind:(Sc_rollup.Kind.to_string node_ctxt.kind) ; - protect start ~on_error:(function - | Sc_rollup_node_errors.( - Lost_game _ | Unparsable_boot_sector _ | Invalid_genesis_state _) - :: _ as e -> - Format.eprintf "%!%a@.Exiting.@." pp_print_trace e ; - let*! _ = Lwt_exit.exit_and_wait 1 in - return_unit - | e -> - let*! () = Daemon_event.error e in - degraded_refutation_mode node_ctxt) +let previous_context (node_ctxt : _ Node_context.t) + ~(predecessor : Layer1.header) = + let open Lwt_result_syntax in + if predecessor.level < Raw_level.to_int32 node_ctxt.genesis_info.level then + (* This is before we have interpreted the boot sector, so we start + with an empty context in genesis *) + return (Context.empty node_ctxt.context) + else Node_context.checkout_context node_ctxt predecessor.Layer1.hash - module Internal_for_tests = struct - (** Same as {!process_head} but only builds and stores the L2 block - corresponding to [messages]. It is used by the unit tests to build an L2 - chain. *) - let process_messages (node_ctxt : _ Node_context.t) ~is_first_block - ~predecessor head messages = - let open Lwt_result_syntax in +let rec process_head (node_ctxt : _ Node_context.t) (head : Layer1.header) = + let open Lwt_result_syntax in + let* already_processed = Node_context.is_processed node_ctxt head.hash in + unless (already_processed || before_origination node_ctxt head) @@ fun () -> + let*! () = Daemon_event.head_processing head.hash head.level in + let* predecessor = Node_context.get_predecessor_header_opt node_ctxt head in + match predecessor with + | None -> + (* Predecessor not available on the L1, which means the block does not + exist in the chain. *) + return_unit + | Some predecessor -> + let* () = process_head node_ctxt predecessor in let* ctxt = previous_context node_ctxt ~predecessor in let* () = - Node_context.save_level node_ctxt (Layer1.head_of_header head) + Node_context.save_level + node_ctxt + {Layer1.hash = head.hash; level = head.level} in let* inbox_hash, inbox, inbox_witness, messages = - Inbox.Internal_for_tests.process_messages - node_ctxt - ~is_first_block - ~predecessor - head - messages + Inbox.process_head node_ctxt ~predecessor head + in + let* () = + when_ (Node_context.dal_supported node_ctxt) @@ fun () -> + Dal_slots_tracker.process_head node_ctxt (Layer1.head_of_header head) in + let* () = process_l1_block_operations node_ctxt head in + (* Avoid storing and publishing commitments if the head is not final. *) + (* Avoid triggering the pvm execution if this has been done before for + this head. *) let* ctxt, _num_messages, num_ticks, initial_tick = Interpreter.process_head node_ctxt @@ -610,11 +330,7 @@ module Make (PVM : Pvm.S) = struct in let*! context_hash = Context.commit ctxt in let* commitment_hash = - Publisher.process_head - node_ctxt - ~predecessor:predecessor.Layer1.hash - head - ctxt + Publisher.process_head node_ctxt ~predecessor:predecessor.hash head ctxt in let level = Raw_level.of_int32_exn head.level in let* previous_commitment_hash = @@ -641,9 +357,273 @@ module Make (PVM : Pvm.S) = struct let l2_block = Sc_rollup_block.{header; content = (); num_ticks; initial_tick} in + let* () = + Node_context.mark_finalized_level + node_ctxt + Int32.(sub head.level (of_int node_ctxt.block_finality_time)) + in let* () = Node_context.save_l2_head node_ctxt l2_block in - return l2_block - end + let*! () = Daemon_event.new_head_processed head.hash head.level in + return_unit + +(* [on_layer_1_head node_ctxt head] processes a new head from the L1. It + also processes any missing blocks that were not processed. *) +let on_layer_1_head node_ctxt (head : Layer1.header) = + let open Lwt_result_syntax in + let* old_head = Node_context.last_processed_head_opt node_ctxt in + let old_head = + match old_head with + | Some h -> + `Head + Layer1. + { + hash = h.header.block_hash; + level = Raw_level.to_int32 h.header.level; + } + | None -> + (* if no head has been processed yet, we want to handle all blocks + since, and including, the rollup origination. *) + let origination_level = + Raw_level.to_int32 node_ctxt.genesis_info.level + in + `Level (Int32.pred origination_level) + in + let stripped_head = Layer1.head_of_header head in + let*! reorg = + Node_context.get_tezos_reorg_for_new_head node_ctxt old_head stripped_head + in + let*? reorg = + match reorg with + | Error trace + when TzTrace.fold + (fun yes error -> + yes + || + match error with + | Octez_crawler.Layer_1.Cannot_find_predecessor _ -> true + | _ -> false) + false + trace -> + (* The reorganization could not be computed entirely because of missing + info on the Layer 1. We fallback to a recursive process_head. *) + Ok {Reorg.no_reorg with new_chain = [stripped_head]} + | _ -> reorg + in + (* TODO: https://gitlab.com/tezos/tezos/-/issues/3348 + Rollback state information on reorganization, i.e. for + reorg.old_chain. *) + let*! () = Daemon_event.processing_heads_iteration reorg.new_chain in + let get_header Layer1.{hash; level} = + if Block_hash.equal hash head.hash then return head + else + let+ header = Layer1.fetch_tezos_shell_header node_ctxt.cctxt hash in + {Layer1.hash; level; header} + in + let* () = + List.iter_es + (fun block -> + let* header = get_header block in + process_head node_ctxt header) + reorg.new_chain + in + let* () = Publisher.publish_commitments () in + let* () = Publisher.cement_commitments () in + let*! () = Daemon_event.new_heads_processed reorg.new_chain in + let* () = Refutation_coordinator.process stripped_head in + let* () = Batcher.batch () in + let* () = Batcher.new_head stripped_head in + let*! () = Injector.inject ~header:head.header () in + return_unit + +let daemonize (node_ctxt : _ Node_context.t) = + Layer1.iter_heads node_ctxt.l1_ctxt (on_layer_1_head node_ctxt) + +let degraded_refutation_mode (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let*! () = Daemon_event.degraded_mode () in + let message = node_ctxt.Node_context.cctxt#message in + let*! () = message "Shutting down Batcher@." in + let*! () = Batcher.shutdown () in + let*! () = message "Shutting down Commitment Publisher@." in + let*! () = Publisher.shutdown () in + Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> + let* () = Refutation_coordinator.process (Layer1.head_of_header head) in + let*! () = Injector.inject () in + return_unit + +let install_finalizer node_ctxt rpc_server = + let open Lwt_syntax in + Lwt_exit.register_clean_up_callback ~loc:__LOC__ @@ fun exit_status -> + let message = node_ctxt.Node_context.cctxt#message in + let* () = message "Shutting down RPC server@." in + let* () = RPC_server.shutdown rpc_server in + let* () = message "Shutting down Injector@." in + let* () = Injector.shutdown () in + let* () = message "Shutting down Batcher@." in + let* () = Batcher.shutdown () in + let* () = message "Shutting down Commitment Publisher@." in + let* () = Publisher.shutdown () in + let* () = message "Shutting down Refutation Coordinator@." in + let* () = Refutation_coordinator.shutdown () in + let* (_ : unit tzresult) = Node_context.close node_ctxt in + let* () = Event.shutdown_node exit_status in + Tezos_base_unix.Internal_event_unix.close () + +let check_initial_state_hash {Node_context.cctxt; rollup_address; pvm; _} = + let open Lwt_result_syntax in + let module PVM = (val pvm) in + let* l1_reference_initial_state_hash = + RPC.Sc_rollup.initial_pvm_state_hash + cctxt + (cctxt#chain, cctxt#block) + rollup_address + in + let*! s = PVM.initial_state ~empty:(PVM.State.empty ()) in + let*! l2_initial_state_hash = PVM.state_hash s in + fail_unless + Sc_rollup.State_hash.( + l1_reference_initial_state_hash = l2_initial_state_hash) + (Sc_rollup_node_errors.Wrong_initial_pvm_state + { + initial_state_hash = l2_initial_state_hash; + expected_state_hash = l1_reference_initial_state_hash; + }) + +let run node_ctxt configuration = + let open Lwt_result_syntax in + let* () = check_initial_state_hash node_ctxt in + let* rpc_server = RPC_server.start node_ctxt configuration in + let (_ : Lwt_exit.clean_up_callback_id) = + install_finalizer node_ctxt rpc_server + in + let start () = + let*! () = Inbox.start () in + let signers = + Configuration.Operator_purpose_map.bindings node_ctxt.operators + |> List.fold_left + (fun acc (purpose, operator) -> + let purposes = + match Signature.Public_key_hash.Map.find operator acc with + | None -> [purpose] + | Some ps -> purpose :: ps + in + Signature.Public_key_hash.Map.add operator purposes acc) + Signature.Public_key_hash.Map.empty + |> Signature.Public_key_hash.Map.bindings + |> List.map (fun (operator, purposes) -> + let strategy = + match purposes with + | [Configuration.Add_messages] -> `Delay_block 0.5 + | _ -> `Each_block + in + (operator, strategy, purposes)) + in + let* () = Publisher.init node_ctxt in + let* () = Refutation_coordinator.init node_ctxt in + let* () = + unless (signers = []) @@ fun () -> + Injector.init + node_ctxt.cctxt + (Node_context.readonly node_ctxt) + ~data_dir:node_ctxt.data_dir + ~signers + ~retention_period:configuration.injector.retention_period + ~allowed_attempts:configuration.injector.attempts + in + let* () = + match + Configuration.Operator_purpose_map.find Add_messages node_ctxt.operators + with + | None -> return_unit + | Some signer -> Batcher.init configuration.batcher ~signer node_ctxt + in + Lwt.dont_wait + (fun () -> + let*! r = Metrics.metrics_serve configuration.metrics_addr in + match r with + | Ok () -> Lwt.return_unit + | Error err -> + Event.(metrics_ended (Format.asprintf "%a" pp_print_trace err))) + (fun exn -> Event.(metrics_ended_dont_wait (Printexc.to_string exn))) ; + + let*! () = + Event.node_is_ready + ~rpc_addr:configuration.rpc_addr + ~rpc_port:configuration.rpc_port + in + daemonize node_ctxt + in + Metrics.Info.init_rollup_node_info + ~id:configuration.sc_rollup_address + ~mode:configuration.mode + ~genesis_level:(Raw_level.to_int32 node_ctxt.genesis_info.level) + ~pvm_kind:(Sc_rollup.Kind.to_string node_ctxt.kind) ; + protect start ~on_error:(function + | Sc_rollup_node_errors.( + Lost_game _ | Unparsable_boot_sector _ | Invalid_genesis_state _) + :: _ as e -> + Format.eprintf "%!%a@.Exiting.@." pp_print_trace e ; + let*! _ = Lwt_exit.exit_and_wait 1 in + return_unit + | e -> + let*! () = Daemon_event.error e in + degraded_refutation_mode node_ctxt) + +module Internal_for_tests = struct + (** Same as {!process_head} but only builds and stores the L2 block + corresponding to [messages]. It is used by the unit tests to build an L2 + chain. *) + let process_messages (node_ctxt : _ Node_context.t) ~is_first_block + ~predecessor head messages = + let open Lwt_result_syntax in + let* ctxt = previous_context node_ctxt ~predecessor in + let* () = Node_context.save_level node_ctxt (Layer1.head_of_header head) in + let* inbox_hash, inbox, inbox_witness, messages = + Inbox.Internal_for_tests.process_messages + node_ctxt + ~is_first_block + ~predecessor + head + messages + in + let* ctxt, _num_messages, num_ticks, initial_tick = + Interpreter.process_head node_ctxt ctxt ~predecessor head (inbox, messages) + in + let*! context_hash = Context.commit ctxt in + let* commitment_hash = + Publisher.process_head + node_ctxt + ~predecessor:predecessor.Layer1.hash + head + ctxt + in + let level = Raw_level.of_int32_exn head.level in + let* previous_commitment_hash = + if level = node_ctxt.genesis_info.Sc_rollup.Commitment.level then + (* Previous commitment for rollup genesis is itself. *) + return node_ctxt.genesis_info.Sc_rollup.Commitment.commitment_hash + else + let+ pred = Node_context.get_l2_block node_ctxt predecessor.hash in + Sc_rollup_block.most_recent_commitment pred.header + in + let header = + Sc_rollup_block. + { + block_hash = head.hash; + level; + predecessor = predecessor.hash; + commitment_hash; + previous_commitment_hash; + context = context_hash; + inbox_witness; + inbox_hash; + } + in + let l2_block = + Sc_rollup_block.{header; content = (); num_ticks; initial_tick} + in + let* () = Node_context.save_l2_head node_ctxt l2_block in + return l2_block end let run ~data_dir ?log_kernel_debug_file (configuration : Configuration.t) @@ -668,5 +648,4 @@ let run ~data_dir ?log_kernel_debug_file (configuration : Configuration.t) Read_write configuration in - let module Daemon = Make ((val Components.pvm_of_kind node_ctxt.kind)) in - Daemon.run node_ctxt configuration + run node_ctxt configuration -- GitLab From e13cecd7057b0d2beb57c920b5b25093484b7dd9 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 19:48:07 +0200 Subject: [PATCH 11/13] Tests: simplify helpers (no functor) for rollup node tests --- .../test/helpers/helpers.ml | 356 ++++++++---------- 1 file changed, 153 insertions(+), 203 deletions(-) diff --git a/src/proto_alpha/lib_sc_rollup_node/test/helpers/helpers.ml b/src/proto_alpha/lib_sc_rollup_node/test/helpers/helpers.ml index 2dd030c3a411..e4e10ac23344 100644 --- a/src/proto_alpha/lib_sc_rollup_node/test/helpers/helpers.ml +++ b/src/proto_alpha/lib_sc_rollup_node/test/helpers/helpers.ml @@ -36,217 +36,167 @@ let block_hash_of_level level = in Block_hash.of_string_exn s -module type S = sig - val with_node_context : - ?constants:Constants.Parametric.t -> - Sc_rollup.Kind.t -> - boot_sector:string -> - ([`Read | `Write] Node_context.t -> - genesis:Sc_rollup_block.t -> - 'a tzresult Lwt.t) -> - 'a tzresult Lwt.t - - val add_l2_genesis_block : - [`Read | `Write] Node_context.t -> - boot_sector:string -> - ((Sc_rollup_block.header, unit) Sc_rollup_block.block, tztrace) result Lwt.t - - val append_l2_block : - [`Read | `Write] Node_context.t -> - ?is_first_block:bool -> - Sc_rollup.Inbox_message.t trace -> - ((Sc_rollup_block.header, unit) Sc_rollup_block.block, tztrace) result Lwt.t -end - -module Make (PVM : Pvm.S) = struct - module Daemon = Daemon.Make (PVM) - module Components = Daemon.Components +let default_constants = + let constants = Default_parameters.constants_test in + let sc_rollup = + { + constants.sc_rollup with + arith_pvm_enable = true; + challenge_window_in_blocks = 4032; + commitment_period_in_blocks = 3; + } + in + {constants with sc_rollup} - let default_constants = - let constants = Default_parameters.constants_test in - let sc_rollup = +let add_l2_genesis_block (node_ctxt : _ Node_context.t) ~boot_sector = + let open Lwt_result_syntax in + let head = + Layer1. { - constants.sc_rollup with - arith_pvm_enable = true; - challenge_window_in_blocks = 4032; - commitment_period_in_blocks = 3; + hash = Block_hash.zero; + level = Raw_level.to_int32 node_ctxt.genesis_info.level; } - in - {constants with sc_rollup} - - let add_l2_genesis_block (node_ctxt : _ Node_context.t) ~boot_sector = - let open Lwt_result_syntax in - let head = - Layer1. - { - hash = Block_hash.zero; - level = Raw_level.to_int32 node_ctxt.genesis_info.level; - } - in - let* () = Node_context.save_level node_ctxt head in - let predecessor = head in - let predecessor_timestamp = Time.Protocol.epoch in - let inbox = - Sc_rollup.Inbox.genesis - ~predecessor_timestamp - ~predecessor:predecessor.hash - node_ctxt.genesis_info.level - in - let* inbox_hash = Node_context.save_inbox node_ctxt inbox in - let inbox_witness = Sc_rollup.Inbox.current_witness inbox in - let ctxt = Context.empty node_ctxt.context in - let num_ticks = 0L in - let initial_tick = Sc_rollup.Tick.initial in - let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! state = PVM.install_boot_sector initial_state boot_sector in - let*! genesis_state_hash = PVM.state_hash state in - let*! ctxt = PVM.State.set ctxt state in - let*! context_hash = Context.commit ctxt in - let commitment = - Sc_rollup.Commitment.genesis_commitment - ~origination_level:node_ctxt.genesis_info.level - ~genesis_state_hash - in - let* commitment_hash = Node_context.save_commitment node_ctxt commitment in - let previous_commitment_hash = node_ctxt.genesis_info.commitment_hash in - let header = - Sc_rollup_block. - { - block_hash = head.hash; - level = node_ctxt.genesis_info.level; - predecessor = predecessor.hash; - commitment_hash = Some commitment_hash; - previous_commitment_hash; - context = context_hash; - inbox_witness; - inbox_hash; - } - in - let l2_block = - Sc_rollup_block.{header; content = (); num_ticks; initial_tick} - in - let* () = Node_context.save_l2_head node_ctxt l2_block in - return l2_block - - let initialize_node_context ?(constants = default_constants) kind ~boot_sector - = - let open Lwt_result_syntax in - incr uid ; - (* To avoid any conflict with previous runs of this test. *) - let pid = Unix.getpid () in - let data_dir = - Filename.(concat @@ get_temp_dir_name ()) - (Format.sprintf "sc-rollup-node-test-%s-%d-%d" Protocol.name pid !uid) - in - let base_dir = - Filename.(concat @@ get_temp_dir_name ()) - (Format.sprintf - "sc-rollup-node-test-%s-base-%d-%d" - Protocol.name - pid - !uid) - in - let filesystem = String.Hashtbl.create 10 in - let cctxt = - new Protocol_client_context.wrap_full - (new Faked_client_context.unix_faked ~base_dir ~filesystem) - in - let* ctxt = - Node_context.Internal_for_tests.create_node_context - cctxt - ~constants - ~data_dir - kind - in - let* genesis = add_l2_genesis_block ctxt ~boot_sector in - let commitment_hash = - WithExceptions.Option.get ~loc:__LOC__ genesis.header.commitment_hash - in - let ctxt = - {ctxt with genesis_info = {ctxt.genesis_info with commitment_hash}} - in - return (ctxt, genesis, [data_dir; base_dir]) - - let with_node_context ?constants kind ~boot_sector f = - let open Lwt_result_syntax in - let* node_ctxt, genesis, dirs_to_clean = - initialize_node_context ?constants kind ~boot_sector - in - Lwt.finalize (fun () -> f node_ctxt ~genesis) @@ fun () -> - let open Lwt_syntax in - let* _ = Node_context.close node_ctxt in - let* () = - List.iter_s Tezos_stdlib_unix.Lwt_utils_unix.remove_dir dirs_to_clean - in - return_unit - - let head_of_level ~predecessor level = - let hash = block_hash_of_level level in - let timestamp = Time.Protocol.of_seconds (Int64.of_int32 level) in - let header : Block_header.shell_header = + in + let* () = Node_context.save_level node_ctxt head in + let predecessor = head in + let predecessor_timestamp = Time.Protocol.epoch in + let inbox = + Sc_rollup.Inbox.genesis + ~predecessor_timestamp + ~predecessor:predecessor.hash + node_ctxt.genesis_info.level + in + let* inbox_hash = Node_context.save_inbox node_ctxt inbox in + let inbox_witness = Sc_rollup.Inbox.current_witness inbox in + let ctxt = Context.empty node_ctxt.context in + let num_ticks = 0L in + let module PVM = (val node_ctxt.pvm) in + let initial_tick = Sc_rollup.Tick.initial in + let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in + let*! state = PVM.install_boot_sector initial_state boot_sector in + let*! genesis_state_hash = PVM.state_hash state in + let*! ctxt = PVM.State.set ctxt state in + let*! context_hash = Context.commit ctxt in + let commitment = + Sc_rollup.Commitment.genesis_commitment + ~origination_level:node_ctxt.genesis_info.level + ~genesis_state_hash + in + let* commitment_hash = Node_context.save_commitment node_ctxt commitment in + let previous_commitment_hash = node_ctxt.genesis_info.commitment_hash in + let header = + Sc_rollup_block. { - level; - predecessor; - timestamp; - (* dummy values below *) - proto_level = 0; - validation_passes = 3; - operations_hash = Tezos_crypto.Hashed.Operation_list_list_hash.zero; - fitness = []; - context = Tezos_crypto.Hashed.Context_hash.zero; + block_hash = head.hash; + level = node_ctxt.genesis_info.level; + predecessor = predecessor.hash; + commitment_hash = Some commitment_hash; + previous_commitment_hash; + context = context_hash; + inbox_witness; + inbox_hash; } - in - {Layer1.hash; level; header} - - let append_l2_block (node_ctxt : _ Node_context.t) ?(is_first_block = false) - messages = - let open Lwt_result_syntax in - let* predecessor_l2_block = - Node_context.last_processed_head_opt node_ctxt - in - let* predecessor_l2_block = - match predecessor_l2_block with - | Some b -> return b - | None -> - failwith "No genesis block, please add one with add_l2_genesis_block" - in - let pred_level = Raw_level.to_int32 predecessor_l2_block.header.level in - let predecessor = - head_of_level - ~predecessor:predecessor_l2_block.header.predecessor - pred_level - in - let head = - head_of_level ~predecessor:predecessor.hash (Int32.succ pred_level) - in - Daemon.Internal_for_tests.process_messages - node_ctxt - ~is_first_block - ~predecessor - head - messages -end - -let l2_chain_builders = - List.map - (fun kind -> - let module PVM = (val Components.pvm_of_kind kind) in - (kind, (module Make (PVM) : S))) - Sc_rollup.Kind.all - -let l2_chain_builder kind = Stdlib.List.assoc kind l2_chain_builders + in + let l2_block = + Sc_rollup_block.{header; content = (); num_ticks; initial_tick} + in + let* () = Node_context.save_l2_head node_ctxt l2_block in + return l2_block -let with_node_context ?constants kind ~boot_sector = - let module L = (val l2_chain_builder kind) in - L.with_node_context ?constants kind ~boot_sector +let initialize_node_context ?(constants = default_constants) kind ~boot_sector = + let open Lwt_result_syntax in + incr uid ; + (* To avoid any conflict with previous runs of this test. *) + let pid = Unix.getpid () in + let data_dir = + Filename.(concat @@ get_temp_dir_name ()) + (Format.sprintf "sc-rollup-node-test-%s-%d-%d" Protocol.name pid !uid) + in + let base_dir = + Filename.(concat @@ get_temp_dir_name ()) + (Format.sprintf + "sc-rollup-node-test-%s-base-%d-%d" + Protocol.name + pid + !uid) + in + let filesystem = String.Hashtbl.create 10 in + let cctxt = + new Protocol_client_context.wrap_full + (new Faked_client_context.unix_faked ~base_dir ~filesystem) + in + let* ctxt = + Node_context.Internal_for_tests.create_node_context + cctxt + ~constants + ~data_dir + kind + in + let* genesis = add_l2_genesis_block ctxt ~boot_sector in + let commitment_hash = + WithExceptions.Option.get ~loc:__LOC__ genesis.header.commitment_hash + in + let ctxt = + {ctxt with genesis_info = {ctxt.genesis_info with commitment_hash}} + in + return (ctxt, genesis, [data_dir; base_dir]) -let add_l2_genesis_block (node_ctxt : _ Node_context.t) = - let module L = (val l2_chain_builder node_ctxt.kind) in - L.add_l2_genesis_block node_ctxt +let with_node_context ?constants kind ~boot_sector f = + let open Lwt_result_syntax in + let* node_ctxt, genesis, dirs_to_clean = + initialize_node_context ?constants kind ~boot_sector + in + Lwt.finalize (fun () -> f node_ctxt ~genesis) @@ fun () -> + let open Lwt_syntax in + let* _ = Node_context.close node_ctxt in + let* () = + List.iter_s Tezos_stdlib_unix.Lwt_utils_unix.remove_dir dirs_to_clean + in + return_unit + +let head_of_level ~predecessor level = + let hash = block_hash_of_level level in + let timestamp = Time.Protocol.of_seconds (Int64.of_int32 level) in + let header : Block_header.shell_header = + { + level; + predecessor; + timestamp; + (* dummy values below *) + proto_level = 0; + validation_passes = 3; + operations_hash = Tezos_crypto.Hashed.Operation_list_list_hash.zero; + fitness = []; + context = Tezos_crypto.Hashed.Context_hash.zero; + } + in + {Layer1.hash; level; header} -let append_l2_block (node_ctxt : _ Node_context.t) = - let module L = (val l2_chain_builder node_ctxt.kind) in - L.append_l2_block node_ctxt +let append_l2_block (node_ctxt : _ Node_context.t) ?(is_first_block = false) + messages = + let open Lwt_result_syntax in + let* predecessor_l2_block = Node_context.last_processed_head_opt node_ctxt in + let* predecessor_l2_block = + match predecessor_l2_block with + | Some b -> return b + | None -> + failwith "No genesis block, please add one with add_l2_genesis_block" + in + let pred_level = Raw_level.to_int32 predecessor_l2_block.header.level in + let predecessor = + head_of_level + ~predecessor:predecessor_l2_block.header.predecessor + pred_level + in + let head = + head_of_level ~predecessor:predecessor.hash (Int32.succ pred_level) + in + Daemon.Internal_for_tests.process_messages + node_ctxt + ~is_first_block + ~predecessor + head + messages let append_l2_blocks node_ctxt message_batches = List.map_es (append_l2_block node_ctxt) message_batches -- GitLab From 15fb182de39839f71fa1693ff429d70ccc79146e Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 18:49:28 +0200 Subject: [PATCH 12/13] SCORU/Node/Nairobi: backport !8504 (defunctorize) - SCORU/Node: remove dependency of pvm on node_context - SCORU/Node: defunctorize Fueled_pvm - SCORU/Node: defunctorize Interpreter - SCORU/Node: rename Commitment component to Publisher - SCORU/Node: defunctorize Commitment publisher - SCORU/Node: defunctorize refutation games - SCORU/Node: defunctorize simulation and batcher - SCORU/Node: defunctorize outbox - SCORU/Node: defunctorize RPC server - SCORU/Node: defunctorize daemon - Tests: simplify helpers (no functor) for rollup node tests --- .../lib_sc_rollup_node/RPC_server.ml | 846 +++++++------ .../lib_sc_rollup_node/RPC_server.mli | 17 +- .../lib_sc_rollup_node/arith_pvm.ml | 4 - .../lib_sc_rollup_node/batcher.ml | 777 ++++++------ .../lib_sc_rollup_node/batcher.mli | 82 +- .../lib_sc_rollup_node/commitment.ml | 548 -------- .../lib_sc_rollup_node/commitment_sig.ml | 17 +- .../lib_sc_rollup_node/daemon.ml | 1100 ++++++++--------- .../lib_sc_rollup_node/fueled_pvm.ml | 799 ++++++------ .../lib_sc_rollup_node/interpreter.ml | 493 ++++---- .../lib_sc_rollup_node/interpreter.mli | 83 +- .../lib_sc_rollup_node/node_context.ml | 8 + .../lib_sc_rollup_node/node_context.mli | 1 + .../lib_sc_rollup_node/outbox.ml | 63 +- .../lib_sc_rollup_node/outbox.mli | 14 +- .../lib_sc_rollup_node/publisher.ml | 521 ++++++++ .../{commitment.mli => publisher.mli} | 45 +- .../lib_sc_rollup_node/pvm.ml | 6 +- .../{components.ml => pvm_rpc.ml} | 28 +- .../refutation_coordinator.ml | 384 +++--- .../refutation_coordinator.mli | 32 +- .../lib_sc_rollup_node/refutation_game.ml | 880 +++++++------ .../lib_sc_rollup_node/refutation_game.mli | 38 +- .../lib_sc_rollup_node/refutation_player.ml | 251 ++-- .../lib_sc_rollup_node/refutation_player.mli | 51 +- .../lib_sc_rollup_node/simulation.ml | 299 ++--- .../lib_sc_rollup_node/simulation.mli | 80 +- .../test/helpers/helpers.ml | 356 +++--- .../lib_sc_rollup_node/wasm_2_0_0_pvm.ml | 29 +- .../lib_sc_rollup_node/wasm_2_0_0_rpc.ml | 25 +- 30 files changed, 3771 insertions(+), 4106 deletions(-) delete mode 100644 src/proto_017_PtNairob/lib_sc_rollup_node/commitment.ml create mode 100644 src/proto_017_PtNairob/lib_sc_rollup_node/publisher.ml rename src/proto_017_PtNairob/lib_sc_rollup_node/{commitment.mli => publisher.mli} (56%) rename src/proto_017_PtNairob/lib_sc_rollup_node/{components.ml => pvm_rpc.ml} (72%) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_server.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_server.ml index 993c887ba690..ad948a1a6d6a 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_server.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_server.ml @@ -53,297 +53,290 @@ end let get_dal_processed_slots node_ctxt block = Node_context.list_slots_statuses node_ctxt ~confirmed_in_block_hash:block -module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct - module PVM = Simulation.PVM - module Interpreter = Simulation.Interpreter - module Outbox = Outbox.Make (PVM) - module Free_pvm = Interpreter.Free_pvm +module Global_directory = Make_directory (struct + include Sc_rollup_services.Global - module Global_directory = Make_directory (struct - include Sc_rollup_services.Global + type context = Node_context.ro - type context = Node_context.ro + let context_of_prefix node_ctxt () = return (Node_context.readonly node_ctxt) +end) - let context_of_prefix node_ctxt () = - return (Node_context.readonly node_ctxt) - end) +module Proof_helpers_directory = Make_directory (struct + include Sc_rollup_services.Global.Helpers - module Proof_helpers_directory = Make_directory (struct - include Sc_rollup_services.Global.Helpers + (* The context needs to be accessed with write permissions because we need to + commit on disk to generate the proofs. *) + type context = Node_context.rw - (* The context needs to be accessed with write permissions because we need to - commit on disk to generate the proofs. *) - type context = Node_context.rw + let context_of_prefix node_ctxt () = return node_ctxt +end) - let context_of_prefix node_ctxt () = return node_ctxt - end) +module Local_directory = Make_directory (struct + include Sc_rollup_services.Local - module Local_directory = Make_directory (struct - include Sc_rollup_services.Local + type context = Node_context.ro - type context = Node_context.ro + let context_of_prefix node_ctxt () = return (Node_context.readonly node_ctxt) +end) - let context_of_prefix node_ctxt () = - return (Node_context.readonly node_ctxt) - end) +module Block_directory = Make_directory (struct + include Sc_rollup_services.Global.Block - module Block_directory = Make_directory (struct - include Sc_rollup_services.Global.Block + type context = Node_context.ro * Block_hash.t - type context = Node_context.ro * Block_hash.t - - let context_of_prefix node_ctxt (((), block) : prefix) = - let open Lwt_result_syntax in - let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in - (Node_context.readonly node_ctxt, block) - end) - - module Outbox_directory = Make_directory (struct - include Sc_rollup_services.Global.Block.Outbox - - type context = Node_context.ro * Block_hash.t * Alpha_context.Raw_level.t + let context_of_prefix node_ctxt (((), block) : prefix) = + let open Lwt_result_syntax in + let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in + (Node_context.readonly node_ctxt, block) +end) - let context_of_prefix node_ctxt (((), block), level) = - let open Lwt_result_syntax in - let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in - (Node_context.readonly node_ctxt, block, level) - end) +module Outbox_directory = Make_directory (struct + include Sc_rollup_services.Global.Block.Outbox - module Common = struct - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.block - @@ fun (node_ctxt, block) () () -> - Node_context.get_full_l2_block node_ctxt block + type context = Node_context.ro * Block_hash.t * Alpha_context.Raw_level.t - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.num_messages - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* l2_block = Node_context.get_l2_block node_ctxt block in - let+ num_messages = - Node_context.get_num_messages node_ctxt l2_block.header.inbox_witness - in - Z.of_int num_messages - - let () = - Global_directory.register0 Sc_rollup_services.Global.sc_rollup_address - @@ fun node_ctxt () () -> return @@ node_ctxt.rollup_address - - let () = - Global_directory.register0 Sc_rollup_services.Global.current_tezos_head - @@ fun node_ctxt () () -> get_head_hash_opt node_ctxt - - let () = - Global_directory.register0 Sc_rollup_services.Global.current_tezos_level - @@ fun node_ctxt () () -> get_head_level_opt node_ctxt - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.hash - @@ fun (_node_ctxt, block) () () -> return block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.level - @@ fun (node_ctxt, block) () () -> - Node_context.level_of_hash node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.inbox - @@ fun (node_ctxt, block) () () -> - Node_context.get_inbox_by_block_hash node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.ticks - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let+ l2_block = Node_context.get_l2_block node_ctxt block in - Z.of_int64 l2_block.num_ticks - end - - let get_state (node_ctxt : _ Node_context.t) block_hash = + let context_of_prefix node_ctxt (((), block), level) = let open Lwt_result_syntax in - let* ctxt = Node_context.checkout_context node_ctxt block_hash in - let*! state = PVM.State.find ctxt in - match state with None -> failwith "No state" | Some state -> return state - - let simulate_messages (node_ctxt : Node_context.ro) block ~reveal_pages - messages = - let open Lwt_result_syntax in - let open Alpha_context in - let reveal_map = - match reveal_pages with - | Some pages -> - let map = - List.fold_left - (fun map page -> - let hash = - Sc_rollup_reveal_hash.(hash_string ~scheme:Blake2B [page]) - in - Sc_rollup_reveal_hash.Map.add hash page map) - Sc_rollup_reveal_hash.Map.empty - pages - in - Some map - | None -> None - in - let* level = Node_context.level_of_hash node_ctxt block in - let* sim = - Simulation.start_simulation - node_ctxt - ~reveal_map - Layer1.{hash = block; level} - in - let messages = - List.map (fun m -> Sc_rollup.Inbox_message.External m) messages - in - let* sim, num_ticks_0 = - Simulation.simulate_messages node_ctxt sim messages - in - let* {state; inbox_level; _}, num_ticks_end = - Simulation.end_simulation node_ctxt sim - in - let num_ticks = Z.(num_ticks_0 + num_ticks_end) in - let*! outbox = PVM.get_outbox inbox_level state in - let output = - List.filter - (fun Sc_rollup.{outbox_level; _} -> outbox_level = inbox_level) - outbox - in - let*! state_hash = PVM.state_hash state in - let*! status = PVM.get_status state in - let status = PVM.string_of_status status in - return - Sc_rollup_services.{state_hash; status; output; inbox_level; num_ticks} + let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in + (Node_context.readonly node_ctxt, block, level) +end) +module Common = struct let () = - Block_directory.register0 Sc_rollup_services.Global.Block.total_ticks + Block_directory.register0 Sc_rollup_services.Global.Block.block @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! tick = PVM.get_tick state in - return tick + Node_context.get_full_l2_block node_ctxt block let () = - Block_directory.register0 Sc_rollup_services.Global.Block.state_hash + Block_directory.register0 Sc_rollup_services.Global.Block.num_messages @@ fun (node_ctxt, block) () () -> let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! hash = PVM.state_hash state in - return hash + let* l2_block = Node_context.get_l2_block node_ctxt block in + let+ num_messages = + Node_context.get_num_messages node_ctxt l2_block.header.inbox_witness + in + Z.of_int num_messages let () = - Block_directory.register0 - Sc_rollup_services.Global.Block.state_current_level - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! current_level = PVM.get_current_level state in - return current_level + Global_directory.register0 Sc_rollup_services.Global.sc_rollup_address + @@ fun node_ctxt () () -> return @@ node_ctxt.rollup_address let () = - Block_directory.register0 Sc_rollup_services.Global.Block.state_value - @@ fun (node_ctxt, block) {key} () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let path = String.split_on_char '/' key in - let*! value = PVM.State.lookup state path in - match value with - | None -> failwith "No such key in PVM state" - | Some value -> - Format.eprintf "Encoded %S\n@.%!" (Bytes.to_string value) ; - return value + Global_directory.register0 Sc_rollup_services.Global.current_tezos_head + @@ fun node_ctxt () () -> get_head_hash_opt node_ctxt let () = - Global_directory.register0 Sc_rollup_services.Global.last_stored_commitment - @@ fun node_ctxt () () -> - let open Lwt_result_syntax in - let* head = Node_context.last_processed_head_opt node_ctxt in - match head with - | None -> return_none - | Some head -> - let commitment_hash = - Sc_rollup_block.most_recent_commitment head.header - in - let+ commitment = - Node_context.find_commitment node_ctxt commitment_hash - in - Option.map (fun c -> (c, commitment_hash)) commitment + Global_directory.register0 Sc_rollup_services.Global.current_tezos_level + @@ fun node_ctxt () () -> get_head_level_opt node_ctxt let () = - Local_directory.register0 Sc_rollup_services.Local.last_published_commitment - @@ fun node_ctxt () () -> - let open Lwt_result_syntax in - match Reference.get node_ctxt.lpc with - | None -> return_none - | Some commitment -> - let hash = - Alpha_context.Sc_rollup.Commitment.hash_uncarbonated commitment - in - (* The corresponding level in Store.Commitments.published_at_level is - available only when the commitment has been published and included - in a block. *) - let* published_at_level_info = - Node_context.commitment_published_at_level node_ctxt hash - in - let first_published, published = - match published_at_level_info with - | None -> (None, None) - | Some {first_published_at_level; published_at_level} -> - (Some first_published_at_level, published_at_level) - in - return_some (commitment, hash, first_published, published) + Block_directory.register0 Sc_rollup_services.Global.Block.hash + @@ fun (_node_ctxt, block) () () -> return block let () = - Block_directory.register0 Sc_rollup_services.Global.Block.status + Block_directory.register0 Sc_rollup_services.Global.Block.level @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! status = PVM.get_status state in - return (PVM.string_of_status status) + Node_context.level_of_hash node_ctxt block let () = - Block_directory.register0 Sc_rollup_services.Global.Block.dal_slots + Block_directory.register0 Sc_rollup_services.Global.Block.inbox @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* slots = - Node_context.get_all_slot_headers node_ctxt ~published_in_block_hash:block - in - return slots + Node_context.get_inbox_by_block_hash node_ctxt block let () = - Block_directory.register0 - Sc_rollup_services.Global.Block.dal_processed_slots - @@ fun (node_ctxt, block) () () -> get_dal_processed_slots node_ctxt block - - let () = - Outbox_directory.register0 Sc_rollup_services.Global.Block.Outbox.messages - @@ fun (node_ctxt, block, outbox_level) () () -> + Block_directory.register0 Sc_rollup_services.Global.Block.ticks + @@ fun (node_ctxt, block) () () -> let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! outbox = PVM.get_outbox outbox_level state in - return outbox + let+ l2_block = Node_context.get_l2_block node_ctxt block in + Z.of_int64 l2_block.num_ticks +end - let () = - Proof_helpers_directory.register0 - Sc_rollup_services.Global.Helpers.outbox_proof - @@ fun node_ctxt output () -> Outbox.proof_of_output node_ctxt output +let get_state (node_ctxt : _ Node_context.t) block_hash = + let open Lwt_result_syntax in + let* ctxt = Node_context.checkout_context node_ctxt block_hash in + let*! state = Context.PVMState.find ctxt in + match state with None -> failwith "No state" | Some state -> return state - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.simulate - @@ fun (node_ctxt, block) () {messages; reveal_pages} -> - simulate_messages node_ctxt block ~reveal_pages messages +let simulate_messages (node_ctxt : Node_context.ro) block ~reveal_pages messages + = + let open Lwt_result_syntax in + let open Alpha_context in + let module PVM = (val node_ctxt.pvm) in + let reveal_map = + match reveal_pages with + | Some pages -> + let map = + List.fold_left + (fun map page -> + let hash = + Sc_rollup_reveal_hash.(hash_string ~scheme:Blake2B [page]) + in + Sc_rollup_reveal_hash.Map.add hash page map) + Sc_rollup_reveal_hash.Map.empty + pages + in + Some map + | None -> None + in + let* level = Node_context.level_of_hash node_ctxt block in + let* sim = + Simulation.start_simulation + node_ctxt + ~reveal_map + Layer1.{hash = block; level} + in + let messages = + List.map (fun m -> Sc_rollup.Inbox_message.External m) messages + in + let* sim, num_ticks_0 = Simulation.simulate_messages node_ctxt sim messages in + let* {state; inbox_level; _}, num_ticks_end = + Simulation.end_simulation node_ctxt sim + in + let num_ticks = Z.(num_ticks_0 + num_ticks_end) in + let*! outbox = PVM.get_outbox inbox_level state in + let output = + List.filter + (fun Sc_rollup.{outbox_level; _} -> outbox_level = inbox_level) + outbox + in + let*! state_hash = PVM.state_hash state in + let*! status = PVM.get_status state in + let status = PVM.string_of_status status in + return Sc_rollup_services.{state_hash; status; output; inbox_level; num_ticks} + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.total_ticks + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! tick = PVM.get_tick state in + return tick + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.state_hash + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! hash = PVM.state_hash state in + return hash + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.state_current_level + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! current_level = PVM.get_current_level state in + return current_level + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.state_value + @@ fun (node_ctxt, block) {key} () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let path = String.split_on_char '/' key in + let*! value = Context.PVMState.lookup state path in + match value with + | None -> failwith "No such key in PVM state" + | Some value -> + Format.eprintf "Encoded %S\n@.%!" (Bytes.to_string value) ; + return value + +let () = + Global_directory.register0 Sc_rollup_services.Global.last_stored_commitment + @@ fun node_ctxt () () -> + let open Lwt_result_syntax in + let* head = Node_context.last_processed_head_opt node_ctxt in + match head with + | None -> return_none + | Some head -> + let commitment_hash = + Sc_rollup_block.most_recent_commitment head.header + in + let+ commitment = + Node_context.find_commitment node_ctxt commitment_hash + in + Option.map (fun c -> (c, commitment_hash)) commitment - let () = - Local_directory.register0 Sc_rollup_services.Local.injection - @@ fun _node_ctxt () messages -> Batcher.register_messages messages +let () = + Local_directory.register0 Sc_rollup_services.Local.last_published_commitment + @@ fun node_ctxt () () -> + let open Lwt_result_syntax in + match Reference.get node_ctxt.lpc with + | None -> return_none + | Some commitment -> + let hash = + Alpha_context.Sc_rollup.Commitment.hash_uncarbonated commitment + in + (* The corresponding level in Store.Commitments.published_at_level is + available only when the commitment has been published and included + in a block. *) + let* published_at_level_info = + Node_context.commitment_published_at_level node_ctxt hash + in + let first_published, published = + match published_at_level_info with + | None -> (None, None) + | Some {first_published_at_level; published_at_level} -> + (Some first_published_at_level, published_at_level) + in + return_some (commitment, hash, first_published, published) - let () = - Local_directory.register0 Sc_rollup_services.Local.batcher_queue - @@ fun _node_ctxt () () -> - let open Lwt_result_syntax in - let*? queue = Batcher.get_queue () in - return queue +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.status + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! status = PVM.get_status state in + return (PVM.string_of_status status) + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.dal_slots + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* slots = + Node_context.get_all_slot_headers node_ctxt ~published_in_block_hash:block + in + return slots + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.dal_processed_slots + @@ fun (node_ctxt, block) () () -> get_dal_processed_slots node_ctxt block + +let () = + Outbox_directory.register0 Sc_rollup_services.Global.Block.Outbox.messages + @@ fun (node_ctxt, block, outbox_level) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! outbox = PVM.get_outbox outbox_level state in + return outbox + +let () = + Proof_helpers_directory.register0 + Sc_rollup_services.Global.Helpers.outbox_proof + @@ fun node_ctxt output () -> Outbox.proof_of_output node_ctxt output + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.simulate + @@ fun (node_ctxt, block) () {messages; reveal_pages} -> + simulate_messages node_ctxt block ~reveal_pages messages + +let () = + Local_directory.register0 Sc_rollup_services.Local.injection + @@ fun _node_ctxt () messages -> Batcher.register_messages messages + +let () = + Local_directory.register0 Sc_rollup_services.Local.batcher_queue + @@ fun _node_ctxt () () -> + let open Lwt_result_syntax in + let*? queue = Batcher.get_queue () in + return queue - (** [commitment_level_of_inbox_level node_ctxt inbox_level] returns the level +(** [commitment_level_of_inbox_level node_ctxt inbox_level] returns the level of the commitment which should include the inbox of level [inbox_level]. @@ -355,184 +348,181 @@ module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct * commitment_period) v} *) - let commitment_level_of_inbox_level (node_ctxt : _ Node_context.t) inbox_level - = - let open Alpha_context in - let open Option_syntax in - let+ last_published_commitment = Reference.get node_ctxt.lpc in - let commitment_period = - Int32.of_int - node_ctxt.protocol_constants.parametric.sc_rollup - .commitment_period_in_blocks - in - let last_published = - Raw_level.to_int32 last_published_commitment.inbox_level - in - let open Int32 in - div (sub last_published inbox_level) commitment_period - |> mul commitment_period |> sub last_published |> Raw_level.of_int32_exn - - let inbox_info_of_level (node_ctxt : _ Node_context.t) inbox_level = - let open Alpha_context in - let open Lwt_result_syntax in - let+ finalized_level = Node_context.get_finalized_level node_ctxt in - let finalized = Compare.Int32.(inbox_level <= finalized_level) in - let lcc = Reference.get node_ctxt.lcc in - let cemented = - Compare.Int32.(inbox_level <= Raw_level.to_int32 lcc.level) - in - (finalized, cemented) - - let () = - Local_directory.register1 Sc_rollup_services.Local.batcher_message - @@ fun node_ctxt hash () () -> - let open Lwt_result_syntax in - let*? batch_status = Batcher.message_status hash in - let* status = - match batch_status with - | None -> return (None, Sc_rollup_services.Unknown) - | Some (batch_status, msg) -> ( - let return status = return (Some msg, status) in - match batch_status with - | Pending_batch -> return Sc_rollup_services.Pending_batch - | Batched l1_hash -> ( - match Injector.operation_status l1_hash with - | None -> return Sc_rollup_services.Unknown - | Some (Pending op) -> - return (Sc_rollup_services.Pending_injection op) - | Some (Injected {op; oph; op_index}) -> - return - (Sc_rollup_services.Injected - {op = op.operation; oph; op_index}) - | Some (Included {op; oph; op_index; l1_block; l1_level}) -> ( - let* finalized, cemented = - inbox_info_of_level node_ctxt l1_level - in - let commitment_level = - commitment_level_of_inbox_level node_ctxt l1_level - in - match commitment_level with - | None -> - return - (Sc_rollup_services.Included - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - }) - | Some commitment_level -> ( - let* block = - Node_context.find_l2_block_by_level - node_ctxt - (Alpha_context.Raw_level.to_int32 commitment_level) - in - match block with - | None -> - (* Commitment not computed yet for inbox *) - return - (Sc_rollup_services.Included - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - }) - | Some block -> ( - let commitment_hash = - WithExceptions.Option.get - ~loc:__LOC__ - block.header.commitment_hash - in - (* Commitment computed *) - let* published_at = - Node_context.commitment_published_at_level - node_ctxt - commitment_hash - in - match published_at with - | None | Some {published_at_level = None; _} -> - (* Commitment not published yet *) - return - (Sc_rollup_services.Included - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - }) - | Some - { - first_published_at_level; - published_at_level = Some published_at_level; - } -> - (* Commitment published *) - let* commitment = - Node_context.get_commitment - node_ctxt - commitment_hash - in - return - (Sc_rollup_services.Committed - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - commitment; - commitment_hash; - first_published_at_level; - published_at_level; - })))))) - in - - return status - - let register node_ctxt = - List.fold_left - (fun dir f -> Tezos_rpc.Directory.merge dir (f node_ctxt)) - Tezos_rpc.Directory.empty - [ - Global_directory.build_directory; - Local_directory.build_directory; - Block_directory.build_directory; - Proof_helpers_directory.build_directory; - Outbox_directory.build_directory; - PVM.RPC.build_directory; - ] - - let start node_ctxt configuration = - let open Lwt_result_syntax in - let Configuration.{rpc_addr; rpc_port; _} = configuration in - let rpc_addr = P2p_addr.of_string_exn rpc_addr in - let host = Ipaddr.V6.to_string rpc_addr in - let node = `TCP (`Port rpc_port) in - let acl = RPC_server.Acl.allow_all in - let dir = register node_ctxt in - let server = - RPC_server.init_server dir ~acl ~media_types:Media_type.all_media_types - in - protect @@ fun () -> - let*! () = - RPC_server.launch - ~host - server - ~callback:(RPC_server.resto_callback server) - node - in - return server - - let shutdown = RPC_server.shutdown -end +let commitment_level_of_inbox_level (node_ctxt : _ Node_context.t) inbox_level = + let open Alpha_context in + let open Option_syntax in + let+ last_published_commitment = Reference.get node_ctxt.lpc in + let commitment_period = + Int32.of_int + node_ctxt.protocol_constants.parametric.sc_rollup + .commitment_period_in_blocks + in + let last_published = + Raw_level.to_int32 last_published_commitment.inbox_level + in + let open Int32 in + div (sub last_published inbox_level) commitment_period + |> mul commitment_period |> sub last_published |> Raw_level.of_int32_exn + +let inbox_info_of_level (node_ctxt : _ Node_context.t) inbox_level = + let open Alpha_context in + let open Lwt_result_syntax in + let+ finalized_level = Node_context.get_finalized_level node_ctxt in + let finalized = Compare.Int32.(inbox_level <= finalized_level) in + let lcc = Reference.get node_ctxt.lcc in + let cemented = Compare.Int32.(inbox_level <= Raw_level.to_int32 lcc.level) in + (finalized, cemented) + +let () = + Local_directory.register1 Sc_rollup_services.Local.batcher_message + @@ fun node_ctxt hash () () -> + let open Lwt_result_syntax in + let*? batch_status = Batcher.message_status hash in + let* status = + match batch_status with + | None -> return (None, Sc_rollup_services.Unknown) + | Some (batch_status, msg) -> ( + let return status = return (Some msg, status) in + match batch_status with + | Pending_batch -> return Sc_rollup_services.Pending_batch + | Batched l1_hash -> ( + match Injector.operation_status l1_hash with + | None -> return Sc_rollup_services.Unknown + | Some (Pending op) -> + return (Sc_rollup_services.Pending_injection op) + | Some (Injected {op; oph; op_index}) -> + return + (Sc_rollup_services.Injected + {op = op.operation; oph; op_index}) + | Some (Included {op; oph; op_index; l1_block; l1_level}) -> ( + let* finalized, cemented = + inbox_info_of_level node_ctxt l1_level + in + let commitment_level = + commitment_level_of_inbox_level node_ctxt l1_level + in + match commitment_level with + | None -> + return + (Sc_rollup_services.Included + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + }) + | Some commitment_level -> ( + let* block = + Node_context.find_l2_block_by_level + node_ctxt + (Alpha_context.Raw_level.to_int32 commitment_level) + in + match block with + | None -> + (* Commitment not computed yet for inbox *) + return + (Sc_rollup_services.Included + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + }) + | Some block -> ( + let commitment_hash = + WithExceptions.Option.get + ~loc:__LOC__ + block.header.commitment_hash + in + (* Commitment computed *) + let* published_at = + Node_context.commitment_published_at_level + node_ctxt + commitment_hash + in + match published_at with + | None | Some {published_at_level = None; _} -> + (* Commitment not published yet *) + return + (Sc_rollup_services.Included + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + }) + | Some + { + first_published_at_level; + published_at_level = Some published_at_level; + } -> + (* Commitment published *) + let* commitment = + Node_context.get_commitment + node_ctxt + commitment_hash + in + return + (Sc_rollup_services.Committed + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + commitment; + commitment_hash; + first_published_at_level; + published_at_level; + })))))) + in + + return status + +let register (node_ctxt : _ Node_context.t) = + let module PVM = (val Pvm_rpc.of_kind node_ctxt.kind) in + List.fold_left + (fun dir f -> Tezos_rpc.Directory.merge dir (f node_ctxt)) + Tezos_rpc.Directory.empty + [ + Global_directory.build_directory; + Local_directory.build_directory; + Block_directory.build_directory; + Proof_helpers_directory.build_directory; + Outbox_directory.build_directory; + PVM.build_directory; + ] + +let start node_ctxt configuration = + let open Lwt_result_syntax in + let Configuration.{rpc_addr; rpc_port; _} = configuration in + let rpc_addr = P2p_addr.of_string_exn rpc_addr in + let host = Ipaddr.V6.to_string rpc_addr in + let node = `TCP (`Port rpc_port) in + let acl = RPC_server.Acl.allow_all in + let dir = register node_ctxt in + let server = + RPC_server.init_server dir ~acl ~media_types:Media_type.all_media_types + in + protect @@ fun () -> + let*! () = + RPC_server.launch + ~host + server + ~callback:(RPC_server.resto_callback server) + node + in + return server + +let shutdown = RPC_server.shutdown diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_server.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_server.mli index a5ead51ff6bf..7830dad2505f 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_server.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/RPC_server.mli @@ -25,14 +25,11 @@ open Tezos_rpc_http_server -(** Functor to construct an RPC server for a given PVM with simulation. *) -module Make (Simulation : Simulation.S) (Batcher : Batcher.S) : sig - (** [start node_ctxt config] starts an RPC server listening for requests on - the port [config.rpc_port] and address [config.rpc_addr]. *) - val start : - Node_context.rw -> Configuration.t -> RPC_server.server tzresult Lwt.t +(** [start node_ctxt config] starts an RPC server listening for requests on the + port [config.rpc_port] and address [config.rpc_addr]. *) +val start : + Node_context.rw -> Configuration.t -> RPC_server.server tzresult Lwt.t - (** Shutdown a running RPC server. When this function is called, the rollup - node will stop listening to incoming requests. *) - val shutdown : RPC_server.server -> unit Lwt.t -end +(** Shutdown a running RPC server. When this function is called, the rollup node + will stop listening to incoming requests. *) +val shutdown : RPC_server.server -> unit Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/arith_pvm.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/arith_pvm.ml index c7684ea50e50..0d35862d09d1 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/arith_pvm.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/arith_pvm.ml @@ -52,10 +52,6 @@ module Impl : Pvm.S = struct module State = Context.PVMState - module RPC = struct - let build_directory _node_ctxt = Tezos_rpc.Directory.empty - end - let new_dissection = Game_helpers.default_new_dissection let string_of_status status = diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/batcher.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/batcher.ml index d317880cb45d..f267a359dab2 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/batcher.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/batcher.ml @@ -34,435 +34,388 @@ end module Batched_messages = Hash_queue.Make (L2_message.Hash) (L2_batched_message) -(* Count instances of the batcher functor to allow for multiple worker events - without conflicts. *) -let instances_count = ref 0 - -module type S = sig - type status = Pending_batch | Batched of Injector.Inj_operation.hash - - val init : - Configuration.batcher -> - signer:public_key_hash -> - _ Node_context.t -> - unit tzresult Lwt.t - - val active : unit -> bool +type status = Pending_batch | Batched of Injector.Inj_operation.hash + +(* Same as {!Configuration.batcher} with max_batch_size non optional. *) +type conf = { + simulate : bool; + min_batch_elements : int; + min_batch_size : int; + max_batch_elements : int; + max_batch_size : int; +} + +type state = { + node_ctxt : Node_context.ro; + signer : Signature.public_key_hash; + conf : conf; + messages : Message_queue.t; + batched : Batched_messages.t; + mutable simulation_ctxt : Simulation.t option; +} + +let message_size s = + (* Encoded as length of s on 4 bytes + s *) + 4 + String.length s + +let inject_batch state (l2_messages : L2_message.t list) = + let open Lwt_result_syntax in + let messages = List.map L2_message.content l2_messages in + let operation = L1_operation.Add_messages {messages} in + let+ l1_hash = + Injector.add_pending_operation ~source:state.signer operation + in + List.iter + (fun msg -> + let content = L2_message.content msg in + let hash = L2_message.hash msg in + Batched_messages.replace state.batched hash {content; l1_hash}) + l2_messages + +let inject_batches state = List.iter_es (inject_batch state) + +let get_batches state ~only_full = + let ( current_rev_batch, + current_batch_size, + current_batch_elements, + full_batches ) = + Message_queue.fold + (fun msg_hash + message + ( current_rev_batch, + current_batch_size, + current_batch_elements, + full_batches ) -> + let size = message_size (L2_message.content message) in + let new_batch_size = current_batch_size + size in + let new_batch_elements = current_batch_elements + 1 in + if + new_batch_size <= state.conf.max_batch_size + && new_batch_elements <= state.conf.max_batch_elements + then + (* We can add the message to the current batch because we are still + within the bounds. *) + ( (msg_hash, message) :: current_rev_batch, + new_batch_size, + new_batch_elements, + full_batches ) + else + (* The batch augmented with the message would be too big but it is + below the limit without it. We finalize the current batch and + create a new one for the message. NOTE: Messages in the queue are + always < [state.conf.max_batch_size] because {!on_register} only + accepts those. *) + let batch = List.rev current_rev_batch in + ([(msg_hash, message)], size, 1, batch :: full_batches)) + state.messages + ([], 0, 0, []) + in + let batches = + if + (not only_full) + || current_batch_size >= state.conf.min_batch_size + && current_batch_elements >= state.conf.min_batch_elements + then + (* We have enough to make a batch with the last non-full batch. *) + List.rev current_rev_batch :: full_batches + else full_batches + in + List.fold_left + (fun (batches, to_remove) -> function + | [] -> (batches, to_remove) + | batch -> + let msg_hashes, batch = List.split batch in + let to_remove = List.rev_append msg_hashes to_remove in + (batch :: batches, to_remove)) + ([], []) + batches + +let produce_batches state ~only_full = + let open Lwt_result_syntax in + let batches, to_remove = get_batches state ~only_full in + match batches with + | [] -> return_unit + | _ -> + let* () = inject_batches state batches in + let*! () = + Batcher_events.(emit batched) + (List.length batches, List.length to_remove) + in + List.iter + (fun tr_hash -> Message_queue.remove state.messages tr_hash) + to_remove ; + return_unit + +let on_batch state = produce_batches state ~only_full:false + +let simulate node_ctxt simulation_ctxt (messages : L2_message.t list) = + let open Lwt_result_syntax in + let ext_messages = + List.map + (fun m -> Sc_rollup.Inbox_message.External (L2_message.content m)) + messages + in + let+ simulation_ctxt, _ticks = + Simulation.simulate_messages node_ctxt simulation_ctxt ext_messages + in + simulation_ctxt + +let on_register state (messages : string list) = + let open Lwt_result_syntax in + let max_size_msg = + min + (Protocol.Constants_repr.sc_rollup_message_size_limit + + 4 (* We add 4 because [message_size] adds 4. *)) + state.conf.max_batch_size + in + let*? messages = + List.mapi_e + (fun i message -> + if message_size message > max_size_msg then + error_with "Message %d is too large (max size is %d)" i max_size_msg + else Ok (L2_message.make message)) + messages + in + let* () = + if not state.conf.simulate then return_unit + else + match state.simulation_ctxt with + | None -> failwith "Simulation context of batcher not initialized" + | Some simulation_ctxt -> + let+ simulation_ctxt = + simulate state.node_ctxt simulation_ctxt messages + in + state.simulation_ctxt <- Some simulation_ctxt + in + let*! () = Batcher_events.(emit queue) (List.length messages) in + let hashes = + List.map + (fun message -> + let msg_hash = L2_message.hash message in + Message_queue.replace state.messages msg_hash message ; + msg_hash) + messages + in + let+ () = produce_batches state ~only_full:true in + hashes + +let on_new_head state head = + let open Lwt_result_syntax in + let* simulation_ctxt = + Simulation.start_simulation ~reveal_map:None state.node_ctxt head + in + (* TODO: https://gitlab.com/tezos/tezos/-/issues/4224 + Replay with simulation may be too expensive *) + let+ simulation_ctxt, failing = + if not state.conf.simulate then return (simulation_ctxt, []) + else + (* Re-simulate one by one *) + Message_queue.fold_es + (fun msg_hash msg (simulation_ctxt, failing) -> + let*! result = simulate state.node_ctxt simulation_ctxt [msg] in + match result with + | Ok simulation_ctxt -> return (simulation_ctxt, failing) + | Error _ -> return (simulation_ctxt, msg_hash :: failing)) + state.messages + (simulation_ctxt, []) + in + state.simulation_ctxt <- Some simulation_ctxt ; + (* Forget failing messages *) + List.iter (Message_queue.remove state.messages) failing + +let init_batcher_state node_ctxt ~signer (conf : Configuration.batcher) = + let open Lwt_syntax in + let conf = + { + simulate = conf.simulate; + min_batch_elements = conf.min_batch_elements; + min_batch_size = conf.min_batch_size; + max_batch_elements = conf.max_batch_elements; + max_batch_size = + Option.value + conf.max_batch_size + ~default:Node_context.protocol_max_batch_size; + } + in + return + { + node_ctxt; + signer; + conf; + messages = Message_queue.create 100_000 (* ~ 400MB *); + batched = Batched_messages.create 100_000 (* ~ 400MB *); + simulation_ctxt = None; + } - val find_message : L2_message.hash -> L2_message.t option tzresult +module Types = struct + type nonrec state = state - val get_queue : unit -> (L2_message.hash * L2_message.t) list tzresult + type parameters = { + node_ctxt : Node_context.ro; + signer : Signature.public_key_hash; + conf : Configuration.batcher; + } +end - val register_messages : string list -> L2_message.hash list tzresult Lwt.t +module Name = struct + (* We only have a single batcher in the node *) + type t = unit - val batch : unit -> unit tzresult Lwt.t + let encoding = Data_encoding.unit - val new_head : Layer1.head -> unit tzresult Lwt.t + let base = Batcher_events.Worker.section @ ["worker"] - val shutdown : unit -> unit Lwt.t + let pp _ _ = () - val message_status : L2_message.hash -> (status * string) option tzresult + let equal () () = true end -module Make (Simulation : Simulation.S) : S = struct - let () = incr instances_count - - module PVM = Simulation.PVM +module Worker = Worker.MakeSingle (Name) (Request) (Types) - type status = Pending_batch | Batched of Injector.Inj_operation.hash +type worker = Worker.infinite Worker.queue Worker.t - (* Same as {!Configuration.batcher} with max_batch_size non optional. *) - type conf = { - simulate : bool; - min_batch_elements : int; - min_batch_size : int; - max_batch_elements : int; - max_batch_size : int; - } +module Handlers = struct + type self = worker - type state = { - node_ctxt : Node_context.ro; - signer : Signature.public_key_hash; - conf : conf; - messages : Message_queue.t; - batched : Batched_messages.t; - mutable simulation_ctxt : Simulation.t option; - } - - let message_size s = - (* Encoded as length of s on 4 bytes + s *) - 4 + String.length s + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with + | Request.Register messages -> + protect @@ fun () -> on_register state messages + | Request.Batch -> protect @@ fun () -> on_batch state + | Request.New_head head -> protect @@ fun () -> on_new_head state head - let inject_batch state (l2_messages : L2_message.t list) = - let open Lwt_result_syntax in - let messages = List.map L2_message.content l2_messages in - let operation = L1_operation.Add_messages {messages} in - let+ l1_hash = - Injector.add_pending_operation ~source:state.signer operation - in - List.iter - (fun msg -> - let content = L2_message.content msg in - let hash = L2_message.hash msg in - Batched_messages.replace state.batched hash {content; l1_hash}) - l2_messages - - let inject_batches state = List.iter_es (inject_batch state) - - let get_batches state ~only_full = - let ( current_rev_batch, - current_batch_size, - current_batch_elements, - full_batches ) = - Message_queue.fold - (fun msg_hash - message - ( current_rev_batch, - current_batch_size, - current_batch_elements, - full_batches ) -> - let size = message_size (L2_message.content message) in - let new_batch_size = current_batch_size + size in - let new_batch_elements = current_batch_elements + 1 in - if - new_batch_size <= state.conf.max_batch_size - && new_batch_elements <= state.conf.max_batch_elements - then - (* We can add the message to the current batch because we are still - within the bounds. *) - ( (msg_hash, message) :: current_rev_batch, - new_batch_size, - new_batch_elements, - full_batches ) - else - (* The batch augmented with the message would be too big but it is - below the limit without it. We finalize the current batch and - create a new one for the message. NOTE: Messages in the queue are - always < [state.conf.max_batch_size] because {!on_register} only - accepts those. *) - let batch = List.rev current_rev_batch in - ([(msg_hash, message)], size, 1, batch :: full_batches)) - state.messages - ([], 0, 0, []) - in - let batches = - if - (not only_full) - || current_batch_size >= state.conf.min_batch_size - && current_batch_elements >= state.conf.min_batch_elements - then - (* We have enough to make a batch with the last non-full batch. *) - List.rev current_rev_batch :: full_batches - else full_batches - in - List.fold_left - (fun (batches, to_remove) -> function - | [] -> (batches, to_remove) - | batch -> - let msg_hashes, batch = List.split batch in - let to_remove = List.rev_append msg_hashes to_remove in - (batch :: batches, to_remove)) - ([], []) - batches - - let produce_batches state ~only_full = - let open Lwt_result_syntax in - let batches, to_remove = get_batches state ~only_full in - match batches with - | [] -> return_unit - | _ -> - let* () = inject_batches state batches in - let*! () = - Batcher_events.(emit batched) - (List.length batches, List.length to_remove) - in - List.iter - (fun tr_hash -> Message_queue.remove state.messages tr_hash) - to_remove ; - return_unit - - let on_batch state = produce_batches state ~only_full:false - - let simulate node_ctxt simulation_ctxt (messages : L2_message.t list) = - let open Lwt_result_syntax in - let ext_messages = - List.map - (fun m -> Sc_rollup.Inbox_message.External (L2_message.content m)) - messages - in - let+ simulation_ctxt, _ticks = - Simulation.simulate_messages node_ctxt simulation_ctxt ext_messages - in - simulation_ctxt + type launch_error = error trace - let on_register state (messages : string list) = + let on_launch _w () Types.{node_ctxt; signer; conf} = let open Lwt_result_syntax in - let max_size_msg = - min - (Protocol.Constants_repr.sc_rollup_message_size_limit - + 4 (* We add 4 because [message_size] adds 4. *)) - state.conf.max_batch_size - in - let*? messages = - List.mapi_e - (fun i message -> - if message_size message > max_size_msg then - error_with "Message %d is too large (max size is %d)" i max_size_msg - else Ok (L2_message.make message)) - messages - in - let* () = - if not state.conf.simulate then return_unit - else - match state.simulation_ctxt with - | None -> failwith "Simulation context of batcher not initialized" - | Some simulation_ctxt -> - let+ simulation_ctxt = - simulate state.node_ctxt simulation_ctxt messages - in - state.simulation_ctxt <- Some simulation_ctxt - in - let*! () = Batcher_events.(emit queue) (List.length messages) in - let hashes = - List.map - (fun message -> - let msg_hash = L2_message.hash message in - Message_queue.replace state.messages msg_hash message ; - msg_hash) - messages - in - let+ () = produce_batches state ~only_full:true in - hashes + let*! state = init_batcher_state node_ctxt ~signer conf in + return state - let on_new_head state head = + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let* simulation_ctxt = - Simulation.start_simulation ~reveal_map:None state.node_ctxt head - in - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4224 - Replay with simulation may be too expensive *) - let+ simulation_ctxt, failing = - if not state.conf.simulate then return (simulation_ctxt, []) - else - (* Re-simulate one by one *) - Message_queue.fold_es - (fun msg_hash msg (simulation_ctxt, failing) -> - let*! result = simulate state.node_ctxt simulation_ctxt [msg] in - match result with - | Ok simulation_ctxt -> return (simulation_ctxt, failing) - | Error _ -> return (simulation_ctxt, msg_hash :: failing)) - state.messages - (simulation_ctxt, []) - in - state.simulation_ctxt <- Some simulation_ctxt ; - (* Forget failing messages *) - List.iter (Message_queue.remove state.messages) failing - - let init_batcher_state node_ctxt ~signer (conf : Configuration.batcher) = - let open Lwt_syntax in - let conf = - { - simulate = conf.simulate; - min_batch_elements = conf.min_batch_elements; - min_batch_size = conf.min_batch_size; - max_batch_elements = conf.max_batch_elements; - max_batch_size = - Option.value - conf.max_batch_size - ~default:Node_context.protocol_max_batch_size; - } - in - return - { - node_ctxt; - signer; - conf; - messages = Message_queue.create 100_000 (* ~ 400MB *); - batched = Batched_messages.create 100_000 (* ~ 400MB *); - simulation_ctxt = None; - } - - module Types = struct - type nonrec state = state - - type parameters = { - node_ctxt : Node_context.ro; - signer : Signature.public_key_hash; - conf : Configuration.batcher; - } - end - - module Name = struct - (* We only have a single batcher in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Batcher_events.Worker.section - @ [ - ("worker" - ^ if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Register messages -> - protect @@ fun () -> on_register state messages - | Request.Batch -> protect @@ fun () -> on_batch state - | Request.New_head head -> protect @@ fun () -> on_new_head state head - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt; signer; conf} = - let open Lwt_result_syntax in - let*! state = init_batcher_state node_ctxt ~signer conf in - return state - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Batcher_events.(emit Worker.request_failed) (request_view, st, errs) - in - return_unit + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Batcher_events.(emit Worker.request_failed) (request_view, st, errs) in - match r with - | Request.Register _ -> emit_and_return_errors errs - | Request.Batch -> emit_and_return_errors errs - | Request.New_head _ -> emit_and_return_errors errs - - let on_completion _w r _ st = - match Request.view r with - | Request.View (Register _ | New_head _) -> - Batcher_events.(emit Worker.request_completed_debug) - (Request.view r, st) - | View Batch -> - Batcher_events.(emit Worker.request_completed_notice) - (Request.view r, st) - - let on_no_request _ = Lwt.return_unit - - let on_close _w = Lwt.return_unit - end - - let table = Worker.create_table Queue - - let worker_promise, worker_waker = Lwt.task () - - let init conf ~signer node_ctxt = - let open Lwt_result_syntax in - let node_ctxt = Node_context.readonly node_ctxt in - let+ worker = - Worker.launch table () {node_ctxt; signer; conf} (module Handlers) + return_unit in - Lwt.wakeup worker_waker worker - - (* This is a batcher worker for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_batcher) - - let active () = - match Lwt.state worker_promise with - | Lwt.Return _ -> true - | Lwt.Fail _ | Lwt.Sleep -> false - - let find_message hash = - let open Result_syntax in - let+ w = Lazy.force worker in - let state = Worker.state w in - Message_queue.find_opt state.messages hash - - let get_queue () = - let open Result_syntax in - let+ w = Lazy.force worker in - let state = Worker.state w in - Message_queue.bindings state.messages - - let handle_request_error rq = - let open Lwt_syntax in - let* rq in - match rq with - | Ok res -> return_ok res - | Error (Worker.Request_error errs) -> Lwt.return_error errs - | Error (Closed None) -> Lwt.return_error [Worker_types.Terminated] - | Error (Closed (Some errs)) -> Lwt.return_error errs - | Error (Any exn) -> Lwt.return_error [Exn exn] - - let register_messages messages = - let open Lwt_result_syntax in - let*? w = Lazy.force worker in - Worker.Queue.push_request_and_wait w (Request.Register messages) - |> handle_request_error - - let batch () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no batcher, nothing to do *) - return_unit - | Ok w -> - Worker.Queue.push_request_and_wait w Request.Batch - |> handle_request_error - - let new_head b = - let open Lwt_result_syntax in - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no batcher, nothing to do *) - return_unit - | Ok w -> - let*! (_pushed : bool) = - Worker.Queue.push_request w (Request.New_head b) - in - return_unit - - let shutdown () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no batcher, nothing to do *) - Lwt.return_unit - | Ok w -> Worker.shutdown w - - let message_status state msg_hash = - match Message_queue.find_opt state.messages msg_hash with - | Some msg -> Some (Pending_batch, L2_message.content msg) - | None -> ( - match Batched_messages.find_opt state.batched msg_hash with - | Some {content; l1_hash} -> Some (Batched l1_hash, content) - | None -> None) - - let message_status msg_hash = - let open Result_syntax in - let+ w = Lazy.force worker in - let state = Worker.state w in - message_status state msg_hash + match r with + | Request.Register _ -> emit_and_return_errors errs + | Request.Batch -> emit_and_return_errors errs + | Request.New_head _ -> emit_and_return_errors errs + + let on_completion _w r _ st = + match Request.view r with + | Request.View (Register _ | New_head _) -> + Batcher_events.(emit Worker.request_completed_debug) (Request.view r, st) + | View Batch -> + Batcher_events.(emit Worker.request_completed_notice) + (Request.view r, st) + + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit end + +let table = Worker.create_table Queue + +let worker_promise, worker_waker = Lwt.task () + +let init conf ~signer node_ctxt = + let open Lwt_result_syntax in + let node_ctxt = Node_context.readonly node_ctxt in + let+ worker = + Worker.launch table () {node_ctxt; signer; conf} (module Handlers) + in + Lwt.wakeup worker_waker worker + +(* This is a batcher worker for a single scoru *) +let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_batcher) + +let active () = + match Lwt.state worker_promise with + | Lwt.Return _ -> true + | Lwt.Fail _ | Lwt.Sleep -> false + +let find_message hash = + let open Result_syntax in + let+ w = Lazy.force worker in + let state = Worker.state w in + Message_queue.find_opt state.messages hash + +let get_queue () = + let open Result_syntax in + let+ w = Lazy.force worker in + let state = Worker.state w in + Message_queue.bindings state.messages + +let handle_request_error rq = + let open Lwt_syntax in + let* rq in + match rq with + | Ok res -> return_ok res + | Error (Worker.Request_error errs) -> Lwt.return_error errs + | Error (Closed None) -> Lwt.return_error [Worker_types.Terminated] + | Error (Closed (Some errs)) -> Lwt.return_error errs + | Error (Any exn) -> Lwt.return_error [Exn exn] + +let register_messages messages = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + Worker.Queue.push_request_and_wait w (Request.Register messages) + |> handle_request_error + +let batch () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no batcher, nothing to do *) + return_unit + | Ok w -> + Worker.Queue.push_request_and_wait w Request.Batch |> handle_request_error + +let new_head b = + let open Lwt_result_syntax in + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no batcher, nothing to do *) + return_unit + | Ok w -> + let*! (_pushed : bool) = + Worker.Queue.push_request w (Request.New_head b) + in + return_unit + +let shutdown () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no batcher, nothing to do *) + Lwt.return_unit + | Ok w -> Worker.shutdown w + +let message_status state msg_hash = + match Message_queue.find_opt state.messages msg_hash with + | Some msg -> Some (Pending_batch, L2_message.content msg) + | None -> ( + match Batched_messages.find_opt state.batched msg_hash with + | Some {content; l1_hash} -> Some (Batched l1_hash, content) + | None -> None) + +let message_status msg_hash = + let open Result_syntax in + let+ w = Lazy.force worker in + let state = Worker.state w in + message_status state msg_hash diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/batcher.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/batcher.mli index a6618f27bdc9..f4e9e223a647 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/batcher.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/batcher.mli @@ -26,55 +26,51 @@ open Protocol open Alpha_context -module type S = sig - (** The type for the status of messages in the batcher. *) - type status = - | Pending_batch (** The message is in the queue of the batcher. *) - | Batched of Injector.Inj_operation.hash - (** The message has already been batched and sent to the injector in an - L1 operation whose hash is given. *) +(** The type for the status of messages in the batcher. *) +type status = + | Pending_batch (** The message is in the queue of the batcher. *) + | Batched of Injector.Inj_operation.hash + (** The message has already been batched and sent to the injector in an L1 + operation whose hash is given. *) - (** [init config ~signer node_ctxt] initializes and starts the batcher for - [signer]. If [config.simulation] is [true] (the default), messages added - to the batcher are simulated in an incremental simulation context. *) - val init : - Configuration.batcher -> - signer:public_key_hash -> - _ Node_context.t -> - unit tzresult Lwt.t +(** [init config ~signer node_ctxt] initializes and starts the batcher for + [signer]. If [config.simulation] is [true] (the default), messages added to + the batcher are simulated in an incremental simulation context. *) +val init : + Configuration.batcher -> + signer:public_key_hash -> + _ Node_context.t -> + unit tzresult Lwt.t - (** Return [true] if the batcher was started for this node. *) - val active : unit -> bool +(** Return [true] if the batcher was started for this node. *) +val active : unit -> bool - (** Retrieve an L2 message from the queue. *) - val find_message : L2_message.hash -> L2_message.t option tzresult +(** Retrieve an L2 message from the queue. *) +val find_message : L2_message.hash -> L2_message.t option tzresult - (** List all queued messages in the order they appear in the queue, i.e. the - message that were added first to the queue are at the end of list. *) - val get_queue : unit -> (L2_message.hash * L2_message.t) list tzresult +(** List all queued messages in the order they appear in the queue, i.e. the + message that were added first to the queue are at the end of list. *) +val get_queue : unit -> (L2_message.hash * L2_message.t) list tzresult - (** [register_messages messages] registers new L2 [messages] in the queue of - the batcher for future injection on L1. If the batcher was initialized - with [simualte = true], the messages are evaluated the batcher's - incremental simulation context. In this case, when the application fails, - the messages are not queued. *) - val register_messages : string list -> L2_message.hash list tzresult Lwt.t +(** [register_messages messages] registers new L2 [messages] in the queue of the + batcher for future injection on L1. If the batcher was initialized with + [simualte = true], the messages are evaluated the batcher's incremental + simulation context. In this case, when the application fails, the messages + are not queued. *) +val register_messages : string list -> L2_message.hash list tzresult Lwt.t - (** Create L2 batches of operations from the queue and pack them in an L1 - batch operation. The batch operation is queued in the injector for - injection on the Tezos node. *) - val batch : unit -> unit tzresult Lwt.t +(** Create L2 batches of operations from the queue and pack them in an L1 batch + operation. The batch operation is queued in the injector for injection on + the Tezos node. *) +val batch : unit -> unit tzresult Lwt.t - (** Notify a new L2 head to the batcher worker. *) - val new_head : Layer1.head -> unit tzresult Lwt.t +(** Notify a new L2 head to the batcher worker. *) +val new_head : Layer1.head -> unit tzresult Lwt.t - (** Shutdown the batcher, waiting for the ongoing request to be processed. *) - val shutdown : unit -> unit Lwt.t +(** Shutdown the batcher, waiting for the ongoing request to be processed. *) +val shutdown : unit -> unit Lwt.t - (** The status of a message in the batcher. Returns [None] if the message is - not known by the batcher (the batcher only keeps the batched status of the - last 500000 messages). *) - val message_status : L2_message.hash -> (status * string) option tzresult -end - -module Make (Simulation : Simulation.S) : S +(** The status of a message in the batcher. Returns [None] if the message is not + known by the batcher (the batcher only keeps the batched status of the last + 500000 messages). *) +val message_status : L2_message.hash -> (status * string) option tzresult diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/commitment.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/commitment.ml deleted file mode 100644 index d82c08e76da2..000000000000 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/commitment.ml +++ /dev/null @@ -1,548 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 TriliTech *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** The rollup node stores and publishes commitments for the PVM every - [Constants.sc_rollup_commitment_period_in_blocks] levels. - - Every time a finalized block is processed by the rollup node, the latter - determines whether the last commitment that the node has produced referred - to [sc_rollup.commitment_period_in_blocks] blocks earlier. For mainnet, - [sc_rollup.commitment_period_in_blocks = 30]. In this case, it computes and - stores a new commitment in a level-indexed map. - - Stored commitments are signed by the rollup node operator - and published on the layer1 chain. To ensure that commitments - produced by the rollup node are eventually published, - storing and publishing commitments are decoupled. Every time - a new head is processed, the node tries to publish the oldest - commitment that was not published already. -*) - -open Protocol -open Alpha_context -open Publisher_worker_types - -module Lwt_result_option_syntax = struct - let ( let** ) a f = - let open Lwt_result_syntax in - let* a in - match a with None -> return_none | Some a -> f a -end - -module Lwt_result_option_list_syntax = struct - (** A small monadic combinator to return an empty list on None results. *) - let ( let*& ) x f = - let open Lwt_result_syntax in - let* x in - match x with None -> return_nil | Some x -> f x -end - -let add_level level increment = - (* We only use this function with positive increments so it is safe *) - if increment < 0 then invalid_arg "Commitment.add_level negative increment" ; - Raw_level.Internal_for_tests.add level increment - -let sub_level level decrement = - (* We only use this function with positive increments so it is safe *) - if decrement < 0 then invalid_arg "Commitment.sub_level negative decrement" ; - Raw_level.Internal_for_tests.sub level decrement - -let sc_rollup_commitment_period node_ctxt = - node_ctxt.Node_context.protocol_constants.parametric.sc_rollup - .commitment_period_in_blocks - -let sc_rollup_challenge_window node_ctxt = - node_ctxt.Node_context.protocol_constants.parametric.sc_rollup - .challenge_window_in_blocks - -let next_commitment_level node_ctxt last_commitment_level = - add_level last_commitment_level (sc_rollup_commitment_period node_ctxt) - -(* Count instances of the commitment functor to allow for multiple worker events - without conflicts. *) -let instances_count = ref 0 - -module Make (PVM : Pvm.S) : Commitment_sig.S with module PVM = PVM = struct - let () = incr instances_count - - module PVM = PVM - - type state = Node_context.ro - - let tick_of_level (node_ctxt : _ Node_context.t) inbox_level = - let open Lwt_result_syntax in - let* block = - Node_context.get_l2_block_by_level - node_ctxt - (Raw_level.to_int32 inbox_level) - in - return (Sc_rollup_block.final_tick block) - - let build_commitment (node_ctxt : _ Node_context.t) - (prev_commitment : Sc_rollup.Commitment.Hash.t) ~prev_commitment_level - ~inbox_level ctxt = - let open Lwt_result_syntax in - let*! pvm_state = PVM.State.find ctxt in - let*? pvm_state = - match pvm_state with - | Some pvm_state -> Ok pvm_state - | None -> - error_with - "PVM state for commitment at level %a is not available" - Raw_level.pp - inbox_level - in - let*! compressed_state = PVM.state_hash pvm_state in - let*! tick = PVM.get_tick pvm_state in - let* prev_commitment_tick = tick_of_level node_ctxt prev_commitment_level in - let number_of_ticks = - Sc_rollup.Tick.distance tick prev_commitment_tick - |> Z.to_int64 |> Sc_rollup.Number_of_ticks.of_value - in - let*? number_of_ticks = - match number_of_ticks with - | Some number_of_ticks -> - if number_of_ticks = Sc_rollup.Number_of_ticks.zero then - error_with "A 0-tick commitment is impossible" - else Ok number_of_ticks - | None -> error_with "Invalid number of ticks for commitment" - in - return - Sc_rollup.Commitment. - { - predecessor = prev_commitment; - inbox_level; - number_of_ticks; - compressed_state; - } - - let genesis_commitment (node_ctxt : _ Node_context.t) ctxt = - let open Lwt_result_syntax in - let*! pvm_state = PVM.State.find ctxt in - let*? pvm_state = - match pvm_state with - | Some pvm_state -> Ok pvm_state - | None -> error_with "PVM state for genesis commitment is not available" - in - let*! compressed_state = PVM.state_hash pvm_state in - let commitment = - Sc_rollup.Commitment. - { - predecessor = Hash.zero; - inbox_level = node_ctxt.genesis_info.level; - number_of_ticks = Sc_rollup.Number_of_ticks.zero; - compressed_state; - } - in - (* Ensure the initial state corresponds to the one of the rollup's in the - protocol. A mismatch is possible if a wrong external boot sector was - provided. *) - let commitment_hash = Sc_rollup.Commitment.hash_uncarbonated commitment in - let+ () = - fail_unless - Sc_rollup.Commitment.Hash.( - commitment_hash = node_ctxt.genesis_info.commitment_hash) - (Sc_rollup_node_errors.Invalid_genesis_state - { - expected = node_ctxt.genesis_info.commitment_hash; - actual = commitment_hash; - }) - in - commitment - - let create_commitment_if_necessary (node_ctxt : _ Node_context.t) ~predecessor - current_level ctxt = - let open Lwt_result_syntax in - if Raw_level.(current_level = node_ctxt.genesis_info.level) then - let*! () = Commitment_event.compute_commitment current_level in - let+ genesis_commitment = genesis_commitment node_ctxt ctxt in - Some genesis_commitment - else - let* last_commitment_hash = - let+ pred = Node_context.get_l2_block node_ctxt predecessor in - Sc_rollup_block.most_recent_commitment pred.header - in - let* last_commitment = - Node_context.get_commitment node_ctxt last_commitment_hash - in - let next_commitment_level = - next_commitment_level node_ctxt last_commitment.inbox_level - in - if Raw_level.(current_level = next_commitment_level) then - let*! () = Commitment_event.compute_commitment current_level in - let+ commitment = - build_commitment - node_ctxt - last_commitment_hash - ~prev_commitment_level:last_commitment.inbox_level - ~inbox_level:current_level - ctxt - in - Some commitment - else return_none - - let process_head (node_ctxt : _ Node_context.t) ~predecessor - Layer1.{level; header = _; _} ctxt = - let open Lwt_result_syntax in - let current_level = Raw_level.of_int32_exn level in - let* commitment = - create_commitment_if_necessary node_ctxt ~predecessor current_level ctxt - in - match commitment with - | None -> return_none - | Some commitment -> - let* commitment_hash = - Node_context.save_commitment node_ctxt commitment - in - return_some commitment_hash - - let missing_commitments (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - let lpc_level = - match Reference.get node_ctxt.lpc with - | None -> node_ctxt.genesis_info.level - | Some lpc -> lpc.inbox_level - in - let* head = Node_context.last_processed_head_opt node_ctxt in - let next_head_level = - Option.map - (fun (b : Sc_rollup_block.t) -> Raw_level.succ b.header.level) - head - in - let sc_rollup_challenge_window_int32 = - sc_rollup_challenge_window node_ctxt |> Int32.of_int - in - let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = - let* commitment = - Node_context.find_commitment node_ctxt commitment_hash - in - let lcc = Reference.get node_ctxt.lcc in - match commitment with - | None -> return acc - | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> - (* Commitment is before or at the LCC, we have reached the end. *) - return acc - | Some commitment when Raw_level.(commitment.inbox_level <= lpc_level) -> - (* Commitment is before the last published one, we have also reached - the end because we only publish commitments that are for the inbox - of a finalized L1 block. *) - return acc - | Some commitment -> - let* published_info = - Node_context.commitment_published_at_level node_ctxt commitment_hash - in - let past_curfew = - match (published_info, next_head_level) with - | None, _ | _, None -> false - | Some {first_published_at_level; _}, Some next_head_level -> - Raw_level.diff next_head_level first_published_at_level - > sc_rollup_challenge_window_int32 - in - let acc = if past_curfew then acc else commitment :: acc in - (* We keep the commitment and go back to the previous one. *) - gather acc commitment.predecessor - in - let* finalized_block = Node_context.get_finalized_head_opt node_ctxt in - match finalized_block with - | None -> return_nil - | Some finalized -> - (* Start from finalized block's most recent commitment and gather all - commitments that are missing. *) - let commitment = - Sc_rollup_block.most_recent_commitment finalized.header - in - gather [] commitment - - let publish_commitment (node_ctxt : _ Node_context.t) ~source - (commitment : Sc_rollup.Commitment.t) = - let open Lwt_result_syntax in - let publish_operation = - L1_operation.Publish {rollup = node_ctxt.rollup_address; commitment} - in - let*! () = - Commitment_event.publish_commitment - (Sc_rollup.Commitment.hash_uncarbonated commitment) - commitment.inbox_level - in - let* _hash = Injector.add_pending_operation ~source publish_operation in - return_unit - - let on_publish_commitments (node_ctxt : state) = - let open Lwt_result_syntax in - let operator = Node_context.get_operator node_ctxt Publish in - if Node_context.is_accuser node_ctxt then - (* Accuser does not publish all commitments *) - return_unit - else - match operator with - | None -> - (* Configured to not publish commitments *) - return_unit - | Some source -> - let* commitments = missing_commitments node_ctxt in - List.iter_es (publish_commitment node_ctxt ~source) commitments - - let publish_single_commitment node_ctxt (commitment : Sc_rollup.Commitment.t) - = - let open Lwt_result_syntax in - let operator = Node_context.get_operator node_ctxt Publish in - let lcc = Reference.get node_ctxt.lcc in - match operator with - | None -> - (* Configured to not publish commitments *) - return_unit - | Some source -> - when_ (commitment.inbox_level > lcc.level) @@ fun () -> - publish_commitment node_ctxt ~source commitment - - (* Commitments can only be cemented after [sc_rollup_challenge_window] has - passed since they were first published. *) - let earliest_cementing_level node_ctxt commitment_hash = - let open Lwt_result_option_syntax in - let** {first_published_at_level; _} = - Node_context.commitment_published_at_level node_ctxt commitment_hash - in - return_some - @@ add_level first_published_at_level (sc_rollup_challenge_window node_ctxt) - - (** [latest_cementable_commitment node_ctxt head] is the most recent commitment - hash that could be cemented in [head]'s successor if: - - - all its predecessors were cemented - - it would have been first published at the same level as its inbox - - It does not need to be exact but it must be an upper bound on which we can - start the search for cementable commitments. *) - let latest_cementable_commitment (node_ctxt : _ Node_context.t) - (head : Sc_rollup_block.t) = - let open Lwt_result_option_syntax in - let commitment_hash = Sc_rollup_block.most_recent_commitment head.header in - let** commitment = Node_context.find_commitment node_ctxt commitment_hash in - let** cementable_level_bound = - return - @@ sub_level commitment.inbox_level (sc_rollup_challenge_window node_ctxt) - in - let lcc = Reference.get node_ctxt.lcc in - if Raw_level.(cementable_level_bound <= lcc.level) then return_none - else - let** cementable_bound_block = - Node_context.find_l2_block_by_level - node_ctxt - (Raw_level.to_int32 cementable_level_bound) - in - let cementable_commitment = - Sc_rollup_block.most_recent_commitment cementable_bound_block.header - in - return_some cementable_commitment - - let cementable_commitments (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - let open Lwt_result_option_list_syntax in - let*& head = Node_context.last_processed_head_opt node_ctxt in - let head_level = head.header.level in - let lcc = Reference.get node_ctxt.lcc in - let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = - let* commitment = - Node_context.find_commitment node_ctxt commitment_hash - in - match commitment with - | None -> return acc - | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> - (* If we have moved backward passed or at the current LCC then we have - reached the end. *) - return acc - | Some commitment -> - let* earliest_cementing_level = - earliest_cementing_level node_ctxt commitment_hash - in - let acc = - match earliest_cementing_level with - | None -> acc - | Some earliest_cementing_level -> - if Raw_level.(earliest_cementing_level > head_level) then - (* Commitments whose cementing level are after the head's - successor won't be cementable in the next block. *) - acc - else commitment_hash :: acc - in - gather acc commitment.predecessor - in - (* We start our search from the last possible cementable commitment. This is - to avoid iterating over a large number of commitments - ([challenge_window_in_blocks / commitment_period_in_blocks], in the order - of 10^3 on mainnet). *) - let*& latest_cementable_commitment = - latest_cementable_commitment node_ctxt head - in - let* cementable = gather [] latest_cementable_commitment in - match cementable with - | [] -> return_nil - | first_cementable :: _ -> - (* Make sure that the first commitment can be cemented according to the - Layer 1 node as a failsafe. *) - let* green_light = - Plugin.RPC.Sc_rollup.can_be_cemented - node_ctxt.cctxt - (node_ctxt.cctxt#chain, `Head 0) - node_ctxt.rollup_address - first_cementable - in - if green_light then return cementable else return_nil - - let cement_commitment (node_ctxt : _ Node_context.t) ~source commitment_hash = - let open Lwt_result_syntax in - let cement_operation = - L1_operation.Cement - {rollup = node_ctxt.rollup_address; commitment = commitment_hash} - in - let* _hash = Injector.add_pending_operation ~source cement_operation in - return_unit - - let on_cement_commitments (node_ctxt : state) = - let open Lwt_result_syntax in - let operator = Node_context.get_operator node_ctxt Cement in - match operator with - | None -> - (* Configured to not cement commitments *) - return_unit - | Some source -> - let* cementable_commitments = cementable_commitments node_ctxt in - List.iter_es - (cement_commitment node_ctxt ~source) - cementable_commitments - - module Publisher = struct - module Types = struct - type nonrec state = state - - type parameters = {node_ctxt : Node_context.ro} - end - - module Name = struct - (* We only have a single committer in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Commitment_event.section - @ [ - ("publisher" - ^ - if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Publish -> protect @@ fun () -> on_publish_commitments state - | Request.Cement -> protect @@ fun () -> on_cement_commitments state - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt} = return node_ctxt - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Commitment_event.Publisher.request_failed request_view st errs - in - return_unit - in - match r with - | Request.Publish -> emit_and_return_errors errs - | Request.Cement -> emit_and_return_errors errs - - let on_completion _w r _ st = - Commitment_event.Publisher.request_completed (Request.view r) st - - let on_no_request _ = Lwt.return_unit - - let on_close _w = Lwt.return_unit - end - - let table = Worker.create_table Queue - - let worker_promise, worker_waker = Lwt.task () - - let init node_ctxt = - let open Lwt_result_syntax in - let*! () = Commitment_event.starting () in - let node_ctxt = Node_context.readonly node_ctxt in - let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in - Lwt.wakeup worker_waker worker - - (* This is a publisher worker for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_publisher) - - let publish_commitments () = - let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w Request.Publish in - return_unit - - let cement_commitments () = - let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w Request.Cement in - return_unit - - let shutdown () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no publisher, nothing to do *) - Lwt.return_unit - | Ok w -> Worker.shutdown w - end -end diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/commitment_sig.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/commitment_sig.ml index fccdc19b1854..af79ffb90c90 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/commitment_sig.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/commitment_sig.ml @@ -63,21 +63,20 @@ module type S = sig Protocol.Alpha_context.Sc_rollup.Commitment.t -> unit tzresult Lwt.t - (** Worker for publishing and cementing commitments. *) - module Publisher : sig - val init : _ Node_context.t -> unit tzresult Lwt.t + (** Initialize worker for publishing and cementing commitments. *) + val init : _ Node_context.t -> unit tzresult Lwt.t - (** [publish_commitments node_ctxt] publishes the commitments that were not + (** [publish_commitments node_ctxt] publishes the commitments that were not yet published up to the finalized head and which are after the last cemented commitment. *) - val publish_commitments : unit -> unit tzresult Lwt.t + val publish_commitments : unit -> unit tzresult Lwt.t - (** [cement_commitments node_ctxt] cements the commitments that can be + (** [cement_commitments node_ctxt] cements the commitments that can be cemented, i.e. the commitments that are after the current last cemented commitment and which have [sc_rollup_challenge_period] levels on top of them since they were originally published. *) - val cement_commitments : unit -> unit tzresult Lwt.t + val cement_commitments : unit -> unit tzresult Lwt.t - val shutdown : unit -> unit Lwt.t - end + (** Stop worker for publishing and cementing commitments. *) + val shutdown : unit -> unit Lwt.t end diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/daemon.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/daemon.ml index 849a8fd47f02..7a26c556ec3c 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/daemon.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/daemon.ml @@ -25,585 +25,303 @@ (* *) (*****************************************************************************) -module Make (PVM : Pvm.S) = struct - module Components = Components.Make (PVM) - open Protocol - open Alpha_context - open Apply_results +open Protocol +open Alpha_context +open Apply_results - (** Returns [Some c] if [their_commitment] is refutable where [c] is our +(** Returns [Some c] if [their_commitment] is refutable where [c] is our commitment for the same inbox level. *) - let is_refutable_commitment node_ctxt - (their_commitment : Sc_rollup.Commitment.t) their_commitment_hash = - let open Lwt_result_syntax in - let* l2_block = - Node_context.get_l2_block_by_level - node_ctxt - (Raw_level.to_int32 their_commitment.inbox_level) - in - let* our_commitment_and_hash = - Option.filter_map_es - (fun hash -> - let+ commitment = Node_context.find_commitment node_ctxt hash in - Option.map (fun c -> (c, hash)) commitment) - l2_block.header.commitment_hash - in - match our_commitment_and_hash with - | Some (our_commitment, our_commitment_hash) - when Sc_rollup.Commitment.Hash.( - their_commitment_hash <> our_commitment_hash - && their_commitment.predecessor = our_commitment.predecessor) -> - return our_commitment_and_hash - | _ -> return_none +let is_refutable_commitment node_ctxt + (their_commitment : Sc_rollup.Commitment.t) their_commitment_hash = + let open Lwt_result_syntax in + let* l2_block = + Node_context.get_l2_block_by_level + node_ctxt + (Raw_level.to_int32 their_commitment.inbox_level) + in + let* our_commitment_and_hash = + Option.filter_map_es + (fun hash -> + let+ commitment = Node_context.find_commitment node_ctxt hash in + Option.map (fun c -> (c, hash)) commitment) + l2_block.header.commitment_hash + in + match our_commitment_and_hash with + | Some (our_commitment, our_commitment_hash) + when Sc_rollup.Commitment.Hash.( + their_commitment_hash <> our_commitment_hash + && their_commitment.predecessor = our_commitment.predecessor) -> + return our_commitment_and_hash + | _ -> return_none - (** Publish a commitment when an accuser node sees a refutable commitment. *) - let accuser_publish_commitment_when_refutable node_ctxt ~other rollup - their_commitment their_commitment_hash = - let open Lwt_result_syntax in - when_ (Node_context.is_accuser node_ctxt) @@ fun () -> - (* We are seeing a commitment from someone else. We check if we agree - with it, otherwise the accuser publishes our commitment in order to - play the refutation game. *) - let* refutable = - is_refutable_commitment node_ctxt their_commitment their_commitment_hash - in - match refutable with - | None -> return_unit - | Some (our_commitment, our_commitment_hash) -> - let*! () = - Refutation_game_event.potential_conflict_detected - ~our_commitment_hash - ~their_commitment_hash - ~level:their_commitment.inbox_level - ~other - in - assert (Sc_rollup.Address.(node_ctxt.rollup_address = rollup)) ; - Components.Commitment.publish_single_commitment node_ctxt our_commitment +(** Publish a commitment when an accuser node sees a refutable commitment. *) +let accuser_publish_commitment_when_refutable node_ctxt ~other rollup + their_commitment their_commitment_hash = + let open Lwt_result_syntax in + when_ (Node_context.is_accuser node_ctxt) @@ fun () -> + (* We are seeing a commitment from someone else. We check if we agree + with it, otherwise the accuser publishes our commitment in order to + play the refutation game. *) + let* refutable = + is_refutable_commitment node_ctxt their_commitment their_commitment_hash + in + match refutable with + | None -> return_unit + | Some (our_commitment, our_commitment_hash) -> + let*! () = + Refutation_game_event.potential_conflict_detected + ~our_commitment_hash + ~their_commitment_hash + ~level:their_commitment.inbox_level + ~other + in + assert (Sc_rollup.Address.(node_ctxt.rollup_address = rollup)) ; + Publisher.publish_single_commitment node_ctxt our_commitment - (** Process an L1 SCORU operation (for the node's rollup) which is included +(** Process an L1 SCORU operation (for the node's rollup) which is included for the first time. {b Note}: this function does not process inboxes for the rollup, which is done instead by {!Inbox.process_head}. *) - let process_included_l1_operation (type kind) (node_ctxt : Node_context.rw) - (head : Layer1.header) ~source (operation : kind manager_operation) - (result : kind successful_manager_operation_result) = - let open Lwt_result_syntax in - match (operation, result) with - | ( Sc_rollup_publish {commitment; _}, - Sc_rollup_publish_result {published_at_level; _} ) - when Node_context.is_operator node_ctxt source -> - (* Published commitment --------------------------------------------- *) - let save_lpc = - match Reference.get node_ctxt.lpc with - | None -> true - | Some lpc -> Raw_level.(commitment.inbox_level >= lpc.inbox_level) - in - if save_lpc then Reference.set node_ctxt.lpc (Some commitment) ; - let commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated commitment - in - let* () = - Node_context.set_commitment_published_at_level - node_ctxt - commitment_hash - { - first_published_at_level = published_at_level; - published_at_level = - Some (Raw_level.of_int32_exn head.Layer1.level); - } - in - let*! () = - Commitment_event.last_published_commitment_updated - commitment_hash - (Raw_level.of_int32_exn head.Layer1.level) - in - return_unit - | ( Sc_rollup_publish {commitment = their_commitment; rollup}, - Sc_rollup_publish_result - {published_at_level; staked_hash = their_commitment_hash; _} ) -> - (* Commitment published by someone else *) - (* We first register the publication information *) - let* known_commitment = - Node_context.commitment_exists node_ctxt their_commitment_hash - in - let* () = - if not known_commitment then return_unit +let process_included_l1_operation (type kind) (node_ctxt : Node_context.rw) + (head : Layer1.header) ~source (operation : kind manager_operation) + (result : kind successful_manager_operation_result) = + let open Lwt_result_syntax in + match (operation, result) with + | ( Sc_rollup_publish {commitment; _}, + Sc_rollup_publish_result {published_at_level; _} ) + when Node_context.is_operator node_ctxt source -> + (* Published commitment --------------------------------------------- *) + let save_lpc = + match Reference.get node_ctxt.lpc with + | None -> true + | Some lpc -> Raw_level.(commitment.inbox_level >= lpc.inbox_level) + in + if save_lpc then Reference.set node_ctxt.lpc (Some commitment) ; + let commitment_hash = Sc_rollup.Commitment.hash_uncarbonated commitment in + let* () = + Node_context.set_commitment_published_at_level + node_ctxt + commitment_hash + { + first_published_at_level = published_at_level; + published_at_level = Some (Raw_level.of_int32_exn head.Layer1.level); + } + in + let*! () = + Commitment_event.last_published_commitment_updated + commitment_hash + (Raw_level.of_int32_exn head.Layer1.level) + in + return_unit + | ( Sc_rollup_publish {commitment = their_commitment; rollup}, + Sc_rollup_publish_result + {published_at_level; staked_hash = their_commitment_hash; _} ) -> + (* Commitment published by someone else *) + (* We first register the publication information *) + let* known_commitment = + Node_context.commitment_exists node_ctxt their_commitment_hash + in + let* () = + if not known_commitment then return_unit + else + let* republication = + Node_context.commitment_was_published + node_ctxt + ~source:Anyone + their_commitment_hash + in + if republication then return_unit else - let* republication = - Node_context.commitment_was_published + let* () = + Node_context.set_commitment_published_at_level node_ctxt - ~source:Anyone their_commitment_hash + { + first_published_at_level = published_at_level; + published_at_level = None; + } in - if republication then return_unit - else - let* () = - Node_context.set_commitment_published_at_level - node_ctxt - their_commitment_hash - { - first_published_at_level = published_at_level; - published_at_level = None; - } - in - return_unit - in - (* An accuser node will publish its commitment if the other one is - refutable. *) - accuser_publish_commitment_when_refutable - node_ctxt - ~other:source - rollup - their_commitment - their_commitment_hash - | ( Sc_rollup_cement _, - Sc_rollup_cement_result {inbox_level; commitment_hash; _} ) -> - (* Cemented commitment ---------------------------------------------- *) - let* inbox_block = - Node_context.get_l2_block_by_level - node_ctxt - (Raw_level.to_int32 inbox_level) - in - let*? () = - (* We stop the node if we disagree with a cemented commitment *) - error_unless - (Option.equal - Sc_rollup.Commitment.Hash.( = ) - inbox_block.header.commitment_hash - (Some commitment_hash)) - (Sc_rollup_node_errors.Disagree_with_cemented - { - inbox_level; - ours = inbox_block.header.commitment_hash; - on_l1 = commitment_hash; - }) - in - let lcc = Reference.get node_ctxt.lcc in - let*! () = - if Raw_level.(inbox_level > lcc.level) then ( - Reference.set - node_ctxt.lcc - {commitment = commitment_hash; level = inbox_level} ; - Commitment_event.last_cemented_commitment_updated - commitment_hash - inbox_level) - else Lwt.return_unit - in - return_unit - | ( Sc_rollup_refute _, - Sc_rollup_refute_result {game_status = Ended end_status; _} ) - | ( Sc_rollup_timeout _, - Sc_rollup_timeout_result {game_status = Ended end_status; _} ) -> ( - match end_status with - | Loser {loser; _} when Node_context.is_operator node_ctxt loser -> - tzfail (Sc_rollup_node_errors.Lost_game end_status) - | Loser _ -> - (* Other player lost *) return_unit - | Draw -> - let stakers = - match operation with - | Sc_rollup_refute {opponent; _} -> [source; opponent] - | Sc_rollup_timeout {stakers = {alice; bob}; _} -> [alice; bob] - | _ -> assert false - in - fail_when - (List.exists (Node_context.is_operator node_ctxt) stakers) - (Sc_rollup_node_errors.Lost_game end_status)) - | Dal_publish_slot_header _, Dal_publish_slot_header_result {slot_header; _} - when Node_context.dal_supported node_ctxt -> - let* () = - Node_context.save_slot_header - node_ctxt - ~published_in_block_hash:head.Layer1.hash - slot_header - in - return_unit - | _, _ -> - (* Other manager operations *) - return_unit - - let process_l1_operation (type kind) node_ctxt (head : Layer1.header) ~source - (operation : kind manager_operation) - (result : kind Apply_results.manager_operation_result) = - let open Lwt_result_syntax in - let is_for_my_rollup : type kind. kind manager_operation -> bool = function - | Sc_rollup_add_messages _ -> true - | Sc_rollup_cement {rollup; _} - | Sc_rollup_publish {rollup; _} - | Sc_rollup_refute {rollup; _} - | Sc_rollup_timeout {rollup; _} - | Sc_rollup_execute_outbox_message {rollup; _} - | Sc_rollup_recover_bond {sc_rollup = rollup; staker = _} -> - Sc_rollup.Address.(rollup = node_ctxt.Node_context.rollup_address) - | Dal_publish_slot_header _ -> true - | Reveal _ | Transaction _ | Origination _ | Delegation _ - | Update_consensus_key _ | Register_global_constant _ - | Set_deposits_limit _ | Increase_paid_storage _ | Transfer_ticket _ - | Sc_rollup_originate _ | Zk_rollup_origination _ | Zk_rollup_publish _ - | Zk_rollup_update _ -> - false - in - if not (is_for_my_rollup operation) then return_unit - else - (* Only look at operations that are for the node's rollup *) - let*! () = Daemon_event.included_operation operation result in - match result with - | Applied success_result -> - process_included_l1_operation - node_ctxt - head - ~source - operation - success_result - | _ -> - (* No action for non successful operations *) + in + (* An accuser node will publish its commitment if the other one is + refutable. *) + accuser_publish_commitment_when_refutable + node_ctxt + ~other:source + rollup + their_commitment + their_commitment_hash + | ( Sc_rollup_cement _, + Sc_rollup_cement_result {inbox_level; commitment_hash; _} ) -> + (* Cemented commitment ---------------------------------------------- *) + let* inbox_block = + Node_context.get_l2_block_by_level + node_ctxt + (Raw_level.to_int32 inbox_level) + in + let*? () = + (* We stop the node if we disagree with a cemented commitment *) + error_unless + (Option.equal + Sc_rollup.Commitment.Hash.( = ) + inbox_block.header.commitment_hash + (Some commitment_hash)) + (Sc_rollup_node_errors.Disagree_with_cemented + { + inbox_level; + ours = inbox_block.header.commitment_hash; + on_l1 = commitment_hash; + }) + in + let lcc = Reference.get node_ctxt.lcc in + let*! () = + if Raw_level.(inbox_level > lcc.level) then ( + Reference.set + node_ctxt.lcc + {commitment = commitment_hash; level = inbox_level} ; + Commitment_event.last_cemented_commitment_updated + commitment_hash + inbox_level) + else Lwt.return_unit + in + return_unit + | ( Sc_rollup_refute _, + Sc_rollup_refute_result {game_status = Ended end_status; _} ) + | ( Sc_rollup_timeout _, + Sc_rollup_timeout_result {game_status = Ended end_status; _} ) -> ( + match end_status with + | Loser {loser; _} when Node_context.is_operator node_ctxt loser -> + tzfail (Sc_rollup_node_errors.Lost_game end_status) + | Loser _ -> + (* Other player lost *) return_unit + | Draw -> + let stakers = + match operation with + | Sc_rollup_refute {opponent; _} -> [source; opponent] + | Sc_rollup_timeout {stakers = {alice; bob}; _} -> [alice; bob] + | _ -> assert false + in + fail_when + (List.exists (Node_context.is_operator node_ctxt) stakers) + (Sc_rollup_node_errors.Lost_game end_status)) + | Dal_publish_slot_header _, Dal_publish_slot_header_result {slot_header; _} + when Node_context.dal_supported node_ctxt -> + let* () = + Node_context.save_slot_header + node_ctxt + ~published_in_block_hash:head.Layer1.hash + slot_header + in + return_unit + | _, _ -> + (* Other manager operations *) + return_unit - let process_l1_block_operations node_ctxt (head : Layer1.header) = - let open Lwt_result_syntax in - let* block = - Layer1.fetch_tezos_block node_ctxt.Node_context.cctxt head.hash - in - let apply (type kind) accu ~source (operation : kind manager_operation) - result = - let open Lwt_result_syntax in - let* () = accu in - process_l1_operation node_ctxt head ~source operation result - in - let apply_internal (type kind) accu ~source:_ - (_operation : kind Apply_internal_results.internal_operation) - (_result : kind Apply_internal_results.internal_operation_result) = - accu - in - let* () = - Layer1_services.process_manager_operations +let process_l1_operation (type kind) node_ctxt (head : Layer1.header) ~source + (operation : kind manager_operation) + (result : kind Apply_results.manager_operation_result) = + let open Lwt_result_syntax in + let is_for_my_rollup : type kind. kind manager_operation -> bool = function + | Sc_rollup_add_messages _ -> true + | Sc_rollup_cement {rollup; _} + | Sc_rollup_publish {rollup; _} + | Sc_rollup_refute {rollup; _} + | Sc_rollup_timeout {rollup; _} + | Sc_rollup_execute_outbox_message {rollup; _} + | Sc_rollup_recover_bond {sc_rollup = rollup; staker = _} -> + Sc_rollup.Address.(rollup = node_ctxt.Node_context.rollup_address) + | Dal_publish_slot_header _ -> true + | Reveal _ | Transaction _ | Origination _ | Delegation _ + | Update_consensus_key _ | Register_global_constant _ | Set_deposits_limit _ + | Increase_paid_storage _ | Transfer_ticket _ | Sc_rollup_originate _ + | Zk_rollup_origination _ | Zk_rollup_publish _ | Zk_rollup_update _ -> + false + in + if not (is_for_my_rollup operation) then return_unit + else + (* Only look at operations that are for the node's rollup *) + let*! () = Daemon_event.included_operation operation result in + match result with + | Applied success_result -> + process_included_l1_operation + node_ctxt + head + ~source + operation + success_result + | _ -> + (* No action for non successful operations *) return_unit - block.operations - {apply; apply_internal} - in - return_unit - let before_origination (node_ctxt : _ Node_context.t) (header : Layer1.header) +let process_l1_block_operations node_ctxt (head : Layer1.header) = + let open Lwt_result_syntax in + let* block = + Layer1.fetch_tezos_block node_ctxt.Node_context.cctxt head.hash + in + let apply (type kind) accu ~source (operation : kind manager_operation) result = - let origination_level = Raw_level.to_int32 node_ctxt.genesis_info.level in - header.level < origination_level - - let previous_context (node_ctxt : _ Node_context.t) - ~(predecessor : Layer1.header) = - let open Lwt_result_syntax in - if predecessor.level < Raw_level.to_int32 node_ctxt.genesis_info.level then - (* This is before we have interpreted the boot sector, so we start - with an empty context in genesis *) - return (Context.empty node_ctxt.context) - else Node_context.checkout_context node_ctxt predecessor.Layer1.hash - - let rec process_head (node_ctxt : _ Node_context.t) (head : Layer1.header) = - let open Lwt_result_syntax in - let* already_processed = Node_context.is_processed node_ctxt head.hash in - unless (already_processed || before_origination node_ctxt head) @@ fun () -> - let*! () = Daemon_event.head_processing head.hash head.level in - let* predecessor = Node_context.get_predecessor_header_opt node_ctxt head in - match predecessor with - | None -> - (* Predecessor not available on the L1, which means the block does not - exist in the chain. *) - return_unit - | Some predecessor -> - let* () = process_head node_ctxt predecessor in - let* ctxt = previous_context node_ctxt ~predecessor in - let* () = - Node_context.save_level - node_ctxt - {Layer1.hash = head.hash; level = head.level} - in - let* inbox_hash, inbox, inbox_witness, messages = - Inbox.process_head node_ctxt ~predecessor head - in - let* () = - when_ (Node_context.dal_supported node_ctxt) @@ fun () -> - Dal_slots_tracker.process_head node_ctxt (Layer1.head_of_header head) - in - let* () = process_l1_block_operations node_ctxt head in - (* Avoid storing and publishing commitments if the head is not final. *) - (* Avoid triggering the pvm execution if this has been done before for - this head. *) - let* ctxt, _num_messages, num_ticks, initial_tick = - Components.Interpreter.process_head - node_ctxt - ctxt - ~predecessor - head - (inbox, messages) - in - let*! context_hash = Context.commit ctxt in - let* commitment_hash = - Components.Commitment.process_head - node_ctxt - ~predecessor:predecessor.hash - head - ctxt - in - let level = Raw_level.of_int32_exn head.level in - let* previous_commitment_hash = - if level = node_ctxt.genesis_info.Sc_rollup.Commitment.level then - (* Previous commitment for rollup genesis is itself. *) - return node_ctxt.genesis_info.Sc_rollup.Commitment.commitment_hash - else - let+ pred = Node_context.get_l2_block node_ctxt predecessor.hash in - Sc_rollup_block.most_recent_commitment pred.header - in - let header = - Sc_rollup_block. - { - block_hash = head.hash; - level; - predecessor = predecessor.hash; - commitment_hash; - previous_commitment_hash; - context = context_hash; - inbox_witness; - inbox_hash; - } - in - let l2_block = - Sc_rollup_block.{header; content = (); num_ticks; initial_tick} - in - let* () = - Node_context.mark_finalized_level - node_ctxt - Int32.(sub head.level (of_int node_ctxt.block_finality_time)) - in - let* () = Node_context.save_l2_head node_ctxt l2_block in - let*! () = Daemon_event.new_head_processed head.hash head.level in - return_unit - - (* [on_layer_1_head node_ctxt head] processes a new head from the L1. It - also processes any missing blocks that were not processed. *) - let on_layer_1_head node_ctxt (head : Layer1.header) = - let open Lwt_result_syntax in - let* old_head = Node_context.last_processed_head_opt node_ctxt in - let old_head = - match old_head with - | Some h -> - `Head - Layer1. - { - hash = h.header.block_hash; - level = Raw_level.to_int32 h.header.level; - } - | None -> - (* if no head has been processed yet, we want to handle all blocks - since, and including, the rollup origination. *) - let origination_level = - Raw_level.to_int32 node_ctxt.genesis_info.level - in - `Level (Int32.pred origination_level) - in - let stripped_head = Layer1.head_of_header head in - let*! reorg = - Node_context.get_tezos_reorg_for_new_head node_ctxt old_head stripped_head - in - let*? reorg = - match reorg with - | Error trace - when TzTrace.fold - (fun yes error -> - yes - || - match error with - | Octez_crawler.Layer_1.Cannot_find_predecessor _ -> true - | _ -> false) - false - trace -> - (* The reorganization could not be computed entirely because of missing - info on the Layer 1. We fallback to a recursive process_head. *) - Ok {Reorg.no_reorg with new_chain = [stripped_head]} - | _ -> reorg - in - (* TODO: https://gitlab.com/tezos/tezos/-/issues/3348 - Rollback state information on reorganization, i.e. for - reorg.old_chain. *) - let*! () = Daemon_event.processing_heads_iteration reorg.new_chain in - let get_header Layer1.{hash; level} = - if Block_hash.equal hash head.hash then return head - else - let+ header = Layer1.fetch_tezos_shell_header node_ctxt.cctxt hash in - {Layer1.hash; level; header} - in - let* () = - List.iter_es - (fun block -> - let* header = get_header block in - process_head node_ctxt header) - reorg.new_chain - in - let* () = Components.Commitment.Publisher.publish_commitments () in - let* () = Components.Commitment.Publisher.cement_commitments () in - let*! () = Daemon_event.new_heads_processed reorg.new_chain in - let* () = Components.Refutation_coordinator.process stripped_head in - let* () = Components.Batcher.batch () in - let* () = Components.Batcher.new_head stripped_head in - let*! () = Injector.inject ~header:head.header () in - return_unit - - let daemonize (node_ctxt : _ Node_context.t) = - Layer1.iter_heads node_ctxt.l1_ctxt (on_layer_1_head node_ctxt) - - let degraded_refutation_mode (node_ctxt : _ Node_context.t) = let open Lwt_result_syntax in - let*! () = Daemon_event.degraded_mode () in - let message = node_ctxt.Node_context.cctxt#message in - let*! () = message "Shutting down Batcher@." in - let*! () = Components.Batcher.shutdown () in - let*! () = message "Shutting down Commitment Publisher@." in - let*! () = Components.Commitment.Publisher.shutdown () in - Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> - let* () = - Components.Refutation_coordinator.process (Layer1.head_of_header head) - in - let*! () = Injector.inject () in - return_unit - - let install_finalizer node_ctxt rpc_server = - let open Lwt_syntax in - Lwt_exit.register_clean_up_callback ~loc:__LOC__ @@ fun exit_status -> - let message = node_ctxt.Node_context.cctxt#message in - let* () = message "Shutting down RPC server@." in - let* () = Components.RPC_server.shutdown rpc_server in - let* () = message "Shutting down Injector@." in - let* () = Injector.shutdown () in - let* () = message "Shutting down Batcher@." in - let* () = Components.Batcher.shutdown () in - let* () = message "Shutting down Commitment Publisher@." in - let* () = Components.Commitment.Publisher.shutdown () in - let* () = message "Shutting down Refutation Coordinator@." in - let* () = Components.Refutation_coordinator.shutdown () in - let* (_ : unit tzresult) = Node_context.close node_ctxt in - let* () = Event.shutdown_node exit_status in - Tezos_base_unix.Internal_event_unix.close () - - let check_initial_state_hash {Node_context.cctxt; rollup_address; _} = - let open Lwt_result_syntax in - let* l1_reference_initial_state_hash = - RPC.Sc_rollup.initial_pvm_state_hash - cctxt - (cctxt#chain, cctxt#block) - rollup_address - in - let*! s = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! l2_initial_state_hash = PVM.state_hash s in - fail_unless - Sc_rollup.State_hash.( - l1_reference_initial_state_hash = l2_initial_state_hash) - (Sc_rollup_node_errors.Wrong_initial_pvm_state - { - initial_state_hash = l2_initial_state_hash; - expected_state_hash = l1_reference_initial_state_hash; - }) + let* () = accu in + process_l1_operation node_ctxt head ~source operation result + in + let apply_internal (type kind) accu ~source:_ + (_operation : kind Apply_internal_results.internal_operation) + (_result : kind Apply_internal_results.internal_operation_result) = + accu + in + let* () = + Layer1_services.process_manager_operations + return_unit + block.operations + {apply; apply_internal} + in + return_unit - let run node_ctxt configuration = - let open Lwt_result_syntax in - let* () = check_initial_state_hash node_ctxt in - let* rpc_server = Components.RPC_server.start node_ctxt configuration in - let (_ : Lwt_exit.clean_up_callback_id) = - install_finalizer node_ctxt rpc_server - in - let start () = - let*! () = Inbox.start () in - let signers = - Configuration.Operator_purpose_map.bindings node_ctxt.operators - |> List.fold_left - (fun acc (purpose, operator) -> - let purposes = - match Signature.Public_key_hash.Map.find operator acc with - | None -> [purpose] - | Some ps -> purpose :: ps - in - Signature.Public_key_hash.Map.add operator purposes acc) - Signature.Public_key_hash.Map.empty - |> Signature.Public_key_hash.Map.bindings - |> List.map (fun (operator, purposes) -> - let strategy = - match purposes with - | [Configuration.Add_messages] -> `Delay_block 0.5 - | _ -> `Each_block - in - (operator, strategy, purposes)) - in - let* () = Components.Commitment.Publisher.init node_ctxt in - let* () = Components.Refutation_coordinator.init node_ctxt in - let* () = - unless (signers = []) @@ fun () -> - Injector.init - node_ctxt.cctxt - (Node_context.readonly node_ctxt) - ~data_dir:node_ctxt.data_dir - ~signers - ~retention_period:configuration.injector.retention_period - ~allowed_attempts:configuration.injector.attempts - in - let* () = - match - Configuration.Operator_purpose_map.find - Add_messages - node_ctxt.operators - with - | None -> return_unit - | Some signer -> - Components.Batcher.init configuration.batcher ~signer node_ctxt - in - Lwt.dont_wait - (fun () -> - let*! r = Metrics.metrics_serve configuration.metrics_addr in - match r with - | Ok () -> Lwt.return_unit - | Error err -> - Event.(metrics_ended (Format.asprintf "%a" pp_print_trace err))) - (fun exn -> Event.(metrics_ended_dont_wait (Printexc.to_string exn))) ; +let before_origination (node_ctxt : _ Node_context.t) (header : Layer1.header) = + let origination_level = Raw_level.to_int32 node_ctxt.genesis_info.level in + header.level < origination_level - let*! () = - Event.node_is_ready - ~rpc_addr:configuration.rpc_addr - ~rpc_port:configuration.rpc_port - in - daemonize node_ctxt - in - Metrics.Info.init_rollup_node_info - ~id:configuration.sc_rollup_address - ~mode:configuration.mode - ~genesis_level:(Raw_level.to_int32 node_ctxt.genesis_info.level) - ~pvm_kind:(Sc_rollup.Kind.to_string node_ctxt.kind) ; - protect start ~on_error:(function - | Sc_rollup_node_errors.(Lost_game _ | Invalid_genesis_state _) :: _ as - e -> - Format.eprintf "%!%a@.Exiting.@." pp_print_trace e ; - let*! _ = Lwt_exit.exit_and_wait 1 in - return_unit - | e -> - let*! () = Daemon_event.error e in - degraded_refutation_mode node_ctxt) +let previous_context (node_ctxt : _ Node_context.t) + ~(predecessor : Layer1.header) = + let open Lwt_result_syntax in + if predecessor.level < Raw_level.to_int32 node_ctxt.genesis_info.level then + (* This is before we have interpreted the boot sector, so we start + with an empty context in genesis *) + return (Context.empty node_ctxt.context) + else Node_context.checkout_context node_ctxt predecessor.Layer1.hash - module Internal_for_tests = struct - (** Same as {!process_head} but only builds and stores the L2 block - corresponding to [messages]. It is used by the unit tests to build an L2 - chain. *) - let process_messages (node_ctxt : _ Node_context.t) ~is_first_block - ~predecessor head messages = - let open Lwt_result_syntax in +let rec process_head (node_ctxt : _ Node_context.t) (head : Layer1.header) = + let open Lwt_result_syntax in + let* already_processed = Node_context.is_processed node_ctxt head.hash in + unless (already_processed || before_origination node_ctxt head) @@ fun () -> + let*! () = Daemon_event.head_processing head.hash head.level in + let* predecessor = Node_context.get_predecessor_header_opt node_ctxt head in + match predecessor with + | None -> + (* Predecessor not available on the L1, which means the block does not + exist in the chain. *) + return_unit + | Some predecessor -> + let* () = process_head node_ctxt predecessor in let* ctxt = previous_context node_ctxt ~predecessor in let* () = - Node_context.save_level node_ctxt (Layer1.head_of_header head) + Node_context.save_level + node_ctxt + {Layer1.hash = head.hash; level = head.level} in let* inbox_hash, inbox, inbox_witness, messages = - Inbox.Internal_for_tests.process_messages - node_ctxt - ~is_first_block - ~predecessor - head - messages + Inbox.process_head node_ctxt ~predecessor head + in + let* () = + when_ (Node_context.dal_supported node_ctxt) @@ fun () -> + Dal_slots_tracker.process_head node_ctxt (Layer1.head_of_header head) in + let* () = process_l1_block_operations node_ctxt head in + (* Avoid storing and publishing commitments if the head is not final. *) + (* Avoid triggering the pvm execution if this has been done before for + this head. *) let* ctxt, _num_messages, num_ticks, initial_tick = - Components.Interpreter.process_head + Interpreter.process_head node_ctxt ctxt ~predecessor @@ -612,11 +330,7 @@ module Make (PVM : Pvm.S) = struct in let*! context_hash = Context.commit ctxt in let* commitment_hash = - Components.Commitment.process_head - node_ctxt - ~predecessor:predecessor.Layer1.hash - head - ctxt + Publisher.process_head node_ctxt ~predecessor:predecessor.hash head ctxt in let level = Raw_level.of_int32_exn head.level in let* previous_commitment_hash = @@ -643,9 +357,272 @@ module Make (PVM : Pvm.S) = struct let l2_block = Sc_rollup_block.{header; content = (); num_ticks; initial_tick} in + let* () = + Node_context.mark_finalized_level + node_ctxt + Int32.(sub head.level (of_int node_ctxt.block_finality_time)) + in let* () = Node_context.save_l2_head node_ctxt l2_block in - return l2_block - end + let*! () = Daemon_event.new_head_processed head.hash head.level in + return_unit + +(* [on_layer_1_head node_ctxt head] processes a new head from the L1. It + also processes any missing blocks that were not processed. *) +let on_layer_1_head node_ctxt (head : Layer1.header) = + let open Lwt_result_syntax in + let* old_head = Node_context.last_processed_head_opt node_ctxt in + let old_head = + match old_head with + | Some h -> + `Head + Layer1. + { + hash = h.header.block_hash; + level = Raw_level.to_int32 h.header.level; + } + | None -> + (* if no head has been processed yet, we want to handle all blocks + since, and including, the rollup origination. *) + let origination_level = + Raw_level.to_int32 node_ctxt.genesis_info.level + in + `Level (Int32.pred origination_level) + in + let stripped_head = Layer1.head_of_header head in + let*! reorg = + Node_context.get_tezos_reorg_for_new_head node_ctxt old_head stripped_head + in + let*? reorg = + match reorg with + | Error trace + when TzTrace.fold + (fun yes error -> + yes + || + match error with + | Octez_crawler.Layer_1.Cannot_find_predecessor _ -> true + | _ -> false) + false + trace -> + (* The reorganization could not be computed entirely because of missing + info on the Layer 1. We fallback to a recursive process_head. *) + Ok {Reorg.no_reorg with new_chain = [stripped_head]} + | _ -> reorg + in + (* TODO: https://gitlab.com/tezos/tezos/-/issues/3348 + Rollback state information on reorganization, i.e. for + reorg.old_chain. *) + let*! () = Daemon_event.processing_heads_iteration reorg.new_chain in + let get_header Layer1.{hash; level} = + if Block_hash.equal hash head.hash then return head + else + let+ header = Layer1.fetch_tezos_shell_header node_ctxt.cctxt hash in + {Layer1.hash; level; header} + in + let* () = + List.iter_es + (fun block -> + let* header = get_header block in + process_head node_ctxt header) + reorg.new_chain + in + let* () = Publisher.publish_commitments () in + let* () = Publisher.cement_commitments () in + let*! () = Daemon_event.new_heads_processed reorg.new_chain in + let* () = Refutation_coordinator.process stripped_head in + let* () = Batcher.batch () in + let* () = Batcher.new_head stripped_head in + let*! () = Injector.inject ~header:head.header () in + return_unit + +let daemonize (node_ctxt : _ Node_context.t) = + Layer1.iter_heads node_ctxt.l1_ctxt (on_layer_1_head node_ctxt) + +let degraded_refutation_mode (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let*! () = Daemon_event.degraded_mode () in + let message = node_ctxt.Node_context.cctxt#message in + let*! () = message "Shutting down Batcher@." in + let*! () = Batcher.shutdown () in + let*! () = message "Shutting down Commitment Publisher@." in + let*! () = Publisher.shutdown () in + Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> + let* () = Refutation_coordinator.process (Layer1.head_of_header head) in + let*! () = Injector.inject () in + return_unit + +let install_finalizer node_ctxt rpc_server = + let open Lwt_syntax in + Lwt_exit.register_clean_up_callback ~loc:__LOC__ @@ fun exit_status -> + let message = node_ctxt.Node_context.cctxt#message in + let* () = message "Shutting down RPC server@." in + let* () = RPC_server.shutdown rpc_server in + let* () = message "Shutting down Injector@." in + let* () = Injector.shutdown () in + let* () = message "Shutting down Batcher@." in + let* () = Batcher.shutdown () in + let* () = message "Shutting down Commitment Publisher@." in + let* () = Publisher.shutdown () in + let* () = message "Shutting down Refutation Coordinator@." in + let* () = Refutation_coordinator.shutdown () in + let* (_ : unit tzresult) = Node_context.close node_ctxt in + let* () = Event.shutdown_node exit_status in + Tezos_base_unix.Internal_event_unix.close () + +let check_initial_state_hash {Node_context.cctxt; rollup_address; pvm; _} = + let open Lwt_result_syntax in + let* l1_reference_initial_state_hash = + RPC.Sc_rollup.initial_pvm_state_hash + cctxt + (cctxt#chain, cctxt#block) + rollup_address + in + let module PVM = (val pvm) in + let*! s = PVM.initial_state ~empty:(PVM.State.empty ()) in + let*! l2_initial_state_hash = PVM.state_hash s in + fail_unless + Sc_rollup.State_hash.( + l1_reference_initial_state_hash = l2_initial_state_hash) + (Sc_rollup_node_errors.Wrong_initial_pvm_state + { + initial_state_hash = l2_initial_state_hash; + expected_state_hash = l1_reference_initial_state_hash; + }) + +let run node_ctxt configuration = + let open Lwt_result_syntax in + let* () = check_initial_state_hash node_ctxt in + let* rpc_server = RPC_server.start node_ctxt configuration in + let (_ : Lwt_exit.clean_up_callback_id) = + install_finalizer node_ctxt rpc_server + in + let start () = + let*! () = Inbox.start () in + let signers = + Configuration.Operator_purpose_map.bindings node_ctxt.operators + |> List.fold_left + (fun acc (purpose, operator) -> + let purposes = + match Signature.Public_key_hash.Map.find operator acc with + | None -> [purpose] + | Some ps -> purpose :: ps + in + Signature.Public_key_hash.Map.add operator purposes acc) + Signature.Public_key_hash.Map.empty + |> Signature.Public_key_hash.Map.bindings + |> List.map (fun (operator, purposes) -> + let strategy = + match purposes with + | [Configuration.Add_messages] -> `Delay_block 0.5 + | _ -> `Each_block + in + (operator, strategy, purposes)) + in + let* () = Publisher.init node_ctxt in + let* () = Refutation_coordinator.init node_ctxt in + let* () = + unless (signers = []) @@ fun () -> + Injector.init + node_ctxt.cctxt + (Node_context.readonly node_ctxt) + ~data_dir:node_ctxt.data_dir + ~signers + ~retention_period:configuration.injector.retention_period + ~allowed_attempts:configuration.injector.attempts + in + let* () = + match + Configuration.Operator_purpose_map.find Add_messages node_ctxt.operators + with + | None -> return_unit + | Some signer -> Batcher.init configuration.batcher ~signer node_ctxt + in + Lwt.dont_wait + (fun () -> + let*! r = Metrics.metrics_serve configuration.metrics_addr in + match r with + | Ok () -> Lwt.return_unit + | Error err -> + Event.(metrics_ended (Format.asprintf "%a" pp_print_trace err))) + (fun exn -> Event.(metrics_ended_dont_wait (Printexc.to_string exn))) ; + + let*! () = + Event.node_is_ready + ~rpc_addr:configuration.rpc_addr + ~rpc_port:configuration.rpc_port + in + daemonize node_ctxt + in + Metrics.Info.init_rollup_node_info + ~id:configuration.sc_rollup_address + ~mode:configuration.mode + ~genesis_level:(Raw_level.to_int32 node_ctxt.genesis_info.level) + ~pvm_kind:(Sc_rollup.Kind.to_string node_ctxt.kind) ; + protect start ~on_error:(function + | Sc_rollup_node_errors.(Lost_game _ | Invalid_genesis_state _) :: _ as e + -> + Format.eprintf "%!%a@.Exiting.@." pp_print_trace e ; + let*! _ = Lwt_exit.exit_and_wait 1 in + return_unit + | e -> + let*! () = Daemon_event.error e in + degraded_refutation_mode node_ctxt) + +module Internal_for_tests = struct + (** Same as {!process_head} but only builds and stores the L2 block + corresponding to [messages]. It is used by the unit tests to build an L2 + chain. *) + let process_messages (node_ctxt : _ Node_context.t) ~is_first_block + ~predecessor head messages = + let open Lwt_result_syntax in + let* ctxt = previous_context node_ctxt ~predecessor in + let* () = Node_context.save_level node_ctxt (Layer1.head_of_header head) in + let* inbox_hash, inbox, inbox_witness, messages = + Inbox.Internal_for_tests.process_messages + node_ctxt + ~is_first_block + ~predecessor + head + messages + in + let* ctxt, _num_messages, num_ticks, initial_tick = + Interpreter.process_head node_ctxt ctxt ~predecessor head (inbox, messages) + in + let*! context_hash = Context.commit ctxt in + let* commitment_hash = + Publisher.process_head + node_ctxt + ~predecessor:predecessor.Layer1.hash + head + ctxt + in + let level = Raw_level.of_int32_exn head.level in + let* previous_commitment_hash = + if level = node_ctxt.genesis_info.Sc_rollup.Commitment.level then + (* Previous commitment for rollup genesis is itself. *) + return node_ctxt.genesis_info.Sc_rollup.Commitment.commitment_hash + else + let+ pred = Node_context.get_l2_block node_ctxt predecessor.hash in + Sc_rollup_block.most_recent_commitment pred.header + in + let header = + Sc_rollup_block. + { + block_hash = head.hash; + level; + predecessor = predecessor.hash; + commitment_hash; + previous_commitment_hash; + context = context_hash; + inbox_witness; + inbox_hash; + } + in + let l2_block = + Sc_rollup_block.{header; content = (); num_ticks; initial_tick} + in + let* () = Node_context.save_l2_head node_ctxt l2_block in + return l2_block end let run ~data_dir ?log_kernel_debug_file (configuration : Configuration.t) @@ -670,5 +647,4 @@ let run ~data_dir ?log_kernel_debug_file (configuration : Configuration.t) Read_write configuration in - let module Daemon = Make ((val Components.pvm_of_kind node_ctxt.kind)) in - Daemon.run node_ctxt configuration + run node_ctxt configuration diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/fueled_pvm.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/fueled_pvm.ml index adbb02216313..0ef8791e759c 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/fueled_pvm.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/fueled_pvm.ml @@ -30,14 +30,14 @@ open Protocol open Alpha_context module type S = sig - module PVM : Pvm.S - type fuel + type pvm_state = Context.tree + (** Evaluation state for the PVM. *) type eval_state = { - state : PVM.state; (** The actual PVM state. *) - state_hash : PVM.hash; (** Hash of [state]. *) + state : pvm_state; (** The actual PVM state. *) + state_hash : Sc_rollup.State_hash.t; (** Hash of [state]. *) tick : Sc_rollup.Tick.t; (** Tick of [state]. *) inbox_level : Raw_level.t; (** Inbox level in which messages are evaluated. *) @@ -62,7 +62,7 @@ module type S = sig fuel:fuel -> _ Node_context.t -> Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> - PVM.state -> + pvm_state -> eval_result Node_context.delayed_write tzresult Lwt.t (** [eval_messages ?reveal_map ~fuel node_ctxt ~message_counter_offset state @@ -81,393 +81,267 @@ module type S = sig eval_result Node_context.delayed_write tzresult Lwt.t end -module Make (PVM : Pvm.S) = struct - module Make_fueled (F : Fuel.S) : - S with module PVM = PVM and type fuel = F.t = struct - module PVM = PVM +module Make_fueled (F : Fuel.S) : S with type fuel = F.t = struct + type fuel = F.t - type fuel = F.t + type pvm_state = Context.tree - type eval_state = { - state : PVM.state; - state_hash : PVM.hash; - tick : Sc_rollup.Tick.t; - inbox_level : Raw_level.t; - message_counter_offset : int; - remaining_fuel : fuel; - remaining_messages : Sc_rollup.Inbox_message.t list; - } + type eval_state = { + state : pvm_state; + state_hash : Sc_rollup.State_hash.t; + tick : Sc_rollup.Tick.t; + inbox_level : Raw_level.t; + message_counter_offset : int; + remaining_fuel : fuel; + remaining_messages : Sc_rollup.Inbox_message.t list; + } - type eval_result = {state : eval_state; num_ticks : Z.t; num_messages : int} + type eval_result = {state : eval_state; num_ticks : Z.t; num_messages : int} - let get_reveal ~data_dir reveal_map hash = - let found_in_map = - match reveal_map with - | None -> None - | Some map -> Sc_rollup_reveal_hash.Map.find_opt hash map - in - match found_in_map with - | Some data -> return data - | None -> Reveals.get ~data_dir ~pvm_kind:PVM.kind ~hash + let get_reveal ~data_dir ~pvm_kind reveal_map hash = + let found_in_map = + match reveal_map with + | None -> None + | Some map -> Sc_rollup_reveal_hash.Map.find_opt hash map + in + match found_in_map with + | Some data -> return data + | None -> Reveals.get ~data_dir ~pvm_kind ~hash - type eval_completion = - | Aborted of {state : PVM.state; fuel : fuel; current_tick : int64} - | Completed of { - state : PVM.state; - fuel : fuel; - current_tick : int64; - failing_ticks : int64 list; - } + type eval_completion = + | Aborted of {state : pvm_state; fuel : fuel; current_tick : int64} + | Completed of { + state : pvm_state; + fuel : fuel; + current_tick : int64; + failing_ticks : int64 list; + } - exception Error_wrapper of tztrace + exception Error_wrapper of tztrace - (** [eval_until_input node_ctxt reveal_map level message_index ~fuel + (** [eval_until_input node_ctxt reveal_map level message_index ~fuel start_tick failing_ticks state] advances a PVM [state] until it wants more inputs or there are no more [fuel] (if [Some fuel] is specified). The evaluation is running under the processing of some [message_index] at a given [level] and this is the [start_tick] of this message processing. If some [failing_ticks] are planned by the loser mode, they will be made. *) - let eval_until_input node_ctxt reveal_map level message_index ~fuel - start_tick failing_ticks state = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let metadata = Node_context.metadata node_ctxt in - let dal_attestation_lag = - node_ctxt.protocol_constants.parametric.dal.attestation_lag - in - let reveal_builtins = - Tezos_scoru_wasm.Builtins. - { - reveal_preimage = - (fun hash -> - let*! data = - let*? hash = - (* The payload represents the encoded [Sc_rollup_reveal_hash.t]. We must - decode it properly, instead of converting it byte-for-byte. *) - Result.bind_error - (Data_encoding.Binary.of_string - Sc_rollup_reveal_hash.encoding - hash) - (error_with - "Bad reveal hash '%a': %a" - Hex.pp - (Hex.of_string hash) - Data_encoding.Binary.pp_read_error) - in - get_reveal ~data_dir:node_ctxt.data_dir reveal_map hash + let eval_until_input (node_ctxt : _ Node_context.t) reveal_map level + message_index ~fuel start_tick failing_ticks state = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let metadata = Node_context.metadata node_ctxt in + let dal_attestation_lag = + node_ctxt.protocol_constants.parametric.dal.attestation_lag + in + let reveal_builtins = + Tezos_scoru_wasm.Builtins. + { + reveal_preimage = + (fun hash -> + let*! data = + let*? hash = + (* The payload represents the encoded [Sc_rollup_reveal_hash.t]. We must + decode it properly, instead of converting it byte-for-byte. *) + Result.bind_error + (Data_encoding.Binary.of_string + Sc_rollup_reveal_hash.encoding + hash) + (error_with + "Bad reveal hash '%a': %a" + Hex.pp + (Hex.of_string hash) + Data_encoding.Binary.pp_read_error) in - match data with - | Error error -> - (* The [Error_wrapper] must be caught upstream and converted into a - tzresult. *) - Lwt.fail (Error_wrapper error) - | Ok data -> Lwt.return data); - reveal_metadata = - (fun () -> - Lwt.return - (Data_encoding.Binary.to_string_exn - Sc_rollup.Metadata.encoding - metadata)); - } - in - let eval_tick fuel failing_ticks state = - let max_steps = F.max_ticks fuel in - let normal_eval ?(max_steps = max_steps) state = - Lwt.catch - (fun () -> - let*! state, executed_ticks = - PVM.eval_many - ~reveal_builtins - ~write_debug:(Printer node_ctxt.kernel_debug_logger) - ~max_steps - state - in - return (state, executed_ticks, failing_ticks)) - (function - | Error_wrapper error -> Lwt.return (Error error) - | exn -> raise exn) - in - let failure_insertion_eval state tick failing_ticks' = - let*! () = - Interpreter_event.intended_failure - ~level - ~message_index - ~message_tick:tick - ~internal:true - in - let*! state = PVM.Internal_for_tests.insert_failure state in - return (state, 1L, failing_ticks') - in - match failing_ticks with - | xtick :: failing_ticks' -> - let jump = Int64.(max 0L (pred xtick)) in - if Compare.Int64.(jump = 0L) then - (* Insert the failure in the first tick. *) - failure_insertion_eval state xtick failing_ticks' - else - (* Jump just before the tick where we'll insert a failure. - Nevertheless, we don't execute more than [max_steps]. *) - let max_steps = Int64.max 0L max_steps |> Int64.min max_steps in - let open Delayed_write_monad.Lwt_result_syntax in - let>* state, executed_ticks, _failing_ticks = - normal_eval ~max_steps state - in - (* Insert the failure. *) - let>* state, executed_ticks', failing_ticks' = - failure_insertion_eval state xtick failing_ticks' + get_reveal + ~data_dir:node_ctxt.data_dir + ~pvm_kind:node_ctxt.kind + reveal_map + hash in - let executed_ticks = Int64.add executed_ticks executed_ticks' in - return (state, executed_ticks, failing_ticks') - | _ -> normal_eval state - in - let abort state fuel current_tick = - return (Aborted {state; fuel; current_tick}) + match data with + | Error error -> + (* The [Error_wrapper] must be caught upstream and converted into a + tzresult. *) + Lwt.fail (Error_wrapper error) + | Ok data -> Lwt.return data); + reveal_metadata = + (fun () -> + Lwt.return + (Data_encoding.Binary.to_string_exn + Sc_rollup.Metadata.encoding + metadata)); + } + in + let eval_tick fuel failing_ticks state = + let max_steps = F.max_ticks fuel in + let normal_eval ?(max_steps = max_steps) state = + Lwt.catch + (fun () -> + let*! state, executed_ticks = + PVM.eval_many + ~reveal_builtins + ~write_debug:(Printer node_ctxt.kernel_debug_logger) + ~max_steps + state + in + return (state, executed_ticks, failing_ticks)) + (function + | Error_wrapper error -> Lwt.return (Error error) | exn -> raise exn) in - let complete state fuel current_tick failing_ticks = - return (Completed {state; fuel; current_tick; failing_ticks}) + let failure_insertion_eval state tick failing_ticks' = + let*! () = + Interpreter_event.intended_failure + ~level + ~message_index + ~message_tick:tick + ~internal:true + in + let*! state = PVM.Internal_for_tests.insert_failure state in + return (state, 1L, failing_ticks') in - let rec go (fuel : fuel) current_tick failing_ticks state = - let*! input_request = PVM.is_input_state state in - match input_request with - | No_input_required when F.is_empty fuel -> - abort state fuel current_tick - | No_input_required -> ( - let>* next_state, executed_ticks, failing_ticks = - eval_tick fuel failing_ticks state + match failing_ticks with + | xtick :: failing_ticks' -> + let jump = Int64.(max 0L (pred xtick)) in + if Compare.Int64.(jump = 0L) then + (* Insert the failure in the first tick. *) + failure_insertion_eval state xtick failing_ticks' + else + (* Jump just before the tick where we'll insert a failure. + Nevertheless, we don't execute more than [max_steps]. *) + let max_steps = Int64.max 0L max_steps |> Int64.min max_steps in + let open Delayed_write_monad.Lwt_result_syntax in + let>* state, executed_ticks, _failing_ticks = + normal_eval ~max_steps state in - let fuel_executed = F.of_ticks executed_ticks in - match F.consume fuel_executed fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go - fuel - (Int64.add current_tick executed_ticks) - failing_ticks - next_state) - | Needs_reveal (Reveal_raw_data hash) -> ( - let* data = - get_reveal ~data_dir:node_ctxt.data_dir reveal_map hash - in - let*! next_state = PVM.set_input (Reveal (Raw_data data)) state in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Needs_reveal Reveal_metadata -> ( - let*! next_state = - PVM.set_input (Reveal (Metadata metadata)) state - in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Needs_reveal (Request_dal_page page_id) -> ( - let* content_opt = - Dal_pages_request.page_content - ~dal_attestation_lag - node_ctxt - page_id - in - let*! next_state = - PVM.set_input (Reveal (Dal_page content_opt)) state + (* Insert the failure. *) + let>* state, executed_ticks', failing_ticks' = + failure_insertion_eval state xtick failing_ticks' in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Initial | First_after _ -> - complete state fuel current_tick failing_ticks - in - go fuel start_tick failing_ticks state + let executed_ticks = Int64.add executed_ticks executed_ticks' in + return (state, executed_ticks, failing_ticks') + | _ -> normal_eval state + in + let abort state fuel current_tick = + return (Aborted {state; fuel; current_tick}) + in + let complete state fuel current_tick failing_ticks = + return (Completed {state; fuel; current_tick; failing_ticks}) + in + let rec go (fuel : fuel) current_tick failing_ticks state = + let*! input_request = PVM.is_input_state state in + match input_request with + | No_input_required when F.is_empty fuel -> abort state fuel current_tick + | No_input_required -> ( + let>* next_state, executed_ticks, failing_ticks = + eval_tick fuel failing_ticks state + in + let fuel_executed = F.of_ticks executed_ticks in + match F.consume fuel_executed fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go + fuel + (Int64.add current_tick executed_ticks) + failing_ticks + next_state) + | Needs_reveal (Reveal_raw_data hash) -> ( + let* data = + get_reveal + ~data_dir:node_ctxt.data_dir + ~pvm_kind:node_ctxt.kind + reveal_map + hash + in + let*! next_state = PVM.set_input (Reveal (Raw_data data)) state in + match F.consume F.one_tick_consumption fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go fuel (Int64.succ current_tick) failing_ticks next_state) + | Needs_reveal Reveal_metadata -> ( + let*! next_state = PVM.set_input (Reveal (Metadata metadata)) state in + match F.consume F.one_tick_consumption fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go fuel (Int64.succ current_tick) failing_ticks next_state) + | Needs_reveal (Request_dal_page page_id) -> ( + let* content_opt = + Dal_pages_request.page_content + ~dal_attestation_lag + node_ctxt + page_id + in + let*! next_state = + PVM.set_input (Reveal (Dal_page content_opt)) state + in + match F.consume F.one_tick_consumption fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go fuel (Int64.succ current_tick) failing_ticks next_state) + | Initial | First_after _ -> + complete state fuel current_tick failing_ticks + in + go fuel start_tick failing_ticks state - (** [mutate input] corrupts the payload of [input] for testing purposes. *) - let mutate input = - let payload = - Sc_rollup.Inbox_message.unsafe_of_string - "\001to the cheater we promise pain and misery" - in - {input with Sc_rollup.payload} + (** [mutate input] corrupts the payload of [input] for testing purposes. *) + let mutate input = + let payload = + Sc_rollup.Inbox_message.unsafe_of_string + "\001to the cheater we promise pain and misery" + in + {input with Sc_rollup.payload} - type feed_input_completion = - | Feed_input_aborted of {state : PVM.state; fuel : fuel; fed_input : bool} - | Feed_input_completed of {state : PVM.state; fuel : fuel} + type feed_input_completion = + | Feed_input_aborted of {state : pvm_state; fuel : fuel; fed_input : bool} + | Feed_input_completed of {state : pvm_state; fuel : fuel} - (** [feed_input node_ctxt reveal_map level message_index ~fuel + (** [feed_input node_ctxt reveal_map level message_index ~fuel ~failing_ticks state input] feeds [input] (that has a given [message_index] in inbox of [level]) to the PVM in order to advance [state] to the next step that requires an input. This function is controlled by some [fuel] and may introduce intended failures at some given [failing_ticks]. *) - let feed_input node_ctxt reveal_map level message_index ~fuel ~failing_ticks - state input = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let>* res = - eval_until_input - node_ctxt - reveal_map - level - message_index - ~fuel - 0L - failing_ticks - state - in - match res with - | Aborted {state; fuel; _} -> - return (Feed_input_aborted {state; fuel; fed_input = false}) - | Completed {state; fuel; current_tick = tick; failing_ticks} -> ( - let open Delayed_write_monad.Lwt_result_syntax in - match F.consume F.one_tick_consumption fuel with - | None -> return (Feed_input_aborted {state; fuel; fed_input = false}) - | Some fuel -> ( - let>* input, failing_ticks = - match failing_ticks with - | xtick :: failing_ticks' -> - if xtick = tick then - let*! () = - Interpreter_event.intended_failure - ~level - ~message_index - ~message_tick:tick - ~internal:false - in - return (mutate input, failing_ticks') - else return (input, failing_ticks) - | [] -> return (input, failing_ticks) - in - let*! state = PVM.set_input (Inbox_message input) state in - let>* res = - eval_until_input - node_ctxt - reveal_map - level - message_index - ~fuel - tick - failing_ticks - state - in - match res with - | Aborted {state; fuel; _} -> - return (Feed_input_aborted {state; fuel; fed_input = true}) - | Completed {state; fuel; _} -> - return (Feed_input_completed {state; fuel}))) - - let eval_messages ~reveal_map ~fuel node_ctxt ~message_counter_offset state - inbox_level messages = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let level = Raw_level.to_int32 inbox_level |> Int32.to_int in - (* Iterate the PVM state with all the messages. *) - let rec feed_messages (state, fuel) message_index = function - | [] -> - (* Fed all messages *) - return (state, fuel, message_index - message_counter_offset, []) - | messages when F.is_empty fuel -> - (* Consumed all fuel *) - return - (state, fuel, message_index - message_counter_offset, messages) - | message :: messages -> ( - let*? payload = - Sc_rollup.Inbox_message.( - message |> serialize |> Environment.wrap_tzresult) - in - let message_counter = Z.of_int message_index in - let input = Sc_rollup.{inbox_level; message_counter; payload} in - let failing_ticks = - Loser_mode.is_failure - node_ctxt.Node_context.loser_mode - ~level - ~message_index - in - let>* res = - feed_input - node_ctxt - reveal_map - level - message_index - ~fuel - ~failing_ticks - state - input - in - match res with - | Feed_input_completed {state; fuel} -> - feed_messages (state, fuel) (message_index + 1) messages - | Feed_input_aborted {state; fuel; fed_input = false} -> - return - ( state, - fuel, - message_index - message_counter_offset, - message :: messages ) - | Feed_input_aborted {state; fuel; fed_input = true} -> - return - ( state, - fuel, - message_index + 1 - message_counter_offset, - messages )) - in - (feed_messages [@tailcall]) (state, fuel) message_counter_offset messages - - let eval_block_inbox ~fuel node_ctxt (inbox, messages) (state : PVM.state) : - eval_result Node_context.delayed_write tzresult Lwt.t = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - (* Obtain inbox and its messages for this block. *) - let inbox_level = Inbox.inbox_level inbox in - let*! initial_tick = PVM.get_tick state in - (* Evaluate all the messages for this level. *) - let>* state, remaining_fuel, num_messages, remaining_messages = - eval_messages - ~reveal_map:None - ~fuel - node_ctxt - ~message_counter_offset:0 - state - inbox_level - messages - in - let*! final_tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in - let eval_state = - { - state; - state_hash; - tick = final_tick; - inbox_level; - message_counter_offset = num_messages; - remaining_fuel; - remaining_messages; - } - in - return {state = eval_state; num_ticks; num_messages} - - let eval_messages ?reveal_map node_ctxt - { - state; - tick = initial_tick; - inbox_level; - message_counter_offset; - remaining_fuel = fuel; - remaining_messages = messages; - _; - } = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let>* state, remaining_fuel, num_messages, remaining_messages = - match messages with - | [] -> - let level = Raw_level.to_int32 inbox_level |> Int32.to_int in - let message_index = message_counter_offset - 1 in - let failing_ticks = - Loser_mode.is_failure - node_ctxt.Node_context.loser_mode - ~level - ~message_index + let feed_input (node_ctxt : _ Node_context.t) reveal_map level message_index + ~fuel ~failing_ticks state input = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let>* res = + eval_until_input + node_ctxt + reveal_map + level + message_index + ~fuel + 0L + failing_ticks + state + in + match res with + | Aborted {state; fuel; _} -> + return (Feed_input_aborted {state; fuel; fed_input = false}) + | Completed {state; fuel; current_tick = tick; failing_ticks} -> ( + let open Delayed_write_monad.Lwt_result_syntax in + match F.consume F.one_tick_consumption fuel with + | None -> return (Feed_input_aborted {state; fuel; fed_input = false}) + | Some fuel -> ( + let>* input, failing_ticks = + match failing_ticks with + | xtick :: failing_ticks' -> + if xtick = tick then + let*! () = + Interpreter_event.intended_failure + ~level + ~message_index + ~message_tick:tick + ~internal:false + in + return (mutate input, failing_ticks') + else return (input, failing_ticks) + | [] -> return (input, failing_ticks) in + let*! state = PVM.set_input (Inbox_message input) state in let>* res = eval_until_input node_ctxt @@ -475,43 +349,174 @@ module Make (PVM : Pvm.S) = struct level message_index ~fuel - 0L + tick failing_ticks state in - let state, remaining_fuel = - match res with - | Aborted {state; fuel; _} | Completed {state; fuel; _} -> - (state, fuel) - in - return (state, remaining_fuel, 0, []) - | _ -> - eval_messages - ~reveal_map - ~fuel + match res with + | Aborted {state; fuel; _} -> + return (Feed_input_aborted {state; fuel; fed_input = true}) + | Completed {state; fuel; _} -> + return (Feed_input_completed {state; fuel}))) + + let eval_messages ~reveal_map ~fuel node_ctxt ~message_counter_offset state + inbox_level messages = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let level = Raw_level.to_int32 inbox_level |> Int32.to_int in + (* Iterate the PVM state with all the messages. *) + let rec feed_messages (state, fuel) message_index = function + | [] -> + (* Fed all messages *) + return (state, fuel, message_index - message_counter_offset, []) + | messages when F.is_empty fuel -> + (* Consumed all fuel *) + return (state, fuel, message_index - message_counter_offset, messages) + | message :: messages -> ( + let*? payload = + Sc_rollup.Inbox_message.( + message |> serialize |> Environment.wrap_tzresult) + in + let message_counter = Z.of_int message_index in + let input = Sc_rollup.{inbox_level; message_counter; payload} in + let failing_ticks = + Loser_mode.is_failure + node_ctxt.Node_context.loser_mode + ~level + ~message_index + in + let>* res = + feed_input node_ctxt - ~message_counter_offset + reveal_map + level + message_index + ~fuel + ~failing_ticks state - inbox_level - messages - in - let*! final_tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in - let eval_state = - { - state; - state_hash; - tick = final_tick; - inbox_level; - message_counter_offset = message_counter_offset + num_messages; - remaining_fuel; - remaining_messages; - } - in - return {state = eval_state; num_ticks; num_messages} - end + input + in + match res with + | Feed_input_completed {state; fuel} -> + feed_messages (state, fuel) (message_index + 1) messages + | Feed_input_aborted {state; fuel; fed_input = false} -> + return + ( state, + fuel, + message_index - message_counter_offset, + message :: messages ) + | Feed_input_aborted {state; fuel; fed_input = true} -> + return + ( state, + fuel, + message_index + 1 - message_counter_offset, + messages )) + in + (feed_messages [@tailcall]) (state, fuel) message_counter_offset messages + + let eval_block_inbox ~fuel (node_ctxt : _ Node_context.t) (inbox, messages) + (state : pvm_state) : + eval_result Node_context.delayed_write tzresult Lwt.t = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + (* Obtain inbox and its messages for this block. *) + let inbox_level = Inbox.inbox_level inbox in + let*! initial_tick = PVM.get_tick state in + (* Evaluate all the messages for this level. *) + let>* state, remaining_fuel, num_messages, remaining_messages = + eval_messages + ~reveal_map:None + ~fuel + node_ctxt + ~message_counter_offset:0 + state + inbox_level + messages + in + let*! final_tick = PVM.get_tick state in + let*! state_hash = PVM.state_hash state in + let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in + let eval_state = + { + state; + state_hash; + tick = final_tick; + inbox_level; + message_counter_offset = num_messages; + remaining_fuel; + remaining_messages; + } + in + return {state = eval_state; num_ticks; num_messages} - module Free = Make_fueled (Fuel.Free) - module Accounted = Make_fueled (Fuel.Accounted) + let eval_messages ?reveal_map (node_ctxt : _ Node_context.t) + { + state; + tick = initial_tick; + inbox_level; + message_counter_offset; + remaining_fuel = fuel; + remaining_messages = messages; + _; + } = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let>* state, remaining_fuel, num_messages, remaining_messages = + match messages with + | [] -> + let level = Raw_level.to_int32 inbox_level |> Int32.to_int in + let message_index = message_counter_offset - 1 in + let failing_ticks = + Loser_mode.is_failure + node_ctxt.Node_context.loser_mode + ~level + ~message_index + in + let>* res = + eval_until_input + node_ctxt + reveal_map + level + message_index + ~fuel + 0L + failing_ticks + state + in + let state, remaining_fuel = + match res with + | Aborted {state; fuel; _} | Completed {state; fuel; _} -> + (state, fuel) + in + return (state, remaining_fuel, 0, []) + | _ -> + eval_messages + ~reveal_map + ~fuel + node_ctxt + ~message_counter_offset + state + inbox_level + messages + in + let*! final_tick = PVM.get_tick state in + let*! state_hash = PVM.state_hash state in + let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in + let eval_state = + { + state; + state_hash; + tick = final_tick; + inbox_level; + message_counter_offset = message_counter_offset + num_messages; + remaining_fuel; + remaining_messages; + } + in + return {state = eval_state; num_ticks; num_messages} end + +module Free = Make_fueled (Fuel.Free) +module Accounted = Make_fueled (Fuel.Accounted) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/interpreter.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/interpreter.ml index f52bdb1540fe..10e0a8602581 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/interpreter.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/interpreter.ml @@ -26,291 +26,244 @@ open Protocol open Alpha_context -module type S = sig - module PVM : Pvm.S +(** [get_boot_sector block_hash node_ctxt] fetches the operations in the + [block_hash] and looks for the bootsector used to originate the rollup we're + following. It must be called with [block_hash.level] = + [node_ctxt.genesis_info.level]. *) +let get_boot_sector block_hash (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let exception Found_boot_sector of string in + let* block = Layer1.fetch_tezos_block node_ctxt.cctxt block_hash in + let missing_boot_sector () = + failwith "Boot sector not found in Tezos block %a" Block_hash.pp block_hash + in + Lwt.catch + (fun () -> + let apply (type kind) accu ~source:_ (operation : kind manager_operation) + (result : kind Apply_results.successful_manager_operation_result) = + match (operation, result) with + | ( Sc_rollup_originate {kind; boot_sector; _}, + Sc_rollup_originate_result {address; _} ) + when node_ctxt.rollup_address = address && node_ctxt.kind = kind -> + raise (Found_boot_sector boot_sector) + | _ -> accu + in + let apply_internal (type kind) accu ~source:_ + (_operation : kind Apply_internal_results.internal_operation) + (_result : + kind Apply_internal_results.successful_internal_operation_result) = + accu + in + let*? () = + Layer1_services.( + process_applied_manager_operations + (Ok ()) + block.operations + {apply; apply_internal}) + in + missing_boot_sector ()) + (function + | Found_boot_sector boot_sector -> return boot_sector + | _ -> missing_boot_sector ()) - module Accounted_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Accounted.t +let genesis_state block_hash node_ctxt ctxt = + let open Lwt_result_syntax in + let* boot_sector = get_boot_sector block_hash node_ctxt in + let module PVM = (val node_ctxt.pvm) in + let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in + let*! genesis_state = PVM.install_boot_sector initial_state boot_sector in + let*! ctxt = PVM.State.set ctxt genesis_state in + return (ctxt, genesis_state) - module Free_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Free.t +let state_of_head node_ctxt ctxt Layer1.{hash; level} = + let open Lwt_result_syntax in + let*! state = Context.PVMState.find ctxt in + match state with + | None -> + let genesis_level = + Raw_level.to_int32 node_ctxt.Node_context.genesis_info.level + in + if level = genesis_level then genesis_state hash node_ctxt ctxt + else tzfail (Sc_rollup_node_errors.Missing_PVM_state (hash, level)) + | Some state -> return (ctxt, state) - val process_head : - Node_context.rw -> - 'a Context.t -> - predecessor:Layer1.header -> - Layer1.header -> - Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> - ('a Context.t * int * int64 * Sc_rollup.Tick.t) tzresult Lwt.t - - val state_of_tick : - _ Node_context.t -> - ?start_state:Accounted_pvm.eval_state -> - Sc_rollup.Tick.t -> - Raw_level.t -> - Accounted_pvm.eval_state option tzresult Lwt.t - - val state_of_head : - 'a Node_context.t -> - 'a Context.t -> - Layer1.head -> - ('a Context.t * PVM.state) tzresult Lwt.t -end - -module Make (PVM : Pvm.S) : S with module PVM = PVM = struct - module PVM = PVM - module Fueled_pvm = Fueled_pvm.Make (PVM) - module Accounted_pvm = Fueled_pvm.Accounted - module Free_pvm = Fueled_pvm.Free - - (** [get_boot_sector block_hash node_ctxt] fetches the operations in the - [block_hash] and looks for the bootsector used to originate the rollup - we're following. - It must be called with [block_hash.level] = [node_ctxt.genesis_info.level]. - *) - let get_boot_sector block_hash (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - let exception Found_boot_sector of string in - let* block = Layer1.fetch_tezos_block node_ctxt.cctxt block_hash in - let missing_boot_sector () = - failwith - "Boot sector not found in Tezos block %a" - Block_hash.pp - block_hash - in - Lwt.catch - (fun () -> - let apply (type kind) accu ~source:_ - (operation : kind manager_operation) - (result : kind Apply_results.successful_manager_operation_result) = - match (operation, result) with - | ( Sc_rollup_originate {kind; boot_sector; _}, - Sc_rollup_originate_result {address; _} ) - when node_ctxt.rollup_address = address && node_ctxt.kind = kind -> - raise (Found_boot_sector boot_sector) - | _ -> accu - in - let apply_internal (type kind) accu ~source:_ - (_operation : kind Apply_internal_results.internal_operation) - (_result : - kind Apply_internal_results.successful_internal_operation_result) - = - accu - in - let*? () = - Layer1_services.( - process_applied_manager_operations - (Ok ()) - block.operations - {apply; apply_internal}) - in - missing_boot_sector ()) - (function - | Found_boot_sector boot_sector -> return boot_sector - | _ -> missing_boot_sector ()) - - let genesis_state block_hash node_ctxt ctxt = - let open Lwt_result_syntax in - let* boot_sector = get_boot_sector block_hash node_ctxt in - let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! genesis_state = PVM.install_boot_sector initial_state boot_sector in - let*! ctxt = PVM.State.set ctxt genesis_state in - return (ctxt, genesis_state) - - let state_of_head node_ctxt ctxt Layer1.{hash; level} = - let open Lwt_result_syntax in - let*! state = PVM.State.find ctxt in - match state with - | None -> - let genesis_level = - Raw_level.to_int32 node_ctxt.Node_context.genesis_info.level - in - if level = genesis_level then genesis_state hash node_ctxt ctxt - else tzfail (Sc_rollup_node_errors.Missing_PVM_state (hash, level)) - | Some state -> return (ctxt, state) - - (** [transition_pvm node_ctxt predecessor head] runs a PVM at the +(** [transition_pvm node_ctxt predecessor head] runs a PVM at the previous state from block [predecessor] by consuming as many messages as possible from block [head]. *) - let transition_pvm node_ctxt ctxt predecessor Layer1.{hash = _; _} - inbox_messages = - let open Lwt_result_syntax in - (* Retrieve the previous PVM state from store. *) - let* ctxt, predecessor_state = state_of_head node_ctxt ctxt predecessor in - let* eval_result = - Free_pvm.eval_block_inbox - ~fuel:(Fuel.Free.of_ticks 0L) - node_ctxt - inbox_messages - predecessor_state - in - let* { - state = {state; state_hash; inbox_level; tick; _}; - num_messages; - num_ticks; - } = - Delayed_write_monad.apply node_ctxt eval_result - in - let*! ctxt = PVM.State.set ctxt state in - let*! initial_tick = PVM.get_tick predecessor_state in - (* Produce events. *) - let*! () = - Interpreter_event.transitioned_pvm - inbox_level - state_hash - tick - num_messages - in - return (ctxt, num_messages, Z.to_int64 num_ticks, initial_tick) +let transition_pvm node_ctxt ctxt predecessor Layer1.{hash = _; _} + inbox_messages = + let open Lwt_result_syntax in + (* Retrieve the previous PVM state from store. *) + let* ctxt, predecessor_state = state_of_head node_ctxt ctxt predecessor in + let* eval_result = + Fueled_pvm.Free.eval_block_inbox + ~fuel:(Fuel.Free.of_ticks 0L) + node_ctxt + inbox_messages + predecessor_state + in + let* { + state = {state; state_hash; inbox_level; tick; _}; + num_messages; + num_ticks; + } = + Delayed_write_monad.apply node_ctxt eval_result + in + let module PVM = (val node_ctxt.pvm) in + let*! ctxt = PVM.State.set ctxt state in + let*! initial_tick = PVM.get_tick predecessor_state in + (* Produce events. *) + let*! () = + Interpreter_event.transitioned_pvm inbox_level state_hash tick num_messages + in + return (ctxt, num_messages, Z.to_int64 num_ticks, initial_tick) - (** [process_head node_ctxt ctxt ~predecessor head] runs the PVM for the given +(** [process_head node_ctxt ctxt ~predecessor head] runs the PVM for the given head. *) - let process_head (node_ctxt : _ Node_context.t) ctxt - ~(predecessor : Layer1.header) (head : Layer1.header) inbox_messages = - let open Lwt_result_syntax in - let first_inbox_level = - Raw_level.to_int32 node_ctxt.genesis_info.level |> Int32.succ - in - if head.Layer1.level >= first_inbox_level then - transition_pvm - node_ctxt - ctxt - (Layer1.head_of_header predecessor) - (Layer1.head_of_header head) - inbox_messages - else if head.Layer1.level = Raw_level.to_int32 node_ctxt.genesis_info.level - then - let* ctxt, state = genesis_state head.hash node_ctxt ctxt in - let*! ctxt = PVM.State.set ctxt state in - return (ctxt, 0, 0L, Sc_rollup.Tick.initial) - else return (ctxt, 0, 0L, Sc_rollup.Tick.initial) +let process_head (node_ctxt : _ Node_context.t) ctxt + ~(predecessor : Layer1.header) (head : Layer1.header) inbox_messages = + let open Lwt_result_syntax in + let first_inbox_level = + Raw_level.to_int32 node_ctxt.genesis_info.level |> Int32.succ + in + if head.Layer1.level >= first_inbox_level then + transition_pvm + node_ctxt + ctxt + (Layer1.head_of_header predecessor) + (Layer1.head_of_header head) + inbox_messages + else if head.Layer1.level = Raw_level.to_int32 node_ctxt.genesis_info.level + then + let* ctxt, state = genesis_state head.hash node_ctxt ctxt in + let*! ctxt = Context.PVMState.set ctxt state in + return (ctxt, 0, 0L, Sc_rollup.Tick.initial) + else return (ctxt, 0, 0L, Sc_rollup.Tick.initial) - (** Returns the starting evaluation before the evaluation of the block. It - contains the PVM state at the end of the execution of the previous block - and the messages the block ([remaining_messages]). *) - let start_state_of_block node_ctxt (block : Sc_rollup_block.t) = - let open Lwt_result_syntax in - let pred_level = Raw_level.to_int32 block.header.level |> Int32.pred in - let* ctxt = - Node_context.checkout_context node_ctxt block.header.predecessor - in - let* _ctxt, state = - state_of_head - node_ctxt - ctxt - Layer1.{hash = block.header.predecessor; level = pred_level} - in - let* inbox = Node_context.get_inbox node_ctxt block.header.inbox_hash in - let* {is_first_block; predecessor; predecessor_timestamp; messages} = - Node_context.get_messages node_ctxt block.header.inbox_witness - in - let inbox_level = Sc_rollup.Inbox.inbox_level inbox in - let*! tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let messages = - let open Sc_rollup.Inbox_message in - Internal Start_of_level - :: - (if is_first_block then - [Internal Sc_rollup.Inbox_message.protocol_migration_internal_message] - else []) - @ Internal (Info_per_level {predecessor; predecessor_timestamp}) - :: messages - @ [Internal End_of_level] - in - return - Accounted_pvm. - { - state; - state_hash; - inbox_level; - tick; - message_counter_offset = 0; - remaining_fuel = Fuel.Accounted.of_ticks 0L; - remaining_messages = messages; - } +(** Returns the starting evaluation before the evaluation of the block. It + contains the PVM state at the end of the execution of the previous block and + the messages the block ([remaining_messages]). *) +let start_state_of_block node_ctxt (block : Sc_rollup_block.t) = + let open Lwt_result_syntax in + let pred_level = Raw_level.to_int32 block.header.level |> Int32.pred in + let* ctxt = + Node_context.checkout_context node_ctxt block.header.predecessor + in + let* _ctxt, state = + state_of_head + node_ctxt + ctxt + Layer1.{hash = block.header.predecessor; level = pred_level} + in + let* inbox = Node_context.get_inbox node_ctxt block.header.inbox_hash in + let* {is_first_block; predecessor; predecessor_timestamp; messages} = + Node_context.get_messages node_ctxt block.header.inbox_witness + in + let inbox_level = Sc_rollup.Inbox.inbox_level inbox in + let module PVM = (val node_ctxt.pvm) in + let*! tick = PVM.get_tick state in + let*! state_hash = PVM.state_hash state in + let messages = + let open Sc_rollup.Inbox_message in + Internal Start_of_level + :: + (if is_first_block then + [Internal Sc_rollup.Inbox_message.protocol_migration_internal_message] + else []) + @ Internal (Info_per_level {predecessor; predecessor_timestamp}) + :: messages + @ [Internal End_of_level] + in + return + Fueled_pvm.Accounted. + { + state; + state_hash; + inbox_level; + tick; + message_counter_offset = 0; + remaining_fuel = Fuel.Accounted.of_ticks 0L; + remaining_messages = messages; + } - (** [run_for_ticks node_ctxt start_state tick_distance] starts the evaluation - of messages in the [start_state] for at most [tick_distance]. *) - let run_to_tick node_ctxt start_state tick = - let open Delayed_write_monad.Lwt_result_syntax in - let tick_distance = - Sc_rollup.Tick.distance tick start_state.Accounted_pvm.tick |> Z.to_int64 - in - let>+ eval_result = - Accounted_pvm.eval_messages - node_ctxt - { - start_state with - remaining_fuel = Fuel.Accounted.of_ticks tick_distance; - } - in - eval_result.state +(** [run_for_ticks node_ctxt start_state tick_distance] starts the evaluation of + messages in the [start_state] for at most [tick_distance]. *) +let run_to_tick node_ctxt start_state tick = + let open Delayed_write_monad.Lwt_result_syntax in + let tick_distance = + Sc_rollup.Tick.distance tick start_state.Fueled_pvm.Accounted.tick + |> Z.to_int64 + in + let>+ eval_result = + Fueled_pvm.Accounted.eval_messages + node_ctxt + {start_state with remaining_fuel = Fuel.Accounted.of_ticks tick_distance} + in + eval_result.state - let state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) tick - = - let open Lwt_result_syntax in - let* start_state = - match start_state with - | Some start_state - when Raw_level.( - start_state.Accounted_pvm.inbox_level = event.header.level) -> - return start_state - | _ -> - (* Recompute start state on level change or if we don't have a - starting state on hand. *) - start_state_of_block node_ctxt event - in - (* TODO: #3384 - We should test that we always have enough blocks to find the tick - because [state_of_tick] is a critical function. *) - let* result_state = run_to_tick node_ctxt start_state tick in - let result_state = Delayed_write_monad.ignore result_state in - return result_state +let state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) tick = + let open Lwt_result_syntax in + let* start_state = + match start_state with + | Some start_state + when Raw_level.( + start_state.Fueled_pvm.Accounted.inbox_level = event.header.level) + -> + return start_state + | _ -> + (* Recompute start state on level change or if we don't have a + starting state on hand. *) + start_state_of_block node_ctxt event + in + (* TODO: #3384 + We should test that we always have enough blocks to find the tick + because [state_of_tick] is a critical function. *) + let* result_state = run_to_tick node_ctxt start_state tick in + let result_state = Delayed_write_monad.ignore result_state in + return result_state - (* The cache allows cache intermediate states of the PVM in e.g. dissections. *) - module Tick_state_cache = - Aches_lwt.Lache.Make - (Aches.Rache.Transfer - (Aches.Rache.LRU) - (struct - type t = Sc_rollup.Tick.t * Block_hash.t +(* The cache allows cache intermediate states of the PVM in e.g. dissections. *) +module Tick_state_cache = + Aches_lwt.Lache.Make + (Aches.Rache.Transfer + (Aches.Rache.LRU) + (struct + type t = Sc_rollup.Tick.t * Block_hash.t - let equal (t1, b1) (t2, b2) = - Sc_rollup.Tick.(t1 = t2) && Block_hash.(b1 = b2) + let equal (t1, b1) (t2, b2) = + Sc_rollup.Tick.(t1 = t2) && Block_hash.(b1 = b2) - let hash (tick, block) = - ((Sc_rollup.Tick.to_z tick |> Z.hash) * 13) + Block_hash.hash block - end)) + let hash (tick, block) = + ((Sc_rollup.Tick.to_z tick |> Z.hash) * 13) + Block_hash.hash block + end)) - let tick_state_cache = Tick_state_cache.create 64 (* size of 2 dissections *) +let tick_state_cache = Tick_state_cache.create 64 (* size of 2 dissections *) - (* Memoized version of [state_of_tick_aux]. *) - let memo_state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) - tick = - Tick_state_cache.bind_or_put - tick_state_cache - (tick, event.header.block_hash) - (fun (tick, _hash) -> state_of_tick_aux node_ctxt ~start_state event tick) - Lwt.return +(* Memoized version of [state_of_tick_aux]. *) +let memo_state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) + tick = + Tick_state_cache.bind_or_put + tick_state_cache + (tick, event.header.block_hash) + (fun (tick, _hash) -> state_of_tick_aux node_ctxt ~start_state event tick) + Lwt.return - (** [state_of_tick node_ctxt ?start_state tick level] returns [Some end_state] +(** [state_of_tick node_ctxt ?start_state tick level] returns [Some end_state] for a given [tick] if this [tick] happened before [level]. Otherwise, returns [None].*) - let state_of_tick node_ctxt ?start_state tick level = - let open Lwt_result_syntax in - let* event = Node_context.block_with_tick node_ctxt ~max_level:level tick in - match event with - | None -> return_none - | Some event -> - assert (Raw_level.(event.header.level <= level)) ; - let* result_state = - if Node_context.is_loser node_ctxt then - (* TODO: https://gitlab.com/tezos/tezos/-/issues/5253 - The failures/loser mode does not work properly when restarting - from intermediate states. *) - state_of_tick_aux node_ctxt ~start_state:None event tick - else memo_state_of_tick_aux node_ctxt ~start_state event tick - in - return_some result_state -end +let state_of_tick node_ctxt ?start_state tick level = + let open Lwt_result_syntax in + let* event = Node_context.block_with_tick node_ctxt ~max_level:level tick in + match event with + | None -> return_none + | Some event -> + assert (Raw_level.(event.header.level <= level)) ; + let* result_state = + if Node_context.is_loser node_ctxt then + (* TODO: https://gitlab.com/tezos/tezos/-/issues/5253 + The failures/loser mode does not work properly when restarting + from intermediate states. *) + state_of_tick_aux node_ctxt ~start_state:None event tick + else memo_state_of_tick_aux node_ctxt ~start_state event tick + in + return_some result_state diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/interpreter.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/interpreter.mli index 99dd231a3ab9..44cabfbbab1e 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/interpreter.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/interpreter.mli @@ -25,51 +25,38 @@ open Protocol.Alpha_context -module type S = sig - module PVM : Pvm.S - - module Accounted_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Accounted.t - - module Free_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Free.t - - (** [process_head node_ctxt ~predecessor head (inbox, messages)] interprets - the [messages] associated with a [head] (where [predecessor] is the - predecessor of [head] in the L1 chain). This requires the [inbox] to be - updated beforehand. It returns [(ctxt, num_messages, num_ticks, tick)] - where [ctxt] is the updated layer 2 context (with the new PVM state), - [num_messages] is the number of [messages], [num_ticks] is the number of - ticks taken by the PVM for the evaluation and [tick] is the tick reached - by the PVM after the evaluation. *) - val process_head : - Node_context.rw -> - 'a Context.t -> - predecessor:Layer1.header -> - Layer1.header -> - Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> - ('a Context.t * int * int64 * Sc_rollup.Tick.t) tzresult Lwt.t - - (** [state_of_tick node_ctxt ?start_state tick level] returns [Some (state, - hash)] for a given [tick] if this [tick] happened before - [level]. Otherwise, returns [None]. If provided, the evaluation is resumed - from [start_state]. *) - val state_of_tick : - _ Node_context.t -> - ?start_state:Accounted_pvm.eval_state -> - Sc_rollup.Tick.t -> - Raw_level.t -> - Accounted_pvm.eval_state option tzresult Lwt.t - - (** [state_of_head node_ctxt ctxt head] returns the state corresponding to the - block [head], or the state at rollup genesis if the block is before the - rollup origination. *) - val state_of_head : - 'a Node_context.t -> - 'a Context.t -> - Layer1.head -> - ('a Context.t * PVM.state) tzresult Lwt.t -end - -(** Functor to construct an interpreter for a given PVM. *) -module Make (PVM : Pvm.S) : S with module PVM = PVM +(** [process_head node_ctxt ~predecessor head (inbox, messages)] interprets the + [messages] associated with a [head] (where [predecessor] is the predecessor + of [head] in the L1 chain). This requires the [inbox] to be updated + beforehand. It returns [(ctxt, num_messages, num_ticks, tick)] where [ctxt] + is the updated layer 2 context (with the new PVM state), [num_messages] is + the number of [messages], [num_ticks] is the number of ticks taken by the + PVM for the evaluation and [tick] is the tick reached by the PVM after the + evaluation. *) +val process_head : + Node_context.rw -> + 'a Context.t -> + predecessor:Layer1.header -> + Layer1.header -> + Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> + ('a Context.t * int * int64 * Sc_rollup.Tick.t) tzresult Lwt.t + +(** [state_of_tick node_ctxt ?start_state tick level] returns [Some (state, + hash)] for a given [tick] if this [tick] happened before [level]. Otherwise, + returns [None]. If provided, the evaluation is resumed from + [start_state]. *) +val state_of_tick : + _ Node_context.t -> + ?start_state:Fueled_pvm.Accounted.eval_state -> + Sc_rollup.Tick.t -> + Raw_level.t -> + Fueled_pvm.Accounted.eval_state option tzresult Lwt.t + +(** [state_of_head node_ctxt ctxt head] returns the state corresponding to the + block [head], or the state at rollup genesis if the block is before the + rollup origination. *) +val state_of_head : + 'a Node_context.t -> + 'a Context.t -> + Layer1.head -> + ('a Context.t * Context.tree) tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/node_context.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/node_context.ml index 9a63f68e36f9..d344d4301c54 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/node_context.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/node_context.ml @@ -45,6 +45,7 @@ type 'a t = { injector_retention_period : int; block_finality_time : int; kind : Sc_rollup.Kind.t; + pvm : (module Pvm.S); fee_parameters : Configuration.fee_parameters; protocol_constants : Constants.t; loser_mode : Loser_mode.t; @@ -177,6 +178,11 @@ let make_kernel_logger ?log_kernel_debug_file data_dir = in Lwt_io.of_fd ~close:(fun () -> Lwt_unix.close fd) ~mode:Lwt_io.Output fd +let pvm_of_kind : Protocol.Alpha_context.Sc_rollup.Kind.t -> (module Pvm.S) = + function + | Example_arith -> (module Arith_pvm) + | Wasm_2_0_0 -> (module Wasm_2_0_0_pvm) + let check_fee_parameters Configuration.{fee_parameters; _} = let check_value purpose name compare to_string mempool_default value = if compare mempool_default value > 0 then @@ -357,6 +363,7 @@ let init (cctxt : Protocol_client_context.full) ~data_dir ?log_kernel_debug_file lcc = Reference.new_ lcc; lpc = Reference.new_ lpc; kind; + pvm = pvm_of_kind kind; injector_retention_period = 0; block_finality_time = 2; fee_parameters; @@ -974,6 +981,7 @@ module Internal_for_tests = struct lcc; lpc; kind; + pvm = pvm_of_kind kind; injector_retention_period = 0; block_finality_time = 2; fee_parameters = Configuration.default_fee_parameters; diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/node_context.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/node_context.mli index 84c0970b2534..bf462508f6a2 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/node_context.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/node_context.mli @@ -58,6 +58,7 @@ type 'a t = { block_finality_time : int; (** Deterministic block finality time for the layer 1 protocol. *) kind : Sc_rollup.Kind.t; (** Kind of the smart rollup. *) + pvm : (module Pvm.S); (** The PVM used by the smart rollup. *) fee_parameters : Configuration.fee_parameters; (** Fee parameters to use when injecting operations in layer 1. *) protocol_constants : Constants.t; diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.ml index 8b539af74ef6..a76f94397d5e 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.ml @@ -26,39 +26,38 @@ open Node_context open Protocol.Alpha_context -module Make (PVM : Pvm.S) = struct - let get_state_of_lcc node_ctxt = - let open Lwt_result_syntax in - let lcc = Reference.get node_ctxt.lcc in - let* block_hash = - Node_context.hash_of_level node_ctxt (Raw_level.to_int32 lcc.level) - in - let* ctxt = Node_context.checkout_context node_ctxt block_hash in - let*! state = PVM.State.find ctxt in - return state +let get_state_of_lcc node_ctxt = + let open Lwt_result_syntax in + let lcc = Reference.get node_ctxt.lcc in + let* block_hash = + Node_context.hash_of_level node_ctxt (Raw_level.to_int32 lcc.level) + in + let* ctxt = Node_context.checkout_context node_ctxt block_hash in + let*! state = Context.PVMState.find ctxt in + return state - let proof_of_output node_ctxt output = - let open Lwt_result_syntax in - let* state = get_state_of_lcc node_ctxt in - let lcc = Reference.get node_ctxt.lcc in - match state with - | None -> - (* +let proof_of_output node_ctxt output = + let open Lwt_result_syntax in + let* state = get_state_of_lcc node_ctxt in + let lcc = Reference.get node_ctxt.lcc in + match state with + | None -> + (* This case should never happen as origination creates an LCC which must have been considered by the rollup node at startup time. *) - failwith "Error producing outbox proof (no cemented state in the node)" - | Some state -> ( - let*! proof = PVM.produce_output_proof node_ctxt.context state output in - match proof with - | Ok proof -> - let serialized_proof = - Data_encoding.Binary.to_string_exn PVM.output_proof_encoding proof - in - return @@ (lcc.commitment, serialized_proof) - | Error err -> - failwith - "Error producing outbox proof (%a)" - Environment.Error_monad.pp - err) -end + failwith "Error producing outbox proof (no cemented state in the node)" + | Some state -> ( + let module PVM = (val node_ctxt.pvm) in + let*! proof = PVM.produce_output_proof node_ctxt.context state output in + match proof with + | Ok proof -> + let serialized_proof = + Data_encoding.Binary.to_string_exn PVM.output_proof_encoding proof + in + return @@ (lcc.commitment, serialized_proof) + | Error err -> + failwith + "Error producing outbox proof (%a)" + Environment.Error_monad.pp + err) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.mli index 613661e456a7..71e8c4a1f28d 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/outbox.mli @@ -27,11 +27,9 @@ open Protocol.Alpha_context -module Make (PVM : Pvm.S) : sig - (** [proof_of_output node_ctxt output] returns the last cemented commitment - hash and the proof of the output in the LCC. *) - val proof_of_output : - Node_context.rw -> - Sc_rollup.output -> - (Sc_rollup.Commitment.Hash.t * string) tzresult Lwt.t -end +(** [proof_of_output node_ctxt output] returns the last cemented commitment hash + and the proof of the output in the LCC. *) +val proof_of_output : + Node_context.rw -> + Sc_rollup.output -> + (Sc_rollup.Commitment.Hash.t * string) tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/publisher.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/publisher.ml new file mode 100644 index 000000000000..7265d13488f5 --- /dev/null +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/publisher.ml @@ -0,0 +1,521 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** The rollup node stores and publishes commitments for the PVM every + [Constants.sc_rollup_commitment_period_in_blocks] levels. + + Every time a finalized block is processed by the rollup node, the latter + determines whether the last commitment that the node has produced referred + to [sc_rollup.commitment_period_in_blocks] blocks earlier. For mainnet, + [sc_rollup.commitment_period_in_blocks = 30]. In this case, it computes and + stores a new commitment in a level-indexed map. + + Stored commitments are signed by the rollup node operator + and published on the layer1 chain. To ensure that commitments + produced by the rollup node are eventually published, + storing and publishing commitments are decoupled. Every time + a new head is processed, the node tries to publish the oldest + commitment that was not published already. +*) + +open Protocol +open Alpha_context +open Publisher_worker_types + +module Lwt_result_option_syntax = struct + let ( let** ) a f = + let open Lwt_result_syntax in + let* a in + match a with None -> return_none | Some a -> f a +end + +module Lwt_result_option_list_syntax = struct + (** A small monadic combinator to return an empty list on None results. *) + let ( let*& ) x f = + let open Lwt_result_syntax in + let* x in + match x with None -> return_nil | Some x -> f x +end + +let add_level level increment = + (* We only use this function with positive increments so it is safe *) + if increment < 0 then invalid_arg "Commitment.add_level negative increment" ; + Raw_level.Internal_for_tests.add level increment + +let sub_level level decrement = + (* We only use this function with positive increments so it is safe *) + if decrement < 0 then invalid_arg "Commitment.sub_level negative decrement" ; + Raw_level.Internal_for_tests.sub level decrement + +let sc_rollup_commitment_period node_ctxt = + node_ctxt.Node_context.protocol_constants.parametric.sc_rollup + .commitment_period_in_blocks + +let sc_rollup_challenge_window node_ctxt = + node_ctxt.Node_context.protocol_constants.parametric.sc_rollup + .challenge_window_in_blocks + +let next_commitment_level node_ctxt last_commitment_level = + add_level last_commitment_level (sc_rollup_commitment_period node_ctxt) + +type state = Node_context.ro + +let tick_of_level (node_ctxt : _ Node_context.t) inbox_level = + let open Lwt_result_syntax in + let* block = + Node_context.get_l2_block_by_level + node_ctxt + (Raw_level.to_int32 inbox_level) + in + return (Sc_rollup_block.final_tick block) + +let build_commitment (node_ctxt : _ Node_context.t) + (prev_commitment : Sc_rollup.Commitment.Hash.t) ~prev_commitment_level + ~inbox_level ctxt = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! pvm_state = PVM.State.find ctxt in + let*? pvm_state = + match pvm_state with + | Some pvm_state -> Ok pvm_state + | None -> + error_with + "PVM state for commitment at level %a is not available" + Raw_level.pp + inbox_level + in + let*! compressed_state = PVM.state_hash pvm_state in + let*! tick = PVM.get_tick pvm_state in + let* prev_commitment_tick = tick_of_level node_ctxt prev_commitment_level in + let number_of_ticks = + Sc_rollup.Tick.distance tick prev_commitment_tick + |> Z.to_int64 |> Sc_rollup.Number_of_ticks.of_value + in + let*? number_of_ticks = + match number_of_ticks with + | Some number_of_ticks -> + if number_of_ticks = Sc_rollup.Number_of_ticks.zero then + error_with "A 0-tick commitment is impossible" + else Ok number_of_ticks + | None -> error_with "Invalid number of ticks for commitment" + in + return + Sc_rollup.Commitment. + { + predecessor = prev_commitment; + inbox_level; + number_of_ticks; + compressed_state; + } + +let genesis_commitment (node_ctxt : _ Node_context.t) ctxt = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! pvm_state = PVM.State.find ctxt in + let*? pvm_state = + match pvm_state with + | Some pvm_state -> Ok pvm_state + | None -> error_with "PVM state for genesis commitment is not available" + in + let*! compressed_state = PVM.state_hash pvm_state in + let commitment = + Sc_rollup.Commitment. + { + predecessor = Hash.zero; + inbox_level = node_ctxt.genesis_info.level; + number_of_ticks = Sc_rollup.Number_of_ticks.zero; + compressed_state; + } + in + (* Ensure the initial state corresponds to the one of the rollup's in the + protocol. A mismatch is possible if a wrong external boot sector was + provided. *) + let commitment_hash = Sc_rollup.Commitment.hash_uncarbonated commitment in + let+ () = + fail_unless + Sc_rollup.Commitment.Hash.( + commitment_hash = node_ctxt.genesis_info.commitment_hash) + (Sc_rollup_node_errors.Invalid_genesis_state + { + expected = node_ctxt.genesis_info.commitment_hash; + actual = commitment_hash; + }) + in + commitment + +let create_commitment_if_necessary (node_ctxt : _ Node_context.t) ~predecessor + current_level ctxt = + let open Lwt_result_syntax in + if Raw_level.(current_level = node_ctxt.genesis_info.level) then + let*! () = Commitment_event.compute_commitment current_level in + let+ genesis_commitment = genesis_commitment node_ctxt ctxt in + Some genesis_commitment + else + let* last_commitment_hash = + let+ pred = Node_context.get_l2_block node_ctxt predecessor in + Sc_rollup_block.most_recent_commitment pred.header + in + let* last_commitment = + Node_context.get_commitment node_ctxt last_commitment_hash + in + let next_commitment_level = + next_commitment_level node_ctxt last_commitment.inbox_level + in + if Raw_level.(current_level = next_commitment_level) then + let*! () = Commitment_event.compute_commitment current_level in + let+ commitment = + build_commitment + node_ctxt + last_commitment_hash + ~prev_commitment_level:last_commitment.inbox_level + ~inbox_level:current_level + ctxt + in + Some commitment + else return_none + +let process_head (node_ctxt : _ Node_context.t) ~predecessor + Layer1.{level; header = _; _} ctxt = + let open Lwt_result_syntax in + let current_level = Raw_level.of_int32_exn level in + let* commitment = + create_commitment_if_necessary node_ctxt ~predecessor current_level ctxt + in + match commitment with + | None -> return_none + | Some commitment -> + let* commitment_hash = + Node_context.save_commitment node_ctxt commitment + in + return_some commitment_hash + +let missing_commitments (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let lpc_level = + match Reference.get node_ctxt.lpc with + | None -> node_ctxt.genesis_info.level + | Some lpc -> lpc.inbox_level + in + let* head = Node_context.last_processed_head_opt node_ctxt in + let next_head_level = + Option.map + (fun (b : Sc_rollup_block.t) -> Raw_level.succ b.header.level) + head + in + let sc_rollup_challenge_window_int32 = + sc_rollup_challenge_window node_ctxt |> Int32.of_int + in + let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = + let* commitment = Node_context.find_commitment node_ctxt commitment_hash in + let lcc = Reference.get node_ctxt.lcc in + match commitment with + | None -> return acc + | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> + (* Commitment is before or at the LCC, we have reached the end. *) + return acc + | Some commitment when Raw_level.(commitment.inbox_level <= lpc_level) -> + (* Commitment is before the last published one, we have also reached + the end because we only publish commitments that are for the inbox + of a finalized L1 block. *) + return acc + | Some commitment -> + let* published_info = + Node_context.commitment_published_at_level node_ctxt commitment_hash + in + let past_curfew = + match (published_info, next_head_level) with + | None, _ | _, None -> false + | Some {first_published_at_level; _}, Some next_head_level -> + Raw_level.diff next_head_level first_published_at_level + > sc_rollup_challenge_window_int32 + in + let acc = if past_curfew then acc else commitment :: acc in + (* We keep the commitment and go back to the previous one. *) + gather acc commitment.predecessor + in + let* finalized_block = Node_context.get_finalized_head_opt node_ctxt in + match finalized_block with + | None -> return_nil + | Some finalized -> + (* Start from finalized block's most recent commitment and gather all + commitments that are missing. *) + let commitment = + Sc_rollup_block.most_recent_commitment finalized.header + in + gather [] commitment + +let publish_commitment (node_ctxt : _ Node_context.t) ~source + (commitment : Sc_rollup.Commitment.t) = + let open Lwt_result_syntax in + let publish_operation = + L1_operation.Publish {rollup = node_ctxt.rollup_address; commitment} + in + let*! () = + Commitment_event.publish_commitment + (Sc_rollup.Commitment.hash_uncarbonated commitment) + commitment.inbox_level + in + let* _hash = Injector.add_pending_operation ~source publish_operation in + return_unit + +let on_publish_commitments (node_ctxt : state) = + let open Lwt_result_syntax in + let operator = Node_context.get_operator node_ctxt Publish in + if Node_context.is_accuser node_ctxt then + (* Accuser does not publish all commitments *) + return_unit + else + match operator with + | None -> + (* Configured to not publish commitments *) + return_unit + | Some source -> + let* commitments = missing_commitments node_ctxt in + List.iter_es (publish_commitment node_ctxt ~source) commitments + +let publish_single_commitment node_ctxt (commitment : Sc_rollup.Commitment.t) = + let open Lwt_result_syntax in + let operator = Node_context.get_operator node_ctxt Publish in + let lcc = Reference.get node_ctxt.lcc in + match operator with + | None -> + (* Configured to not publish commitments *) + return_unit + | Some source -> + when_ (commitment.inbox_level > lcc.level) @@ fun () -> + publish_commitment node_ctxt ~source commitment + +(* Commitments can only be cemented after [sc_rollup_challenge_window] has + passed since they were first published. *) +let earliest_cementing_level node_ctxt commitment_hash = + let open Lwt_result_option_syntax in + let** {first_published_at_level; _} = + Node_context.commitment_published_at_level node_ctxt commitment_hash + in + return_some + @@ add_level first_published_at_level (sc_rollup_challenge_window node_ctxt) + +(** [latest_cementable_commitment node_ctxt head] is the most recent commitment + hash that could be cemented in [head]'s successor if: + + - all its predecessors were cemented + - it would have been first published at the same level as its inbox + + It does not need to be exact but it must be an upper bound on which we can + start the search for cementable commitments. *) +let latest_cementable_commitment (node_ctxt : _ Node_context.t) + (head : Sc_rollup_block.t) = + let open Lwt_result_option_syntax in + let commitment_hash = Sc_rollup_block.most_recent_commitment head.header in + let** commitment = Node_context.find_commitment node_ctxt commitment_hash in + let** cementable_level_bound = + return + @@ sub_level commitment.inbox_level (sc_rollup_challenge_window node_ctxt) + in + let lcc = Reference.get node_ctxt.lcc in + if Raw_level.(cementable_level_bound <= lcc.level) then return_none + else + let** cementable_bound_block = + Node_context.find_l2_block_by_level + node_ctxt + (Raw_level.to_int32 cementable_level_bound) + in + let cementable_commitment = + Sc_rollup_block.most_recent_commitment cementable_bound_block.header + in + return_some cementable_commitment + +let cementable_commitments (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let open Lwt_result_option_list_syntax in + let*& head = Node_context.last_processed_head_opt node_ctxt in + let head_level = head.header.level in + let lcc = Reference.get node_ctxt.lcc in + let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = + let* commitment = Node_context.find_commitment node_ctxt commitment_hash in + match commitment with + | None -> return acc + | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> + (* If we have moved backward passed or at the current LCC then we have + reached the end. *) + return acc + | Some commitment -> + let* earliest_cementing_level = + earliest_cementing_level node_ctxt commitment_hash + in + let acc = + match earliest_cementing_level with + | None -> acc + | Some earliest_cementing_level -> + if Raw_level.(earliest_cementing_level > head_level) then + (* Commitments whose cementing level are after the head's + successor won't be cementable in the next block. *) + acc + else commitment_hash :: acc + in + gather acc commitment.predecessor + in + (* We start our search from the last possible cementable commitment. This is + to avoid iterating over a large number of commitments + ([challenge_window_in_blocks / commitment_period_in_blocks], in the order + of 10^3 on mainnet). *) + let*& latest_cementable_commitment = + latest_cementable_commitment node_ctxt head + in + let* cementable = gather [] latest_cementable_commitment in + match cementable with + | [] -> return_nil + | first_cementable :: _ -> + (* Make sure that the first commitment can be cemented according to the + Layer 1 node as a failsafe. *) + let* green_light = + Plugin.RPC.Sc_rollup.can_be_cemented + node_ctxt.cctxt + (node_ctxt.cctxt#chain, `Head 0) + node_ctxt.rollup_address + first_cementable + in + if green_light then return cementable else return_nil + +let cement_commitment (node_ctxt : _ Node_context.t) ~source commitment_hash = + let open Lwt_result_syntax in + let cement_operation = + L1_operation.Cement + {rollup = node_ctxt.rollup_address; commitment = commitment_hash} + in + let* _hash = Injector.add_pending_operation ~source cement_operation in + return_unit + +let on_cement_commitments (node_ctxt : state) = + let open Lwt_result_syntax in + let operator = Node_context.get_operator node_ctxt Cement in + match operator with + | None -> + (* Configured to not cement commitments *) + return_unit + | Some source -> + let* cementable_commitments = cementable_commitments node_ctxt in + List.iter_es (cement_commitment node_ctxt ~source) cementable_commitments + +module Types = struct + type nonrec state = state + + type parameters = {node_ctxt : Node_context.ro} +end + +module Name = struct + (* We only have a single committer in the node *) + type t = unit + + let encoding = Data_encoding.unit + + let base = Commitment_event.section @ ["publisher"] + + let pp _ _ = () + + let equal () () = true +end + +module Worker = Worker.MakeSingle (Name) (Request) (Types) + +type worker = Worker.infinite Worker.queue Worker.t + +module Handlers = struct + type self = worker + + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with + | Request.Publish -> protect @@ fun () -> on_publish_commitments state + | Request.Cement -> protect @@ fun () -> on_cement_commitments state + + type launch_error = error trace + + let on_launch _w () Types.{node_ctxt} = return node_ctxt + + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = + let open Lwt_result_syntax in + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Commitment_event.Publisher.request_failed request_view st errs + in + return_unit + in + match r with + | Request.Publish -> emit_and_return_errors errs + | Request.Cement -> emit_and_return_errors errs + + let on_completion _w r _ st = + Commitment_event.Publisher.request_completed (Request.view r) st + + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit +end + +let table = Worker.create_table Queue + +let worker_promise, worker_waker = Lwt.task () + +let init node_ctxt = + let open Lwt_result_syntax in + let*! () = Commitment_event.starting () in + let node_ctxt = Node_context.readonly node_ctxt in + let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in + Lwt.wakeup worker_waker worker + +(* This is a publisher worker for a single scoru *) +let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_publisher) + +let publish_commitments () = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w Request.Publish in + return_unit + +let cement_commitments () = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w Request.Cement in + return_unit + +let shutdown () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no publisher, nothing to do *) + Lwt.return_unit + | Ok w -> Worker.shutdown w diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/commitment.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/publisher.mli similarity index 56% rename from src/proto_017_PtNairob/lib_sc_rollup_node/commitment.mli rename to src/proto_017_PtNairob/lib_sc_rollup_node/publisher.mli index cb6c364d87cd..79990b2198ad 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/commitment.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/publisher.mli @@ -24,12 +24,13 @@ (*****************************************************************************) (** The rollup node stores and publishes commitments for the PVM - every 20 levels. + every `Commitment.sc_rollup_commitment_period` levels. Every time a finalized block is processed by the rollup node, the latter determines whether the last commitment that the node - has produced referred to 20 blocks earlier. In this case, it - computes and stores a new commitment in a level-indexed map. + has produced referred to `Commitment.sc_rollup_commitment_period` blocks + earlier. In this case, it computes and stores a new commitment in a + level-indexed map. Stored commitments are signed by the rollup node operator and published on the layer1 chain. To ensure that commitments @@ -39,4 +40,40 @@ commitment that was not published already. *) -module Make (PVM : Pvm.S) : Commitment_sig.S with module PVM = PVM +(** [process_head node_ctxt ~predecessor head ctxt] builds a new commitment if + needed, by looking at the level of [head] and checking whether it is a + multiple of `Commitment.sc_rollup_commitment_period` levels away from + [node_ctxt.initial_level]. It uses the functionalities of [PVM] to compute + the hash of to be included in the commitment. *) +val process_head : + Node_context.rw -> + predecessor:Block_hash.t -> + Layer1.header -> + Context.rw -> + Protocol.Alpha_context.Sc_rollup.Commitment.Hash.t option tzresult Lwt.t + +(** [publish_single_commitment node_ctxt commitment] publishes a single + [commitment] if it is missing. This function is meant to be used by the {e + accuser} mode to sparingly publish commitments when it detects a + conflict. *) +val publish_single_commitment : + _ Node_context.t -> + Protocol.Alpha_context.Sc_rollup.Commitment.t -> + unit tzresult Lwt.t + +(** Initialize worker for publishing and cementing commitments. *) +val init : _ Node_context.t -> unit tzresult Lwt.t + +(** [publish_commitments node_ctxt] publishes the commitments that were not yet + published up to the finalized head and which are after the last cemented + commitment. *) +val publish_commitments : unit -> unit tzresult Lwt.t + +(** [cement_commitments node_ctxt] cements the commitments that can be cemented, + i.e. the commitments that are after the current last cemented commitment and + which have [sc_rollup_challenge_period] levels on top of them since they + were originally published. *) +val cement_commitments : unit -> unit tzresult Lwt.t + +(** Stop worker for publishing and cementing commitments. *) +val shutdown : unit -> unit Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/pvm.ml index ca8e5769b9f6..13917d6c8b45 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/pvm.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/pvm.ml @@ -32,6 +32,7 @@ module type S = sig include Sc_rollup.PVM.S with type context = Context.rw_index + and type state = Context.tree and type hash = Sc_rollup.State_hash.t (** Kind of the PVM (same as {!name}). *) @@ -69,11 +70,6 @@ module type S = sig our_stop_chunk:Sc_rollup.Dissection_chunk.t -> Sc_rollup.Tick.t list - module RPC : sig - (** Build RPC directory of the PVM *) - val build_directory : Node_context.rw -> unit Environment.RPC_directory.t - end - (** State storage for this PVM. *) module State : sig (** [empty ()] is the empty state. *) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/components.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_rpc.ml similarity index 72% rename from src/proto_017_PtNairob/lib_sc_rollup_node/components.ml rename to src/proto_017_PtNairob/lib_sc_rollup_node/pvm_rpc.ml index 1d5b8c0984fa..06c5c60b5e51 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/components.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/pvm_rpc.ml @@ -1,8 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* Copyright (c) 2022 Trili Tech, *) +(* Copyright (c) 2023 Functori, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -24,17 +23,18 @@ (* *) (*****************************************************************************) -module Make (PVM : Pvm.S) = struct - module PVM = PVM - module Interpreter = Interpreter.Make (PVM) - module Commitment = Commitment.Make (PVM) - module Simulation = Simulation.Make (Interpreter) - module Refutation_coordinator = Refutation_coordinator.Make (Interpreter) - module Batcher = Batcher.Make (Simulation) - module RPC_server = RPC_server.Make (Simulation) (Batcher) +module type S = sig + (** Build RPC directory of the PVM *) + val build_directory : Node_context.rw -> unit Environment.RPC_directory.t end -let pvm_of_kind : Protocol.Alpha_context.Sc_rollup.Kind.t -> (module Pvm.S) = - function - | Example_arith -> (module Arith_pvm) - | Wasm_2_0_0 -> (module Wasm_2_0_0_pvm) +module No_rpc = struct + let build_directory _node_ctxt = Tezos_rpc.Directory.empty +end + +let no_rpc = (module No_rpc : S) + +let of_kind = function + | Protocol.Alpha_context.Sc_rollup.Kind.Example_arith -> no_rpc + | Wasm_2_0_0 -> + (module Wasm_2_0_0_rpc.Make_RPC (Wasm_2_0_0_pvm.Durable_state) : S) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_coordinator.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_coordinator.ml index 183553ddda91..b841d2e7353c 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_coordinator.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_coordinator.ml @@ -26,223 +26,195 @@ open Protocol open Alpha_context open Refutation_coordinator_types +include Refutation_game +module Player = Refutation_player +module Pkh_map = Signature.Public_key_hash.Map +module Pkh_table = Signature.Public_key_hash.Table + +type state = {node_ctxt : Node_context.rw; pending_opponents : unit Pkh_table.t} + +let get_conflicts cctxt head_block = + Plugin.RPC.Sc_rollup.conflicts cctxt (cctxt#chain, head_block) + +let get_ongoing_games cctxt head_block = + Plugin.RPC.Sc_rollup.ongoing_refutation_games cctxt (cctxt#chain, head_block) + +let untracked_conflicts opponent_players conflicts = + List.filter + (fun conflict -> + not + @@ Pkh_map.mem + conflict.Sc_rollup.Refutation_storage.other + opponent_players) + conflicts + +(* Transform the list of ongoing games [(Game.t * pkh * pkh) list] + into a mapping from opponents' pkhs to their corresponding game + state. +*) +let make_game_map self ongoing_games = + List.fold_left + (fun acc (game, alice, bob) -> + let opponent_pkh = + if Signature.Public_key_hash.equal self alice then bob else alice + in + Pkh_map.add opponent_pkh game acc) + Pkh_map.empty + ongoing_games + +let on_process Layer1.{hash; level} state = + let node_ctxt = state.node_ctxt in + let head_block = `Hash (hash, 0) in + let open Lwt_result_syntax in + let refute_signer = Node_context.get_operator node_ctxt Refute in + match refute_signer with + | None -> + (* Not injecting refutations, don't play refutation games *) + return_unit + | Some self -> + let Node_context.{rollup_address; cctxt; _} = node_ctxt in + (* Current conflicts in L1 *) + let* conflicts = get_conflicts cctxt head_block rollup_address self in + (* Map of opponents the node is playing against to the corresponding + player worker *) + let opponent_players = + Pkh_map.of_seq @@ List.to_seq @@ Player.current_games () + in + (* Conflicts for which we need to start new refutation players. + Some of these might be ongoing. *) + let new_conflicts = untracked_conflicts opponent_players conflicts in + (* L1 ongoing games *) + let* ongoing_games = + get_ongoing_games cctxt head_block rollup_address self + in + (* Map between opponents and their corresponding games *) + let ongoing_game_map = make_game_map self ongoing_games in + (* Launch new players for new conflicts, and play one step *) + let* () = + List.iter_ep + (fun conflict -> + let other = conflict.Sc_rollup.Refutation_storage.other in + Pkh_table.replace state.pending_opponents other () ; + let game = Pkh_map.find_opt other ongoing_game_map in + Player.init_and_play node_ctxt ~self ~conflict ~game ~level) + new_conflicts + in + let*! () = + (* Play one step of the refutation game in every remaining player *) + Pkh_map.iter_p + (fun opponent worker -> + match Pkh_map.find opponent ongoing_game_map with + | Some game -> + Pkh_table.remove state.pending_opponents opponent ; + Player.play worker game ~level + | None -> + (* Kill finished players: those who don't aren't + playing against pending opponents that don't have + ongoing games in the L1 *) + if not @@ Pkh_table.mem state.pending_opponents opponent then + Player.shutdown worker + else Lwt.return_unit) + opponent_players + in + return_unit + +module Types = struct + type nonrec state = state + + type parameters = {node_ctxt : Node_context.rw} +end + +module Name = struct + (* We only have a single coordinator in the node *) + type t = unit -module type S = sig - module PVM : Pvm.S + let encoding = Data_encoding.unit - val init : Node_context.rw -> unit tzresult Lwt.t + let base = + (* But we can have multiple instances in the unit tests. This is just to + avoid conflicts in the events declarations. *) + Refutation_game_event.Coordinator.section @ ["worker"] - val process : Layer1.head -> unit tzresult Lwt.t + let pp _ _ = () - val shutdown : unit -> unit Lwt.t + let equal () () = true end -(* Count instances of the coordinator functor to allow for multiple - worker events without conflicts. *) -let instances_count = ref 0 - -module Make (Interpreter : Interpreter.S) = struct - include Refutation_game.Make (Interpreter) - module Player = Refutation_player.Make (Interpreter) - module Pkh_map = Signature.Public_key_hash.Map - module Pkh_table = Signature.Public_key_hash.Table - - let () = incr instances_count - - type state = { - node_ctxt : Node_context.rw; - pending_opponents : unit Pkh_table.t; - } - - let get_conflicts cctxt head_block = - Plugin.RPC.Sc_rollup.conflicts cctxt (cctxt#chain, head_block) - - let get_ongoing_games cctxt head_block = - Plugin.RPC.Sc_rollup.ongoing_refutation_games cctxt (cctxt#chain, head_block) - - let untracked_conflicts opponent_players conflicts = - List.filter - (fun conflict -> - not - @@ Pkh_map.mem - conflict.Sc_rollup.Refutation_storage.other - opponent_players) - conflicts - - (* Transform the list of ongoing games [(Game.t * pkh * pkh) list] - into a mapping from opponents' pkhs to their corresponding game - state. - *) - let make_game_map self ongoing_games = - List.fold_left - (fun acc (game, alice, bob) -> - let opponent_pkh = - if Signature.Public_key_hash.equal self alice then bob else alice - in - Pkh_map.add opponent_pkh game acc) - Pkh_map.empty - ongoing_games - - let on_process Layer1.{hash; level} state = - let node_ctxt = state.node_ctxt in - let head_block = `Hash (hash, 0) in - let open Lwt_result_syntax in - let refute_signer = Node_context.get_operator node_ctxt Refute in - match refute_signer with - | None -> - (* Not injecting refutations, don't play refutation games *) - return_unit - | Some self -> - let Node_context.{rollup_address; cctxt; _} = node_ctxt in - (* Current conflicts in L1 *) - let* conflicts = get_conflicts cctxt head_block rollup_address self in - (* Map of opponents the node is playing against to the corresponding - player worker *) - let opponent_players = - Pkh_map.of_seq @@ List.to_seq @@ Player.current_games () - in - (* Conflicts for which we need to start new refutation players. - Some of these might be ongoing. *) - let new_conflicts = untracked_conflicts opponent_players conflicts in - (* L1 ongoing games *) - let* ongoing_games = - get_ongoing_games cctxt head_block rollup_address self - in - (* Map between opponents and their corresponding games *) - let ongoing_game_map = make_game_map self ongoing_games in - (* Launch new players for new conflicts, and play one step *) - let* () = - List.iter_ep - (fun conflict -> - let other = conflict.Sc_rollup.Refutation_storage.other in - Pkh_table.replace state.pending_opponents other () ; - let game = Pkh_map.find_opt other ongoing_game_map in - Player.init_and_play node_ctxt ~self ~conflict ~game ~level) - new_conflicts - in - let*! () = - (* Play one step of the refutation game in every remaining player *) - Pkh_map.iter_p - (fun opponent worker -> - match Pkh_map.find opponent ongoing_game_map with - | Some game -> - Pkh_table.remove state.pending_opponents opponent ; - Player.play worker game ~level - | None -> - (* Kill finished players: those who don't aren't - playing against pending opponents that don't have - ongoing games in the L1 *) - if not @@ Pkh_table.mem state.pending_opponents opponent then - Player.shutdown worker - else Lwt.return_unit) - opponent_players - in - return_unit - - module Types = struct - type nonrec state = state - - type parameters = {node_ctxt : Node_context.rw} - end - - module Name = struct - (* We only have a single coordinator in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Refutation_game_event.Coordinator.section - @ [ - ("worker" - ^ if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with Request.Process b -> on_process b state - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt} = - return {node_ctxt; pending_opponents = Pkh_table.create 5} - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Refutation_game_event.Coordinator.request_failed request_view st errs - in - return_unit - in - match r with Request.Process _ -> emit_and_return_errors errs +module Worker = Worker.MakeSingle (Name) (Request) (Types) - let on_completion _w r _ st = - Refutation_game_event.Coordinator.request_completed (Request.view r) st +type worker = Worker.infinite Worker.queue Worker.t - let on_no_request _ = Lwt.return_unit +module Handlers = struct + type self = worker - let on_close _w = Lwt.return_unit - end + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with Request.Process b -> on_process b state - let table = Worker.create_table Queue + type launch_error = error trace - let worker_promise, worker_waker = Lwt.task () + let on_launch _w () Types.{node_ctxt} = + return {node_ctxt; pending_opponents = Pkh_table.create 5} - let init node_ctxt = - let open Lwt_result_syntax in - let*! () = Refutation_game_event.Coordinator.starting () in - let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in - Lwt.wakeup worker_waker worker - - (* This is a refutation coordinator for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> - error Sc_rollup_node_errors.No_refutation_coordinator) - - let process b = + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w (Request.Process b) in - return_unit - - let shutdown () = - let open Lwt_syntax in - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no refutation coordinator, nothing to do *) - Lwt.return_unit - | Ok w -> - (* Shut down all current refutation players *) - let games = Player.current_games () in - let* () = - List.iter_s (fun (_opponent, player) -> Player.shutdown player) games - in - Worker.shutdown w + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Refutation_game_event.Coordinator.request_failed request_view st errs + in + return_unit + in + match r with Request.Process _ -> emit_and_return_errors errs + + let on_completion _w r _ st = + Refutation_game_event.Coordinator.request_completed (Request.view r) st + + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit end + +let table = Worker.create_table Queue + +let worker_promise, worker_waker = Lwt.task () + +let init node_ctxt = + let open Lwt_result_syntax in + let*! () = Refutation_game_event.Coordinator.starting () in + let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in + Lwt.wakeup worker_waker worker + +(* This is a refutation coordinator for a single scoru *) +let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> + error Sc_rollup_node_errors.No_refutation_coordinator) + +let process b = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w (Request.Process b) in + return_unit + +let shutdown () = + let open Lwt_syntax in + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no refutation coordinator, nothing to do *) + Lwt.return_unit + | Ok w -> + (* Shut down all current refutation players *) + let games = Player.current_games () in + let* () = + List.iter_s (fun (_opponent, player) -> Player.shutdown player) games + in + Worker.shutdown w diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_coordinator.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_coordinator.mli index ca17d1eb19ab..12a35582b9b2 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_coordinator.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_coordinator.mli @@ -29,25 +29,19 @@ the refutation game players. (See {!Refutation_player}). *) -module type S = sig - module PVM : Pvm.S +(** Initiatilize the refuation coordinator. *) +val init : Node_context.rw -> unit tzresult Lwt.t - (** Initiatilize the refuation coordinator. *) - val init : Node_context.rw -> unit tzresult Lwt.t - - (** Process a new l1 head. This means that the coordinator will: - {ol - {li Gather all existing conflicts} - {li Launch new refutation players for each conflict that doesn't - have a player in this node} - {li Kill all players whose conflict has disappeared from L1} - {li Make all players play a step in the refutation} - } +(** Process a new l1 head. This means that the coordinator will: + {ol + {li Gather all existing conflicts} + {li Launch new refutation players for each conflict that doesn't + have a player in this node} + {li Kill all players whose conflict has disappeared from L1} + {li Make all players play a step in the refutation} + } *) - val process : Layer1.head -> unit tzresult Lwt.t - - (** Shutdown the refutation coordinator. *) - val shutdown : unit -> unit Lwt.t -end +val process : Layer1.head -> unit tzresult Lwt.t -module Make (Interpreter : Interpreter.S) : S +(** Shutdown the refutation coordinator. *) +val shutdown : unit -> unit Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game.ml index 70a3f82e2af9..7bef664b97a1 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game.ml @@ -42,90 +42,69 @@ starts a game to refute C' by starting a game with one of its staker. *) -open Protocol +open Protocol open Alpha_context +open Sc_rollup.Game + +let node_role ~self Sc_rollup.Game.Index.{alice; bob} = + if Sc_rollup.Staker.equal alice self then Alice + else if Sc_rollup.Staker.equal bob self then Bob + else (* By validity of [ongoing_game] RPC. *) + assert false + +type role = Our_turn of {opponent : public_key_hash} | Their_turn -module type S = sig - module PVM : Pvm.S - - val play_opening_move : - [< `Read | `Write > `Read] Node_context.t -> - public_key_hash -> - Sc_rollup.Refutation_storage.conflict -> - (unit, tztrace) result Lwt.t - - val play : - Node_context.rw -> - self:public_key_hash -> - Sc_rollup.Game.t -> - public_key_hash -> - (unit, tztrace) result Lwt.t -end - -module Make (Interpreter : Interpreter.S) : - S with module PVM = Interpreter.PVM = struct - module PVM = Interpreter.PVM - open Sc_rollup.Game - - let node_role ~self Sc_rollup.Game.Index.{alice; bob} = - if Sc_rollup.Staker.equal alice self then Alice - else if Sc_rollup.Staker.equal bob self then Bob - else (* By validity of [ongoing_game] RPC. *) - assert false - - type role = Our_turn of {opponent : public_key_hash} | Their_turn - - let turn ~self game players = - let Sc_rollup.Game.Index.{alice; bob} = players in - match (node_role ~self players, game.turn) with - | Alice, Alice -> Our_turn {opponent = bob} - | Bob, Bob -> Our_turn {opponent = alice} - | Alice, Bob -> Their_turn - | Bob, Alice -> Their_turn - - (** [inject_next_move node_ctxt source ~refutation ~opponent ~commitment +let turn ~self game players = + let Sc_rollup.Game.Index.{alice; bob} = players in + match (node_role ~self players, game.turn) with + | Alice, Alice -> Our_turn {opponent = bob} + | Bob, Bob -> Our_turn {opponent = alice} + | Alice, Bob -> Their_turn + | Bob, Alice -> Their_turn + +(** [inject_next_move node_ctxt source ~refutation ~opponent ~commitment ~opponent_commitment] submits an L1 operation (signed by [source]) to issue the next move in the refutation game. *) - let inject_next_move node_ctxt source ~refutation ~opponent = - let open Lwt_result_syntax in - let refute_operation = - L1_operation.Refute - {rollup = node_ctxt.Node_context.rollup_address; refutation; opponent} - in - let* _hash = Injector.add_pending_operation ~source refute_operation in - return_unit - - (** This function computes the inclusion/membership proof of the page +let inject_next_move node_ctxt source ~refutation ~opponent = + let open Lwt_result_syntax in + let refute_operation = + L1_operation.Refute + {rollup = node_ctxt.Node_context.rollup_address; refutation; opponent} + in + let* _hash = Injector.add_pending_operation ~source refute_operation in + return_unit + +(** This function computes the inclusion/membership proof of the page identified by [page_id] in the slot whose data are provided in [slot_data]. *) - let page_membership_proof params page_index slot_data = - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4048 - Rely on DAL node to compute page membership proof and drop - the dal-crypto dependency from the rollup node. *) - let proof = - let open Result_syntax in - (* The computation of the page's proof below can be a bit costly. In fact, - it involves initialising a cryptobox environment and some non-trivial - crypto processing. *) - let* dal = Cryptobox.make params in - let* polynomial = Cryptobox.polynomial_from_slot dal slot_data in - Cryptobox.prove_page dal polynomial page_index - in - let open Lwt_result_syntax in - match proof with - | Ok proof -> return proof - | Error e -> - failwith - "%s" - (match e with - | `Fail s -> "Fail " ^ s - | `Page_index_out_of_range -> "Page_index_out_of_range" - | `Slot_wrong_size s -> "Slot_wrong_size: " ^ s - | `Invalid_degree_strictly_less_than_expected _ as commit_error -> - Cryptobox.string_of_commit_error commit_error) - - (** When the PVM is waiting for a Dal page input, this function attempts to +let page_membership_proof params page_index slot_data = + (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4048 + Rely on DAL node to compute page membership proof and drop + the dal-crypto dependency from the rollup node. *) + let proof = + let open Result_syntax in + (* The computation of the page's proof below can be a bit costly. In fact, + it involves initialising a cryptobox environment and some non-trivial + crypto processing. *) + let* dal = Cryptobox.make params in + let* polynomial = Cryptobox.polynomial_from_slot dal slot_data in + Cryptobox.prove_page dal polynomial page_index + in + let open Lwt_result_syntax in + match proof with + | Ok proof -> return proof + | Error e -> + failwith + "%s" + (match e with + | `Fail s -> "Fail " ^ s + | `Page_index_out_of_range -> "Page_index_out_of_range" + | `Slot_wrong_size s -> "Slot_wrong_size: " ^ s + | `Invalid_degree_strictly_less_than_expected _ as commit_error -> + Cryptobox.string_of_commit_error commit_error) + +(** When the PVM is waiting for a Dal page input, this function attempts to retrieve the page's content from the store, the data of its slot. Then it computes the proof that the page is part of the slot and returns the content along with the proof. @@ -134,400 +113,389 @@ module Make (Interpreter : Interpreter.S) : be unconfirmed on L1, this function returns [None]. If the data of the slot are not saved to the store, the function returns a failure in the error monad. *) - let page_info_from_pvm_state node_ctxt ~dal_attestation_lag - (dal_params : Dal.parameters) start_state = - let open Lwt_result_syntax in - let*! input_request = PVM.is_input_state start_state in - match input_request with - | Sc_rollup.(Needs_reveal (Request_dal_page page_id)) -> ( - let Dal.Page.{slot_id; page_index} = page_id in - let* pages = - Dal_pages_request.slot_pages ~dal_attestation_lag node_ctxt slot_id - in - match pages with - | None -> return_none (* The slot is not confirmed. *) - | Some pages -> ( - let pages_per_slot = dal_params.slot_size / dal_params.page_size in - (* check invariant that pages' length is correct. *) - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4031 - It's better to do the check when the slots are saved into disk. *) - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997 - This check is not resilient to dal parameters change. *) - match List.nth_opt pages page_index with - | Some content -> - let* page_proof = - page_membership_proof dal_params page_index - @@ Bytes.concat Bytes.empty pages - in - return_some (content, page_proof) - | None -> - failwith - "Page index %d too big or negative.\n\ - Number of pages in a slot is %d." - page_index - pages_per_slot)) - | _ -> return_none - - let generate_proof node_ctxt game start_state = - let open Lwt_result_syntax in - let snapshot = game.inbox_snapshot in - (* NOTE: [snapshot_level_int32] below refers to the level of the snapshotted - inbox (from the skip list) which also matches [game.start_level - 1]. *) - let snapshot_level_int32 = - Raw_level.to_int32 (Sc_rollup.Inbox.Skip_list.content snapshot).level - in - let get_snapshot_head () = - let+ hash = Node_context.hash_of_level node_ctxt snapshot_level_int32 in - Layer1.{hash; level = snapshot_level_int32} - in - let* context = - let* start_hash = - Node_context.hash_of_level - node_ctxt - (Raw_level.to_int32 game.inbox_level) +let page_info_from_pvm_state (node_ctxt : _ Node_context.t) ~dal_attestation_lag + (dal_params : Dal.parameters) start_state = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! input_request = PVM.is_input_state start_state in + match input_request with + | Sc_rollup.(Needs_reveal (Request_dal_page page_id)) -> ( + let Dal.Page.{slot_id; page_index} = page_id in + let* pages = + Dal_pages_request.slot_pages ~dal_attestation_lag node_ctxt slot_id in - let+ context = Node_context.checkout_context node_ctxt start_hash in - Context.index context - in - let* dal_slots_history = - if Node_context.dal_supported node_ctxt then - let* snapshot_head = get_snapshot_head () in - Dal_slots_tracker.slots_history_of_hash node_ctxt snapshot_head - else return Dal.Slots_history.genesis - in - let* dal_slots_history_cache = - if Node_context.dal_supported node_ctxt then - let* snapshot_head = get_snapshot_head () in - Dal_slots_tracker.slots_history_cache_of_hash node_ctxt snapshot_head - else return (Dal.Slots_history.History_cache.empty ~capacity:0L) + match pages with + | None -> return_none (* The slot is not confirmed. *) + | Some pages -> ( + let pages_per_slot = dal_params.slot_size / dal_params.page_size in + (* check invariant that pages' length is correct. *) + (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4031 + It's better to do the check when the slots are saved into disk. *) + (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997 + This check is not resilient to dal parameters change. *) + match List.nth_opt pages page_index with + | Some content -> + let* page_proof = + page_membership_proof dal_params page_index + @@ Bytes.concat Bytes.empty pages + in + return_some (content, page_proof) + | None -> + failwith + "Page index %d too big or negative.\n\ + Number of pages in a slot is %d." + page_index + pages_per_slot)) + | _ -> return_none + +let generate_proof (node_ctxt : _ Node_context.t) game start_state = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let snapshot = game.inbox_snapshot in + (* NOTE: [snapshot_level_int32] below refers to the level of the snapshotted + inbox (from the skip list) which also matches [game.start_level - 1]. *) + let snapshot_level_int32 = + Raw_level.to_int32 (Sc_rollup.Inbox.Skip_list.content snapshot).level + in + let get_snapshot_head () = + let+ hash = Node_context.hash_of_level node_ctxt snapshot_level_int32 in + Layer1.{hash; level = snapshot_level_int32} + in + let* context = + let* start_hash = + Node_context.hash_of_level node_ctxt (Raw_level.to_int32 game.inbox_level) in - (* We fetch the value of protocol constants at block snapshot level - where the game started. *) - let* parametric_constants = - let cctxt = node_ctxt.cctxt in - Protocol.Constants_services.parametric - cctxt - (cctxt#chain, `Level snapshot_level_int32) - in - let dal_l1_parameters = parametric_constants.dal in - let dal_parameters = dal_l1_parameters.cryptobox_parameters in - let dal_attestation_lag = dal_l1_parameters.attestation_lag in - - let* page_info = - page_info_from_pvm_state - ~dal_attestation_lag - node_ctxt - dal_parameters - start_state - in - let module P = struct - include PVM - - let context = context + let+ context = Node_context.checkout_context node_ctxt start_hash in + Context.index context + in + let* dal_slots_history = + if Node_context.dal_supported node_ctxt then + let* snapshot_head = get_snapshot_head () in + Dal_slots_tracker.slots_history_of_hash node_ctxt snapshot_head + else return Dal.Slots_history.genesis + in + let* dal_slots_history_cache = + if Node_context.dal_supported node_ctxt then + let* snapshot_head = get_snapshot_head () in + Dal_slots_tracker.slots_history_cache_of_hash node_ctxt snapshot_head + else return (Dal.Slots_history.History_cache.empty ~capacity:0L) + in + (* We fetch the value of protocol constants at block snapshot level + where the game started. *) + let* parametric_constants = + let cctxt = node_ctxt.cctxt in + Protocol.Constants_services.parametric + cctxt + (cctxt#chain, `Level snapshot_level_int32) + in + let dal_l1_parameters = parametric_constants.dal in + let dal_parameters = dal_l1_parameters.cryptobox_parameters in + let dal_attestation_lag = dal_l1_parameters.attestation_lag in + + let* page_info = + page_info_from_pvm_state + ~dal_attestation_lag + node_ctxt + dal_parameters + start_state + in + let module P = struct + include PVM + + let context = context + + let state = start_state + + let reveal hash = + let open Lwt_syntax in + let* res = + Reveals.get ~data_dir:node_ctxt.data_dir ~pvm_kind:PVM.kind ~hash + in + match res with Ok data -> return @@ Some data | Error _ -> return None - let state = start_state + module Inbox_with_history = struct + let inbox = snapshot - let reveal hash = + let get_history inbox_hash = let open Lwt_syntax in - let* res = - Reveals.get ~data_dir:node_ctxt.data_dir ~pvm_kind:PVM.kind ~hash + let+ inbox = Node_context.find_inbox node_ctxt inbox_hash in + match inbox with + | Error err -> + Format.kasprintf + Stdlib.failwith + "Refutation game: Cannot get inbox history for %a, %a" + Sc_rollup.Inbox.Hash.pp + inbox_hash + pp_print_trace + err + | Ok inbox -> Option.map Sc_rollup.Inbox.take_snapshot inbox + + let get_payloads_history witness = + Lwt.map + (WithExceptions.Result.to_exn_f + ~error:(Format.kasprintf Stdlib.failwith "%a" pp_print_trace)) + @@ + let open Lwt_result_syntax in + let* {is_first_block; predecessor; predecessor_timestamp; messages} = + Node_context.get_messages node_ctxt witness in - match res with Ok data -> return @@ Some data | Error _ -> return None - - module Inbox_with_history = struct - let inbox = snapshot - - let get_history inbox_hash = - let open Lwt_syntax in - let+ inbox = Node_context.find_inbox node_ctxt inbox_hash in - match inbox with - | Error err -> - Format.kasprintf - Stdlib.failwith - "Refutation game: Cannot get inbox history for %a, %a" - Sc_rollup.Inbox.Hash.pp - inbox_hash - pp_print_trace - err - | Ok inbox -> Option.map Sc_rollup.Inbox.take_snapshot inbox - - let get_payloads_history witness = - Lwt.map - (WithExceptions.Result.to_exn_f - ~error:(Format.kasprintf Stdlib.failwith "%a" pp_print_trace)) - @@ - let open Lwt_result_syntax in - let* {is_first_block; predecessor; predecessor_timestamp; messages} = - Node_context.get_messages node_ctxt witness - in - let*? hist = - Inbox.payloads_history_of_messages - ~is_first_block - ~predecessor - ~predecessor_timestamp - messages - in - return hist - end - - module Dal_with_history = struct - let confirmed_slots_history = dal_slots_history - - let get_history ptr = - Dal.Slots_history.History_cache.find ptr dal_slots_history_cache - |> Lwt.return - - let dal_attestation_lag = dal_attestation_lag - - let dal_parameters = dal_parameters - - let page_info = page_info - end - end in - let metadata = Node_context.metadata node_ctxt in - let* proof = - trace (Sc_rollup_node_errors.Cannot_produce_proof game) - @@ (Sc_rollup.Proof.produce ~metadata (module P) game.inbox_level - >|= Environment.wrap_tzresult) - in - let*? pvm_step = - Sc_rollup.Proof.unserialize_pvm_step ~pvm:(module PVM) proof.pvm_step - |> Environment.wrap_tzresult - in - let proof = {proof with pvm_step} in - let*! res = - Sc_rollup.Proof.valid - ~metadata - snapshot - game.inbox_level - dal_slots_history - dal_parameters - ~dal_attestation_lag - ~pvm:(module PVM) - proof - >|= Environment.wrap_tzresult - in - if Result.is_ok res then return proof else assert false - - type pvm_intermediate_state = - | Hash of PVM.hash - | Evaluated of Interpreter.Accounted_pvm.eval_state - - let new_dissection ~opponent ~default_number_of_sections node_ctxt last_level - ok our_view = - let open Lwt_result_syntax in - let state_of_tick ?start_state tick = - Interpreter.state_of_tick node_ctxt ?start_state tick last_level - in - let state_hash_of_eval_state Interpreter.Accounted_pvm.{state_hash; _} = - state_hash - in - let start_hash, start_tick, start_state = - match ok with - | Hash hash, tick -> (hash, tick, None) - | Evaluated ({state_hash; _} as state), tick -> - (state_hash, tick, Some state) - in - let start_chunk = - Sc_rollup.Dissection_chunk. - {state_hash = Some start_hash; tick = start_tick} - in - let our_state, our_tick = our_view in - let our_state_hash = - Option.map - (fun Interpreter.Accounted_pvm.{state_hash; _} -> state_hash) - our_state - in - let our_stop_chunk = - Sc_rollup.Dissection_chunk.{state_hash = our_state_hash; tick = our_tick} - in - let* dissection = - Game_helpers.make_dissection - ~state_of_tick - ~state_hash_of_eval_state - ?start_state - ~start_chunk - ~our_stop_chunk - @@ PVM.new_dissection - ~start_chunk - ~our_stop_chunk - ~default_number_of_sections - in - let*! () = - Refutation_game_event.computed_dissection - ~opponent - ~start_tick - ~end_tick:our_tick - dissection - in - return dissection - - (** [generate_from_dissection ~default_number_of_sections node_ctxt game + let*? hist = + Inbox.payloads_history_of_messages + ~is_first_block + ~predecessor + ~predecessor_timestamp + messages + in + return hist + end + + module Dal_with_history = struct + let confirmed_slots_history = dal_slots_history + + let get_history ptr = + Dal.Slots_history.History_cache.find ptr dal_slots_history_cache + |> Lwt.return + + let dal_attestation_lag = dal_attestation_lag + + let dal_parameters = dal_parameters + + let page_info = page_info + end + end in + let metadata = Node_context.metadata node_ctxt in + let* proof = + trace (Sc_rollup_node_errors.Cannot_produce_proof game) + @@ (Sc_rollup.Proof.produce ~metadata (module P) game.inbox_level + >|= Environment.wrap_tzresult) + in + let*? pvm_step = + Sc_rollup.Proof.unserialize_pvm_step ~pvm:(module PVM) proof.pvm_step + |> Environment.wrap_tzresult + in + let unserialized_proof = {proof with pvm_step} in + let*! res = + Sc_rollup.Proof.valid + ~metadata + snapshot + game.inbox_level + dal_slots_history + dal_parameters + ~dal_attestation_lag + ~pvm:(module PVM) + unserialized_proof + >|= Environment.wrap_tzresult + in + if Result.is_ok res then return proof else assert false + +type pvm_intermediate_state = + | Hash of Sc_rollup.State_hash.t + | Evaluated of Fueled_pvm.Accounted.eval_state + +let new_dissection ~opponent ~default_number_of_sections node_ctxt last_level ok + our_view = + let open Lwt_result_syntax in + let state_of_tick ?start_state tick = + Interpreter.state_of_tick node_ctxt ?start_state tick last_level + in + let state_hash_of_eval_state Fueled_pvm.Accounted.{state_hash; _} = + state_hash + in + let start_hash, start_tick, start_state = + match ok with + | Hash hash, tick -> (hash, tick, None) + | Evaluated ({state_hash; _} as state), tick -> + (state_hash, tick, Some state) + in + let start_chunk = + Sc_rollup.Dissection_chunk.{state_hash = Some start_hash; tick = start_tick} + in + let our_state, our_tick = our_view in + let our_state_hash = + Option.map + (fun Fueled_pvm.Accounted.{state_hash; _} -> state_hash) + our_state + in + let our_stop_chunk = + Sc_rollup.Dissection_chunk.{state_hash = our_state_hash; tick = our_tick} + in + let module PVM = (val node_ctxt.pvm) in + let* dissection = + Game_helpers.make_dissection + ~state_of_tick + ~state_hash_of_eval_state + ?start_state + ~start_chunk + ~our_stop_chunk + @@ PVM.new_dissection + ~start_chunk + ~our_stop_chunk + ~default_number_of_sections + in + let*! () = + Refutation_game_event.computed_dissection + ~opponent + ~start_tick + ~end_tick:our_tick + dissection + in + return dissection + +(** [generate_from_dissection ~default_number_of_sections node_ctxt game dissection] traverses the current [dissection] and returns a move which performs a new dissection of the execution trace or provides a refutation proof to serve as the next move of the [game]. *) - let generate_next_dissection ~default_number_of_sections node_ctxt ~opponent - game dissection = - let open Lwt_result_syntax in - let rec traverse ok = function - | [] -> - (* The game invariant states that the dissection from the - opponent must contain a tick we disagree with. If the - retrieved game does not respect this, we cannot trust the - Tezos node we are connected to and prefer to stop here. *) - tzfail - Sc_rollup_node_errors - .Unreliable_tezos_node_returning_inconsistent_game - | Sc_rollup.Dissection_chunk.{state_hash = their_hash; tick} :: dissection - -> ( - let start_state = - match ok with - | Hash _, _ -> None - | Evaluated ok_state, _ -> Some ok_state - in - let* our = - Interpreter.state_of_tick - node_ctxt - ?start_state - tick - game.inbox_level - in - match (their_hash, our) with - | None, None -> - (* This case is absurd since: [None] can only occur at the - end and the two players disagree about the end. *) - assert false - | Some _, None | None, Some _ -> return (ok, (our, tick)) - | Some their_hash, Some ({state_hash = our_hash; _} as our_state) -> - if Sc_rollup.State_hash.equal our_hash their_hash then - traverse (Evaluated our_state, tick) dissection - else return (ok, (our, tick))) - in - match dissection with - | Sc_rollup.Dissection_chunk.{state_hash = Some hash; tick} :: dissection -> - let* ok, ko = traverse (Hash hash, tick) dissection in - let* dissection = - new_dissection - ~opponent - ~default_number_of_sections - node_ctxt - game.inbox_level - ok - ko +let generate_next_dissection ~default_number_of_sections node_ctxt ~opponent + game dissection = + let open Lwt_result_syntax in + let rec traverse ok = function + | [] -> + (* The game invariant states that the dissection from the + opponent must contain a tick we disagree with. If the + retrieved game does not respect this, we cannot trust the + Tezos node we are connected to and prefer to stop here. *) + tzfail + Sc_rollup_node_errors + .Unreliable_tezos_node_returning_inconsistent_game + | Sc_rollup.Dissection_chunk.{state_hash = their_hash; tick} :: dissection + -> ( + let start_state = + match ok with + | Hash _, _ -> None + | Evaluated ok_state, _ -> Some ok_state in - let _, choice = ok in - let _, ko_tick = ko in - let chosen_section_len = Sc_rollup.Tick.distance ko_tick choice in - return (choice, chosen_section_len, dissection) - | [] | {state_hash = None; _} :: _ -> - (* + let* our = + Interpreter.state_of_tick node_ctxt ?start_state tick game.inbox_level + in + match (their_hash, our) with + | None, None -> + (* This case is absurd since: [None] can only occur at the + end and the two players disagree about the end. *) + assert false + | Some _, None | None, Some _ -> return (ok, (our, tick)) + | Some their_hash, Some ({state_hash = our_hash; _} as our_state) -> + if Sc_rollup.State_hash.equal our_hash their_hash then + traverse (Evaluated our_state, tick) dissection + else return (ok, (our, tick))) + in + match dissection with + | Sc_rollup.Dissection_chunk.{state_hash = Some hash; tick} :: dissection -> + let* ok, ko = traverse (Hash hash, tick) dissection in + let* dissection = + new_dissection + ~opponent + ~default_number_of_sections + node_ctxt + game.inbox_level + ok + ko + in + let _, choice = ok in + let _, ko_tick = ko in + let chosen_section_len = Sc_rollup.Tick.distance ko_tick choice in + return (choice, chosen_section_len, dissection) + | [] | {state_hash = None; _} :: _ -> + (* By wellformedness of dissection. A dissection always starts with a tick of the form [(Some hash, tick)]. A dissection always contains strictly more than one element. *) + tzfail + Sc_rollup_node_errors.Unreliable_tezos_node_returning_inconsistent_game + +let next_move node_ctxt ~opponent game = + let open Lwt_result_syntax in + let final_move start_tick = + let* start_state = + Interpreter.state_of_tick node_ctxt start_tick game.inbox_level + in + match start_state with + | None -> tzfail Sc_rollup_node_errors .Unreliable_tezos_node_returning_inconsistent_game - - let next_move node_ctxt ~opponent game = - let open Lwt_result_syntax in - let final_move start_tick = - let* start_state = - Interpreter.state_of_tick node_ctxt start_tick game.inbox_level + | Some {state = start_state; _} -> + let* proof = generate_proof node_ctxt game start_state in + let choice = start_tick in + return (Move {choice; step = Proof proof}) + in + + match game.game_state with + | Dissecting {dissection; default_number_of_sections} -> + let* choice, chosen_section_len, dissection = + generate_next_dissection + ~default_number_of_sections + node_ctxt + ~opponent + game + dissection in - match start_state with - | None -> - tzfail - Sc_rollup_node_errors - .Unreliable_tezos_node_returning_inconsistent_game - | Some {state = start_state; _} -> - let* proof = generate_proof node_ctxt game start_state in - let*? pvm_step = - Sc_rollup.Proof.serialize_pvm_step ~pvm:(module PVM) proof.pvm_step - |> Environment.wrap_tzresult - in - let step = Proof {proof with pvm_step} in - let choice = start_tick in - return (Move {choice; step}) - in - - match game.game_state with - | Dissecting {dissection; default_number_of_sections} -> - let* choice, chosen_section_len, dissection = - generate_next_dissection - ~default_number_of_sections - node_ctxt - ~opponent - game - dissection - in - if Z.(equal chosen_section_len one) then final_move choice - else return (Move {choice; step = Dissection dissection}) - | Final_move {agreed_start_chunk; refuted_stop_chunk = _} -> - let choice = agreed_start_chunk.tick in - final_move choice - - let play_next_move node_ctxt game self opponent = - let open Lwt_result_syntax in - let* refutation = next_move node_ctxt ~opponent game in - inject_next_move node_ctxt self ~refutation ~opponent - - let play_timeout (node_ctxt : _ Node_context.t) self stakers = - let open Lwt_result_syntax in - let timeout_operation = - L1_operation.Timeout {rollup = node_ctxt.rollup_address; stakers} - in - let source = - Node_context.get_operator node_ctxt Timeout |> Option.value ~default:self - (* We fallback on the [Refute] operator if none is provided for [Timeout] *) - in - let* _hash = Injector.add_pending_operation ~source timeout_operation in - return_unit - - let timeout_reached ~self head_block node_ctxt staker1 staker2 = - let open Lwt_result_syntax in - let Node_context.{rollup_address; cctxt; _} = node_ctxt in - let* game_result = - Plugin.RPC.Sc_rollup.timeout_reached - cctxt - (cctxt#chain, head_block) - rollup_address - staker1 - staker2 - in - let open Sc_rollup.Game in - match game_result with - | Some (Loser {loser; _}) -> - let is_it_me = Signature.Public_key_hash.(self = loser) in - if is_it_me then return_none else return (Some loser) - | _ -> return_none - - let play node_ctxt ~self game opponent = - let open Lwt_result_syntax in - let index = Sc_rollup.Game.Index.make self opponent in - let head_block = `Head 0 in - match turn ~self game index with - | Our_turn {opponent} -> play_next_move node_ctxt game self opponent - | Their_turn -> ( - let* timeout_reached = - timeout_reached ~self head_block node_ctxt self opponent - in - match timeout_reached with - | Some opponent -> - let*! () = Refutation_game_event.timeout_detected opponent in - play_timeout node_ctxt self index - | None -> return_unit) - - let play_opening_move node_ctxt self conflict = - let open Lwt_syntax in - let open Sc_rollup.Refutation_storage in - let* () = Refutation_game_event.conflict_detected conflict in - let player_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated conflict.our_commitment - in - let opponent_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated conflict.their_commitment - in - let refutation = Start {player_commitment_hash; opponent_commitment_hash} in - inject_next_move node_ctxt self ~refutation ~opponent:conflict.other -end + if Z.(equal chosen_section_len one) then final_move choice + else return (Move {choice; step = Dissection dissection}) + | Final_move {agreed_start_chunk; refuted_stop_chunk = _} -> + let choice = agreed_start_chunk.tick in + final_move choice + +let play_next_move node_ctxt game self opponent = + let open Lwt_result_syntax in + let* refutation = next_move node_ctxt ~opponent game in + inject_next_move node_ctxt self ~refutation ~opponent + +let play_timeout (node_ctxt : _ Node_context.t) self stakers = + let open Lwt_result_syntax in + let timeout_operation = + L1_operation.Timeout {rollup = node_ctxt.rollup_address; stakers} + in + let source = + Node_context.get_operator node_ctxt Timeout |> Option.value ~default:self + (* We fallback on the [Refute] operator if none is provided for [Timeout] *) + in + let* _hash = Injector.add_pending_operation ~source timeout_operation in + return_unit + +let timeout_reached ~self head_block node_ctxt staker1 staker2 = + let open Lwt_result_syntax in + let Node_context.{rollup_address; cctxt; _} = node_ctxt in + let* game_result = + Plugin.RPC.Sc_rollup.timeout_reached + cctxt + (cctxt#chain, head_block) + rollup_address + staker1 + staker2 + in + let open Sc_rollup.Game in + match game_result with + | Some (Loser {loser; _}) -> + let is_it_me = Signature.Public_key_hash.(self = loser) in + if is_it_me then return_none else return (Some loser) + | _ -> return_none + +let play node_ctxt ~self game opponent = + let open Lwt_result_syntax in + let index = Sc_rollup.Game.Index.make self opponent in + let head_block = `Head 0 in + match turn ~self game index with + | Our_turn {opponent} -> play_next_move node_ctxt game self opponent + | Their_turn -> ( + let* timeout_reached = + timeout_reached ~self head_block node_ctxt self opponent + in + match timeout_reached with + | Some opponent -> + let*! () = Refutation_game_event.timeout_detected opponent in + play_timeout node_ctxt self index + | None -> return_unit) + +let play_opening_move node_ctxt self conflict = + let open Lwt_syntax in + let open Sc_rollup.Refutation_storage in + let* () = Refutation_game_event.conflict_detected conflict in + let player_commitment_hash = + Sc_rollup.Commitment.hash_uncarbonated conflict.our_commitment + in + let opponent_commitment_hash = + Sc_rollup.Commitment.hash_uncarbonated conflict.their_commitment + in + let refutation = Start {player_commitment_hash; opponent_commitment_hash} in + inject_next_move node_ctxt self ~refutation ~opponent:conflict.other diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game.mli index 89399c86ae0a..3229857d1aa7 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_game.mli @@ -26,27 +26,21 @@ open Protocol open Alpha_context -(** This module implements the refutation game logic of the rollup - node. *) -module type S = sig - module PVM : Pvm.S +(** This module implements the refutation game logic of the rollup node. *) - (** [play_opening_move node_ctxt self conflict] injects the opening - refutation game move for [conflict]. *) - val play_opening_move : - [< `Read | `Write > `Read] Node_context.t -> - public_key_hash -> - Sc_rollup.Refutation_storage.conflict -> - (unit, tztrace) result Lwt.t +(** [play_opening_move node_ctxt self conflict] injects the opening refutation + game move for [conflict]. *) +val play_opening_move : + [< `Read | `Write > `Read] Node_context.t -> + public_key_hash -> + Sc_rollup.Refutation_storage.conflict -> + (unit, tztrace) result Lwt.t - (** [play head_block node_ctxt ~self game opponent] injects the next - move in the refutation [game] played by [self] and [opponent]. *) - val play : - Node_context.rw -> - self:public_key_hash -> - Sc_rollup.Game.t -> - public_key_hash -> - (unit, tztrace) result Lwt.t -end - -module Make (Interpreter : Interpreter.S) : S with module PVM = Interpreter.PVM +(** [play head_block node_ctxt ~self game opponent] injects the next move in the + refutation [game] played by [self] and [opponent]. *) +val play : + Node_context.rw -> + self:public_key_hash -> + Sc_rollup.Game.t -> + public_key_hash -> + (unit, tztrace) result Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_player.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_player.ml index e5c51eecfb46..72901a452bf2 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_player.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_player.ml @@ -26,6 +26,7 @@ open Protocol open Alpha_context open Refutation_player_types +open Refutation_game module Types = struct type state = { @@ -54,151 +55,129 @@ type worker = Worker.infinite Worker.queue Worker.t let table = Worker.create_table Queue -module type S = sig - val init_and_play : - Node_context.rw -> - self:public_key_hash -> - conflict:Sc_rollup.Refutation_storage.conflict -> - game:Sc_rollup.Game.t option -> - level:int32 -> - unit tzresult Lwt.t +let on_play game Types.{node_ctxt; self; opponent; _} = + play node_ctxt ~self game opponent - val play : worker -> Sc_rollup.Game.t -> level:int32 -> unit Lwt.t +let on_play_opening conflict (Types.{node_ctxt; self; _} : Types.state) = + play_opening_move node_ctxt self conflict - val shutdown : worker -> unit Lwt.t +module Handlers = struct + type self = worker - val current_games : unit -> (public_key_hash * worker) list -end - -module Make (Interpreter : Interpreter.S) : S = struct - open Refutation_game.Make (Interpreter) - - let on_play game Types.{node_ctxt; self; opponent; _} = - play node_ctxt ~self game opponent - - let on_play_opening conflict (Types.{node_ctxt; self; _} : Types.state) = - play_opening_move node_ctxt self conflict - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Play game -> on_play game state - | Request.Play_opening conflict -> on_play_opening conflict state - - type launch_error = error trace - - let on_launch _w _name Types.{node_ctxt; self; conflict} = - return - Types. - {node_ctxt; self; opponent = conflict.other; last_move_cache = None} - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Refutation_game_event.Player.request_failed request_view st errs - in - return_unit - in - match r with - | Request.Play _ -> emit_and_return_errors errs - | Request.Play_opening _ -> emit_and_return_errors errs - - let on_completion _w r _ st = - Refutation_game_event.Player.request_completed (Request.view r) st + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with + | Request.Play game -> on_play game state + | Request.Play_opening conflict -> on_play_opening conflict state - let on_no_request _ = Lwt.return_unit + type launch_error = error trace - let on_close w = - let open Lwt_syntax in - let state = Worker.state w in - let* () = Refutation_game_event.Player.stopped state.opponent in - return_unit - end + let on_launch _w _name Types.{node_ctxt; self; conflict} = + return + Types.{node_ctxt; self; opponent = conflict.other; last_move_cache = None} - let init node_ctxt ~self ~conflict = + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let*! () = - Refutation_game_event.Player.started - conflict.Sc_rollup.Refutation_storage.other - conflict.Sc_rollup.Refutation_storage.our_commitment - in - let worker_promise, worker_waker = Lwt.task () in - let* worker = - trace Sc_rollup_node_errors.Refutation_player_failed_to_start - @@ Worker.launch - table - conflict.other - {node_ctxt; self; conflict} - (module Handlers) - in - let () = Lwt.wakeup worker_waker worker in - let worker = - match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> - error Sc_rollup_node_errors.Refutation_player_failed_to_start - in - Lwt.return worker - - (* Play if: - - There's a new game state to play against or - - The current level is past the buffer for re-playing in the - same game state. - *) - let should_move ~level game last_move_cache = - match last_move_cache with - | None -> true - | Some (last_move_game_state, last_move_level) -> - (not - (Sc_rollup.Game.game_state_equal - game.Sc_rollup.Game.game_state - last_move_game_state)) - || Int32.( - sub level last_move_level - > of_int Configuration.refutation_player_buffer_levels) - - let play w game ~(level : int32) = - let open Lwt_syntax in - let state = Worker.state w in - if should_move ~level game state.last_move_cache then ( - let* pushed = Worker.Queue.push_request w (Request.Play game) in - if pushed then - state.last_move_cache <- Some (game.Sc_rollup.Game.game_state, level) ; - return_unit) - else return_unit - - let play_opening w conflict = - let open Lwt_syntax in - let* (_pushed : bool) = - Worker.Queue.push_request w (Request.Play_opening conflict) + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Refutation_game_event.Player.request_failed request_view st errs + in + return_unit in - return_unit + match r with + | Request.Play _ -> emit_and_return_errors errs + | Request.Play_opening _ -> emit_and_return_errors errs - let init_and_play node_ctxt ~self ~conflict ~game ~level = - let open Lwt_result_syntax in - let* worker = init node_ctxt ~self ~conflict in - let*! () = - match game with - | None -> play_opening worker conflict - | Some game -> play worker game ~level - in - return_unit + let on_completion _w r _ st = + Refutation_game_event.Player.request_completed (Request.view r) st - let current_games () = - List.map - (fun (_name, worker) -> ((Worker.state worker).opponent, worker)) - (Worker.list table) + let on_no_request _ = Lwt.return_unit - let shutdown = Worker.shutdown + let on_close w = + let open Lwt_syntax in + let state = Worker.state w in + let* () = Refutation_game_event.Player.stopped state.opponent in + return_unit end + +let init node_ctxt ~self ~conflict = + let open Lwt_result_syntax in + let*! () = + Refutation_game_event.Player.started + conflict.Sc_rollup.Refutation_storage.other + conflict.Sc_rollup.Refutation_storage.our_commitment + in + let worker_promise, worker_waker = Lwt.task () in + let* worker = + trace Sc_rollup_node_errors.Refutation_player_failed_to_start + @@ Worker.launch + table + conflict.other + {node_ctxt; self; conflict} + (module Handlers) + in + let () = Lwt.wakeup worker_waker worker in + let worker = + match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> + error Sc_rollup_node_errors.Refutation_player_failed_to_start + in + Lwt.return worker + +(* Play if: + - There's a new game state to play against or + - The current level is past the buffer for re-playing in the + same game state. +*) +let should_move ~level game last_move_cache = + match last_move_cache with + | None -> true + | Some (last_move_game_state, last_move_level) -> + (not + (Sc_rollup.Game.game_state_equal + game.Sc_rollup.Game.game_state + last_move_game_state)) + || Int32.( + sub level last_move_level + > of_int Configuration.refutation_player_buffer_levels) + +let play w game ~(level : int32) = + let open Lwt_syntax in + let state = Worker.state w in + if should_move ~level game state.last_move_cache then ( + let* pushed = Worker.Queue.push_request w (Request.Play game) in + if pushed then + state.last_move_cache <- Some (game.Sc_rollup.Game.game_state, level) ; + return_unit) + else return_unit + +let play_opening w conflict = + let open Lwt_syntax in + let* (_pushed : bool) = + Worker.Queue.push_request w (Request.Play_opening conflict) + in + return_unit + +let init_and_play node_ctxt ~self ~conflict ~game ~level = + let open Lwt_result_syntax in + let* worker = init node_ctxt ~self ~conflict in + let*! () = + match game with + | None -> play_opening worker conflict + | Some game -> play worker game ~level + in + return_unit + +let current_games () = + List.map + (fun (_name, worker) -> ((Worker.state worker).opponent, worker)) + (Worker.list table) + +let shutdown = Worker.shutdown diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_player.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_player.mli index 1c6bbed96676..92592e7c7cc5 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_player.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/refutation_player.mli @@ -26,43 +26,34 @@ open Protocol open Alpha_context -(** Worker module for a signle refutation game player. - The node's refutation coordinator will spawn a new refutation player - for each refutation game. +(** Worker module for a single refutation game player. The node's refutation + coordinator will spawn a new refutation player for each refutation game. *) module Worker : Worker.T (** Type for a refutation game player. *) type worker = Worker.infinite Worker.queue Worker.t -module type S = sig - (** [init_and_play node_ctxt ~self ~conflict ~game ~level] - initializes a new refutation game player for signer [self]. - After initizialization, the worker will play the next move - depending on the [game] state. - If no [game] is passed, the worker will play the opening - move for [conflict]. - *) - val init_and_play : - Node_context.rw -> - self:public_key_hash -> - conflict:Sc_rollup.Refutation_storage.conflict -> - game:Sc_rollup.Game.t option -> - level:int32 -> - unit tzresult Lwt.t - - (** [play worker game ~level] makes the [worker] play the next move depending +(** [init_and_play node_ctxt ~self ~conflict ~game ~level] initializes a new + refutation game player for signer [self]. After initizialization, the + worker will play the next move depending on the [game] state. If no [game] + is passed, the worker will play the opening move for [conflict]. *) +val init_and_play : + Node_context.rw -> + self:public_key_hash -> + conflict:Sc_rollup.Refutation_storage.conflict -> + game:Sc_rollup.Game.t option -> + level:int32 -> + unit tzresult Lwt.t + +(** [play worker game ~level] makes the [worker] play the next move depending on the [game] state for their conflict. *) - val play : worker -> Sc_rollup.Game.t -> level:int32 -> unit Lwt.t - - (** Shutdown a refutaiton game player. *) - val shutdown : worker -> unit Lwt.t +val play : worker -> Sc_rollup.Game.t -> level:int32 -> unit Lwt.t - (** [current_games ()] lists the opponents' this node is playing - refutation games against, alongside the worker that takes care - of each game. *) - val current_games : unit -> (public_key_hash * worker) list -end +(** Shutdown a refutaiton game player. *) +val shutdown : worker -> unit Lwt.t -module Make (Interpreter : Interpreter.S) : S +(** [current_games ()] lists the opponents' this node is playing refutation + games against, alongside the worker that takes care of each game. *) +val current_games : unit -> (public_key_hash * worker) list diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/simulation.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/simulation.ml index 58d0fbdebe06..3070ab805392 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/simulation.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/simulation.ml @@ -25,176 +25,133 @@ open Protocol open Alpha_context - -module type S = sig - module Interpreter : Interpreter.S - - module PVM = Interpreter.PVM - module Fueled_pvm = Interpreter.Free_pvm - - type level_position = Start | Middle | End - - type info_per_level = { - predecessor_timestamp : Timestamp.time; - predecessor : Block_hash.t; - } - - type t = { - ctxt : Context.ro; - inbox_level : Raw_level.t; - state : PVM.state; - reveal_map : string Sc_rollup_reveal_hash.Map.t option; - nb_messages_inbox : int; - level_position : level_position; - info_per_level : info_per_level; +module Fueled_pvm = Fueled_pvm.Free + +type level_position = Start | Middle | End + +type info_per_level = { + predecessor_timestamp : Timestamp.time; + predecessor : Block_hash.t; +} + +type t = { + ctxt : Context.ro; + inbox_level : Raw_level.t; + state : Context.tree; + reveal_map : string Sc_rollup_reveal_hash.Map.t option; + nb_messages_inbox : int; + level_position : level_position; + info_per_level : info_per_level; +} + +let simulate_info_per_level (node_ctxt : [`Read] Node_context.t) predecessor = + let open Lwt_result_syntax in + let* block_info = Layer1.fetch_tezos_block node_ctxt.cctxt predecessor in + let predecessor_timestamp = block_info.header.shell.timestamp in + return {predecessor_timestamp; predecessor} + +let start_simulation node_ctxt ~reveal_map (Layer1.{hash; level} as head) = + let open Lwt_result_syntax in + let*? level = Environment.wrap_tzresult @@ Raw_level.of_int32 level in + let*? () = + error_unless + Raw_level.(level >= node_ctxt.Node_context.genesis_info.level) + (Exn (Failure "Cannot simulate before origination level")) + in + let first_inbox_level = Raw_level.succ node_ctxt.genesis_info.level in + let* ctxt = + if Raw_level.(level < first_inbox_level) then + (* This is before we have interpreted the boot sector, so we start + with an empty context in genesis *) + return (Context.empty node_ctxt.context) + else Node_context.checkout_context node_ctxt hash + in + let* ctxt, state = Interpreter.state_of_head node_ctxt ctxt head in + let+ info_per_level = simulate_info_per_level node_ctxt hash in + let inbox_level = Raw_level.succ level in + { + ctxt; + inbox_level; + state; + reveal_map; + nb_messages_inbox = 0; + level_position = Start; + info_per_level; } - val start_simulation : - Node_context.ro -> - reveal_map:string Sc_rollup_reveal_hash.Map.t option -> - Layer1.head -> - t tzresult Lwt.t - - val simulate_messages : - Node_context.ro -> - t -> - Sc_rollup.Inbox_message.t list -> - (t * Z.t) tzresult Lwt.t - - val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t -end - -module Make (Interpreter : Interpreter.S) : - S with module Interpreter = Interpreter = struct - module Interpreter = Interpreter - module PVM = Interpreter.PVM - module Fueled_pvm = Interpreter.Free_pvm - - type level_position = Start | Middle | End - - type info_per_level = { - predecessor_timestamp : Timestamp.time; - predecessor : Block_hash.t; - } - - type t = { - ctxt : Context.ro; - inbox_level : Raw_level.t; - state : PVM.state; - reveal_map : string Sc_rollup_reveal_hash.Map.t option; - nb_messages_inbox : int; - level_position : level_position; - info_per_level : info_per_level; - } - - let simulate_info_per_level (node_ctxt : [`Read] Node_context.t) predecessor = - let open Lwt_result_syntax in - let* block_info = Layer1.fetch_tezos_block node_ctxt.cctxt predecessor in - let predecessor_timestamp = block_info.header.shell.timestamp in - return {predecessor_timestamp; predecessor} - - let start_simulation node_ctxt ~reveal_map (Layer1.{hash; level} as head) = - let open Lwt_result_syntax in - let*? level = Environment.wrap_tzresult @@ Raw_level.of_int32 level in - let*? () = - error_unless - Raw_level.(level >= node_ctxt.Node_context.genesis_info.level) - (Exn (Failure "Cannot simulate before origination level")) - in - let first_inbox_level = Raw_level.succ node_ctxt.genesis_info.level in - let* ctxt = - if Raw_level.(level < first_inbox_level) then - (* This is before we have interpreted the boot sector, so we start - with an empty context in genesis *) - return (Context.empty node_ctxt.context) - else Node_context.checkout_context node_ctxt hash - in - let* ctxt, state = Interpreter.state_of_head node_ctxt ctxt head in - let+ info_per_level = simulate_info_per_level node_ctxt hash in - let inbox_level = Raw_level.succ level in - { - ctxt; - inbox_level; - state; - reveal_map; - nb_messages_inbox = 0; - level_position = Start; - info_per_level; - } - - let simulate_messages_no_checks (node_ctxt : Node_context.ro) - ({ - ctxt; - state; - inbox_level; - reveal_map; - nb_messages_inbox; - level_position = _; - info_per_level = _; - } as sim) messages = - let open Lwt_result_syntax in - let*! state_hash = PVM.state_hash state in - let*! tick = PVM.get_tick state in - let eval_state = - Fueled_pvm. - { - state; - state_hash; - tick; - inbox_level; - message_counter_offset = nb_messages_inbox; - remaining_fuel = Fuel.Free.of_ticks 0L; - remaining_messages = messages; - } - in - (* Build new state *) - let* eval_result = - Fueled_pvm.eval_messages ?reveal_map node_ctxt eval_state - in - let Fueled_pvm.{state = {state; _}; num_ticks; num_messages; _} = - Delayed_write_monad.ignore eval_result - in - let*! ctxt = PVM.State.set ctxt state in - let nb_messages_inbox = nb_messages_inbox + num_messages in - return ({sim with ctxt; state; nb_messages_inbox}, num_ticks) - - let simulate_messages (node_ctxt : Node_context.ro) sim messages = - let open Lwt_result_syntax in - (* Build new inbox *) - let*? () = - error_when - (sim.level_position = End) - (Exn (Failure "Level for simulation is ended")) - in - let*? () = - error_when - (messages = []) - (Environment.wrap_tzerror Sc_rollup_errors.Sc_rollup_add_zero_messages) - in - let messages = - if sim.level_position = Start then - let {predecessor_timestamp; predecessor} = sim.info_per_level in - let open Sc_rollup.Inbox_message in - Internal Start_of_level - :: Internal (Info_per_level {predecessor_timestamp; predecessor}) - :: messages - else messages - in - let+ sim, num_ticks = simulate_messages_no_checks node_ctxt sim messages in - ({sim with level_position = Middle}, num_ticks) - - let end_simulation node_ctxt sim = - let open Lwt_result_syntax in - let*? () = - error_when - (sim.level_position = End) - (Exn (Failure "Level for simulation is ended")) - in - let+ sim, num_ticks = - simulate_messages_no_checks - node_ctxt - sim - [Sc_rollup.Inbox_message.Internal End_of_level] - in - ({sim with level_position = End}, num_ticks) -end +let simulate_messages_no_checks (node_ctxt : Node_context.ro) + ({ + ctxt; + state; + inbox_level; + reveal_map; + nb_messages_inbox; + level_position = _; + info_per_level = _; + } as sim) messages = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! state_hash = PVM.state_hash state in + let*! tick = PVM.get_tick state in + let eval_state = + Fueled_pvm. + { + state; + state_hash; + tick; + inbox_level; + message_counter_offset = nb_messages_inbox; + remaining_fuel = Fuel.Free.of_ticks 0L; + remaining_messages = messages; + } + in + (* Build new state *) + let* eval_result = + Fueled_pvm.eval_messages ?reveal_map node_ctxt eval_state + in + let Fueled_pvm.{state = {state; _}; num_ticks; num_messages; _} = + Delayed_write_monad.ignore eval_result + in + let*! ctxt = PVM.State.set ctxt state in + let nb_messages_inbox = nb_messages_inbox + num_messages in + return ({sim with ctxt; state; nb_messages_inbox}, num_ticks) + +let simulate_messages (node_ctxt : Node_context.ro) sim messages = + let open Lwt_result_syntax in + (* Build new inbox *) + let*? () = + error_when + (sim.level_position = End) + (Exn (Failure "Level for simulation is ended")) + in + let*? () = + error_when + (messages = []) + (Environment.wrap_tzerror Sc_rollup_errors.Sc_rollup_add_zero_messages) + in + let messages = + if sim.level_position = Start then + let {predecessor_timestamp; predecessor} = sim.info_per_level in + let open Sc_rollup.Inbox_message in + Internal Start_of_level + :: Internal (Info_per_level {predecessor_timestamp; predecessor}) + :: messages + else messages + in + let+ sim, num_ticks = simulate_messages_no_checks node_ctxt sim messages in + ({sim with level_position = Middle}, num_ticks) + +let end_simulation node_ctxt sim = + let open Lwt_result_syntax in + let*? () = + error_when + (sim.level_position = End) + (Exn (Failure "Level for simulation is ended")) + in + let+ sim, num_ticks = + simulate_messages_no_checks + node_ctxt + sim + [Sc_rollup.Inbox_message.Internal End_of_level] + in + ({sim with level_position = End}, num_ticks) diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/simulation.mli b/src/proto_017_PtNairob/lib_sc_rollup_node/simulation.mli index ad4faaedfd0e..317a8809e097 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/simulation.mli +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/simulation.mli @@ -25,54 +25,44 @@ open Protocol open Protocol.Alpha_context +module Fueled_pvm = Fueled_pvm.Free -module type S = sig - module Interpreter : Interpreter.S +type level_position = Start | Middle | End - module PVM = Interpreter.PVM - module Fueled_pvm = Interpreter.Free_pvm +type info_per_level = { + predecessor_timestamp : Timestamp.time; + predecessor : Block_hash.t; +} - type level_position = Start | Middle | End +(** Type of the state for a simulation. *) +type t = { + ctxt : Context.ro; + inbox_level : Raw_level.t; + state : Context.tree; + reveal_map : string Sc_rollup_reveal_hash.Map.t option; + nb_messages_inbox : int; + level_position : level_position; + info_per_level : info_per_level; +} - type info_per_level = { - predecessor_timestamp : Timestamp.time; - predecessor : Block_hash.t; - } +(** [start_simulation node_ctxt reveal_source block] starts a new simulation {e + on top} of [block], i.e. for an hypothetical new inbox (level). *) +val start_simulation : + Node_context.ro -> + reveal_map:string Sc_rollup_reveal_hash.Map.t option -> + Layer1.head -> + t tzresult Lwt.t - (** Type of the state for a simulation. *) - type t = { - ctxt : Context.ro; - inbox_level : Raw_level.t; - state : PVM.state; - reveal_map : string Sc_rollup_reveal_hash.Map.t option; - nb_messages_inbox : int; - level_position : level_position; - info_per_level : info_per_level; - } +(** [simulate_messages node_ctxt sim messages] runs a simulation of new + [messages] in the given simulation (state) [sim] and returns a new + simulation state, the remaining fuel (when [?fuel] is provided) and the + number of ticks that happened. *) +val simulate_messages : + Node_context.ro -> + t -> + Sc_rollup.Inbox_message.t list -> + (t * Z.t) tzresult Lwt.t - (** [start_simulation node_ctxt reveal_source block] starts a new simulation - {e on top} of [block], i.e. for an hypothetical new inbox (level). *) - val start_simulation : - Node_context.ro -> - reveal_map:string Sc_rollup_reveal_hash.Map.t option -> - Layer1.head -> - t tzresult Lwt.t - - (** [simulate_messages node_ctxt sim messages] runs a simulation of new - [messages] in the given simulation (state) [sim] and returns a new - simulation state, the remaining fuel (when [?fuel] is provided) and the - number of ticks that happened. *) - val simulate_messages : - Node_context.ro -> - t -> - Sc_rollup.Inbox_message.t list -> - (t * Z.t) tzresult Lwt.t - - (** [end_simulation node_ctxt sim] adds and [End_of_level] message and marks - the simulation as ended. *) - val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t -end - -(** Functor to construct a simulator for a given PVM with interpreter. *) -module Make (Interpreter : Interpreter.S) : - S with module Interpreter = Interpreter +(** [end_simulation node_ctxt sim] adds and [End_of_level] message and marks the + simulation as ended. *) +val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/test/helpers/helpers.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/test/helpers/helpers.ml index 2dd030c3a411..e4e10ac23344 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/test/helpers/helpers.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/test/helpers/helpers.ml @@ -36,217 +36,167 @@ let block_hash_of_level level = in Block_hash.of_string_exn s -module type S = sig - val with_node_context : - ?constants:Constants.Parametric.t -> - Sc_rollup.Kind.t -> - boot_sector:string -> - ([`Read | `Write] Node_context.t -> - genesis:Sc_rollup_block.t -> - 'a tzresult Lwt.t) -> - 'a tzresult Lwt.t - - val add_l2_genesis_block : - [`Read | `Write] Node_context.t -> - boot_sector:string -> - ((Sc_rollup_block.header, unit) Sc_rollup_block.block, tztrace) result Lwt.t - - val append_l2_block : - [`Read | `Write] Node_context.t -> - ?is_first_block:bool -> - Sc_rollup.Inbox_message.t trace -> - ((Sc_rollup_block.header, unit) Sc_rollup_block.block, tztrace) result Lwt.t -end - -module Make (PVM : Pvm.S) = struct - module Daemon = Daemon.Make (PVM) - module Components = Daemon.Components +let default_constants = + let constants = Default_parameters.constants_test in + let sc_rollup = + { + constants.sc_rollup with + arith_pvm_enable = true; + challenge_window_in_blocks = 4032; + commitment_period_in_blocks = 3; + } + in + {constants with sc_rollup} - let default_constants = - let constants = Default_parameters.constants_test in - let sc_rollup = +let add_l2_genesis_block (node_ctxt : _ Node_context.t) ~boot_sector = + let open Lwt_result_syntax in + let head = + Layer1. { - constants.sc_rollup with - arith_pvm_enable = true; - challenge_window_in_blocks = 4032; - commitment_period_in_blocks = 3; + hash = Block_hash.zero; + level = Raw_level.to_int32 node_ctxt.genesis_info.level; } - in - {constants with sc_rollup} - - let add_l2_genesis_block (node_ctxt : _ Node_context.t) ~boot_sector = - let open Lwt_result_syntax in - let head = - Layer1. - { - hash = Block_hash.zero; - level = Raw_level.to_int32 node_ctxt.genesis_info.level; - } - in - let* () = Node_context.save_level node_ctxt head in - let predecessor = head in - let predecessor_timestamp = Time.Protocol.epoch in - let inbox = - Sc_rollup.Inbox.genesis - ~predecessor_timestamp - ~predecessor:predecessor.hash - node_ctxt.genesis_info.level - in - let* inbox_hash = Node_context.save_inbox node_ctxt inbox in - let inbox_witness = Sc_rollup.Inbox.current_witness inbox in - let ctxt = Context.empty node_ctxt.context in - let num_ticks = 0L in - let initial_tick = Sc_rollup.Tick.initial in - let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! state = PVM.install_boot_sector initial_state boot_sector in - let*! genesis_state_hash = PVM.state_hash state in - let*! ctxt = PVM.State.set ctxt state in - let*! context_hash = Context.commit ctxt in - let commitment = - Sc_rollup.Commitment.genesis_commitment - ~origination_level:node_ctxt.genesis_info.level - ~genesis_state_hash - in - let* commitment_hash = Node_context.save_commitment node_ctxt commitment in - let previous_commitment_hash = node_ctxt.genesis_info.commitment_hash in - let header = - Sc_rollup_block. - { - block_hash = head.hash; - level = node_ctxt.genesis_info.level; - predecessor = predecessor.hash; - commitment_hash = Some commitment_hash; - previous_commitment_hash; - context = context_hash; - inbox_witness; - inbox_hash; - } - in - let l2_block = - Sc_rollup_block.{header; content = (); num_ticks; initial_tick} - in - let* () = Node_context.save_l2_head node_ctxt l2_block in - return l2_block - - let initialize_node_context ?(constants = default_constants) kind ~boot_sector - = - let open Lwt_result_syntax in - incr uid ; - (* To avoid any conflict with previous runs of this test. *) - let pid = Unix.getpid () in - let data_dir = - Filename.(concat @@ get_temp_dir_name ()) - (Format.sprintf "sc-rollup-node-test-%s-%d-%d" Protocol.name pid !uid) - in - let base_dir = - Filename.(concat @@ get_temp_dir_name ()) - (Format.sprintf - "sc-rollup-node-test-%s-base-%d-%d" - Protocol.name - pid - !uid) - in - let filesystem = String.Hashtbl.create 10 in - let cctxt = - new Protocol_client_context.wrap_full - (new Faked_client_context.unix_faked ~base_dir ~filesystem) - in - let* ctxt = - Node_context.Internal_for_tests.create_node_context - cctxt - ~constants - ~data_dir - kind - in - let* genesis = add_l2_genesis_block ctxt ~boot_sector in - let commitment_hash = - WithExceptions.Option.get ~loc:__LOC__ genesis.header.commitment_hash - in - let ctxt = - {ctxt with genesis_info = {ctxt.genesis_info with commitment_hash}} - in - return (ctxt, genesis, [data_dir; base_dir]) - - let with_node_context ?constants kind ~boot_sector f = - let open Lwt_result_syntax in - let* node_ctxt, genesis, dirs_to_clean = - initialize_node_context ?constants kind ~boot_sector - in - Lwt.finalize (fun () -> f node_ctxt ~genesis) @@ fun () -> - let open Lwt_syntax in - let* _ = Node_context.close node_ctxt in - let* () = - List.iter_s Tezos_stdlib_unix.Lwt_utils_unix.remove_dir dirs_to_clean - in - return_unit - - let head_of_level ~predecessor level = - let hash = block_hash_of_level level in - let timestamp = Time.Protocol.of_seconds (Int64.of_int32 level) in - let header : Block_header.shell_header = + in + let* () = Node_context.save_level node_ctxt head in + let predecessor = head in + let predecessor_timestamp = Time.Protocol.epoch in + let inbox = + Sc_rollup.Inbox.genesis + ~predecessor_timestamp + ~predecessor:predecessor.hash + node_ctxt.genesis_info.level + in + let* inbox_hash = Node_context.save_inbox node_ctxt inbox in + let inbox_witness = Sc_rollup.Inbox.current_witness inbox in + let ctxt = Context.empty node_ctxt.context in + let num_ticks = 0L in + let module PVM = (val node_ctxt.pvm) in + let initial_tick = Sc_rollup.Tick.initial in + let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in + let*! state = PVM.install_boot_sector initial_state boot_sector in + let*! genesis_state_hash = PVM.state_hash state in + let*! ctxt = PVM.State.set ctxt state in + let*! context_hash = Context.commit ctxt in + let commitment = + Sc_rollup.Commitment.genesis_commitment + ~origination_level:node_ctxt.genesis_info.level + ~genesis_state_hash + in + let* commitment_hash = Node_context.save_commitment node_ctxt commitment in + let previous_commitment_hash = node_ctxt.genesis_info.commitment_hash in + let header = + Sc_rollup_block. { - level; - predecessor; - timestamp; - (* dummy values below *) - proto_level = 0; - validation_passes = 3; - operations_hash = Tezos_crypto.Hashed.Operation_list_list_hash.zero; - fitness = []; - context = Tezos_crypto.Hashed.Context_hash.zero; + block_hash = head.hash; + level = node_ctxt.genesis_info.level; + predecessor = predecessor.hash; + commitment_hash = Some commitment_hash; + previous_commitment_hash; + context = context_hash; + inbox_witness; + inbox_hash; } - in - {Layer1.hash; level; header} - - let append_l2_block (node_ctxt : _ Node_context.t) ?(is_first_block = false) - messages = - let open Lwt_result_syntax in - let* predecessor_l2_block = - Node_context.last_processed_head_opt node_ctxt - in - let* predecessor_l2_block = - match predecessor_l2_block with - | Some b -> return b - | None -> - failwith "No genesis block, please add one with add_l2_genesis_block" - in - let pred_level = Raw_level.to_int32 predecessor_l2_block.header.level in - let predecessor = - head_of_level - ~predecessor:predecessor_l2_block.header.predecessor - pred_level - in - let head = - head_of_level ~predecessor:predecessor.hash (Int32.succ pred_level) - in - Daemon.Internal_for_tests.process_messages - node_ctxt - ~is_first_block - ~predecessor - head - messages -end - -let l2_chain_builders = - List.map - (fun kind -> - let module PVM = (val Components.pvm_of_kind kind) in - (kind, (module Make (PVM) : S))) - Sc_rollup.Kind.all - -let l2_chain_builder kind = Stdlib.List.assoc kind l2_chain_builders + in + let l2_block = + Sc_rollup_block.{header; content = (); num_ticks; initial_tick} + in + let* () = Node_context.save_l2_head node_ctxt l2_block in + return l2_block -let with_node_context ?constants kind ~boot_sector = - let module L = (val l2_chain_builder kind) in - L.with_node_context ?constants kind ~boot_sector +let initialize_node_context ?(constants = default_constants) kind ~boot_sector = + let open Lwt_result_syntax in + incr uid ; + (* To avoid any conflict with previous runs of this test. *) + let pid = Unix.getpid () in + let data_dir = + Filename.(concat @@ get_temp_dir_name ()) + (Format.sprintf "sc-rollup-node-test-%s-%d-%d" Protocol.name pid !uid) + in + let base_dir = + Filename.(concat @@ get_temp_dir_name ()) + (Format.sprintf + "sc-rollup-node-test-%s-base-%d-%d" + Protocol.name + pid + !uid) + in + let filesystem = String.Hashtbl.create 10 in + let cctxt = + new Protocol_client_context.wrap_full + (new Faked_client_context.unix_faked ~base_dir ~filesystem) + in + let* ctxt = + Node_context.Internal_for_tests.create_node_context + cctxt + ~constants + ~data_dir + kind + in + let* genesis = add_l2_genesis_block ctxt ~boot_sector in + let commitment_hash = + WithExceptions.Option.get ~loc:__LOC__ genesis.header.commitment_hash + in + let ctxt = + {ctxt with genesis_info = {ctxt.genesis_info with commitment_hash}} + in + return (ctxt, genesis, [data_dir; base_dir]) -let add_l2_genesis_block (node_ctxt : _ Node_context.t) = - let module L = (val l2_chain_builder node_ctxt.kind) in - L.add_l2_genesis_block node_ctxt +let with_node_context ?constants kind ~boot_sector f = + let open Lwt_result_syntax in + let* node_ctxt, genesis, dirs_to_clean = + initialize_node_context ?constants kind ~boot_sector + in + Lwt.finalize (fun () -> f node_ctxt ~genesis) @@ fun () -> + let open Lwt_syntax in + let* _ = Node_context.close node_ctxt in + let* () = + List.iter_s Tezos_stdlib_unix.Lwt_utils_unix.remove_dir dirs_to_clean + in + return_unit + +let head_of_level ~predecessor level = + let hash = block_hash_of_level level in + let timestamp = Time.Protocol.of_seconds (Int64.of_int32 level) in + let header : Block_header.shell_header = + { + level; + predecessor; + timestamp; + (* dummy values below *) + proto_level = 0; + validation_passes = 3; + operations_hash = Tezos_crypto.Hashed.Operation_list_list_hash.zero; + fitness = []; + context = Tezos_crypto.Hashed.Context_hash.zero; + } + in + {Layer1.hash; level; header} -let append_l2_block (node_ctxt : _ Node_context.t) = - let module L = (val l2_chain_builder node_ctxt.kind) in - L.append_l2_block node_ctxt +let append_l2_block (node_ctxt : _ Node_context.t) ?(is_first_block = false) + messages = + let open Lwt_result_syntax in + let* predecessor_l2_block = Node_context.last_processed_head_opt node_ctxt in + let* predecessor_l2_block = + match predecessor_l2_block with + | Some b -> return b + | None -> + failwith "No genesis block, please add one with add_l2_genesis_block" + in + let pred_level = Raw_level.to_int32 predecessor_l2_block.header.level in + let predecessor = + head_of_level + ~predecessor:predecessor_l2_block.header.predecessor + pred_level + in + let head = + head_of_level ~predecessor:predecessor.hash (Int32.succ pred_level) + in + Daemon.Internal_for_tests.process_messages + node_ctxt + ~is_first_block + ~predecessor + head + messages let append_l2_blocks node_ctxt message_batches = List.map_es (append_l2_block node_ctxt) message_batches diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_pvm.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_pvm.ml index cec950da0239..2ab19c30d8e3 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_pvm.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_pvm.ml @@ -65,9 +65,27 @@ end module Make_backend (Tree : TreeS) = Tezos_scoru_wasm_fast.Pvm.Make (Make_wrapped_tree (Tree)) +(** Durable part of the storage of this PVM. *) +module type Durable_state = sig + type state + + (** [value_length state key] returns the length of data stored + for the [key] in the durable storage of the PVM state [state], if any. *) + val value_length : state -> string -> int64 option Lwt.t + + (** [lookup state key] returns the data stored + for the [key] in the durable storage of the PVM state [state], if any. *) + val lookup : state -> string -> bytes option Lwt.t + + (** [subtrees state key] returns subtrees + for the [key] in the durable storage of the PVM state [state]. + Empty list in case if path doesn't exist. *) + val list : state -> string -> string list Lwt.t +end + module Make_durable_state (T : Tezos_tree_encoding.TREE with type tree = Context.tree) : - Wasm_2_0_0_rpc.Durable_state with type state = T.tree = struct + Durable_state with type state = T.tree = struct module Tree_encoding_runner = Tezos_tree_encoding.Runner.Make (T) type state = T.tree @@ -102,7 +120,13 @@ module Make_durable_state Tezos_scoru_wasm.Durable.list durable key end -module Impl : Pvm.S = struct +module type S = sig + module Durable_state : Durable_state with type state = Context.tree + + include Pvm.S +end + +module Impl : S = struct module PVM = Sc_rollup.Wasm_2_0_0PVM.Make (Make_backend) (Wasm_2_0_0_proof_format) include PVM @@ -114,7 +138,6 @@ module Impl : Pvm.S = struct module State = Context.PVMState module Durable_state = Make_durable_state (Make_wrapped_tree (Wasm_2_0_0_proof_format.Tree)) - module RPC = Wasm_2_0_0_rpc.Make_RPC (Durable_state) let string_of_status : status -> string = function | Waiting_for_input_message -> "Waiting for input message" diff --git a/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_rpc.ml b/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_rpc.ml index 8f410c55049e..c5a2210f19fa 100644 --- a/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_rpc.ml +++ b/src/proto_017_PtNairob/lib_sc_rollup_node/wasm_2_0_0_rpc.ml @@ -26,25 +26,8 @@ open RPC_directory_helpers -(** Durable part of the storage of this PVM. *) -module type Durable_state = sig - type state - - (** [value_length state key] returns the length of data stored - for the [key] in the durable storage of the PVM state [state], if any. *) - val value_length : state -> string -> int64 option Lwt.t - - (** [lookup state key] returns the data stored - for the [key] in the durable storage of the PVM state [state], if any. *) - val lookup : state -> string -> bytes option Lwt.t - - (** [subtrees state key] returns subtrees - for the [key] in the durable storage of the PVM state [state]. - Empty list in case if path doesn't exist. *) - val list : state -> string -> string list Lwt.t -end - -module Make_RPC (Durable_state : Durable_state with type state = Context.tree) = +module Make_RPC + (Durable_state : Wasm_2_0_0_pvm.Durable_state with type state = Context.tree) = struct module Block_directory = Make_directory (struct include Sc_rollup_services.Global.Block @@ -89,7 +72,7 @@ struct let*! subkeys = Durable_state.list state key in return subkeys - let build_directory = + let build_directory node_ctxt = register () ; - Block_directory.build_directory + Block_directory.build_directory node_ctxt end -- GitLab From b648d32ff1f11625c23480d078521b681cad013d Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Wed, 19 Apr 2023 18:49:28 +0200 Subject: [PATCH 13/13] SCORU/Node/Mumbai: backport !8504 (defunctorize) - SCORU/Node: remove dependency of pvm on node_context - SCORU/Node: defunctorize Fueled_pvm - SCORU/Node: defunctorize Interpreter - SCORU/Node: rename Commitment component to Publisher - SCORU/Node: defunctorize Commitment publisher - SCORU/Node: defunctorize refutation games - SCORU/Node: defunctorize simulation and batcher - SCORU/Node: defunctorize outbox - SCORU/Node: defunctorize RPC server - SCORU/Node: defunctorize daemon - Tests: simplify helpers (no functor) for rollup node tests --- .../lib_sc_rollup_node/RPC_server.ml | 851 +++++++------ .../lib_sc_rollup_node/RPC_server.mli | 17 +- .../lib_sc_rollup_node/arith_pvm.ml | 4 - .../lib_sc_rollup_node/batcher.ml | 777 ++++++------ .../lib_sc_rollup_node/batcher.mli | 82 +- .../lib_sc_rollup_node/commitment.ml | 548 -------- .../lib_sc_rollup_node/commitment_sig.ml | 17 +- .../lib_sc_rollup_node/daemon.ml | 1117 ++++++++--------- .../lib_sc_rollup_node/fueled_pvm.ml | 799 ++++++------ .../lib_sc_rollup_node/interpreter.ml | 487 ++++--- .../lib_sc_rollup_node/interpreter.mli | 83 +- .../lib_sc_rollup_node/node_context.ml | 8 + .../lib_sc_rollup_node/node_context.mli | 1 + .../lib_sc_rollup_node/outbox.ml | 63 +- .../lib_sc_rollup_node/outbox.mli | 14 +- .../lib_sc_rollup_node/publisher.ml | 521 ++++++++ .../{commitment.mli => publisher.mli} | 45 +- .../lib_sc_rollup_node/pvm.ml | 6 +- .../{components.ml => pvm_rpc.ml} | 28 +- .../refutation_coordinator.ml | 384 +++--- .../refutation_coordinator.mli | 32 +- .../lib_sc_rollup_node/refutation_game.ml | 906 +++++++------ .../lib_sc_rollup_node/refutation_game.mli | 38 +- .../lib_sc_rollup_node/refutation_player.ml | 255 ++-- .../lib_sc_rollup_node/refutation_player.mli | 51 +- .../lib_sc_rollup_node/simulation.ml | 299 ++--- .../lib_sc_rollup_node/simulation.mli | 80 +- .../test/helpers/helpers.ml | 353 +++--- .../lib_sc_rollup_node/wasm_2_0_0_pvm.ml | 29 +- .../lib_sc_rollup_node/wasm_2_0_0_rpc.ml | 25 +- 30 files changed, 3794 insertions(+), 4126 deletions(-) delete mode 100644 src/proto_016_PtMumbai/lib_sc_rollup_node/commitment.ml create mode 100644 src/proto_016_PtMumbai/lib_sc_rollup_node/publisher.ml rename src/proto_016_PtMumbai/lib_sc_rollup_node/{commitment.mli => publisher.mli} (56%) rename src/proto_016_PtMumbai/lib_sc_rollup_node/{components.ml => pvm_rpc.ml} (72%) diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/RPC_server.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/RPC_server.ml index ba98cacfc640..ae7dc4ca0042 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/RPC_server.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/RPC_server.ml @@ -95,303 +95,297 @@ let get_dal_slot_page node_ctxt block slot_index slot_page = | None -> assert false | Some _contents -> return ("Slot page is available", contents_opt)) -module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct - module PVM = Simulation.PVM - module Interpreter = Simulation.Interpreter - module Outbox = Outbox.Make (PVM) - module Free_pvm = Interpreter.Free_pvm +module Global_directory = Make_directory (struct + include Sc_rollup_services.Global - module Global_directory = Make_directory (struct - include Sc_rollup_services.Global + type context = Node_context.ro - type context = Node_context.ro + let context_of_prefix node_ctxt () = return (Node_context.readonly node_ctxt) +end) - let context_of_prefix node_ctxt () = - return (Node_context.readonly node_ctxt) - end) +module Proof_helpers_directory = Make_directory (struct + include Sc_rollup_services.Global.Helpers - module Proof_helpers_directory = Make_directory (struct - include Sc_rollup_services.Global.Helpers + (* The context needs to be accessed with write permissions because we need to + commit on disk to generate the proofs. *) + type context = Node_context.rw - (* The context needs to be accessed with write permissions because we need to - commit on disk to generate the proofs. *) - type context = Node_context.rw + let context_of_prefix node_ctxt () = return node_ctxt +end) - let context_of_prefix node_ctxt () = return node_ctxt - end) +module Local_directory = Make_directory (struct + include Sc_rollup_services.Local - module Local_directory = Make_directory (struct - include Sc_rollup_services.Local + type context = Node_context.ro - type context = Node_context.ro + let context_of_prefix node_ctxt () = return (Node_context.readonly node_ctxt) +end) - let context_of_prefix node_ctxt () = - return (Node_context.readonly node_ctxt) - end) +module Block_directory = Make_directory (struct + include Sc_rollup_services.Global.Block - module Block_directory = Make_directory (struct - include Sc_rollup_services.Global.Block + type context = Node_context.ro * Block_hash.t - type context = Node_context.ro * Block_hash.t - - let context_of_prefix node_ctxt (((), block) : prefix) = - let open Lwt_result_syntax in - let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in - (Node_context.readonly node_ctxt, block) - end) - - module Outbox_directory = Make_directory (struct - include Sc_rollup_services.Global.Block.Outbox - - type context = Node_context.ro * Block_hash.t * Alpha_context.Raw_level.t + let context_of_prefix node_ctxt (((), block) : prefix) = + let open Lwt_result_syntax in + let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in + (Node_context.readonly node_ctxt, block) +end) - let context_of_prefix node_ctxt (((), block), level) = - let open Lwt_result_syntax in - let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in - (Node_context.readonly node_ctxt, block, level) - end) +module Outbox_directory = Make_directory (struct + include Sc_rollup_services.Global.Block.Outbox - module Common = struct - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.block - @@ fun (node_ctxt, block) () () -> - Node_context.get_full_l2_block node_ctxt block + type context = Node_context.ro * Block_hash.t * Alpha_context.Raw_level.t - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.num_messages - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* l2_block = Node_context.get_l2_block node_ctxt block in - let+ num_messages = - Node_context.get_num_messages node_ctxt l2_block.header.inbox_witness - in - Z.of_int num_messages - - let () = - Global_directory.register0 Sc_rollup_services.Global.sc_rollup_address - @@ fun node_ctxt () () -> return @@ node_ctxt.rollup_address - - let () = - Global_directory.register0 Sc_rollup_services.Global.current_tezos_head - @@ fun node_ctxt () () -> get_head_hash_opt node_ctxt - - let () = - Global_directory.register0 Sc_rollup_services.Global.current_tezos_level - @@ fun node_ctxt () () -> get_head_level_opt node_ctxt - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.hash - @@ fun (_node_ctxt, block) () () -> return block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.level - @@ fun (node_ctxt, block) () () -> - Node_context.level_of_hash node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.inbox - @@ fun (node_ctxt, block) () () -> - Node_context.get_inbox_by_block_hash node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.ticks - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let+ l2_block = Node_context.get_l2_block node_ctxt block in - Z.of_int64 l2_block.num_ticks - end - - let get_state (node_ctxt : _ Node_context.t) block_hash = + let context_of_prefix node_ctxt (((), block), level) = let open Lwt_result_syntax in - let* ctxt = Node_context.checkout_context node_ctxt block_hash in - let*! state = PVM.State.find ctxt in - match state with None -> failwith "No state" | Some state -> return state - - let simulate_messages (node_ctxt : Node_context.ro) block ~reveal_pages - messages = - let open Lwt_result_syntax in - let open Alpha_context in - let reveal_map = - match reveal_pages with - | Some pages -> - let map = - List.fold_left - (fun map page -> - let hash = - Sc_rollup_reveal_hash.(hash_string ~scheme:Blake2B [page]) - in - Sc_rollup_reveal_hash.Map.add hash page map) - Sc_rollup_reveal_hash.Map.empty - pages - in - Some map - | None -> None - in - let* level = Node_context.level_of_hash node_ctxt block in - let* sim = - Simulation.start_simulation - node_ctxt - ~reveal_map - Layer1.{hash = block; level} - in - let messages = - List.map (fun m -> Sc_rollup.Inbox_message.External m) messages - in - let* sim, num_ticks_0 = - Simulation.simulate_messages node_ctxt sim messages - in - let* {state; inbox_level; _}, num_ticks_end = - Simulation.end_simulation node_ctxt sim - in - let num_ticks = Z.(num_ticks_0 + num_ticks_end) in - let*! outbox = PVM.get_outbox inbox_level state in - let output = - List.filter - (fun Sc_rollup.{outbox_level; _} -> outbox_level = inbox_level) - outbox - in - let*! state_hash = PVM.state_hash state in - let*! status = PVM.get_status state in - let status = PVM.string_of_status status in - return - Sc_rollup_services.{state_hash; status; output; inbox_level; num_ticks} + let+ block = Block_directory_helpers.block_of_prefix node_ctxt block in + (Node_context.readonly node_ctxt, block, level) +end) +module Common = struct let () = - Block_directory.register0 Sc_rollup_services.Global.Block.total_ticks + Block_directory.register0 Sc_rollup_services.Global.Block.block @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! tick = PVM.get_tick state in - return tick + Node_context.get_full_l2_block node_ctxt block let () = - Block_directory.register0 Sc_rollup_services.Global.Block.state_hash + Block_directory.register0 Sc_rollup_services.Global.Block.num_messages @@ fun (node_ctxt, block) () () -> let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! hash = PVM.state_hash state in - return hash + let* l2_block = Node_context.get_l2_block node_ctxt block in + let+ num_messages = + Node_context.get_num_messages node_ctxt l2_block.header.inbox_witness + in + Z.of_int num_messages let () = - Block_directory.register0 - Sc_rollup_services.Global.Block.state_current_level - @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! current_level = PVM.get_current_level state in - return current_level + Global_directory.register0 Sc_rollup_services.Global.sc_rollup_address + @@ fun node_ctxt () () -> return @@ node_ctxt.rollup_address let () = - Block_directory.register0 Sc_rollup_services.Global.Block.state_value - @@ fun (node_ctxt, block) {key} () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let path = String.split_on_char '/' key in - let*! value = PVM.State.lookup state path in - match value with - | None -> failwith "No such key in PVM state" - | Some value -> - Format.eprintf "Encoded %S\n@.%!" (Bytes.to_string value) ; - return value + Global_directory.register0 Sc_rollup_services.Global.current_tezos_head + @@ fun node_ctxt () () -> get_head_hash_opt node_ctxt let () = - Global_directory.register0 Sc_rollup_services.Global.last_stored_commitment - @@ fun node_ctxt () () -> - let open Lwt_result_syntax in - let* head = Node_context.last_processed_head_opt node_ctxt in - match head with - | None -> return_none - | Some head -> - let commitment_hash = - Sc_rollup_block.most_recent_commitment head.header - in - let+ commitment = - Node_context.find_commitment node_ctxt commitment_hash - in - Option.map (fun c -> (c, commitment_hash)) commitment + Global_directory.register0 Sc_rollup_services.Global.current_tezos_level + @@ fun node_ctxt () () -> get_head_level_opt node_ctxt let () = - Local_directory.register0 Sc_rollup_services.Local.last_published_commitment - @@ fun node_ctxt () () -> - let open Lwt_result_syntax in - match Reference.get node_ctxt.lpc with - | None -> return_none - | Some commitment -> - let hash = - Alpha_context.Sc_rollup.Commitment.hash_uncarbonated commitment - in - (* The corresponding level in Store.Commitments.published_at_level is - available only when the commitment has been published and included - in a block. *) - let* published_at_level_info = - Node_context.commitment_published_at_level node_ctxt hash - in - let first_published, published = - match published_at_level_info with - | None -> (None, None) - | Some {first_published_at_level; published_at_level} -> - (Some first_published_at_level, published_at_level) - in - return_some (commitment, hash, first_published, published) + Block_directory.register0 Sc_rollup_services.Global.Block.hash + @@ fun (_node_ctxt, block) () () -> return block let () = - Block_directory.register0 Sc_rollup_services.Global.Block.status + Block_directory.register0 Sc_rollup_services.Global.Block.level @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! status = PVM.get_status state in - return (PVM.string_of_status status) + Node_context.level_of_hash node_ctxt block let () = - Block_directory.register0 Sc_rollup_services.Global.Block.dal_slots + Block_directory.register0 Sc_rollup_services.Global.Block.inbox @@ fun (node_ctxt, block) () () -> - let open Lwt_result_syntax in - let+ slots = - Node_context.get_all_slot_headers node_ctxt ~published_in_block_hash:block - in - slots + Node_context.get_inbox_by_block_hash node_ctxt block let () = - Block_directory.register0 - Sc_rollup_services.Global.Block.dal_confirmed_slot_pages + Block_directory.register0 Sc_rollup_services.Global.Block.ticks @@ fun (node_ctxt, block) () () -> - get_dal_confirmed_slot_pages node_ctxt block - - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.dal_slot_page - @@ fun (node_ctxt, block) {index; page} () -> - get_dal_slot_page node_ctxt block index page - - let () = - Outbox_directory.register0 Sc_rollup_services.Global.Block.Outbox.messages - @@ fun (node_ctxt, block, outbox_level) () () -> let open Lwt_result_syntax in - let* state = get_state node_ctxt block in - let*! outbox = PVM.get_outbox outbox_level state in - return outbox + let+ l2_block = Node_context.get_l2_block node_ctxt block in + Z.of_int64 l2_block.num_ticks +end - let () = - Proof_helpers_directory.register0 - Sc_rollup_services.Global.Helpers.outbox_proof - @@ fun node_ctxt output () -> Outbox.proof_of_output node_ctxt output +let get_state (node_ctxt : _ Node_context.t) block_hash = + let open Lwt_result_syntax in + let* ctxt = Node_context.checkout_context node_ctxt block_hash in + let*! state = Context.PVMState.find ctxt in + match state with None -> failwith "No state" | Some state -> return state - let () = - Block_directory.register0 Sc_rollup_services.Global.Block.simulate - @@ fun (node_ctxt, block) () {messages; reveal_pages} -> - simulate_messages node_ctxt block ~reveal_pages messages +let simulate_messages (node_ctxt : Node_context.ro) block ~reveal_pages messages + = + let open Lwt_result_syntax in + let open Alpha_context in + let module PVM = (val node_ctxt.pvm) in + let reveal_map = + match reveal_pages with + | Some pages -> + let map = + List.fold_left + (fun map page -> + let hash = + Sc_rollup_reveal_hash.(hash_string ~scheme:Blake2B [page]) + in + Sc_rollup_reveal_hash.Map.add hash page map) + Sc_rollup_reveal_hash.Map.empty + pages + in + Some map + | None -> None + in + let* level = Node_context.level_of_hash node_ctxt block in + let* sim = + Simulation.start_simulation + node_ctxt + ~reveal_map + Layer1.{hash = block; level} + in + let messages = + List.map (fun m -> Sc_rollup.Inbox_message.External m) messages + in + let* sim, num_ticks_0 = Simulation.simulate_messages node_ctxt sim messages in + let* {state; inbox_level; _}, num_ticks_end = + Simulation.end_simulation node_ctxt sim + in + let num_ticks = Z.(num_ticks_0 + num_ticks_end) in + let*! outbox = PVM.get_outbox inbox_level state in + let output = + List.filter + (fun Sc_rollup.{outbox_level; _} -> outbox_level = inbox_level) + outbox + in + let*! state_hash = PVM.state_hash state in + let*! status = PVM.get_status state in + let status = PVM.string_of_status status in + return Sc_rollup_services.{state_hash; status; output; inbox_level; num_ticks} + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.total_ticks + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! tick = PVM.get_tick state in + return tick + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.state_hash + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! hash = PVM.state_hash state in + return hash + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.state_current_level + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! current_level = PVM.get_current_level state in + return current_level + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.state_value + @@ fun (node_ctxt, block) {key} () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let path = String.split_on_char '/' key in + let*! value = Context.PVMState.lookup state path in + match value with + | None -> failwith "No such key in PVM state" + | Some value -> + Format.eprintf "Encoded %S\n@.%!" (Bytes.to_string value) ; + return value + +let () = + Global_directory.register0 Sc_rollup_services.Global.last_stored_commitment + @@ fun node_ctxt () () -> + let open Lwt_result_syntax in + let* head = Node_context.last_processed_head_opt node_ctxt in + match head with + | None -> return_none + | Some head -> + let commitment_hash = + Sc_rollup_block.most_recent_commitment head.header + in + let+ commitment = + Node_context.find_commitment node_ctxt commitment_hash + in + Option.map (fun c -> (c, commitment_hash)) commitment - let () = - Local_directory.register0 Sc_rollup_services.Local.injection - @@ fun _node_ctxt () messages -> Batcher.register_messages messages +let () = + Local_directory.register0 Sc_rollup_services.Local.last_published_commitment + @@ fun node_ctxt () () -> + let open Lwt_result_syntax in + match Reference.get node_ctxt.lpc with + | None -> return_none + | Some commitment -> + let hash = + Alpha_context.Sc_rollup.Commitment.hash_uncarbonated commitment + in + (* The corresponding level in Store.Commitments.published_at_level is + available only when the commitment has been published and included + in a block. *) + let* published_at_level_info = + Node_context.commitment_published_at_level node_ctxt hash + in + let first_published, published = + match published_at_level_info with + | None -> (None, None) + | Some {first_published_at_level; published_at_level} -> + (Some first_published_at_level, published_at_level) + in + return_some (commitment, hash, first_published, published) - let () = - Local_directory.register0 Sc_rollup_services.Local.batcher_queue - @@ fun _node_ctxt () () -> - let open Lwt_result_syntax in - let*? queue = Batcher.get_queue () in - return queue +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.status + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! status = PVM.get_status state in + return (PVM.string_of_status status) + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.dal_slots + @@ fun (node_ctxt, block) () () -> + let open Lwt_result_syntax in + let* slots = + Node_context.get_all_slot_headers node_ctxt ~published_in_block_hash:block + in + return slots + +let () = + Block_directory.register0 + Sc_rollup_services.Global.Block.dal_confirmed_slot_pages + @@ fun (node_ctxt, block) () () -> + get_dal_confirmed_slot_pages node_ctxt block + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.dal_slot_page + @@ fun (node_ctxt, block) {index; page} () -> + get_dal_slot_page node_ctxt block index page + +let () = + Outbox_directory.register0 Sc_rollup_services.Global.Block.Outbox.messages + @@ fun (node_ctxt, block, outbox_level) () () -> + let open Lwt_result_syntax in + let* state = get_state node_ctxt block in + let module PVM = (val node_ctxt.pvm) in + let*! outbox = PVM.get_outbox outbox_level state in + return outbox + +let () = + Proof_helpers_directory.register0 + Sc_rollup_services.Global.Helpers.outbox_proof + @@ fun node_ctxt output () -> Outbox.proof_of_output node_ctxt output + +let () = + Block_directory.register0 Sc_rollup_services.Global.Block.simulate + @@ fun (node_ctxt, block) () {messages; reveal_pages} -> + simulate_messages node_ctxt block ~reveal_pages messages + +let () = + Local_directory.register0 Sc_rollup_services.Local.injection + @@ fun _node_ctxt () messages -> Batcher.register_messages messages + +let () = + Local_directory.register0 Sc_rollup_services.Local.batcher_queue + @@ fun _node_ctxt () () -> + let open Lwt_result_syntax in + let*? queue = Batcher.get_queue () in + return queue - (** [commitment_level_of_inbox_level node_ctxt inbox_level] returns the level +(** [commitment_level_of_inbox_level node_ctxt inbox_level] returns the level of the commitment which should include the inbox of level [inbox_level]. @@ -403,184 +397,181 @@ module Make (Simulation : Simulation.S) (Batcher : Batcher.S) = struct * commitment_period) v} *) - let commitment_level_of_inbox_level (node_ctxt : _ Node_context.t) inbox_level - = - let open Alpha_context in - let open Option_syntax in - let+ last_published_commitment = Reference.get node_ctxt.lpc in - let commitment_period = - Int32.of_int - node_ctxt.protocol_constants.parametric.sc_rollup - .commitment_period_in_blocks - in - let last_published = - Raw_level.to_int32 last_published_commitment.inbox_level - in - let open Int32 in - div (sub last_published inbox_level) commitment_period - |> mul commitment_period |> sub last_published |> Raw_level.of_int32_exn - - let inbox_info_of_level (node_ctxt : _ Node_context.t) inbox_level = - let open Alpha_context in - let open Lwt_result_syntax in - let+ finalized_level = Node_context.get_finalized_level node_ctxt in - let finalized = Compare.Int32.(inbox_level <= finalized_level) in - let lcc = Reference.get node_ctxt.lcc in - let cemented = - Compare.Int32.(inbox_level <= Raw_level.to_int32 lcc.level) - in - (finalized, cemented) - - let () = - Local_directory.register1 Sc_rollup_services.Local.batcher_message - @@ fun node_ctxt hash () () -> - let open Lwt_result_syntax in - let*? batch_status = Batcher.message_status hash in - let* status = - match batch_status with - | None -> return (None, Sc_rollup_services.Unknown) - | Some (batch_status, msg) -> ( - let return status = return (Some msg, status) in - match batch_status with - | Pending_batch -> return Sc_rollup_services.Pending_batch - | Batched l1_hash -> ( - match Injector.operation_status l1_hash with - | None -> return Sc_rollup_services.Unknown - | Some (Pending op) -> - return (Sc_rollup_services.Pending_injection op) - | Some (Injected {op; oph; op_index}) -> - return - (Sc_rollup_services.Injected - {op = op.operation; oph; op_index}) - | Some (Included {op; oph; op_index; l1_block; l1_level}) -> ( - let* finalized, cemented = - inbox_info_of_level node_ctxt l1_level - in - let commitment_level = - commitment_level_of_inbox_level node_ctxt l1_level - in - match commitment_level with - | None -> - return - (Sc_rollup_services.Included - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - }) - | Some commitment_level -> ( - let* block = - Node_context.find_l2_block_by_level - node_ctxt - (Alpha_context.Raw_level.to_int32 commitment_level) - in - match block with - | None -> - (* Commitment not computed yet for inbox *) - return - (Sc_rollup_services.Included - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - }) - | Some block -> ( - let commitment_hash = - WithExceptions.Option.get - ~loc:__LOC__ - block.header.commitment_hash - in - (* Commitment computed *) - let* published_at = - Node_context.commitment_published_at_level - node_ctxt - commitment_hash - in - match published_at with - | None | Some {published_at_level = None; _} -> - (* Commitment not published yet *) - return - (Sc_rollup_services.Included - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - }) - | Some - { - first_published_at_level; - published_at_level = Some published_at_level; - } -> - (* Commitment published *) - let* commitment = - Node_context.get_commitment - node_ctxt - commitment_hash - in - return - (Sc_rollup_services.Committed - { - op = op.operation; - oph; - op_index; - l1_block; - l1_level; - finalized; - cemented; - commitment; - commitment_hash; - first_published_at_level; - published_at_level; - })))))) - in +let commitment_level_of_inbox_level (node_ctxt : _ Node_context.t) inbox_level = + let open Alpha_context in + let open Option_syntax in + let+ last_published_commitment = Reference.get node_ctxt.lpc in + let commitment_period = + Int32.of_int + node_ctxt.protocol_constants.parametric.sc_rollup + .commitment_period_in_blocks + in + let last_published = + Raw_level.to_int32 last_published_commitment.inbox_level + in + let open Int32 in + div (sub last_published inbox_level) commitment_period + |> mul commitment_period |> sub last_published |> Raw_level.of_int32_exn - return status +let inbox_info_of_level (node_ctxt : _ Node_context.t) inbox_level = + let open Alpha_context in + let open Lwt_result_syntax in + let+ finalized_level = Node_context.get_finalized_level node_ctxt in + let finalized = Compare.Int32.(inbox_level <= finalized_level) in + let lcc = Reference.get node_ctxt.lcc in + let cemented = Compare.Int32.(inbox_level <= Raw_level.to_int32 lcc.level) in + (finalized, cemented) + +let () = + Local_directory.register1 Sc_rollup_services.Local.batcher_message + @@ fun node_ctxt hash () () -> + let open Lwt_result_syntax in + let*? batch_status = Batcher.message_status hash in + let* status = + match batch_status with + | None -> return (None, Sc_rollup_services.Unknown) + | Some (batch_status, msg) -> ( + let return status = return (Some msg, status) in + match batch_status with + | Pending_batch -> return Sc_rollup_services.Pending_batch + | Batched l1_hash -> ( + match Injector.operation_status l1_hash with + | None -> return Sc_rollup_services.Unknown + | Some (Pending op) -> + return (Sc_rollup_services.Pending_injection op) + | Some (Injected {op; oph; op_index}) -> + return + (Sc_rollup_services.Injected + {op = op.operation; oph; op_index}) + | Some (Included {op; oph; op_index; l1_block; l1_level}) -> ( + let* finalized, cemented = + inbox_info_of_level node_ctxt l1_level + in + let commitment_level = + commitment_level_of_inbox_level node_ctxt l1_level + in + match commitment_level with + | None -> + return + (Sc_rollup_services.Included + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + }) + | Some commitment_level -> ( + let* block = + Node_context.find_l2_block_by_level + node_ctxt + (Alpha_context.Raw_level.to_int32 commitment_level) + in + match block with + | None -> + (* Commitment not computed yet for inbox *) + return + (Sc_rollup_services.Included + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + }) + | Some block -> ( + let commitment_hash = + WithExceptions.Option.get + ~loc:__LOC__ + block.header.commitment_hash + in + (* Commitment computed *) + let* published_at = + Node_context.commitment_published_at_level + node_ctxt + commitment_hash + in + match published_at with + | None | Some {published_at_level = None; _} -> + (* Commitment not published yet *) + return + (Sc_rollup_services.Included + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + }) + | Some + { + first_published_at_level; + published_at_level = Some published_at_level; + } -> + (* Commitment published *) + let* commitment = + Node_context.get_commitment + node_ctxt + commitment_hash + in + return + (Sc_rollup_services.Committed + { + op = op.operation; + oph; + op_index; + l1_block; + l1_level; + finalized; + cemented; + commitment; + commitment_hash; + first_published_at_level; + published_at_level; + })))))) + in - let register node_ctxt = - List.fold_left - (fun dir f -> Tezos_rpc.Directory.merge dir (f node_ctxt)) - Tezos_rpc.Directory.empty - [ - Global_directory.build_directory; - Local_directory.build_directory; - Block_directory.build_directory; - Proof_helpers_directory.build_directory; - Outbox_directory.build_directory; - PVM.RPC.build_directory; - ] - - let start node_ctxt configuration = - let open Lwt_result_syntax in - let Configuration.{rpc_addr; rpc_port; _} = configuration in - let rpc_addr = P2p_addr.of_string_exn rpc_addr in - let host = Ipaddr.V6.to_string rpc_addr in - let node = `TCP (`Port rpc_port) in - let acl = RPC_server.Acl.allow_all in - let dir = register node_ctxt in - let server = - RPC_server.init_server dir ~acl ~media_types:Media_type.all_media_types - in - protect @@ fun () -> - let*! () = - RPC_server.launch - ~host - server - ~callback:(RPC_server.resto_callback server) - node - in - return server + return status + +let register (node_ctxt : _ Node_context.t) = + let module PVM = (val Pvm_rpc.of_kind node_ctxt.kind) in + List.fold_left + (fun dir f -> Tezos_rpc.Directory.merge dir (f node_ctxt)) + Tezos_rpc.Directory.empty + [ + Global_directory.build_directory; + Local_directory.build_directory; + Block_directory.build_directory; + Proof_helpers_directory.build_directory; + Outbox_directory.build_directory; + PVM.build_directory; + ] + +let start node_ctxt configuration = + let open Lwt_result_syntax in + let Configuration.{rpc_addr; rpc_port; _} = configuration in + let rpc_addr = P2p_addr.of_string_exn rpc_addr in + let host = Ipaddr.V6.to_string rpc_addr in + let node = `TCP (`Port rpc_port) in + let acl = RPC_server.Acl.allow_all in + let dir = register node_ctxt in + let server = + RPC_server.init_server dir ~acl ~media_types:Media_type.all_media_types + in + protect @@ fun () -> + let*! () = + RPC_server.launch + ~host + server + ~callback:(RPC_server.resto_callback server) + node + in + return server - let shutdown = RPC_server.shutdown -end +let shutdown = RPC_server.shutdown diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/RPC_server.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/RPC_server.mli index a5ead51ff6bf..7830dad2505f 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/RPC_server.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/RPC_server.mli @@ -25,14 +25,11 @@ open Tezos_rpc_http_server -(** Functor to construct an RPC server for a given PVM with simulation. *) -module Make (Simulation : Simulation.S) (Batcher : Batcher.S) : sig - (** [start node_ctxt config] starts an RPC server listening for requests on - the port [config.rpc_port] and address [config.rpc_addr]. *) - val start : - Node_context.rw -> Configuration.t -> RPC_server.server tzresult Lwt.t +(** [start node_ctxt config] starts an RPC server listening for requests on the + port [config.rpc_port] and address [config.rpc_addr]. *) +val start : + Node_context.rw -> Configuration.t -> RPC_server.server tzresult Lwt.t - (** Shutdown a running RPC server. When this function is called, the rollup - node will stop listening to incoming requests. *) - val shutdown : RPC_server.server -> unit Lwt.t -end +(** Shutdown a running RPC server. When this function is called, the rollup node + will stop listening to incoming requests. *) +val shutdown : RPC_server.server -> unit Lwt.t diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/arith_pvm.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/arith_pvm.ml index c7684ea50e50..0d35862d09d1 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/arith_pvm.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/arith_pvm.ml @@ -52,10 +52,6 @@ module Impl : Pvm.S = struct module State = Context.PVMState - module RPC = struct - let build_directory _node_ctxt = Tezos_rpc.Directory.empty - end - let new_dissection = Game_helpers.default_new_dissection let string_of_status status = diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/batcher.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/batcher.ml index 273b3a9a0725..f267a359dab2 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/batcher.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/batcher.ml @@ -34,435 +34,388 @@ end module Batched_messages = Hash_queue.Make (L2_message.Hash) (L2_batched_message) -(* Count instances of the batcher functor to allow for multiple worker events - without conflicts. *) -let instances_count = ref 0 - -module type S = sig - type status = Pending_batch | Batched of Injector.Inj_operation.hash - - val init : - Configuration.batcher -> - signer:public_key_hash -> - _ Node_context.t -> - unit tzresult Lwt.t - - val active : unit -> bool +type status = Pending_batch | Batched of Injector.Inj_operation.hash + +(* Same as {!Configuration.batcher} with max_batch_size non optional. *) +type conf = { + simulate : bool; + min_batch_elements : int; + min_batch_size : int; + max_batch_elements : int; + max_batch_size : int; +} + +type state = { + node_ctxt : Node_context.ro; + signer : Signature.public_key_hash; + conf : conf; + messages : Message_queue.t; + batched : Batched_messages.t; + mutable simulation_ctxt : Simulation.t option; +} + +let message_size s = + (* Encoded as length of s on 4 bytes + s *) + 4 + String.length s + +let inject_batch state (l2_messages : L2_message.t list) = + let open Lwt_result_syntax in + let messages = List.map L2_message.content l2_messages in + let operation = L1_operation.Add_messages {messages} in + let+ l1_hash = + Injector.add_pending_operation ~source:state.signer operation + in + List.iter + (fun msg -> + let content = L2_message.content msg in + let hash = L2_message.hash msg in + Batched_messages.replace state.batched hash {content; l1_hash}) + l2_messages + +let inject_batches state = List.iter_es (inject_batch state) + +let get_batches state ~only_full = + let ( current_rev_batch, + current_batch_size, + current_batch_elements, + full_batches ) = + Message_queue.fold + (fun msg_hash + message + ( current_rev_batch, + current_batch_size, + current_batch_elements, + full_batches ) -> + let size = message_size (L2_message.content message) in + let new_batch_size = current_batch_size + size in + let new_batch_elements = current_batch_elements + 1 in + if + new_batch_size <= state.conf.max_batch_size + && new_batch_elements <= state.conf.max_batch_elements + then + (* We can add the message to the current batch because we are still + within the bounds. *) + ( (msg_hash, message) :: current_rev_batch, + new_batch_size, + new_batch_elements, + full_batches ) + else + (* The batch augmented with the message would be too big but it is + below the limit without it. We finalize the current batch and + create a new one for the message. NOTE: Messages in the queue are + always < [state.conf.max_batch_size] because {!on_register} only + accepts those. *) + let batch = List.rev current_rev_batch in + ([(msg_hash, message)], size, 1, batch :: full_batches)) + state.messages + ([], 0, 0, []) + in + let batches = + if + (not only_full) + || current_batch_size >= state.conf.min_batch_size + && current_batch_elements >= state.conf.min_batch_elements + then + (* We have enough to make a batch with the last non-full batch. *) + List.rev current_rev_batch :: full_batches + else full_batches + in + List.fold_left + (fun (batches, to_remove) -> function + | [] -> (batches, to_remove) + | batch -> + let msg_hashes, batch = List.split batch in + let to_remove = List.rev_append msg_hashes to_remove in + (batch :: batches, to_remove)) + ([], []) + batches + +let produce_batches state ~only_full = + let open Lwt_result_syntax in + let batches, to_remove = get_batches state ~only_full in + match batches with + | [] -> return_unit + | _ -> + let* () = inject_batches state batches in + let*! () = + Batcher_events.(emit batched) + (List.length batches, List.length to_remove) + in + List.iter + (fun tr_hash -> Message_queue.remove state.messages tr_hash) + to_remove ; + return_unit + +let on_batch state = produce_batches state ~only_full:false + +let simulate node_ctxt simulation_ctxt (messages : L2_message.t list) = + let open Lwt_result_syntax in + let ext_messages = + List.map + (fun m -> Sc_rollup.Inbox_message.External (L2_message.content m)) + messages + in + let+ simulation_ctxt, _ticks = + Simulation.simulate_messages node_ctxt simulation_ctxt ext_messages + in + simulation_ctxt + +let on_register state (messages : string list) = + let open Lwt_result_syntax in + let max_size_msg = + min + (Protocol.Constants_repr.sc_rollup_message_size_limit + + 4 (* We add 4 because [message_size] adds 4. *)) + state.conf.max_batch_size + in + let*? messages = + List.mapi_e + (fun i message -> + if message_size message > max_size_msg then + error_with "Message %d is too large (max size is %d)" i max_size_msg + else Ok (L2_message.make message)) + messages + in + let* () = + if not state.conf.simulate then return_unit + else + match state.simulation_ctxt with + | None -> failwith "Simulation context of batcher not initialized" + | Some simulation_ctxt -> + let+ simulation_ctxt = + simulate state.node_ctxt simulation_ctxt messages + in + state.simulation_ctxt <- Some simulation_ctxt + in + let*! () = Batcher_events.(emit queue) (List.length messages) in + let hashes = + List.map + (fun message -> + let msg_hash = L2_message.hash message in + Message_queue.replace state.messages msg_hash message ; + msg_hash) + messages + in + let+ () = produce_batches state ~only_full:true in + hashes + +let on_new_head state head = + let open Lwt_result_syntax in + let* simulation_ctxt = + Simulation.start_simulation ~reveal_map:None state.node_ctxt head + in + (* TODO: https://gitlab.com/tezos/tezos/-/issues/4224 + Replay with simulation may be too expensive *) + let+ simulation_ctxt, failing = + if not state.conf.simulate then return (simulation_ctxt, []) + else + (* Re-simulate one by one *) + Message_queue.fold_es + (fun msg_hash msg (simulation_ctxt, failing) -> + let*! result = simulate state.node_ctxt simulation_ctxt [msg] in + match result with + | Ok simulation_ctxt -> return (simulation_ctxt, failing) + | Error _ -> return (simulation_ctxt, msg_hash :: failing)) + state.messages + (simulation_ctxt, []) + in + state.simulation_ctxt <- Some simulation_ctxt ; + (* Forget failing messages *) + List.iter (Message_queue.remove state.messages) failing + +let init_batcher_state node_ctxt ~signer (conf : Configuration.batcher) = + let open Lwt_syntax in + let conf = + { + simulate = conf.simulate; + min_batch_elements = conf.min_batch_elements; + min_batch_size = conf.min_batch_size; + max_batch_elements = conf.max_batch_elements; + max_batch_size = + Option.value + conf.max_batch_size + ~default:Node_context.protocol_max_batch_size; + } + in + return + { + node_ctxt; + signer; + conf; + messages = Message_queue.create 100_000 (* ~ 400MB *); + batched = Batched_messages.create 100_000 (* ~ 400MB *); + simulation_ctxt = None; + } - val find_message : L2_message.hash -> L2_message.t option tzresult +module Types = struct + type nonrec state = state - val get_queue : unit -> (L2_message.hash * L2_message.t) list tzresult + type parameters = { + node_ctxt : Node_context.ro; + signer : Signature.public_key_hash; + conf : Configuration.batcher; + } +end - val register_messages : string list -> L2_message.hash list tzresult Lwt.t +module Name = struct + (* We only have a single batcher in the node *) + type t = unit - val batch : unit -> unit tzresult Lwt.t + let encoding = Data_encoding.unit - val new_head : Layer1.head -> unit tzresult Lwt.t + let base = Batcher_events.Worker.section @ ["worker"] - val shutdown : unit -> unit Lwt.t + let pp _ _ = () - val message_status : L2_message.hash -> (status * string) option tzresult + let equal () () = true end -module Make (Simulation : Simulation.S) : S = struct - let () = incr instances_count - - module PVM = Simulation.PVM - - type status = Pending_batch | Batched of Injector.Inj_operation.hash +module Worker = Worker.MakeSingle (Name) (Request) (Types) - (* Same as {!Configuration.batcher} with max_batch_size non optional. *) - type conf = { - simulate : bool; - min_batch_elements : int; - min_batch_size : int; - max_batch_elements : int; - max_batch_size : int; - } +type worker = Worker.infinite Worker.queue Worker.t - type state = { - node_ctxt : Node_context.ro; - signer : Tezos_crypto.Signature.public_key_hash; - conf : conf; - messages : Message_queue.t; - batched : Batched_messages.t; - mutable simulation_ctxt : Simulation.t option; - } +module Handlers = struct + type self = worker - let message_size s = - (* Encoded as length of s on 4 bytes + s *) - 4 + String.length s + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with + | Request.Register messages -> + protect @@ fun () -> on_register state messages + | Request.Batch -> protect @@ fun () -> on_batch state + | Request.New_head head -> protect @@ fun () -> on_new_head state head - let inject_batch state (l2_messages : L2_message.t list) = - let open Lwt_result_syntax in - let messages = List.map L2_message.content l2_messages in - let operation = L1_operation.Add_messages {messages} in - let+ l1_hash = - Injector.add_pending_operation ~source:state.signer operation - in - List.iter - (fun msg -> - let content = L2_message.content msg in - let hash = L2_message.hash msg in - Batched_messages.replace state.batched hash {content; l1_hash}) - l2_messages - - let inject_batches state = List.iter_es (inject_batch state) - - let get_batches state ~only_full = - let ( current_rev_batch, - current_batch_size, - current_batch_elements, - full_batches ) = - Message_queue.fold - (fun msg_hash - message - ( current_rev_batch, - current_batch_size, - current_batch_elements, - full_batches ) -> - let size = message_size (L2_message.content message) in - let new_batch_size = current_batch_size + size in - let new_batch_elements = current_batch_elements + 1 in - if - new_batch_size <= state.conf.max_batch_size - && new_batch_elements <= state.conf.max_batch_elements - then - (* We can add the message to the current batch because we are still - within the bounds. *) - ( (msg_hash, message) :: current_rev_batch, - new_batch_size, - new_batch_elements, - full_batches ) - else - (* The batch augmented with the message would be too big but it is - below the limit without it. We finalize the current batch and - create a new one for the message. NOTE: Messages in the queue are - always < [state.conf.max_batch_size] because {!on_register} only - accepts those. *) - let batch = List.rev current_rev_batch in - ([(msg_hash, message)], size, 1, batch :: full_batches)) - state.messages - ([], 0, 0, []) - in - let batches = - if - (not only_full) - || current_batch_size >= state.conf.min_batch_size - && current_batch_elements >= state.conf.min_batch_elements - then - (* We have enough to make a batch with the last non-full batch. *) - List.rev current_rev_batch :: full_batches - else full_batches - in - List.fold_left - (fun (batches, to_remove) -> function - | [] -> (batches, to_remove) - | batch -> - let msg_hashes, batch = List.split batch in - let to_remove = List.rev_append msg_hashes to_remove in - (batch :: batches, to_remove)) - ([], []) - batches - - let produce_batches state ~only_full = - let open Lwt_result_syntax in - let batches, to_remove = get_batches state ~only_full in - match batches with - | [] -> return_unit - | _ -> - let* () = inject_batches state batches in - let*! () = - Batcher_events.(emit batched) - (List.length batches, List.length to_remove) - in - List.iter - (fun tr_hash -> Message_queue.remove state.messages tr_hash) - to_remove ; - return_unit - - let on_batch state = produce_batches state ~only_full:false - - let simulate node_ctxt simulation_ctxt (messages : L2_message.t list) = - let open Lwt_result_syntax in - let ext_messages = - List.map - (fun m -> Sc_rollup.Inbox_message.External (L2_message.content m)) - messages - in - let+ simulation_ctxt, _ticks = - Simulation.simulate_messages node_ctxt simulation_ctxt ext_messages - in - simulation_ctxt + type launch_error = error trace - let on_register state (messages : string list) = + let on_launch _w () Types.{node_ctxt; signer; conf} = let open Lwt_result_syntax in - let max_size_msg = - min - (Protocol.Constants_repr.sc_rollup_message_size_limit - + 4 (* We add 4 because [message_size] adds 4. *)) - state.conf.max_batch_size - in - let*? messages = - List.mapi_e - (fun i message -> - if message_size message > max_size_msg then - error_with "Message %d is too large (max size is %d)" i max_size_msg - else Ok (L2_message.make message)) - messages - in - let* () = - if not state.conf.simulate then return_unit - else - match state.simulation_ctxt with - | None -> failwith "Simulation context of batcher not initialized" - | Some simulation_ctxt -> - let+ simulation_ctxt = - simulate state.node_ctxt simulation_ctxt messages - in - state.simulation_ctxt <- Some simulation_ctxt - in - let*! () = Batcher_events.(emit queue) (List.length messages) in - let hashes = - List.map - (fun message -> - let msg_hash = L2_message.hash message in - Message_queue.replace state.messages msg_hash message ; - msg_hash) - messages - in - let+ () = produce_batches state ~only_full:true in - hashes + let*! state = init_batcher_state node_ctxt ~signer conf in + return state - let on_new_head state head = + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let* simulation_ctxt = - Simulation.start_simulation ~reveal_map:None state.node_ctxt head - in - (* TODO: https://gitlab.com/tezos/tezos/-/issues/4224 - Replay with simulation may be too expensive *) - let+ simulation_ctxt, failing = - if not state.conf.simulate then return (simulation_ctxt, []) - else - (* Re-simulate one by one *) - Message_queue.fold_es - (fun msg_hash msg (simulation_ctxt, failing) -> - let*! result = simulate state.node_ctxt simulation_ctxt [msg] in - match result with - | Ok simulation_ctxt -> return (simulation_ctxt, failing) - | Error _ -> return (simulation_ctxt, msg_hash :: failing)) - state.messages - (simulation_ctxt, []) - in - state.simulation_ctxt <- Some simulation_ctxt ; - (* Forget failing messages *) - List.iter (Message_queue.remove state.messages) failing - - let init_batcher_state node_ctxt ~signer (conf : Configuration.batcher) = - let open Lwt_syntax in - let conf = - { - simulate = conf.simulate; - min_batch_elements = conf.min_batch_elements; - min_batch_size = conf.min_batch_size; - max_batch_elements = conf.max_batch_elements; - max_batch_size = - Option.value - conf.max_batch_size - ~default:Node_context.protocol_max_batch_size; - } - in - return - { - node_ctxt; - signer; - conf; - messages = Message_queue.create 100_000 (* ~ 400MB *); - batched = Batched_messages.create 100_000 (* ~ 400MB *); - simulation_ctxt = None; - } - - module Types = struct - type nonrec state = state - - type parameters = { - node_ctxt : Node_context.ro; - signer : Tezos_crypto.Signature.public_key_hash; - conf : Configuration.batcher; - } - end - - module Name = struct - (* We only have a single batcher in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Batcher_events.Worker.section - @ [ - ("worker" - ^ if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Register messages -> - protect @@ fun () -> on_register state messages - | Request.Batch -> protect @@ fun () -> on_batch state - | Request.New_head head -> protect @@ fun () -> on_new_head state head - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt; signer; conf} = - let open Lwt_result_syntax in - let*! state = init_batcher_state node_ctxt ~signer conf in - return state - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Batcher_events.(emit Worker.request_failed) (request_view, st, errs) - in - return_unit + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Batcher_events.(emit Worker.request_failed) (request_view, st, errs) in - match r with - | Request.Register _ -> emit_and_return_errors errs - | Request.Batch -> emit_and_return_errors errs - | Request.New_head _ -> emit_and_return_errors errs - - let on_completion _w r _ st = - match Request.view r with - | Request.View (Register _ | New_head _) -> - Batcher_events.(emit Worker.request_completed_debug) - (Request.view r, st) - | View Batch -> - Batcher_events.(emit Worker.request_completed_notice) - (Request.view r, st) - - let on_no_request _ = Lwt.return_unit - - let on_close _w = Lwt.return_unit - end - - let table = Worker.create_table Queue - - let worker_promise, worker_waker = Lwt.task () - - let init conf ~signer node_ctxt = - let open Lwt_result_syntax in - let node_ctxt = Node_context.readonly node_ctxt in - let+ worker = - Worker.launch table () {node_ctxt; signer; conf} (module Handlers) + return_unit in - Lwt.wakeup worker_waker worker - - (* This is a batcher worker for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_batcher) - - let active () = - match Lwt.state worker_promise with - | Lwt.Return _ -> true - | Lwt.Fail _ | Lwt.Sleep -> false - - let find_message hash = - let open Result_syntax in - let+ w = Lazy.force worker in - let state = Worker.state w in - Message_queue.find_opt state.messages hash - - let get_queue () = - let open Result_syntax in - let+ w = Lazy.force worker in - let state = Worker.state w in - Message_queue.bindings state.messages - - let handle_request_error rq = - let open Lwt_syntax in - let* rq in - match rq with - | Ok res -> return_ok res - | Error (Worker.Request_error errs) -> Lwt.return_error errs - | Error (Closed None) -> Lwt.return_error [Worker_types.Terminated] - | Error (Closed (Some errs)) -> Lwt.return_error errs - | Error (Any exn) -> Lwt.return_error [Exn exn] - - let register_messages messages = - let open Lwt_result_syntax in - let*? w = Lazy.force worker in - Worker.Queue.push_request_and_wait w (Request.Register messages) - |> handle_request_error - - let batch () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no batcher, nothing to do *) - return_unit - | Ok w -> - Worker.Queue.push_request_and_wait w Request.Batch - |> handle_request_error - - let new_head b = - let open Lwt_result_syntax in - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no batcher, nothing to do *) - return_unit - | Ok w -> - let*! (_pushed : bool) = - Worker.Queue.push_request w (Request.New_head b) - in - return_unit - - let shutdown () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no batcher, nothing to do *) - Lwt.return_unit - | Ok w -> Worker.shutdown w - - let message_status state msg_hash = - match Message_queue.find_opt state.messages msg_hash with - | Some msg -> Some (Pending_batch, L2_message.content msg) - | None -> ( - match Batched_messages.find_opt state.batched msg_hash with - | Some {content; l1_hash} -> Some (Batched l1_hash, content) - | None -> None) - - let message_status msg_hash = - let open Result_syntax in - let+ w = Lazy.force worker in - let state = Worker.state w in - message_status state msg_hash + match r with + | Request.Register _ -> emit_and_return_errors errs + | Request.Batch -> emit_and_return_errors errs + | Request.New_head _ -> emit_and_return_errors errs + + let on_completion _w r _ st = + match Request.view r with + | Request.View (Register _ | New_head _) -> + Batcher_events.(emit Worker.request_completed_debug) (Request.view r, st) + | View Batch -> + Batcher_events.(emit Worker.request_completed_notice) + (Request.view r, st) + + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit end + +let table = Worker.create_table Queue + +let worker_promise, worker_waker = Lwt.task () + +let init conf ~signer node_ctxt = + let open Lwt_result_syntax in + let node_ctxt = Node_context.readonly node_ctxt in + let+ worker = + Worker.launch table () {node_ctxt; signer; conf} (module Handlers) + in + Lwt.wakeup worker_waker worker + +(* This is a batcher worker for a single scoru *) +let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_batcher) + +let active () = + match Lwt.state worker_promise with + | Lwt.Return _ -> true + | Lwt.Fail _ | Lwt.Sleep -> false + +let find_message hash = + let open Result_syntax in + let+ w = Lazy.force worker in + let state = Worker.state w in + Message_queue.find_opt state.messages hash + +let get_queue () = + let open Result_syntax in + let+ w = Lazy.force worker in + let state = Worker.state w in + Message_queue.bindings state.messages + +let handle_request_error rq = + let open Lwt_syntax in + let* rq in + match rq with + | Ok res -> return_ok res + | Error (Worker.Request_error errs) -> Lwt.return_error errs + | Error (Closed None) -> Lwt.return_error [Worker_types.Terminated] + | Error (Closed (Some errs)) -> Lwt.return_error errs + | Error (Any exn) -> Lwt.return_error [Exn exn] + +let register_messages messages = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + Worker.Queue.push_request_and_wait w (Request.Register messages) + |> handle_request_error + +let batch () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no batcher, nothing to do *) + return_unit + | Ok w -> + Worker.Queue.push_request_and_wait w Request.Batch |> handle_request_error + +let new_head b = + let open Lwt_result_syntax in + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no batcher, nothing to do *) + return_unit + | Ok w -> + let*! (_pushed : bool) = + Worker.Queue.push_request w (Request.New_head b) + in + return_unit + +let shutdown () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no batcher, nothing to do *) + Lwt.return_unit + | Ok w -> Worker.shutdown w + +let message_status state msg_hash = + match Message_queue.find_opt state.messages msg_hash with + | Some msg -> Some (Pending_batch, L2_message.content msg) + | None -> ( + match Batched_messages.find_opt state.batched msg_hash with + | Some {content; l1_hash} -> Some (Batched l1_hash, content) + | None -> None) + +let message_status msg_hash = + let open Result_syntax in + let+ w = Lazy.force worker in + let state = Worker.state w in + message_status state msg_hash diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/batcher.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/batcher.mli index a6618f27bdc9..f4e9e223a647 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/batcher.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/batcher.mli @@ -26,55 +26,51 @@ open Protocol open Alpha_context -module type S = sig - (** The type for the status of messages in the batcher. *) - type status = - | Pending_batch (** The message is in the queue of the batcher. *) - | Batched of Injector.Inj_operation.hash - (** The message has already been batched and sent to the injector in an - L1 operation whose hash is given. *) +(** The type for the status of messages in the batcher. *) +type status = + | Pending_batch (** The message is in the queue of the batcher. *) + | Batched of Injector.Inj_operation.hash + (** The message has already been batched and sent to the injector in an L1 + operation whose hash is given. *) - (** [init config ~signer node_ctxt] initializes and starts the batcher for - [signer]. If [config.simulation] is [true] (the default), messages added - to the batcher are simulated in an incremental simulation context. *) - val init : - Configuration.batcher -> - signer:public_key_hash -> - _ Node_context.t -> - unit tzresult Lwt.t +(** [init config ~signer node_ctxt] initializes and starts the batcher for + [signer]. If [config.simulation] is [true] (the default), messages added to + the batcher are simulated in an incremental simulation context. *) +val init : + Configuration.batcher -> + signer:public_key_hash -> + _ Node_context.t -> + unit tzresult Lwt.t - (** Return [true] if the batcher was started for this node. *) - val active : unit -> bool +(** Return [true] if the batcher was started for this node. *) +val active : unit -> bool - (** Retrieve an L2 message from the queue. *) - val find_message : L2_message.hash -> L2_message.t option tzresult +(** Retrieve an L2 message from the queue. *) +val find_message : L2_message.hash -> L2_message.t option tzresult - (** List all queued messages in the order they appear in the queue, i.e. the - message that were added first to the queue are at the end of list. *) - val get_queue : unit -> (L2_message.hash * L2_message.t) list tzresult +(** List all queued messages in the order they appear in the queue, i.e. the + message that were added first to the queue are at the end of list. *) +val get_queue : unit -> (L2_message.hash * L2_message.t) list tzresult - (** [register_messages messages] registers new L2 [messages] in the queue of - the batcher for future injection on L1. If the batcher was initialized - with [simualte = true], the messages are evaluated the batcher's - incremental simulation context. In this case, when the application fails, - the messages are not queued. *) - val register_messages : string list -> L2_message.hash list tzresult Lwt.t +(** [register_messages messages] registers new L2 [messages] in the queue of the + batcher for future injection on L1. If the batcher was initialized with + [simualte = true], the messages are evaluated the batcher's incremental + simulation context. In this case, when the application fails, the messages + are not queued. *) +val register_messages : string list -> L2_message.hash list tzresult Lwt.t - (** Create L2 batches of operations from the queue and pack them in an L1 - batch operation. The batch operation is queued in the injector for - injection on the Tezos node. *) - val batch : unit -> unit tzresult Lwt.t +(** Create L2 batches of operations from the queue and pack them in an L1 batch + operation. The batch operation is queued in the injector for injection on + the Tezos node. *) +val batch : unit -> unit tzresult Lwt.t - (** Notify a new L2 head to the batcher worker. *) - val new_head : Layer1.head -> unit tzresult Lwt.t +(** Notify a new L2 head to the batcher worker. *) +val new_head : Layer1.head -> unit tzresult Lwt.t - (** Shutdown the batcher, waiting for the ongoing request to be processed. *) - val shutdown : unit -> unit Lwt.t +(** Shutdown the batcher, waiting for the ongoing request to be processed. *) +val shutdown : unit -> unit Lwt.t - (** The status of a message in the batcher. Returns [None] if the message is - not known by the batcher (the batcher only keeps the batched status of the - last 500000 messages). *) - val message_status : L2_message.hash -> (status * string) option tzresult -end - -module Make (Simulation : Simulation.S) : S +(** The status of a message in the batcher. Returns [None] if the message is not + known by the batcher (the batcher only keeps the batched status of the last + 500000 messages). *) +val message_status : L2_message.hash -> (status * string) option tzresult diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/commitment.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/commitment.ml deleted file mode 100644 index d82c08e76da2..000000000000 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/commitment.ml +++ /dev/null @@ -1,548 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 TriliTech *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -(** The rollup node stores and publishes commitments for the PVM every - [Constants.sc_rollup_commitment_period_in_blocks] levels. - - Every time a finalized block is processed by the rollup node, the latter - determines whether the last commitment that the node has produced referred - to [sc_rollup.commitment_period_in_blocks] blocks earlier. For mainnet, - [sc_rollup.commitment_period_in_blocks = 30]. In this case, it computes and - stores a new commitment in a level-indexed map. - - Stored commitments are signed by the rollup node operator - and published on the layer1 chain. To ensure that commitments - produced by the rollup node are eventually published, - storing and publishing commitments are decoupled. Every time - a new head is processed, the node tries to publish the oldest - commitment that was not published already. -*) - -open Protocol -open Alpha_context -open Publisher_worker_types - -module Lwt_result_option_syntax = struct - let ( let** ) a f = - let open Lwt_result_syntax in - let* a in - match a with None -> return_none | Some a -> f a -end - -module Lwt_result_option_list_syntax = struct - (** A small monadic combinator to return an empty list on None results. *) - let ( let*& ) x f = - let open Lwt_result_syntax in - let* x in - match x with None -> return_nil | Some x -> f x -end - -let add_level level increment = - (* We only use this function with positive increments so it is safe *) - if increment < 0 then invalid_arg "Commitment.add_level negative increment" ; - Raw_level.Internal_for_tests.add level increment - -let sub_level level decrement = - (* We only use this function with positive increments so it is safe *) - if decrement < 0 then invalid_arg "Commitment.sub_level negative decrement" ; - Raw_level.Internal_for_tests.sub level decrement - -let sc_rollup_commitment_period node_ctxt = - node_ctxt.Node_context.protocol_constants.parametric.sc_rollup - .commitment_period_in_blocks - -let sc_rollup_challenge_window node_ctxt = - node_ctxt.Node_context.protocol_constants.parametric.sc_rollup - .challenge_window_in_blocks - -let next_commitment_level node_ctxt last_commitment_level = - add_level last_commitment_level (sc_rollup_commitment_period node_ctxt) - -(* Count instances of the commitment functor to allow for multiple worker events - without conflicts. *) -let instances_count = ref 0 - -module Make (PVM : Pvm.S) : Commitment_sig.S with module PVM = PVM = struct - let () = incr instances_count - - module PVM = PVM - - type state = Node_context.ro - - let tick_of_level (node_ctxt : _ Node_context.t) inbox_level = - let open Lwt_result_syntax in - let* block = - Node_context.get_l2_block_by_level - node_ctxt - (Raw_level.to_int32 inbox_level) - in - return (Sc_rollup_block.final_tick block) - - let build_commitment (node_ctxt : _ Node_context.t) - (prev_commitment : Sc_rollup.Commitment.Hash.t) ~prev_commitment_level - ~inbox_level ctxt = - let open Lwt_result_syntax in - let*! pvm_state = PVM.State.find ctxt in - let*? pvm_state = - match pvm_state with - | Some pvm_state -> Ok pvm_state - | None -> - error_with - "PVM state for commitment at level %a is not available" - Raw_level.pp - inbox_level - in - let*! compressed_state = PVM.state_hash pvm_state in - let*! tick = PVM.get_tick pvm_state in - let* prev_commitment_tick = tick_of_level node_ctxt prev_commitment_level in - let number_of_ticks = - Sc_rollup.Tick.distance tick prev_commitment_tick - |> Z.to_int64 |> Sc_rollup.Number_of_ticks.of_value - in - let*? number_of_ticks = - match number_of_ticks with - | Some number_of_ticks -> - if number_of_ticks = Sc_rollup.Number_of_ticks.zero then - error_with "A 0-tick commitment is impossible" - else Ok number_of_ticks - | None -> error_with "Invalid number of ticks for commitment" - in - return - Sc_rollup.Commitment. - { - predecessor = prev_commitment; - inbox_level; - number_of_ticks; - compressed_state; - } - - let genesis_commitment (node_ctxt : _ Node_context.t) ctxt = - let open Lwt_result_syntax in - let*! pvm_state = PVM.State.find ctxt in - let*? pvm_state = - match pvm_state with - | Some pvm_state -> Ok pvm_state - | None -> error_with "PVM state for genesis commitment is not available" - in - let*! compressed_state = PVM.state_hash pvm_state in - let commitment = - Sc_rollup.Commitment. - { - predecessor = Hash.zero; - inbox_level = node_ctxt.genesis_info.level; - number_of_ticks = Sc_rollup.Number_of_ticks.zero; - compressed_state; - } - in - (* Ensure the initial state corresponds to the one of the rollup's in the - protocol. A mismatch is possible if a wrong external boot sector was - provided. *) - let commitment_hash = Sc_rollup.Commitment.hash_uncarbonated commitment in - let+ () = - fail_unless - Sc_rollup.Commitment.Hash.( - commitment_hash = node_ctxt.genesis_info.commitment_hash) - (Sc_rollup_node_errors.Invalid_genesis_state - { - expected = node_ctxt.genesis_info.commitment_hash; - actual = commitment_hash; - }) - in - commitment - - let create_commitment_if_necessary (node_ctxt : _ Node_context.t) ~predecessor - current_level ctxt = - let open Lwt_result_syntax in - if Raw_level.(current_level = node_ctxt.genesis_info.level) then - let*! () = Commitment_event.compute_commitment current_level in - let+ genesis_commitment = genesis_commitment node_ctxt ctxt in - Some genesis_commitment - else - let* last_commitment_hash = - let+ pred = Node_context.get_l2_block node_ctxt predecessor in - Sc_rollup_block.most_recent_commitment pred.header - in - let* last_commitment = - Node_context.get_commitment node_ctxt last_commitment_hash - in - let next_commitment_level = - next_commitment_level node_ctxt last_commitment.inbox_level - in - if Raw_level.(current_level = next_commitment_level) then - let*! () = Commitment_event.compute_commitment current_level in - let+ commitment = - build_commitment - node_ctxt - last_commitment_hash - ~prev_commitment_level:last_commitment.inbox_level - ~inbox_level:current_level - ctxt - in - Some commitment - else return_none - - let process_head (node_ctxt : _ Node_context.t) ~predecessor - Layer1.{level; header = _; _} ctxt = - let open Lwt_result_syntax in - let current_level = Raw_level.of_int32_exn level in - let* commitment = - create_commitment_if_necessary node_ctxt ~predecessor current_level ctxt - in - match commitment with - | None -> return_none - | Some commitment -> - let* commitment_hash = - Node_context.save_commitment node_ctxt commitment - in - return_some commitment_hash - - let missing_commitments (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - let lpc_level = - match Reference.get node_ctxt.lpc with - | None -> node_ctxt.genesis_info.level - | Some lpc -> lpc.inbox_level - in - let* head = Node_context.last_processed_head_opt node_ctxt in - let next_head_level = - Option.map - (fun (b : Sc_rollup_block.t) -> Raw_level.succ b.header.level) - head - in - let sc_rollup_challenge_window_int32 = - sc_rollup_challenge_window node_ctxt |> Int32.of_int - in - let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = - let* commitment = - Node_context.find_commitment node_ctxt commitment_hash - in - let lcc = Reference.get node_ctxt.lcc in - match commitment with - | None -> return acc - | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> - (* Commitment is before or at the LCC, we have reached the end. *) - return acc - | Some commitment when Raw_level.(commitment.inbox_level <= lpc_level) -> - (* Commitment is before the last published one, we have also reached - the end because we only publish commitments that are for the inbox - of a finalized L1 block. *) - return acc - | Some commitment -> - let* published_info = - Node_context.commitment_published_at_level node_ctxt commitment_hash - in - let past_curfew = - match (published_info, next_head_level) with - | None, _ | _, None -> false - | Some {first_published_at_level; _}, Some next_head_level -> - Raw_level.diff next_head_level first_published_at_level - > sc_rollup_challenge_window_int32 - in - let acc = if past_curfew then acc else commitment :: acc in - (* We keep the commitment and go back to the previous one. *) - gather acc commitment.predecessor - in - let* finalized_block = Node_context.get_finalized_head_opt node_ctxt in - match finalized_block with - | None -> return_nil - | Some finalized -> - (* Start from finalized block's most recent commitment and gather all - commitments that are missing. *) - let commitment = - Sc_rollup_block.most_recent_commitment finalized.header - in - gather [] commitment - - let publish_commitment (node_ctxt : _ Node_context.t) ~source - (commitment : Sc_rollup.Commitment.t) = - let open Lwt_result_syntax in - let publish_operation = - L1_operation.Publish {rollup = node_ctxt.rollup_address; commitment} - in - let*! () = - Commitment_event.publish_commitment - (Sc_rollup.Commitment.hash_uncarbonated commitment) - commitment.inbox_level - in - let* _hash = Injector.add_pending_operation ~source publish_operation in - return_unit - - let on_publish_commitments (node_ctxt : state) = - let open Lwt_result_syntax in - let operator = Node_context.get_operator node_ctxt Publish in - if Node_context.is_accuser node_ctxt then - (* Accuser does not publish all commitments *) - return_unit - else - match operator with - | None -> - (* Configured to not publish commitments *) - return_unit - | Some source -> - let* commitments = missing_commitments node_ctxt in - List.iter_es (publish_commitment node_ctxt ~source) commitments - - let publish_single_commitment node_ctxt (commitment : Sc_rollup.Commitment.t) - = - let open Lwt_result_syntax in - let operator = Node_context.get_operator node_ctxt Publish in - let lcc = Reference.get node_ctxt.lcc in - match operator with - | None -> - (* Configured to not publish commitments *) - return_unit - | Some source -> - when_ (commitment.inbox_level > lcc.level) @@ fun () -> - publish_commitment node_ctxt ~source commitment - - (* Commitments can only be cemented after [sc_rollup_challenge_window] has - passed since they were first published. *) - let earliest_cementing_level node_ctxt commitment_hash = - let open Lwt_result_option_syntax in - let** {first_published_at_level; _} = - Node_context.commitment_published_at_level node_ctxt commitment_hash - in - return_some - @@ add_level first_published_at_level (sc_rollup_challenge_window node_ctxt) - - (** [latest_cementable_commitment node_ctxt head] is the most recent commitment - hash that could be cemented in [head]'s successor if: - - - all its predecessors were cemented - - it would have been first published at the same level as its inbox - - It does not need to be exact but it must be an upper bound on which we can - start the search for cementable commitments. *) - let latest_cementable_commitment (node_ctxt : _ Node_context.t) - (head : Sc_rollup_block.t) = - let open Lwt_result_option_syntax in - let commitment_hash = Sc_rollup_block.most_recent_commitment head.header in - let** commitment = Node_context.find_commitment node_ctxt commitment_hash in - let** cementable_level_bound = - return - @@ sub_level commitment.inbox_level (sc_rollup_challenge_window node_ctxt) - in - let lcc = Reference.get node_ctxt.lcc in - if Raw_level.(cementable_level_bound <= lcc.level) then return_none - else - let** cementable_bound_block = - Node_context.find_l2_block_by_level - node_ctxt - (Raw_level.to_int32 cementable_level_bound) - in - let cementable_commitment = - Sc_rollup_block.most_recent_commitment cementable_bound_block.header - in - return_some cementable_commitment - - let cementable_commitments (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - let open Lwt_result_option_list_syntax in - let*& head = Node_context.last_processed_head_opt node_ctxt in - let head_level = head.header.level in - let lcc = Reference.get node_ctxt.lcc in - let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = - let* commitment = - Node_context.find_commitment node_ctxt commitment_hash - in - match commitment with - | None -> return acc - | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> - (* If we have moved backward passed or at the current LCC then we have - reached the end. *) - return acc - | Some commitment -> - let* earliest_cementing_level = - earliest_cementing_level node_ctxt commitment_hash - in - let acc = - match earliest_cementing_level with - | None -> acc - | Some earliest_cementing_level -> - if Raw_level.(earliest_cementing_level > head_level) then - (* Commitments whose cementing level are after the head's - successor won't be cementable in the next block. *) - acc - else commitment_hash :: acc - in - gather acc commitment.predecessor - in - (* We start our search from the last possible cementable commitment. This is - to avoid iterating over a large number of commitments - ([challenge_window_in_blocks / commitment_period_in_blocks], in the order - of 10^3 on mainnet). *) - let*& latest_cementable_commitment = - latest_cementable_commitment node_ctxt head - in - let* cementable = gather [] latest_cementable_commitment in - match cementable with - | [] -> return_nil - | first_cementable :: _ -> - (* Make sure that the first commitment can be cemented according to the - Layer 1 node as a failsafe. *) - let* green_light = - Plugin.RPC.Sc_rollup.can_be_cemented - node_ctxt.cctxt - (node_ctxt.cctxt#chain, `Head 0) - node_ctxt.rollup_address - first_cementable - in - if green_light then return cementable else return_nil - - let cement_commitment (node_ctxt : _ Node_context.t) ~source commitment_hash = - let open Lwt_result_syntax in - let cement_operation = - L1_operation.Cement - {rollup = node_ctxt.rollup_address; commitment = commitment_hash} - in - let* _hash = Injector.add_pending_operation ~source cement_operation in - return_unit - - let on_cement_commitments (node_ctxt : state) = - let open Lwt_result_syntax in - let operator = Node_context.get_operator node_ctxt Cement in - match operator with - | None -> - (* Configured to not cement commitments *) - return_unit - | Some source -> - let* cementable_commitments = cementable_commitments node_ctxt in - List.iter_es - (cement_commitment node_ctxt ~source) - cementable_commitments - - module Publisher = struct - module Types = struct - type nonrec state = state - - type parameters = {node_ctxt : Node_context.ro} - end - - module Name = struct - (* We only have a single committer in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Commitment_event.section - @ [ - ("publisher" - ^ - if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Publish -> protect @@ fun () -> on_publish_commitments state - | Request.Cement -> protect @@ fun () -> on_cement_commitments state - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt} = return node_ctxt - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Commitment_event.Publisher.request_failed request_view st errs - in - return_unit - in - match r with - | Request.Publish -> emit_and_return_errors errs - | Request.Cement -> emit_and_return_errors errs - - let on_completion _w r _ st = - Commitment_event.Publisher.request_completed (Request.view r) st - - let on_no_request _ = Lwt.return_unit - - let on_close _w = Lwt.return_unit - end - - let table = Worker.create_table Queue - - let worker_promise, worker_waker = Lwt.task () - - let init node_ctxt = - let open Lwt_result_syntax in - let*! () = Commitment_event.starting () in - let node_ctxt = Node_context.readonly node_ctxt in - let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in - Lwt.wakeup worker_waker worker - - (* This is a publisher worker for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_publisher) - - let publish_commitments () = - let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w Request.Publish in - return_unit - - let cement_commitments () = - let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w Request.Cement in - return_unit - - let shutdown () = - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no publisher, nothing to do *) - Lwt.return_unit - | Ok w -> Worker.shutdown w - end -end diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/commitment_sig.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/commitment_sig.ml index fccdc19b1854..af79ffb90c90 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/commitment_sig.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/commitment_sig.ml @@ -63,21 +63,20 @@ module type S = sig Protocol.Alpha_context.Sc_rollup.Commitment.t -> unit tzresult Lwt.t - (** Worker for publishing and cementing commitments. *) - module Publisher : sig - val init : _ Node_context.t -> unit tzresult Lwt.t + (** Initialize worker for publishing and cementing commitments. *) + val init : _ Node_context.t -> unit tzresult Lwt.t - (** [publish_commitments node_ctxt] publishes the commitments that were not + (** [publish_commitments node_ctxt] publishes the commitments that were not yet published up to the finalized head and which are after the last cemented commitment. *) - val publish_commitments : unit -> unit tzresult Lwt.t + val publish_commitments : unit -> unit tzresult Lwt.t - (** [cement_commitments node_ctxt] cements the commitments that can be + (** [cement_commitments node_ctxt] cements the commitments that can be cemented, i.e. the commitments that are after the current last cemented commitment and which have [sc_rollup_challenge_period] levels on top of them since they were originally published. *) - val cement_commitments : unit -> unit tzresult Lwt.t + val cement_commitments : unit -> unit tzresult Lwt.t - val shutdown : unit -> unit Lwt.t - end + (** Stop worker for publishing and cementing commitments. *) + val shutdown : unit -> unit Lwt.t end diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/daemon.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/daemon.ml index c4c572178cc2..b321330df625 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/daemon.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/daemon.ml @@ -25,590 +25,305 @@ (* *) (*****************************************************************************) -module Make (PVM : Pvm.S) = struct - module Components = Components.Make (PVM) - open Protocol - open Alpha_context - open Apply_results +open Protocol +open Alpha_context +open Apply_results - (** Returns [Some c] if [their_commitment] is refutable where [c] is our - commitment for the same inbox level. *) - let is_refutable_commitment node_ctxt - (their_commitment : Sc_rollup.Commitment.t) their_commitment_hash = - let open Lwt_result_syntax in - let* l2_block = - Node_context.get_l2_block_by_level - node_ctxt - (Raw_level.to_int32 their_commitment.inbox_level) - in - let* our_commitment_and_hash = - Option.filter_map_es - (fun hash -> - let+ commitment = Node_context.find_commitment node_ctxt hash in - Option.map (fun c -> (c, hash)) commitment) - l2_block.header.commitment_hash - in - match our_commitment_and_hash with - | Some (our_commitment, our_commitment_hash) - when Sc_rollup.Commitment.Hash.( - their_commitment_hash <> our_commitment_hash - && their_commitment.predecessor = our_commitment.predecessor) -> - return our_commitment_and_hash - | _ -> return_none +(** Returns [Some c] if [their_commitment] is refutable where [c] is our + commitment for the same inbox level. *) +let is_refutable_commitment node_ctxt + (their_commitment : Sc_rollup.Commitment.t) their_commitment_hash = + let open Lwt_result_syntax in + let* l2_block = + Node_context.get_l2_block_by_level + node_ctxt + (Raw_level.to_int32 their_commitment.inbox_level) + in + let* our_commitment_and_hash = + Option.filter_map_es + (fun hash -> + let+ commitment = Node_context.find_commitment node_ctxt hash in + Option.map (fun c -> (c, hash)) commitment) + l2_block.header.commitment_hash + in + match our_commitment_and_hash with + | Some (our_commitment, our_commitment_hash) + when Sc_rollup.Commitment.Hash.( + their_commitment_hash <> our_commitment_hash + && their_commitment.predecessor = our_commitment.predecessor) -> + return our_commitment_and_hash + | _ -> return_none - (** Publish a commitment when an accuser node sees a refutable commitment. *) - let accuser_publish_commitment_when_refutable node_ctxt ~other rollup - their_commitment their_commitment_hash = - let open Lwt_result_syntax in - when_ (Node_context.is_accuser node_ctxt) @@ fun () -> - (* We are seeing a commitment from someone else. We check if we agree - with it, otherwise the accuser publishes our commitment in order to - play the refutation game. *) - let* refutable = - is_refutable_commitment node_ctxt their_commitment their_commitment_hash - in - match refutable with - | None -> return_unit - | Some (our_commitment, our_commitment_hash) -> - let*! () = - Refutation_game_event.potential_conflict_detected - ~our_commitment_hash - ~their_commitment_hash - ~level:their_commitment.inbox_level - ~other - in - assert (Sc_rollup.Address.(node_ctxt.rollup_address = rollup)) ; - Components.Commitment.publish_single_commitment node_ctxt our_commitment +(** Publish a commitment when an accuser node sees a refutable commitment. *) +let accuser_publish_commitment_when_refutable node_ctxt ~other rollup + their_commitment their_commitment_hash = + let open Lwt_result_syntax in + when_ (Node_context.is_accuser node_ctxt) @@ fun () -> + (* We are seeing a commitment from someone else. We check if we agree + with it, otherwise the accuser publishes our commitment in order to + play the refutation game. *) + let* refutable = + is_refutable_commitment node_ctxt their_commitment their_commitment_hash + in + match refutable with + | None -> return_unit + | Some (our_commitment, our_commitment_hash) -> + let*! () = + Refutation_game_event.potential_conflict_detected + ~our_commitment_hash + ~their_commitment_hash + ~level:their_commitment.inbox_level + ~other + in + assert (Sc_rollup.Address.(node_ctxt.rollup_address = rollup)) ; + Publisher.publish_single_commitment node_ctxt our_commitment - (** Process an L1 SCORU operation (for the node's rollup) which is included - for the first time. {b Note}: this function does not process inboxes for - the rollup, which is done instead by {!Inbox.process_head}. *) - let process_included_l1_operation (type kind) (node_ctxt : Node_context.rw) - (head : Layer1.header) ~source (operation : kind manager_operation) - (result : kind successful_manager_operation_result) = - let open Lwt_result_syntax in - match (operation, result) with - | ( Sc_rollup_publish {commitment; _}, - Sc_rollup_publish_result {published_at_level; _} ) - when Node_context.is_operator node_ctxt source -> - (* Published commitment --------------------------------------------- *) - let save_lpc = - match Reference.get node_ctxt.lpc with - | None -> true - | Some lpc -> Raw_level.(commitment.inbox_level >= lpc.inbox_level) - in - if save_lpc then Reference.set node_ctxt.lpc (Some commitment) ; - let commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated commitment - in - let* () = - Node_context.set_commitment_published_at_level - node_ctxt - commitment_hash - { - first_published_at_level = published_at_level; - published_at_level = - Some (Raw_level.of_int32_exn head.Layer1.level); - } - in - let*! () = - Commitment_event.last_published_commitment_updated - commitment_hash - (Raw_level.of_int32_exn head.Layer1.level) - in - return_unit - | ( Sc_rollup_publish {commitment = their_commitment; rollup}, - Sc_rollup_publish_result - {published_at_level; staked_hash = their_commitment_hash; _} ) -> - (* Commitment published by someone else *) - (* We first register the publication information *) - let* known_commitment = - Node_context.commitment_exists node_ctxt their_commitment_hash - in - let* () = - if not known_commitment then return_unit +(** Process an L1 SCORU operation (for the node's rollup) which is included for + the first time. {b Note}: this function does not process inboxes for the + rollup, which is done instead by {!Inbox.process_head}. *) +let process_included_l1_operation (type kind) (node_ctxt : Node_context.rw) + (head : Layer1.header) ~source (operation : kind manager_operation) + (result : kind successful_manager_operation_result) = + let open Lwt_result_syntax in + match (operation, result) with + | ( Sc_rollup_publish {commitment; _}, + Sc_rollup_publish_result {published_at_level; _} ) + when Node_context.is_operator node_ctxt source -> + (* Published commitment --------------------------------------------- *) + let save_lpc = + match Reference.get node_ctxt.lpc with + | None -> true + | Some lpc -> Raw_level.(commitment.inbox_level >= lpc.inbox_level) + in + if save_lpc then Reference.set node_ctxt.lpc (Some commitment) ; + let commitment_hash = Sc_rollup.Commitment.hash_uncarbonated commitment in + let* () = + Node_context.set_commitment_published_at_level + node_ctxt + commitment_hash + { + first_published_at_level = published_at_level; + published_at_level = Some (Raw_level.of_int32_exn head.Layer1.level); + } + in + let*! () = + Commitment_event.last_published_commitment_updated + commitment_hash + (Raw_level.of_int32_exn head.Layer1.level) + in + return_unit + | ( Sc_rollup_publish {commitment = their_commitment; rollup}, + Sc_rollup_publish_result + {published_at_level; staked_hash = their_commitment_hash; _} ) -> + (* Commitment published by someone else *) + (* We first register the publication information *) + let* known_commitment = + Node_context.commitment_exists node_ctxt their_commitment_hash + in + let* () = + if not known_commitment then return_unit + else + let* republication = + Node_context.commitment_was_published + node_ctxt + ~source:Anyone + their_commitment_hash + in + if republication then return_unit else - let* republication = - Node_context.commitment_was_published + let* () = + Node_context.set_commitment_published_at_level node_ctxt - ~source:Anyone their_commitment_hash + { + first_published_at_level = published_at_level; + published_at_level = None; + } in - if republication then return_unit - else - let* () = - Node_context.set_commitment_published_at_level - node_ctxt - their_commitment_hash - { - first_published_at_level = published_at_level; - published_at_level = None; - } - in - return_unit - in - (* An accuser node will publish its commitment if the other one is - refutable. *) - accuser_publish_commitment_when_refutable - node_ctxt - ~other:source - rollup - their_commitment - their_commitment_hash - | Sc_rollup_cement {commitment; _}, Sc_rollup_cement_result {inbox_level; _} - -> - (* Cemented commitment ---------------------------------------------- *) - let* inbox_block = - Node_context.get_l2_block_by_level - node_ctxt - (Raw_level.to_int32 inbox_level) - in - let*? () = - (* We stop the node if we disagree with a cemented commitment *) - error_unless - (Option.equal - Sc_rollup.Commitment.Hash.( = ) - inbox_block.header.commitment_hash - (Some commitment)) - (Sc_rollup_node_errors.Disagree_with_cemented - { - inbox_level; - ours = inbox_block.header.commitment_hash; - on_l1 = commitment; - }) - in - let lcc = Reference.get node_ctxt.lcc in - let*! () = - if Raw_level.(inbox_level > lcc.level) then ( - Reference.set node_ctxt.lcc {commitment; level = inbox_level} ; - Commitment_event.last_cemented_commitment_updated - commitment - inbox_level) - else Lwt.return_unit - in - return_unit - | ( Sc_rollup_refute _, - Sc_rollup_refute_result {game_status = Ended end_status; _} ) - | ( Sc_rollup_timeout _, - Sc_rollup_timeout_result {game_status = Ended end_status; _} ) -> ( - match end_status with - | Loser {loser; _} when Node_context.is_operator node_ctxt loser -> - tzfail (Sc_rollup_node_errors.Lost_game end_status) - | Loser _ -> - (* Other player lost *) return_unit - | Draw -> - let stakers = - match operation with - | Sc_rollup_refute {opponent; _} -> [source; opponent] - | Sc_rollup_timeout {stakers = {alice; bob}; _} -> [alice; bob] - | _ -> assert false - in - fail_when - (List.exists (Node_context.is_operator node_ctxt) stakers) - (Sc_rollup_node_errors.Lost_game end_status)) - | Dal_publish_slot_header slot_header, Dal_publish_slot_header_result _ - when Node_context.dal_supported node_ctxt -> - let* () = - Node_context.save_slot_header - node_ctxt - ~published_in_block_hash:head.Layer1.hash - slot_header.header - in - return_unit - | _, _ -> - (* Other manager operations *) - return_unit - - let process_l1_operation (type kind) node_ctxt (head : Layer1.header) ~source - (operation : kind manager_operation) - (result : kind Apply_results.manager_operation_result) = - let open Lwt_result_syntax in - let is_for_my_rollup : type kind. kind manager_operation -> bool = function - | Sc_rollup_add_messages _ -> true - | Sc_rollup_cement {rollup; _} - | Sc_rollup_publish {rollup; _} - | Sc_rollup_refute {rollup; _} - | Sc_rollup_timeout {rollup; _} - | Sc_rollup_execute_outbox_message {rollup; _} - | Sc_rollup_recover_bond {sc_rollup = rollup; staker = _} -> - Sc_rollup.Address.(rollup = node_ctxt.Node_context.rollup_address) - | Dal_publish_slot_header _ -> true - | Reveal _ | Transaction _ | Origination _ | Delegation _ - | Update_consensus_key _ | Register_global_constant _ - | Set_deposits_limit _ | Increase_paid_storage _ | Tx_rollup_origination - | Tx_rollup_submit_batch _ | Tx_rollup_commit _ | Tx_rollup_return_bond _ - | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ - | Tx_rollup_rejection _ | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ - | Sc_rollup_originate _ | Zk_rollup_origination _ | Zk_rollup_publish _ - | Zk_rollup_update _ -> - false - in - if not (is_for_my_rollup operation) then return_unit - else - (* Only look at operations that are for the node's rollup *) - let*! () = Daemon_event.included_operation operation result in - match result with - | Applied success_result -> - process_included_l1_operation - node_ctxt - head - ~source - operation - success_result - | _ -> - (* No action for non successful operations *) + in + (* An accuser node will publish its commitment if the other one is + refutable. *) + accuser_publish_commitment_when_refutable + node_ctxt + ~other:source + rollup + their_commitment + their_commitment_hash + | Sc_rollup_cement {commitment; _}, Sc_rollup_cement_result {inbox_level; _} + -> + (* Cemented commitment ---------------------------------------------- *) + let* inbox_block = + Node_context.get_l2_block_by_level + node_ctxt + (Raw_level.to_int32 inbox_level) + in + let*? () = + (* We stop the node if we disagree with a cemented commitment *) + error_unless + (Option.equal + Sc_rollup.Commitment.Hash.( = ) + inbox_block.header.commitment_hash + (Some commitment)) + (Sc_rollup_node_errors.Disagree_with_cemented + { + inbox_level; + ours = inbox_block.header.commitment_hash; + on_l1 = commitment; + }) + in + let lcc = Reference.get node_ctxt.lcc in + let*! () = + if Raw_level.(inbox_level > lcc.level) then ( + Reference.set node_ctxt.lcc {commitment; level = inbox_level} ; + Commitment_event.last_cemented_commitment_updated + commitment + inbox_level) + else Lwt.return_unit + in + return_unit + | ( Sc_rollup_refute _, + Sc_rollup_refute_result {game_status = Ended end_status; _} ) + | ( Sc_rollup_timeout _, + Sc_rollup_timeout_result {game_status = Ended end_status; _} ) -> ( + match end_status with + | Loser {loser; _} when Node_context.is_operator node_ctxt loser -> + tzfail (Sc_rollup_node_errors.Lost_game end_status) + | Loser _ -> + (* Other player lost *) return_unit + | Draw -> + let stakers = + match operation with + | Sc_rollup_refute {opponent; _} -> [source; opponent] + | Sc_rollup_timeout {stakers = {alice; bob}; _} -> [alice; bob] + | _ -> assert false + in + fail_when + (List.exists (Node_context.is_operator node_ctxt) stakers) + (Sc_rollup_node_errors.Lost_game end_status)) + | Dal_publish_slot_header slot_header, Dal_publish_slot_header_result _ + when Node_context.dal_supported node_ctxt -> + let* () = + Node_context.save_slot_header + node_ctxt + ~published_in_block_hash:head.Layer1.hash + slot_header.header + in + return_unit + | _, _ -> + (* Other manager operations *) + return_unit - let process_l1_block_operations node_ctxt (head : Layer1.header) = - let open Lwt_result_syntax in - let* block = - Layer1.fetch_tezos_block node_ctxt.Node_context.cctxt head.hash - in - let apply (type kind) accu ~source (operation : kind manager_operation) - result = - let open Lwt_result_syntax in - let* () = accu in - process_l1_operation node_ctxt head ~source operation result - in - let apply_internal (type kind) accu ~source:_ - (_operation : kind Apply_internal_results.internal_operation) - (_result : kind Apply_internal_results.internal_operation_result) = - accu - in - let* () = - Layer1_services.process_manager_operations +let process_l1_operation (type kind) node_ctxt (head : Layer1.header) ~source + (operation : kind manager_operation) + (result : kind Apply_results.manager_operation_result) = + let open Lwt_result_syntax in + let is_for_my_rollup : type kind. kind manager_operation -> bool = function + | Sc_rollup_add_messages _ -> true + | Sc_rollup_cement {rollup; _} + | Sc_rollup_publish {rollup; _} + | Sc_rollup_refute {rollup; _} + | Sc_rollup_timeout {rollup; _} + | Sc_rollup_execute_outbox_message {rollup; _} + | Sc_rollup_recover_bond {sc_rollup = rollup; staker = _} -> + Sc_rollup.Address.(rollup = node_ctxt.Node_context.rollup_address) + | Dal_publish_slot_header _ -> true + | Reveal _ | Transaction _ | Origination _ | Delegation _ + | Update_consensus_key _ | Register_global_constant _ | Set_deposits_limit _ + | Increase_paid_storage _ | Tx_rollup_origination | Tx_rollup_submit_batch _ + | Tx_rollup_commit _ | Tx_rollup_return_bond _ + | Tx_rollup_finalize_commitment _ | Tx_rollup_remove_commitment _ + | Tx_rollup_rejection _ | Tx_rollup_dispatch_tickets _ | Transfer_ticket _ + | Sc_rollup_originate _ | Zk_rollup_origination _ | Zk_rollup_publish _ + | Zk_rollup_update _ -> + false + in + if not (is_for_my_rollup operation) then return_unit + else + (* Only look at operations that are for the node's rollup *) + let*! () = Daemon_event.included_operation operation result in + match result with + | Applied success_result -> + process_included_l1_operation + node_ctxt + head + ~source + operation + success_result + | _ -> + (* No action for non successful operations *) return_unit - block.operations - {apply; apply_internal} - in - return_unit - let before_origination (node_ctxt : _ Node_context.t) (header : Layer1.header) +let process_l1_block_operations node_ctxt (head : Layer1.header) = + let open Lwt_result_syntax in + let* block = + Layer1.fetch_tezos_block node_ctxt.Node_context.cctxt head.hash + in + let apply (type kind) accu ~source (operation : kind manager_operation) result = - let origination_level = Raw_level.to_int32 node_ctxt.genesis_info.level in - header.level < origination_level - - let previous_context (node_ctxt : _ Node_context.t) - ~(predecessor : Layer1.header) = - let open Lwt_result_syntax in - if predecessor.level < Raw_level.to_int32 node_ctxt.genesis_info.level then - (* This is before we have interpreted the boot sector, so we start - with an empty context in genesis *) - return (Context.empty node_ctxt.context) - else Node_context.checkout_context node_ctxt predecessor.Layer1.hash - - let rec process_head (node_ctxt : _ Node_context.t) (head : Layer1.header) = - let open Lwt_result_syntax in - let* already_processed = Node_context.is_processed node_ctxt head.hash in - unless (already_processed || before_origination node_ctxt head) @@ fun () -> - let*! () = Daemon_event.head_processing head.hash head.level in - let* predecessor = Node_context.get_predecessor_header_opt node_ctxt head in - match predecessor with - | None -> - (* Predecessor not available on the L1, which means the block does not - exist in the chain. *) - return_unit - | Some predecessor -> - let* () = process_head node_ctxt predecessor in - let* ctxt = previous_context node_ctxt ~predecessor in - let* () = - Node_context.save_level - node_ctxt - {Layer1.hash = head.hash; level = head.level} - in - let* inbox_hash, inbox, inbox_witness, messages = - Inbox.process_head node_ctxt ~predecessor head - in - let* () = - when_ (Node_context.dal_supported node_ctxt) @@ fun () -> - Dal_slots_tracker.process_head node_ctxt (Layer1.head_of_header head) - in - let* () = process_l1_block_operations node_ctxt head in - (* Avoid storing and publishing commitments if the head is not final. *) - (* Avoid triggering the pvm execution if this has been done before for - this head. *) - let* ctxt, _num_messages, num_ticks, initial_tick = - Components.Interpreter.process_head - node_ctxt - ctxt - ~predecessor - head - (inbox, messages) - in - let*! context_hash = Context.commit ctxt in - let* commitment_hash = - Components.Commitment.process_head - node_ctxt - ~predecessor:predecessor.hash - head - ctxt - in - let level = Raw_level.of_int32_exn head.level in - let* previous_commitment_hash = - if level = node_ctxt.genesis_info.Sc_rollup.Commitment.level then - (* Previous commitment for rollup genesis is itself. *) - return node_ctxt.genesis_info.Sc_rollup.Commitment.commitment_hash - else - let+ pred = Node_context.get_l2_block node_ctxt predecessor.hash in - Sc_rollup_block.most_recent_commitment pred.header - in - let header = - Sc_rollup_block. - { - block_hash = head.hash; - level; - predecessor = predecessor.hash; - commitment_hash; - previous_commitment_hash; - context = context_hash; - inbox_witness; - inbox_hash; - } - in - let l2_block = - Sc_rollup_block.{header; content = (); num_ticks; initial_tick} - in - let* () = - Node_context.mark_finalized_level - node_ctxt - Int32.(sub head.level (of_int node_ctxt.block_finality_time)) - in - let* () = Node_context.save_l2_head node_ctxt l2_block in - let*! () = Daemon_event.new_head_processed head.hash head.level in - return_unit - - (* [on_layer_1_head node_ctxt head] processes a new head from the L1. It - also processes any missing blocks that were not processed. *) - let on_layer_1_head node_ctxt (head : Layer1.header) = - let open Lwt_result_syntax in - let* old_head = Node_context.last_processed_head_opt node_ctxt in - let old_head = - match old_head with - | Some h -> - `Head - Layer1. - { - hash = h.header.block_hash; - level = Raw_level.to_int32 h.header.level; - } - | None -> - (* if no head has been processed yet, we want to handle all blocks - since, and including, the rollup origination. *) - let origination_level = - Raw_level.to_int32 node_ctxt.genesis_info.level - in - `Level (Int32.pred origination_level) - in - let stripped_head = Layer1.head_of_header head in - let*! reorg = - Node_context.get_tezos_reorg_for_new_head node_ctxt old_head stripped_head - in - let*? reorg = - match reorg with - | Error trace - when TzTrace.fold - (fun yes error -> - yes - || - match error with - | Octez_crawler.Layer_1.Cannot_find_predecessor _ -> true - | _ -> false) - false - trace -> - (* The reorganization could not be computed entirely because of missing - info on the Layer 1. We fallback to a recursive process_head. *) - Ok {Reorg.no_reorg with new_chain = [stripped_head]} - | _ -> reorg - in - (* TODO: https://gitlab.com/tezos/tezos/-/issues/3348 - Rollback state information on reorganization, i.e. for - reorg.old_chain. *) - let*! () = Daemon_event.processing_heads_iteration reorg.new_chain in - let get_header Layer1.{hash; level} = - if Block_hash.equal hash head.hash then return head - else - let+ header = Layer1.fetch_tezos_shell_header node_ctxt.cctxt hash in - {Layer1.hash; level; header} - in - let* () = - List.iter_es - (fun block -> - let* header = get_header block in - process_head node_ctxt header) - reorg.new_chain - in - let* () = Components.Commitment.Publisher.publish_commitments () in - let* () = Components.Commitment.Publisher.cement_commitments () in - let*! () = Daemon_event.new_heads_processed reorg.new_chain in - let* () = Components.Refutation_coordinator.process stripped_head in - let* () = Components.Batcher.batch () in - let* () = Components.Batcher.new_head stripped_head in - let*! () = Injector.inject ~header:head.header () in - return_unit - - let daemonize (node_ctxt : _ Node_context.t) = - Layer1.iter_heads node_ctxt.l1_ctxt (on_layer_1_head node_ctxt) - - let degraded_refutation_mode (node_ctxt : _ Node_context.t) = let open Lwt_result_syntax in - let*! () = Daemon_event.degraded_mode () in - let message = node_ctxt.Node_context.cctxt#message in - let*! () = message "Shutting down Batcher@." in - let*! () = Components.Batcher.shutdown () in - let*! () = message "Shutting down Commitment Publisher@." in - let*! () = Components.Commitment.Publisher.shutdown () in - Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> - let* () = - Components.Refutation_coordinator.process (Layer1.head_of_header head) - in - let*! () = Injector.inject () in - return_unit - - let install_finalizer node_ctxt rpc_server = - let open Lwt_syntax in - Lwt_exit.register_clean_up_callback ~loc:__LOC__ @@ fun exit_status -> - let message = node_ctxt.Node_context.cctxt#message in - let* () = message "Shutting down RPC server@." in - let* () = Components.RPC_server.shutdown rpc_server in - let* () = message "Shutting down Injector@." in - let* () = Injector.shutdown () in - let* () = message "Shutting down Batcher@." in - let* () = Components.Batcher.shutdown () in - let* () = message "Shutting down Commitment Publisher@." in - let* () = Components.Commitment.Publisher.shutdown () in - let* () = message "Shutting down Refutation Coordinator@." in - let* () = Components.Refutation_coordinator.shutdown () in - let* (_ : unit tzresult) = Node_context.close node_ctxt in - let* () = Event.shutdown_node exit_status in - Tezos_base_unix.Internal_event_unix.close () - - let check_initial_state_hash {Node_context.cctxt; rollup_address; _} = - let open Lwt_result_syntax in - let* l1_reference_initial_state_hash = - RPC.Sc_rollup.initial_pvm_state_hash - cctxt - (cctxt#chain, cctxt#block) - rollup_address - in - let*! s = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! l2_initial_state_hash = PVM.state_hash s in - fail_unless - Sc_rollup.State_hash.( - l1_reference_initial_state_hash = l2_initial_state_hash) - (Sc_rollup_node_errors.Wrong_initial_pvm_state - { - initial_state_hash = l2_initial_state_hash; - expected_state_hash = l1_reference_initial_state_hash; - }) + let* () = accu in + process_l1_operation node_ctxt head ~source operation result + in + let apply_internal (type kind) accu ~source:_ + (_operation : kind Apply_internal_results.internal_operation) + (_result : kind Apply_internal_results.internal_operation_result) = + accu + in + let* () = + Layer1_services.process_manager_operations + return_unit + block.operations + {apply; apply_internal} + in + return_unit - let run node_ctxt configuration = - let open Lwt_result_syntax in - let* () = check_initial_state_hash node_ctxt in - let* rpc_server = Components.RPC_server.start node_ctxt configuration in - let (_ : Lwt_exit.clean_up_callback_id) = - install_finalizer node_ctxt rpc_server - in - let start () = - let*! () = Inbox.start () in - let signers = - Configuration.Operator_purpose_map.bindings node_ctxt.operators - |> List.fold_left - (fun acc (purpose, operator) -> - let purposes = - match - Tezos_crypto.Signature.Public_key_hash.Map.find operator acc - with - | None -> [purpose] - | Some ps -> purpose :: ps - in - Tezos_crypto.Signature.Public_key_hash.Map.add - operator - purposes - acc) - Tezos_crypto.Signature.Public_key_hash.Map.empty - |> Tezos_crypto.Signature.Public_key_hash.Map.bindings - |> List.map (fun (operator, purposes) -> - let strategy = - match purposes with - | [Configuration.Add_messages] -> `Delay_block 0.5 - | _ -> `Each_block - in - (operator, strategy, purposes)) - in - let* () = Components.Commitment.Publisher.init node_ctxt in - let* () = Components.Refutation_coordinator.init node_ctxt in - let* () = - unless (signers = []) @@ fun () -> - Injector.init - node_ctxt.cctxt - (Node_context.readonly node_ctxt) - ~data_dir:node_ctxt.data_dir - ~signers - ~retention_period:configuration.injector.retention_period - ~allowed_attempts:configuration.injector.attempts - in - let* () = - match - Configuration.Operator_purpose_map.find - Add_messages - node_ctxt.operators - with - | None -> return_unit - | Some signer -> - Components.Batcher.init configuration.batcher ~signer node_ctxt - in - Lwt.dont_wait - (fun () -> - let*! r = Metrics.metrics_serve configuration.metrics_addr in - match r with - | Ok () -> Lwt.return_unit - | Error err -> - Event.(metrics_ended (Format.asprintf "%a" pp_print_trace err))) - (fun exn -> Event.(metrics_ended_dont_wait (Printexc.to_string exn))) ; +let before_origination (node_ctxt : _ Node_context.t) (header : Layer1.header) = + let origination_level = Raw_level.to_int32 node_ctxt.genesis_info.level in + header.level < origination_level - let*! () = - Event.node_is_ready - ~rpc_addr:configuration.rpc_addr - ~rpc_port:configuration.rpc_port - in - daemonize node_ctxt - in - Metrics.Info.init_rollup_node_info - ~id:configuration.sc_rollup_address - ~mode:configuration.mode - ~genesis_level:(Raw_level.to_int32 node_ctxt.genesis_info.level) - ~pvm_kind:(Sc_rollup.Kind.to_string node_ctxt.kind) ; - protect start ~on_error:(function - | Sc_rollup_node_errors.(Lost_game _ | Invalid_genesis_state _) :: _ as - e -> - Format.eprintf "%!%a@.Exiting.@." pp_print_trace e ; - let*! _ = Lwt_exit.exit_and_wait 1 in - return_unit - | e -> - let*! () = Daemon_event.error e in - degraded_refutation_mode node_ctxt) +let previous_context (node_ctxt : _ Node_context.t) + ~(predecessor : Layer1.header) = + let open Lwt_result_syntax in + if predecessor.level < Raw_level.to_int32 node_ctxt.genesis_info.level then + (* This is before we have interpreted the boot sector, so we start + with an empty context in genesis *) + return (Context.empty node_ctxt.context) + else Node_context.checkout_context node_ctxt predecessor.Layer1.hash - module Internal_for_tests = struct - (** Same as {!process_head} but only builds and stores the L2 block - corresponding to [messages]. It is used by the unit tests to build an L2 - chain. *) - let process_messages (node_ctxt : _ Node_context.t) ~predecessor head - messages = - let open Lwt_result_syntax in +let rec process_head (node_ctxt : _ Node_context.t) (head : Layer1.header) = + let open Lwt_result_syntax in + let* already_processed = Node_context.is_processed node_ctxt head.hash in + unless (already_processed || before_origination node_ctxt head) @@ fun () -> + let*! () = Daemon_event.head_processing head.hash head.level in + let* predecessor = Node_context.get_predecessor_header_opt node_ctxt head in + match predecessor with + | None -> + (* Predecessor not available on the L1, which means the block does not + exist in the chain. *) + return_unit + | Some predecessor -> + let* () = process_head node_ctxt predecessor in let* ctxt = previous_context node_ctxt ~predecessor in let* () = - Node_context.save_level node_ctxt (Layer1.head_of_header head) + Node_context.save_level + node_ctxt + {Layer1.hash = head.hash; level = head.level} in let* inbox_hash, inbox, inbox_witness, messages = - Inbox.Internal_for_tests.process_messages - node_ctxt - ~predecessor - head - messages + Inbox.process_head node_ctxt ~predecessor head + in + let* () = + when_ (Node_context.dal_supported node_ctxt) @@ fun () -> + Dal_slots_tracker.process_head node_ctxt (Layer1.head_of_header head) in + let* () = process_l1_block_operations node_ctxt head in + (* Avoid storing and publishing commitments if the head is not final. *) + (* Avoid triggering the pvm execution if this has been done before for + this head. *) let* ctxt, _num_messages, num_ticks, initial_tick = - Components.Interpreter.process_head + Interpreter.process_head node_ctxt ctxt ~predecessor @@ -617,11 +332,7 @@ module Make (PVM : Pvm.S) = struct in let*! context_hash = Context.commit ctxt in let* commitment_hash = - Components.Commitment.process_head - node_ctxt - ~predecessor:predecessor.Layer1.hash - head - ctxt + Publisher.process_head node_ctxt ~predecessor:predecessor.hash head ctxt in let level = Raw_level.of_int32_exn head.level in let* previous_commitment_hash = @@ -648,9 +359,276 @@ module Make (PVM : Pvm.S) = struct let l2_block = Sc_rollup_block.{header; content = (); num_ticks; initial_tick} in + let* () = + Node_context.mark_finalized_level + node_ctxt + Int32.(sub head.level (of_int node_ctxt.block_finality_time)) + in let* () = Node_context.save_l2_head node_ctxt l2_block in - return l2_block - end + let*! () = Daemon_event.new_head_processed head.hash head.level in + return_unit + +(* [on_layer_1_head node_ctxt head] processes a new head from the L1. It + also processes any missing blocks that were not processed. *) +let on_layer_1_head node_ctxt (head : Layer1.header) = + let open Lwt_result_syntax in + let* old_head = Node_context.last_processed_head_opt node_ctxt in + let old_head = + match old_head with + | Some h -> + `Head + Layer1. + { + hash = h.header.block_hash; + level = Raw_level.to_int32 h.header.level; + } + | None -> + (* if no head has been processed yet, we want to handle all blocks + since, and including, the rollup origination. *) + let origination_level = + Raw_level.to_int32 node_ctxt.genesis_info.level + in + `Level (Int32.pred origination_level) + in + let stripped_head = Layer1.head_of_header head in + let*! reorg = + Node_context.get_tezos_reorg_for_new_head node_ctxt old_head stripped_head + in + let*? reorg = + match reorg with + | Error trace + when TzTrace.fold + (fun yes error -> + yes + || + match error with + | Octez_crawler.Layer_1.Cannot_find_predecessor _ -> true + | _ -> false) + false + trace -> + (* The reorganization could not be computed entirely because of missing + info on the Layer 1. We fallback to a recursive process_head. *) + Ok {Reorg.no_reorg with new_chain = [stripped_head]} + | _ -> reorg + in + (* TODO: https://gitlab.com/tezos/tezos/-/issues/3348 + Rollback state information on reorganization, i.e. for + reorg.old_chain. *) + let*! () = Daemon_event.processing_heads_iteration reorg.new_chain in + let get_header Layer1.{hash; level} = + if Block_hash.equal hash head.hash then return head + else + let+ header = Layer1.fetch_tezos_shell_header node_ctxt.cctxt hash in + {Layer1.hash; level; header} + in + let* () = + List.iter_es + (fun block -> + let* header = get_header block in + process_head node_ctxt header) + reorg.new_chain + in + let* () = Publisher.publish_commitments () in + let* () = Publisher.cement_commitments () in + let*! () = Daemon_event.new_heads_processed reorg.new_chain in + let* () = Refutation_coordinator.process stripped_head in + let* () = Batcher.batch () in + let* () = Batcher.new_head stripped_head in + let*! () = Injector.inject ~header:head.header () in + return_unit + +let daemonize (node_ctxt : _ Node_context.t) = + Layer1.iter_heads node_ctxt.l1_ctxt (on_layer_1_head node_ctxt) + +let degraded_refutation_mode (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let*! () = Daemon_event.degraded_mode () in + let message = node_ctxt.Node_context.cctxt#message in + let*! () = message "Shutting down Batcher@." in + let*! () = Batcher.shutdown () in + let*! () = message "Shutting down Commitment Publisher@." in + let*! () = Publisher.shutdown () in + Layer1.iter_heads node_ctxt.l1_ctxt @@ fun head -> + let* () = Refutation_coordinator.process (Layer1.head_of_header head) in + let*! () = Injector.inject () in + return_unit + +let install_finalizer node_ctxt rpc_server = + let open Lwt_syntax in + Lwt_exit.register_clean_up_callback ~loc:__LOC__ @@ fun exit_status -> + let message = node_ctxt.Node_context.cctxt#message in + let* () = message "Shutting down RPC server@." in + let* () = RPC_server.shutdown rpc_server in + let* () = message "Shutting down Injector@." in + let* () = Injector.shutdown () in + let* () = message "Shutting down Batcher@." in + let* () = Batcher.shutdown () in + let* () = message "Shutting down Commitment Publisher@." in + let* () = Publisher.shutdown () in + let* () = message "Shutting down Refutation Coordinator@." in + let* () = Refutation_coordinator.shutdown () in + let* (_ : unit tzresult) = Node_context.close node_ctxt in + let* () = Event.shutdown_node exit_status in + Tezos_base_unix.Internal_event_unix.close () + +let check_initial_state_hash {Node_context.cctxt; rollup_address; pvm; _} = + let open Lwt_result_syntax in + let* l1_reference_initial_state_hash = + RPC.Sc_rollup.initial_pvm_state_hash + cctxt + (cctxt#chain, cctxt#block) + rollup_address + in + let module PVM = (val pvm) in + let*! s = PVM.initial_state ~empty:(PVM.State.empty ()) in + let*! l2_initial_state_hash = PVM.state_hash s in + fail_unless + Sc_rollup.State_hash.( + l1_reference_initial_state_hash = l2_initial_state_hash) + (Sc_rollup_node_errors.Wrong_initial_pvm_state + { + initial_state_hash = l2_initial_state_hash; + expected_state_hash = l1_reference_initial_state_hash; + }) + +let run node_ctxt configuration = + let open Lwt_result_syntax in + let* () = check_initial_state_hash node_ctxt in + let* rpc_server = RPC_server.start node_ctxt configuration in + let (_ : Lwt_exit.clean_up_callback_id) = + install_finalizer node_ctxt rpc_server + in + let start () = + let*! () = Inbox.start () in + let signers = + Configuration.Operator_purpose_map.bindings node_ctxt.operators + |> List.fold_left + (fun acc (purpose, operator) -> + let purposes = + match + Tezos_crypto.Signature.Public_key_hash.Map.find operator acc + with + | None -> [purpose] + | Some ps -> purpose :: ps + in + Tezos_crypto.Signature.Public_key_hash.Map.add + operator + purposes + acc) + Tezos_crypto.Signature.Public_key_hash.Map.empty + |> Tezos_crypto.Signature.Public_key_hash.Map.bindings + |> List.map (fun (operator, purposes) -> + let strategy = + match purposes with + | [Configuration.Add_messages] -> `Delay_block 0.5 + | _ -> `Each_block + in + (operator, strategy, purposes)) + in + let* () = Publisher.init node_ctxt in + let* () = Refutation_coordinator.init node_ctxt in + let* () = + unless (signers = []) @@ fun () -> + Injector.init + node_ctxt.cctxt + (Node_context.readonly node_ctxt) + ~data_dir:node_ctxt.data_dir + ~signers + ~retention_period:configuration.injector.retention_period + ~allowed_attempts:configuration.injector.attempts + in + let* () = + match + Configuration.Operator_purpose_map.find Add_messages node_ctxt.operators + with + | None -> return_unit + | Some signer -> Batcher.init configuration.batcher ~signer node_ctxt + in + Lwt.dont_wait + (fun () -> + let*! r = Metrics.metrics_serve configuration.metrics_addr in + match r with + | Ok () -> Lwt.return_unit + | Error err -> + Event.(metrics_ended (Format.asprintf "%a" pp_print_trace err))) + (fun exn -> Event.(metrics_ended_dont_wait (Printexc.to_string exn))) ; + + let*! () = + Event.node_is_ready + ~rpc_addr:configuration.rpc_addr + ~rpc_port:configuration.rpc_port + in + daemonize node_ctxt + in + Metrics.Info.init_rollup_node_info + ~id:configuration.sc_rollup_address + ~mode:configuration.mode + ~genesis_level:(Raw_level.to_int32 node_ctxt.genesis_info.level) + ~pvm_kind:(Sc_rollup.Kind.to_string node_ctxt.kind) ; + protect start ~on_error:(function + | Sc_rollup_node_errors.(Lost_game _ | Invalid_genesis_state _) :: _ as e + -> + Format.eprintf "%!%a@.Exiting.@." pp_print_trace e ; + let*! _ = Lwt_exit.exit_and_wait 1 in + return_unit + | e -> + let*! () = Daemon_event.error e in + degraded_refutation_mode node_ctxt) + +module Internal_for_tests = struct + (** Same as {!process_head} but only builds and stores the L2 block + corresponding to [messages]. It is used by the unit tests to build an L2 + chain. *) + let process_messages (node_ctxt : _ Node_context.t) ~predecessor head messages + = + let open Lwt_result_syntax in + let* ctxt = previous_context node_ctxt ~predecessor in + let* () = Node_context.save_level node_ctxt (Layer1.head_of_header head) in + let* inbox_hash, inbox, inbox_witness, messages = + Inbox.Internal_for_tests.process_messages + node_ctxt + ~predecessor + head + messages + in + let* ctxt, _num_messages, num_ticks, initial_tick = + Interpreter.process_head node_ctxt ctxt ~predecessor head (inbox, messages) + in + let*! context_hash = Context.commit ctxt in + let* commitment_hash = + Publisher.process_head + node_ctxt + ~predecessor:predecessor.Layer1.hash + head + ctxt + in + let level = Raw_level.of_int32_exn head.level in + let* previous_commitment_hash = + if level = node_ctxt.genesis_info.Sc_rollup.Commitment.level then + (* Previous commitment for rollup genesis is itself. *) + return node_ctxt.genesis_info.Sc_rollup.Commitment.commitment_hash + else + let+ pred = Node_context.get_l2_block node_ctxt predecessor.hash in + Sc_rollup_block.most_recent_commitment pred.header + in + let header = + Sc_rollup_block. + { + block_hash = head.hash; + level; + predecessor = predecessor.hash; + commitment_hash; + previous_commitment_hash; + context = context_hash; + inbox_witness; + inbox_hash; + } + in + let l2_block = + Sc_rollup_block.{header; content = (); num_ticks; initial_tick} + in + let* () = Node_context.save_l2_head node_ctxt l2_block in + return l2_block end let run ~data_dir ?log_kernel_debug_file (configuration : Configuration.t) @@ -675,5 +653,4 @@ let run ~data_dir ?log_kernel_debug_file (configuration : Configuration.t) Read_write configuration in - let module Daemon = Make ((val Components.pvm_of_kind node_ctxt.kind)) in - Daemon.run node_ctxt configuration + run node_ctxt configuration diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/fueled_pvm.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/fueled_pvm.ml index 3f2d28080991..0e6f482a71d5 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/fueled_pvm.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/fueled_pvm.ml @@ -30,14 +30,14 @@ open Protocol open Alpha_context module type S = sig - module PVM : Pvm.S - type fuel + type pvm_state = Context.tree + (** Evaluation state for the PVM. *) type eval_state = { - state : PVM.state; (** The actual PVM state. *) - state_hash : PVM.hash; (** Hash of [state]. *) + state : pvm_state; (** The actual PVM state. *) + state_hash : Sc_rollup.State_hash.t; (** Hash of [state]. *) tick : Sc_rollup.Tick.t; (** Tick of [state]. *) inbox_level : Raw_level.t; (** Inbox level in which messages are evaluated. *) @@ -62,7 +62,7 @@ module type S = sig fuel:fuel -> _ Node_context.t -> Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> - PVM.state -> + pvm_state -> eval_result Node_context.delayed_write tzresult Lwt.t (** [eval_messages ?reveal_map ~fuel node_ctxt ~message_counter_offset state @@ -81,393 +81,267 @@ module type S = sig eval_result Node_context.delayed_write tzresult Lwt.t end -module Make (PVM : Pvm.S) = struct - module Make_fueled (F : Fuel.S) : - S with module PVM = PVM and type fuel = F.t = struct - module PVM = PVM +module Make_fueled (F : Fuel.S) : S with type fuel = F.t = struct + type fuel = F.t - type fuel = F.t + type pvm_state = Context.tree - type eval_state = { - state : PVM.state; - state_hash : PVM.hash; - tick : Sc_rollup.Tick.t; - inbox_level : Raw_level.t; - message_counter_offset : int; - remaining_fuel : fuel; - remaining_messages : Sc_rollup.Inbox_message.t list; - } + type eval_state = { + state : pvm_state; + state_hash : Sc_rollup.State_hash.t; + tick : Sc_rollup.Tick.t; + inbox_level : Raw_level.t; + message_counter_offset : int; + remaining_fuel : fuel; + remaining_messages : Sc_rollup.Inbox_message.t list; + } - type eval_result = {state : eval_state; num_ticks : Z.t; num_messages : int} + type eval_result = {state : eval_state; num_ticks : Z.t; num_messages : int} - let get_reveal ~data_dir reveal_map hash = - let found_in_map = - match reveal_map with - | None -> None - | Some map -> Sc_rollup_reveal_hash.Map.find_opt hash map - in - match found_in_map with - | Some data -> return data - | None -> Reveals.get ~data_dir ~pvm_kind:PVM.kind ~hash + let get_reveal ~data_dir ~pvm_kind reveal_map hash = + let found_in_map = + match reveal_map with + | None -> None + | Some map -> Sc_rollup_reveal_hash.Map.find_opt hash map + in + match found_in_map with + | Some data -> return data + | None -> Reveals.get ~data_dir ~pvm_kind ~hash - type eval_completion = - | Aborted of {state : PVM.state; fuel : fuel; current_tick : int64} - | Completed of { - state : PVM.state; - fuel : fuel; - current_tick : int64; - failing_ticks : int64 list; - } + type eval_completion = + | Aborted of {state : pvm_state; fuel : fuel; current_tick : int64} + | Completed of { + state : pvm_state; + fuel : fuel; + current_tick : int64; + failing_ticks : int64 list; + } - exception Error_wrapper of tztrace + exception Error_wrapper of tztrace - (** [eval_until_input node_ctxt reveal_map level message_index ~fuel + (** [eval_until_input node_ctxt reveal_map level message_index ~fuel start_tick failing_ticks state] advances a PVM [state] until it wants more inputs or there are no more [fuel] (if [Some fuel] is specified). The evaluation is running under the processing of some [message_index] at a given [level] and this is the [start_tick] of this message processing. If some [failing_ticks] are planned by the loser mode, they will be made. *) - let eval_until_input node_ctxt reveal_map level message_index ~fuel - start_tick failing_ticks state = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let metadata = Node_context.metadata node_ctxt in - let dal_attestation_lag = - node_ctxt.protocol_constants.parametric.dal.attestation_lag - in - let reveal_builtins = - Tezos_scoru_wasm.Builtins. - { - reveal_preimage = - (fun hash -> - let*! data = - let*? hash = - (* The payload represents the encoded [Sc_rollup_reveal_hash.t]. We must - decode it properly, instead of converting it byte-for-byte. *) - Result.bind_error - (Data_encoding.Binary.of_string - Sc_rollup_reveal_hash.encoding - hash) - (error_with - "Bad reveal hash '%a': %a" - Hex.pp - (Hex.of_string hash) - Data_encoding.Binary.pp_read_error) - in - get_reveal ~data_dir:node_ctxt.data_dir reveal_map hash + let eval_until_input (node_ctxt : _ Node_context.t) reveal_map level + message_index ~fuel start_tick failing_ticks state = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let metadata = Node_context.metadata node_ctxt in + let dal_attestation_lag = + node_ctxt.protocol_constants.parametric.dal.attestation_lag + in + let reveal_builtins = + Tezos_scoru_wasm.Builtins. + { + reveal_preimage = + (fun hash -> + let*! data = + let*? hash = + (* The payload represents the encoded [Sc_rollup_reveal_hash.t]. We must + decode it properly, instead of converting it byte-for-byte. *) + Result.bind_error + (Data_encoding.Binary.of_string + Sc_rollup_reveal_hash.encoding + hash) + (error_with + "Bad reveal hash '%a': %a" + Hex.pp + (Hex.of_string hash) + Data_encoding.Binary.pp_read_error) in - match data with - | Error error -> - (* The [Error_wrapper] must be caught upstream and converted into a - tzresult. *) - Lwt.fail (Error_wrapper error) - | Ok data -> Lwt.return data); - reveal_metadata = - (fun () -> - Lwt.return - (Data_encoding.Binary.to_string_exn - Sc_rollup.Metadata.encoding - metadata)); - } - in - let eval_tick fuel failing_ticks state = - let max_steps = F.max_ticks fuel in - let normal_eval ?(max_steps = max_steps) state = - Lwt.catch - (fun () -> - let*! state, executed_ticks = - PVM.eval_many - ~reveal_builtins - ~write_debug:(Printer node_ctxt.kernel_debug_logger) - ~max_steps - state - in - return (state, executed_ticks, failing_ticks)) - (function - | Error_wrapper error -> Lwt.return (Error error) - | exn -> raise exn) - in - let failure_insertion_eval state tick failing_ticks' = - let*! () = - Interpreter_event.intended_failure - ~level - ~message_index - ~message_tick:tick - ~internal:true - in - let*! state = PVM.Internal_for_tests.insert_failure state in - return (state, 1L, failing_ticks') - in - match failing_ticks with - | xtick :: failing_ticks' -> - let jump = Int64.(max 0L (pred xtick)) in - if Compare.Int64.(jump = 0L) then - (* Insert the failure in the first tick. *) - failure_insertion_eval state xtick failing_ticks' - else - (* Jump just before the tick where we'll insert a failure. - Nevertheless, we don't execute more than [max_steps]. *) - let max_steps = Int64.max 0L max_steps |> Int64.min max_steps in - let open Delayed_write_monad.Lwt_result_syntax in - let>* state, executed_ticks, _failing_ticks = - normal_eval ~max_steps state - in - (* Insert the failure. *) - let>* state, executed_ticks', failing_ticks' = - failure_insertion_eval state xtick failing_ticks' + get_reveal + ~data_dir:node_ctxt.data_dir + ~pvm_kind:node_ctxt.kind + reveal_map + hash in - let executed_ticks = Int64.add executed_ticks executed_ticks' in - return (state, executed_ticks, failing_ticks') - | _ -> normal_eval state - in - let abort state fuel current_tick = - return (Aborted {state; fuel; current_tick}) + match data with + | Error error -> + (* The [Error_wrapper] must be caught upstream and converted into a + tzresult. *) + Lwt.fail (Error_wrapper error) + | Ok data -> Lwt.return data); + reveal_metadata = + (fun () -> + Lwt.return + (Data_encoding.Binary.to_string_exn + Sc_rollup.Metadata.encoding + metadata)); + } + in + let eval_tick fuel failing_ticks state = + let max_steps = F.max_ticks fuel in + let normal_eval ?(max_steps = max_steps) state = + Lwt.catch + (fun () -> + let*! state, executed_ticks = + PVM.eval_many + ~reveal_builtins + ~write_debug:(Printer node_ctxt.kernel_debug_logger) + ~max_steps + state + in + return (state, executed_ticks, failing_ticks)) + (function + | Error_wrapper error -> Lwt.return (Error error) | exn -> raise exn) in - let complete state fuel current_tick failing_ticks = - return (Completed {state; fuel; current_tick; failing_ticks}) + let failure_insertion_eval state tick failing_ticks' = + let*! () = + Interpreter_event.intended_failure + ~level + ~message_index + ~message_tick:tick + ~internal:true + in + let*! state = PVM.Internal_for_tests.insert_failure state in + return (state, 1L, failing_ticks') in - let rec go (fuel : fuel) current_tick failing_ticks state = - let*! input_request = PVM.is_input_state state in - match input_request with - | No_input_required when F.is_empty fuel -> - abort state fuel current_tick - | No_input_required -> ( - let>* next_state, executed_ticks, failing_ticks = - eval_tick fuel failing_ticks state + match failing_ticks with + | xtick :: failing_ticks' -> + let jump = Int64.(max 0L (pred xtick)) in + if Compare.Int64.(jump = 0L) then + (* Insert the failure in the first tick. *) + failure_insertion_eval state xtick failing_ticks' + else + (* Jump just before the tick where we'll insert a failure. + Nevertheless, we don't execute more than [max_steps]. *) + let max_steps = Int64.max 0L max_steps |> Int64.min max_steps in + let open Delayed_write_monad.Lwt_result_syntax in + let>* state, executed_ticks, _failing_ticks = + normal_eval ~max_steps state in - let fuel_executed = F.of_ticks executed_ticks in - match F.consume fuel_executed fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go - fuel - (Int64.add current_tick executed_ticks) - failing_ticks - next_state) - | Needs_reveal (Reveal_raw_data hash) -> ( - let* data = - get_reveal ~data_dir:node_ctxt.data_dir reveal_map hash - in - let*! next_state = PVM.set_input (Reveal (Raw_data data)) state in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Needs_reveal Reveal_metadata -> ( - let*! next_state = - PVM.set_input (Reveal (Metadata metadata)) state - in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Needs_reveal (Request_dal_page page_id) -> ( - let>* content_opt = - Dal_pages_request.page_content - ~dal_attestation_lag - node_ctxt - page_id - in - let*! next_state = - PVM.set_input (Reveal (Dal_page content_opt)) state + (* Insert the failure. *) + let>* state, executed_ticks', failing_ticks' = + failure_insertion_eval state xtick failing_ticks' in - match F.consume F.one_tick_consumption fuel with - | None -> abort state fuel current_tick - | Some fuel -> - go fuel (Int64.succ current_tick) failing_ticks next_state) - | Initial | First_after _ -> - complete state fuel current_tick failing_ticks - in - go fuel start_tick failing_ticks state + let executed_ticks = Int64.add executed_ticks executed_ticks' in + return (state, executed_ticks, failing_ticks') + | _ -> normal_eval state + in + let abort state fuel current_tick = + return (Aborted {state; fuel; current_tick}) + in + let complete state fuel current_tick failing_ticks = + return (Completed {state; fuel; current_tick; failing_ticks}) + in + let rec go (fuel : fuel) current_tick failing_ticks state = + let*! input_request = PVM.is_input_state state in + match input_request with + | No_input_required when F.is_empty fuel -> abort state fuel current_tick + | No_input_required -> ( + let>* next_state, executed_ticks, failing_ticks = + eval_tick fuel failing_ticks state + in + let fuel_executed = F.of_ticks executed_ticks in + match F.consume fuel_executed fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go + fuel + (Int64.add current_tick executed_ticks) + failing_ticks + next_state) + | Needs_reveal (Reveal_raw_data hash) -> ( + let* data = + get_reveal + ~data_dir:node_ctxt.data_dir + ~pvm_kind:node_ctxt.kind + reveal_map + hash + in + let*! next_state = PVM.set_input (Reveal (Raw_data data)) state in + match F.consume F.one_tick_consumption fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go fuel (Int64.succ current_tick) failing_ticks next_state) + | Needs_reveal Reveal_metadata -> ( + let*! next_state = PVM.set_input (Reveal (Metadata metadata)) state in + match F.consume F.one_tick_consumption fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go fuel (Int64.succ current_tick) failing_ticks next_state) + | Needs_reveal (Request_dal_page page_id) -> ( + let>* content_opt = + Dal_pages_request.page_content + ~dal_attestation_lag + node_ctxt + page_id + in + let*! next_state = + PVM.set_input (Reveal (Dal_page content_opt)) state + in + match F.consume F.one_tick_consumption fuel with + | None -> abort state fuel current_tick + | Some fuel -> + go fuel (Int64.succ current_tick) failing_ticks next_state) + | Initial | First_after _ -> + complete state fuel current_tick failing_ticks + in + go fuel start_tick failing_ticks state - (** [mutate input] corrupts the payload of [input] for testing purposes. *) - let mutate input = - let payload = - Sc_rollup.Inbox_message.unsafe_of_string - "\001to the cheater we promise pain and misery" - in - {input with Sc_rollup.payload} + (** [mutate input] corrupts the payload of [input] for testing purposes. *) + let mutate input = + let payload = + Sc_rollup.Inbox_message.unsafe_of_string + "\001to the cheater we promise pain and misery" + in + {input with Sc_rollup.payload} - type feed_input_completion = - | Feed_input_aborted of {state : PVM.state; fuel : fuel; fed_input : bool} - | Feed_input_completed of {state : PVM.state; fuel : fuel} + type feed_input_completion = + | Feed_input_aborted of {state : pvm_state; fuel : fuel; fed_input : bool} + | Feed_input_completed of {state : pvm_state; fuel : fuel} - (** [feed_input node_ctxt reveal_map level message_index ~fuel + (** [feed_input node_ctxt reveal_map level message_index ~fuel ~failing_ticks state input] feeds [input] (that has a given [message_index] in inbox of [level]) to the PVM in order to advance [state] to the next step that requires an input. This function is controlled by some [fuel] and may introduce intended failures at some given [failing_ticks]. *) - let feed_input node_ctxt reveal_map level message_index ~fuel ~failing_ticks - state input = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let>* res = - eval_until_input - node_ctxt - reveal_map - level - message_index - ~fuel - 0L - failing_ticks - state - in - match res with - | Aborted {state; fuel; _} -> - return (Feed_input_aborted {state; fuel; fed_input = false}) - | Completed {state; fuel; current_tick = tick; failing_ticks} -> ( - let open Delayed_write_monad.Lwt_result_syntax in - match F.consume F.one_tick_consumption fuel with - | None -> return (Feed_input_aborted {state; fuel; fed_input = false}) - | Some fuel -> ( - let>* input, failing_ticks = - match failing_ticks with - | xtick :: failing_ticks' -> - if xtick = tick then - let*! () = - Interpreter_event.intended_failure - ~level - ~message_index - ~message_tick:tick - ~internal:false - in - return (mutate input, failing_ticks') - else return (input, failing_ticks) - | [] -> return (input, failing_ticks) - in - let*! state = PVM.set_input (Inbox_message input) state in - let>* res = - eval_until_input - node_ctxt - reveal_map - level - message_index - ~fuel - tick - failing_ticks - state - in - match res with - | Aborted {state; fuel; _} -> - return (Feed_input_aborted {state; fuel; fed_input = true}) - | Completed {state; fuel; _} -> - return (Feed_input_completed {state; fuel}))) - - let eval_messages ~reveal_map ~fuel node_ctxt ~message_counter_offset state - inbox_level messages = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let level = Raw_level.to_int32 inbox_level |> Int32.to_int in - (* Iterate the PVM state with all the messages. *) - let rec feed_messages (state, fuel) message_index = function - | [] -> - (* Fed all messages *) - return (state, fuel, message_index - message_counter_offset, []) - | messages when F.is_empty fuel -> - (* Consumed all fuel *) - return - (state, fuel, message_index - message_counter_offset, messages) - | message :: messages -> ( - let*? payload = - Sc_rollup.Inbox_message.( - message |> serialize |> Environment.wrap_tzresult) - in - let message_counter = Z.of_int message_index in - let input = Sc_rollup.{inbox_level; message_counter; payload} in - let failing_ticks = - Loser_mode.is_failure - node_ctxt.Node_context.loser_mode - ~level - ~message_index - in - let>* res = - feed_input - node_ctxt - reveal_map - level - message_index - ~fuel - ~failing_ticks - state - input - in - match res with - | Feed_input_completed {state; fuel} -> - feed_messages (state, fuel) (message_index + 1) messages - | Feed_input_aborted {state; fuel; fed_input = false} -> - return - ( state, - fuel, - message_index - message_counter_offset, - message :: messages ) - | Feed_input_aborted {state; fuel; fed_input = true} -> - return - ( state, - fuel, - message_index + 1 - message_counter_offset, - messages )) - in - (feed_messages [@tailcall]) (state, fuel) message_counter_offset messages - - let eval_block_inbox ~fuel node_ctxt (inbox, messages) (state : PVM.state) : - eval_result Node_context.delayed_write tzresult Lwt.t = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - (* Obtain inbox and its messages for this block. *) - let inbox_level = Inbox.inbox_level inbox in - let*! initial_tick = PVM.get_tick state in - (* Evaluate all the messages for this level. *) - let>* state, remaining_fuel, num_messages, remaining_messages = - eval_messages - ~reveal_map:None - ~fuel - node_ctxt - ~message_counter_offset:0 - state - inbox_level - messages - in - let*! final_tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in - let eval_state = - { - state; - state_hash; - tick = final_tick; - inbox_level; - message_counter_offset = num_messages; - remaining_fuel; - remaining_messages; - } - in - return {state = eval_state; num_ticks; num_messages} - - let eval_messages ?reveal_map node_ctxt - { - state; - tick = initial_tick; - inbox_level; - message_counter_offset; - remaining_fuel = fuel; - remaining_messages = messages; - _; - } = - let open Lwt_result_syntax in - let open Delayed_write_monad.Lwt_result_syntax in - let>* state, remaining_fuel, num_messages, remaining_messages = - match messages with - | [] -> - let level = Raw_level.to_int32 inbox_level |> Int32.to_int in - let message_index = message_counter_offset - 1 in - let failing_ticks = - Loser_mode.is_failure - node_ctxt.Node_context.loser_mode - ~level - ~message_index + let feed_input (node_ctxt : _ Node_context.t) reveal_map level message_index + ~fuel ~failing_ticks state input = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let>* res = + eval_until_input + node_ctxt + reveal_map + level + message_index + ~fuel + 0L + failing_ticks + state + in + match res with + | Aborted {state; fuel; _} -> + return (Feed_input_aborted {state; fuel; fed_input = false}) + | Completed {state; fuel; current_tick = tick; failing_ticks} -> ( + let open Delayed_write_monad.Lwt_result_syntax in + match F.consume F.one_tick_consumption fuel with + | None -> return (Feed_input_aborted {state; fuel; fed_input = false}) + | Some fuel -> ( + let>* input, failing_ticks = + match failing_ticks with + | xtick :: failing_ticks' -> + if xtick = tick then + let*! () = + Interpreter_event.intended_failure + ~level + ~message_index + ~message_tick:tick + ~internal:false + in + return (mutate input, failing_ticks') + else return (input, failing_ticks) + | [] -> return (input, failing_ticks) in + let*! state = PVM.set_input (Inbox_message input) state in let>* res = eval_until_input node_ctxt @@ -475,43 +349,174 @@ module Make (PVM : Pvm.S) = struct level message_index ~fuel - 0L + tick failing_ticks state in - let state, remaining_fuel = - match res with - | Aborted {state; fuel; _} | Completed {state; fuel; _} -> - (state, fuel) - in - return (state, remaining_fuel, 0, []) - | _ -> - eval_messages - ~reveal_map - ~fuel + match res with + | Aborted {state; fuel; _} -> + return (Feed_input_aborted {state; fuel; fed_input = true}) + | Completed {state; fuel; _} -> + return (Feed_input_completed {state; fuel}))) + + let eval_messages ~reveal_map ~fuel node_ctxt ~message_counter_offset state + inbox_level messages = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let level = Raw_level.to_int32 inbox_level |> Int32.to_int in + (* Iterate the PVM state with all the messages. *) + let rec feed_messages (state, fuel) message_index = function + | [] -> + (* Fed all messages *) + return (state, fuel, message_index - message_counter_offset, []) + | messages when F.is_empty fuel -> + (* Consumed all fuel *) + return (state, fuel, message_index - message_counter_offset, messages) + | message :: messages -> ( + let*? payload = + Sc_rollup.Inbox_message.( + message |> serialize |> Environment.wrap_tzresult) + in + let message_counter = Z.of_int message_index in + let input = Sc_rollup.{inbox_level; message_counter; payload} in + let failing_ticks = + Loser_mode.is_failure + node_ctxt.Node_context.loser_mode + ~level + ~message_index + in + let>* res = + feed_input node_ctxt - ~message_counter_offset + reveal_map + level + message_index + ~fuel + ~failing_ticks state - inbox_level - messages - in - let*! final_tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in - let eval_state = - { - state; - state_hash; - tick = final_tick; - inbox_level; - message_counter_offset = message_counter_offset + num_messages; - remaining_fuel; - remaining_messages; - } - in - return {state = eval_state; num_ticks; num_messages} - end + input + in + match res with + | Feed_input_completed {state; fuel} -> + feed_messages (state, fuel) (message_index + 1) messages + | Feed_input_aborted {state; fuel; fed_input = false} -> + return + ( state, + fuel, + message_index - message_counter_offset, + message :: messages ) + | Feed_input_aborted {state; fuel; fed_input = true} -> + return + ( state, + fuel, + message_index + 1 - message_counter_offset, + messages )) + in + (feed_messages [@tailcall]) (state, fuel) message_counter_offset messages + + let eval_block_inbox ~fuel (node_ctxt : _ Node_context.t) (inbox, messages) + (state : pvm_state) : + eval_result Node_context.delayed_write tzresult Lwt.t = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + (* Obtain inbox and its messages for this block. *) + let inbox_level = Inbox.inbox_level inbox in + let*! initial_tick = PVM.get_tick state in + (* Evaluate all the messages for this level. *) + let>* state, remaining_fuel, num_messages, remaining_messages = + eval_messages + ~reveal_map:None + ~fuel + node_ctxt + ~message_counter_offset:0 + state + inbox_level + messages + in + let*! final_tick = PVM.get_tick state in + let*! state_hash = PVM.state_hash state in + let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in + let eval_state = + { + state; + state_hash; + tick = final_tick; + inbox_level; + message_counter_offset = num_messages; + remaining_fuel; + remaining_messages; + } + in + return {state = eval_state; num_ticks; num_messages} - module Free = Make_fueled (Fuel.Free) - module Accounted = Make_fueled (Fuel.Accounted) + let eval_messages ?reveal_map (node_ctxt : _ Node_context.t) + { + state; + tick = initial_tick; + inbox_level; + message_counter_offset; + remaining_fuel = fuel; + remaining_messages = messages; + _; + } = + let open Lwt_result_syntax in + let open Delayed_write_monad.Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let>* state, remaining_fuel, num_messages, remaining_messages = + match messages with + | [] -> + let level = Raw_level.to_int32 inbox_level |> Int32.to_int in + let message_index = message_counter_offset - 1 in + let failing_ticks = + Loser_mode.is_failure + node_ctxt.Node_context.loser_mode + ~level + ~message_index + in + let>* res = + eval_until_input + node_ctxt + reveal_map + level + message_index + ~fuel + 0L + failing_ticks + state + in + let state, remaining_fuel = + match res with + | Aborted {state; fuel; _} | Completed {state; fuel; _} -> + (state, fuel) + in + return (state, remaining_fuel, 0, []) + | _ -> + eval_messages + ~reveal_map + ~fuel + node_ctxt + ~message_counter_offset + state + inbox_level + messages + in + let*! final_tick = PVM.get_tick state in + let*! state_hash = PVM.state_hash state in + let num_ticks = Sc_rollup.Tick.distance initial_tick final_tick in + let eval_state = + { + state; + state_hash; + tick = final_tick; + inbox_level; + message_counter_offset = message_counter_offset + num_messages; + remaining_fuel; + remaining_messages; + } + in + return {state = eval_state; num_ticks; num_messages} end + +module Free = Make_fueled (Fuel.Free) +module Accounted = Make_fueled (Fuel.Accounted) diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/interpreter.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/interpreter.ml index 132b6b921519..f51fdb534c0e 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/interpreter.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/interpreter.ml @@ -26,286 +26,239 @@ open Protocol open Alpha_context -module type S = sig - module PVM : Pvm.S +(** [get_boot_sector block_hash node_ctxt] fetches the operations in the + [block_hash] and looks for the bootsector used to originate the rollup we're + following. It must be called with [block_hash.level] = + [node_ctxt.genesis_info.level]. *) +let get_boot_sector block_hash (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let exception Found_boot_sector of string in + let* block = Layer1.fetch_tezos_block node_ctxt.cctxt block_hash in + let missing_boot_sector () = + failwith "Boot sector not found in Tezos block %a" Block_hash.pp block_hash + in + Lwt.catch + (fun () -> + let apply (type kind) accu ~source:_ (operation : kind manager_operation) + (result : kind Apply_results.successful_manager_operation_result) = + match (operation, result) with + | ( Sc_rollup_originate {kind; boot_sector; _}, + Sc_rollup_originate_result {address; _} ) + when node_ctxt.rollup_address = address && node_ctxt.kind = kind -> + raise (Found_boot_sector boot_sector) + | _ -> accu + in + let apply_internal (type kind) accu ~source:_ + (_operation : kind Apply_internal_results.internal_operation) + (_result : + kind Apply_internal_results.successful_internal_operation_result) = + accu + in + let*? () = + Layer1_services.( + process_applied_manager_operations + (Ok ()) + block.operations + {apply; apply_internal}) + in + missing_boot_sector ()) + (function + | Found_boot_sector boot_sector -> return boot_sector + | _ -> missing_boot_sector ()) - module Accounted_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Accounted.t +let genesis_state block_hash node_ctxt ctxt = + let open Lwt_result_syntax in + let* boot_sector = get_boot_sector block_hash node_ctxt in + let module PVM = (val node_ctxt.pvm) in + let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in + let*! genesis_state = PVM.install_boot_sector initial_state boot_sector in + let*! ctxt = PVM.State.set ctxt genesis_state in + return (ctxt, genesis_state) - module Free_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Free.t +let state_of_head node_ctxt ctxt Layer1.{hash; level} = + let open Lwt_result_syntax in + let*! state = Context.PVMState.find ctxt in + match state with + | None -> + let genesis_level = + Raw_level.to_int32 node_ctxt.Node_context.genesis_info.level + in + if level = genesis_level then genesis_state hash node_ctxt ctxt + else tzfail (Sc_rollup_node_errors.Missing_PVM_state (hash, level)) + | Some state -> return (ctxt, state) - val process_head : - Node_context.rw -> - 'a Context.t -> - predecessor:Layer1.header -> - Layer1.header -> - Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> - ('a Context.t * int * int64 * Sc_rollup.Tick.t) tzresult Lwt.t +(** [transition_pvm node_ctxt predecessor head] runs a PVM at the previous state + from block [predecessor] by consuming as many messages as possible from + block [head]. *) +let transition_pvm node_ctxt ctxt predecessor Layer1.{hash = _; _} + inbox_messages = + let open Lwt_result_syntax in + (* Retrieve the previous PVM state from store. *) + let* ctxt, predecessor_state = state_of_head node_ctxt ctxt predecessor in + let* eval_result = + Fueled_pvm.Free.eval_block_inbox + ~fuel:(Fuel.Free.of_ticks 0L) + node_ctxt + inbox_messages + predecessor_state + in + let* { + state = {state; state_hash; inbox_level; tick; _}; + num_messages; + num_ticks; + } = + Delayed_write_monad.apply node_ctxt eval_result + in + let module PVM = (val node_ctxt.pvm) in + let*! ctxt = PVM.State.set ctxt state in + let*! initial_tick = PVM.get_tick predecessor_state in + (* Produce events. *) + let*! () = + Interpreter_event.transitioned_pvm inbox_level state_hash tick num_messages + in + return (ctxt, num_messages, Z.to_int64 num_ticks, initial_tick) - val state_of_tick : - _ Node_context.t -> - ?start_state:Accounted_pvm.eval_state -> - Sc_rollup.Tick.t -> - Raw_level.t -> - Accounted_pvm.eval_state option tzresult Lwt.t +(** [process_head node_ctxt ctxt ~predecessor head] runs the PVM for the given + head. *) +let process_head (node_ctxt : _ Node_context.t) ctxt + ~(predecessor : Layer1.header) (head : Layer1.header) inbox_messages = + let open Lwt_result_syntax in + let first_inbox_level = + Raw_level.to_int32 node_ctxt.genesis_info.level |> Int32.succ + in + if head.Layer1.level >= first_inbox_level then + transition_pvm + node_ctxt + ctxt + (Layer1.head_of_header predecessor) + (Layer1.head_of_header head) + inbox_messages + else if head.Layer1.level = Raw_level.to_int32 node_ctxt.genesis_info.level + then + let* ctxt, state = genesis_state head.hash node_ctxt ctxt in + let*! ctxt = Context.PVMState.set ctxt state in + return (ctxt, 0, 0L, Sc_rollup.Tick.initial) + else return (ctxt, 0, 0L, Sc_rollup.Tick.initial) - val state_of_head : - 'a Node_context.t -> - 'a Context.t -> - Layer1.head -> - ('a Context.t * PVM.state) tzresult Lwt.t -end +(** Returns the starting evaluation before the evaluation of the block. It + contains the PVM state at the end of the execution of the previous block and + the messages the block ([remaining_messages]). *) +let start_state_of_block node_ctxt (block : Sc_rollup_block.t) = + let open Lwt_result_syntax in + let pred_level = Raw_level.to_int32 block.header.level |> Int32.pred in + let* ctxt = + Node_context.checkout_context node_ctxt block.header.predecessor + in + let* _ctxt, state = + state_of_head + node_ctxt + ctxt + Layer1.{hash = block.header.predecessor; level = pred_level} + in + let* inbox = Node_context.get_inbox node_ctxt block.header.inbox_hash in + let* {predecessor; predecessor_timestamp; messages} = + Node_context.get_messages node_ctxt block.header.inbox_witness + in + let inbox_level = Sc_rollup.Inbox.inbox_level inbox in + let module PVM = (val node_ctxt.pvm) in + let*! tick = PVM.get_tick state in + let*! state_hash = PVM.state_hash state in + let messages = + Sc_rollup.Inbox_message.Internal Start_of_level + :: Internal (Info_per_level {predecessor; predecessor_timestamp}) + :: messages + @ [Internal End_of_level] + in + return + Fueled_pvm.Accounted. + { + state; + state_hash; + inbox_level; + tick; + message_counter_offset = 0; + remaining_fuel = Fuel.Accounted.of_ticks 0L; + remaining_messages = messages; + } -module Make (PVM : Pvm.S) : S with module PVM = PVM = struct - module PVM = PVM - module Fueled_pvm = Fueled_pvm.Make (PVM) - module Accounted_pvm = Fueled_pvm.Accounted - module Free_pvm = Fueled_pvm.Free - - (** [get_boot_sector block_hash node_ctxt] fetches the operations in the - [block_hash] and looks for the bootsector used to originate the rollup - we're following. - It must be called with [block_hash.level] = [node_ctxt.genesis_info.level]. - *) - let get_boot_sector block_hash (node_ctxt : _ Node_context.t) = - let open Lwt_result_syntax in - let exception Found_boot_sector of string in - let* block = Layer1.fetch_tezos_block node_ctxt.cctxt block_hash in - let missing_boot_sector () = - failwith - "Boot sector not found in Tezos block %a" - Block_hash.pp - block_hash - in - Lwt.catch - (fun () -> - let apply (type kind) accu ~source:_ - (operation : kind manager_operation) - (result : kind Apply_results.successful_manager_operation_result) = - match (operation, result) with - | ( Sc_rollup_originate {kind; boot_sector; _}, - Sc_rollup_originate_result {address; _} ) - when node_ctxt.rollup_address = address && node_ctxt.kind = kind -> - raise (Found_boot_sector boot_sector) - | _ -> accu - in - let apply_internal (type kind) accu ~source:_ - (_operation : kind Apply_internal_results.internal_operation) - (_result : - kind Apply_internal_results.successful_internal_operation_result) - = - accu - in - let*? () = - Layer1_services.( - process_applied_manager_operations - (Ok ()) - block.operations - {apply; apply_internal}) - in - missing_boot_sector ()) - (function - | Found_boot_sector boot_sector -> return boot_sector - | _ -> missing_boot_sector ()) - - let genesis_state block_hash node_ctxt ctxt = - let open Lwt_result_syntax in - let* boot_sector = get_boot_sector block_hash node_ctxt in - let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! genesis_state = PVM.install_boot_sector initial_state boot_sector in - let*! ctxt = PVM.State.set ctxt genesis_state in - return (ctxt, genesis_state) - - let state_of_head node_ctxt ctxt Layer1.{hash; level} = - let open Lwt_result_syntax in - let*! state = PVM.State.find ctxt in - match state with - | None -> - let genesis_level = - Raw_level.to_int32 node_ctxt.Node_context.genesis_info.level - in - if level = genesis_level then genesis_state hash node_ctxt ctxt - else tzfail (Sc_rollup_node_errors.Missing_PVM_state (hash, level)) - | Some state -> return (ctxt, state) - - (** [transition_pvm node_ctxt predecessor head] runs a PVM at the - previous state from block [predecessor] by consuming as many messages - as possible from block [head]. *) - let transition_pvm node_ctxt ctxt predecessor Layer1.{hash = _; _} - inbox_messages = - let open Lwt_result_syntax in - (* Retrieve the previous PVM state from store. *) - let* ctxt, predecessor_state = state_of_head node_ctxt ctxt predecessor in - let* eval_result = - Free_pvm.eval_block_inbox - ~fuel:(Fuel.Free.of_ticks 0L) - node_ctxt - inbox_messages - predecessor_state - in - let* { - state = {state; state_hash; inbox_level; tick; _}; - num_messages; - num_ticks; - } = - Delayed_write_monad.apply node_ctxt eval_result - in - let*! ctxt = PVM.State.set ctxt state in - let*! initial_tick = PVM.get_tick predecessor_state in - (* Produce events. *) - let*! () = - Interpreter_event.transitioned_pvm - inbox_level - state_hash - tick - num_messages - in - return (ctxt, num_messages, Z.to_int64 num_ticks, initial_tick) - - (** [process_head node_ctxt ctxt ~predecessor head] runs the PVM for the given - head. *) - let process_head (node_ctxt : _ Node_context.t) ctxt - ~(predecessor : Layer1.header) (head : Layer1.header) inbox_messages = - let open Lwt_result_syntax in - let first_inbox_level = - Raw_level.to_int32 node_ctxt.genesis_info.level |> Int32.succ - in - if head.Layer1.level >= first_inbox_level then - transition_pvm - node_ctxt - ctxt - (Layer1.head_of_header predecessor) - (Layer1.head_of_header head) - inbox_messages - else if head.Layer1.level = Raw_level.to_int32 node_ctxt.genesis_info.level - then - let* ctxt, state = genesis_state head.hash node_ctxt ctxt in - let*! ctxt = PVM.State.set ctxt state in - return (ctxt, 0, 0L, Sc_rollup.Tick.initial) - else return (ctxt, 0, 0L, Sc_rollup.Tick.initial) - - (** Returns the starting evaluation before the evaluation of the block. It - contains the PVM state at the end of the execution of the previous block - and the messages the block ([remaining_messages]). *) - let start_state_of_block node_ctxt (block : Sc_rollup_block.t) = - let open Lwt_result_syntax in - let pred_level = Raw_level.to_int32 block.header.level |> Int32.pred in - let* ctxt = - Node_context.checkout_context node_ctxt block.header.predecessor - in - let* _ctxt, state = - state_of_head - node_ctxt - ctxt - Layer1.{hash = block.header.predecessor; level = pred_level} - in - let* inbox = Node_context.get_inbox node_ctxt block.header.inbox_hash in - let* {predecessor; predecessor_timestamp; messages} = - Node_context.get_messages node_ctxt block.header.inbox_witness - in - let inbox_level = Sc_rollup.Inbox.inbox_level inbox in - let*! tick = PVM.get_tick state in - let*! state_hash = PVM.state_hash state in - let messages = - Sc_rollup.Inbox_message.Internal Start_of_level - :: Internal (Info_per_level {predecessor; predecessor_timestamp}) - :: messages - @ [Internal End_of_level] - in - return - Accounted_pvm. - { - state; - state_hash; - inbox_level; - tick; - message_counter_offset = 0; - remaining_fuel = Fuel.Accounted.of_ticks 0L; - remaining_messages = messages; - } - - (** [run_for_ticks node_ctxt start_state tick_distance] starts the evaluation +(** [run_for_ticks node_ctxt start_state tick_distance] starts the evaluation of messages in the [start_state] for at most [tick_distance]. *) - let run_to_tick node_ctxt start_state tick = - let open Delayed_write_monad.Lwt_result_syntax in - let tick_distance = - Sc_rollup.Tick.distance tick start_state.Accounted_pvm.tick |> Z.to_int64 - in - let>+ eval_result = - Accounted_pvm.eval_messages - node_ctxt - { - start_state with - remaining_fuel = Fuel.Accounted.of_ticks tick_distance; - } - in - eval_result.state +let run_to_tick node_ctxt start_state tick = + let open Delayed_write_monad.Lwt_result_syntax in + let tick_distance = + Sc_rollup.Tick.distance tick start_state.Fueled_pvm.Accounted.tick + |> Z.to_int64 + in + let>+ eval_result = + Fueled_pvm.Accounted.eval_messages + node_ctxt + {start_state with remaining_fuel = Fuel.Accounted.of_ticks tick_distance} + in + eval_result.state - let state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) tick - = - let open Lwt_result_syntax in - let* start_state = - match start_state with - | Some start_state - when Raw_level.( - start_state.Accounted_pvm.inbox_level = event.header.level) -> - return start_state - | _ -> - (* Recompute start state on level change or if we don't have a - starting state on hand. *) - start_state_of_block node_ctxt event - in - (* TODO: #3384 - We should test that we always have enough blocks to find the tick - because [state_of_tick] is a critical function. *) - let* result_state = run_to_tick node_ctxt start_state tick in - let result_state = Delayed_write_monad.ignore result_state in - return result_state +let state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) tick = + let open Lwt_result_syntax in + let* start_state = + match start_state with + | Some start_state + when Raw_level.( + start_state.Fueled_pvm.Accounted.inbox_level = event.header.level) + -> + return start_state + | _ -> + (* Recompute start state on level change or if we don't have a + starting state on hand. *) + start_state_of_block node_ctxt event + in + (* TODO: #3384 + We should test that we always have enough blocks to find the tick + because [state_of_tick] is a critical function. *) + let* result_state = run_to_tick node_ctxt start_state tick in + let result_state = Delayed_write_monad.ignore result_state in + return result_state - (* The cache allows cache intermediate states of the PVM in e.g. dissections. *) - module Tick_state_cache = - Aches_lwt.Lache.Make - (Aches.Rache.Transfer - (Aches.Rache.LRU) - (struct - type t = Sc_rollup.Tick.t * Block_hash.t +(* The cache allows cache intermediate states of the PVM in e.g. dissections. *) +module Tick_state_cache = + Aches_lwt.Lache.Make + (Aches.Rache.Transfer + (Aches.Rache.LRU) + (struct + type t = Sc_rollup.Tick.t * Block_hash.t - let equal (t1, b1) (t2, b2) = - Sc_rollup.Tick.(t1 = t2) && Block_hash.(b1 = b2) + let equal (t1, b1) (t2, b2) = + Sc_rollup.Tick.(t1 = t2) && Block_hash.(b1 = b2) - let hash (tick, block) = - ((Sc_rollup.Tick.to_z tick |> Z.hash) * 13) + Block_hash.hash block - end)) + let hash (tick, block) = + ((Sc_rollup.Tick.to_z tick |> Z.hash) * 13) + Block_hash.hash block + end)) - let tick_state_cache = Tick_state_cache.create 64 (* size of 2 dissections *) +let tick_state_cache = Tick_state_cache.create 64 (* size of 2 dissections *) - (* Memoized version of [state_of_tick_aux]. *) - let memo_state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) - tick = - Tick_state_cache.bind_or_put - tick_state_cache - (tick, event.header.block_hash) - (fun (tick, _hash) -> state_of_tick_aux node_ctxt ~start_state event tick) - Lwt.return +(* Memoized version of [state_of_tick_aux]. *) +let memo_state_of_tick_aux node_ctxt ~start_state (event : Sc_rollup_block.t) + tick = + Tick_state_cache.bind_or_put + tick_state_cache + (tick, event.header.block_hash) + (fun (tick, _hash) -> state_of_tick_aux node_ctxt ~start_state event tick) + Lwt.return - (** [state_of_tick node_ctxt ?start_state tick level] returns [Some end_state] +(** [state_of_tick node_ctxt ?start_state tick level] returns [Some end_state] for a given [tick] if this [tick] happened before [level]. Otherwise, returns [None].*) - let state_of_tick node_ctxt ?start_state tick level = - let open Lwt_result_syntax in - let* event = Node_context.block_with_tick node_ctxt ~max_level:level tick in - match event with - | None -> return_none - | Some event -> - assert (Raw_level.(event.header.level <= level)) ; - let* result_state = - if Node_context.is_loser node_ctxt then - (* TODO: https://gitlab.com/tezos/tezos/-/issues/5253 - The failures/loser mode does not work properly when restarting - from intermediate states. *) - state_of_tick_aux node_ctxt ~start_state:None event tick - else memo_state_of_tick_aux node_ctxt ~start_state event tick - in - return_some result_state -end +let state_of_tick node_ctxt ?start_state tick level = + let open Lwt_result_syntax in + let* event = Node_context.block_with_tick node_ctxt ~max_level:level tick in + match event with + | None -> return_none + | Some event -> + assert (Raw_level.(event.header.level <= level)) ; + let* result_state = + if Node_context.is_loser node_ctxt then + (* TODO: https://gitlab.com/tezos/tezos/-/issues/5253 + The failures/loser mode does not work properly when restarting + from intermediate states. *) + state_of_tick_aux node_ctxt ~start_state:None event tick + else memo_state_of_tick_aux node_ctxt ~start_state event tick + in + return_some result_state diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/interpreter.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/interpreter.mli index 99dd231a3ab9..44cabfbbab1e 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/interpreter.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/interpreter.mli @@ -25,51 +25,38 @@ open Protocol.Alpha_context -module type S = sig - module PVM : Pvm.S - - module Accounted_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Accounted.t - - module Free_pvm : - Fueled_pvm.S with module PVM = PVM and type fuel = Fuel.Free.t - - (** [process_head node_ctxt ~predecessor head (inbox, messages)] interprets - the [messages] associated with a [head] (where [predecessor] is the - predecessor of [head] in the L1 chain). This requires the [inbox] to be - updated beforehand. It returns [(ctxt, num_messages, num_ticks, tick)] - where [ctxt] is the updated layer 2 context (with the new PVM state), - [num_messages] is the number of [messages], [num_ticks] is the number of - ticks taken by the PVM for the evaluation and [tick] is the tick reached - by the PVM after the evaluation. *) - val process_head : - Node_context.rw -> - 'a Context.t -> - predecessor:Layer1.header -> - Layer1.header -> - Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> - ('a Context.t * int * int64 * Sc_rollup.Tick.t) tzresult Lwt.t - - (** [state_of_tick node_ctxt ?start_state tick level] returns [Some (state, - hash)] for a given [tick] if this [tick] happened before - [level]. Otherwise, returns [None]. If provided, the evaluation is resumed - from [start_state]. *) - val state_of_tick : - _ Node_context.t -> - ?start_state:Accounted_pvm.eval_state -> - Sc_rollup.Tick.t -> - Raw_level.t -> - Accounted_pvm.eval_state option tzresult Lwt.t - - (** [state_of_head node_ctxt ctxt head] returns the state corresponding to the - block [head], or the state at rollup genesis if the block is before the - rollup origination. *) - val state_of_head : - 'a Node_context.t -> - 'a Context.t -> - Layer1.head -> - ('a Context.t * PVM.state) tzresult Lwt.t -end - -(** Functor to construct an interpreter for a given PVM. *) -module Make (PVM : Pvm.S) : S with module PVM = PVM +(** [process_head node_ctxt ~predecessor head (inbox, messages)] interprets the + [messages] associated with a [head] (where [predecessor] is the predecessor + of [head] in the L1 chain). This requires the [inbox] to be updated + beforehand. It returns [(ctxt, num_messages, num_ticks, tick)] where [ctxt] + is the updated layer 2 context (with the new PVM state), [num_messages] is + the number of [messages], [num_ticks] is the number of ticks taken by the + PVM for the evaluation and [tick] is the tick reached by the PVM after the + evaluation. *) +val process_head : + Node_context.rw -> + 'a Context.t -> + predecessor:Layer1.header -> + Layer1.header -> + Sc_rollup.Inbox.t * Sc_rollup.Inbox_message.t list -> + ('a Context.t * int * int64 * Sc_rollup.Tick.t) tzresult Lwt.t + +(** [state_of_tick node_ctxt ?start_state tick level] returns [Some (state, + hash)] for a given [tick] if this [tick] happened before [level]. Otherwise, + returns [None]. If provided, the evaluation is resumed from + [start_state]. *) +val state_of_tick : + _ Node_context.t -> + ?start_state:Fueled_pvm.Accounted.eval_state -> + Sc_rollup.Tick.t -> + Raw_level.t -> + Fueled_pvm.Accounted.eval_state option tzresult Lwt.t + +(** [state_of_head node_ctxt ctxt head] returns the state corresponding to the + block [head], or the state at rollup genesis if the block is before the + rollup origination. *) +val state_of_head : + 'a Node_context.t -> + 'a Context.t -> + Layer1.head -> + ('a Context.t * Context.tree) tzresult Lwt.t diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/node_context.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/node_context.ml index aea5468a2927..5bfd2bcaddb4 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/node_context.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/node_context.ml @@ -45,6 +45,7 @@ type 'a t = { injector_retention_period : int; block_finality_time : int; kind : Sc_rollup.Kind.t; + pvm : (module Pvm.S); fee_parameters : Configuration.fee_parameters; protocol_constants : Constants.t; loser_mode : Loser_mode.t; @@ -177,6 +178,11 @@ let make_kernel_logger ?log_kernel_debug_file data_dir = in Lwt_io.of_fd ~close:(fun () -> Lwt_unix.close fd) ~mode:Lwt_io.Output fd +let pvm_of_kind : Protocol.Alpha_context.Sc_rollup.Kind.t -> (module Pvm.S) = + function + | Example_arith -> (module Arith_pvm) + | Wasm_2_0_0 -> (module Wasm_2_0_0_pvm) + let check_fee_parameters Configuration.{fee_parameters; _} = let check_value purpose name compare to_string mempool_default value = if compare mempool_default value > 0 then @@ -357,6 +363,7 @@ let init (cctxt : Protocol_client_context.full) ~data_dir ?log_kernel_debug_file lcc = Reference.new_ lcc; lpc = Reference.new_ lpc; kind; + pvm = pvm_of_kind kind; injector_retention_period = 0; block_finality_time = 2; fee_parameters; @@ -995,6 +1002,7 @@ module Internal_for_tests = struct lcc; lpc; kind; + pvm = pvm_of_kind kind; injector_retention_period = 0; block_finality_time = 2; fee_parameters = Configuration.default_fee_parameters; diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/node_context.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/node_context.mli index 335d162f2c86..ccb0969dfee6 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/node_context.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/node_context.mli @@ -58,6 +58,7 @@ type 'a t = { block_finality_time : int; (** Deterministic block finality time for the layer 1 protocol. *) kind : Sc_rollup.Kind.t; (** Kind of the smart rollup. *) + pvm : (module Pvm.S); (** The PVM used by the smart rollup. *) fee_parameters : Configuration.fee_parameters; (** Fee parameters to use when injecting operations in layer 1. *) protocol_constants : Constants.t; diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/outbox.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/outbox.ml index 8b539af74ef6..a76f94397d5e 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/outbox.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/outbox.ml @@ -26,39 +26,38 @@ open Node_context open Protocol.Alpha_context -module Make (PVM : Pvm.S) = struct - let get_state_of_lcc node_ctxt = - let open Lwt_result_syntax in - let lcc = Reference.get node_ctxt.lcc in - let* block_hash = - Node_context.hash_of_level node_ctxt (Raw_level.to_int32 lcc.level) - in - let* ctxt = Node_context.checkout_context node_ctxt block_hash in - let*! state = PVM.State.find ctxt in - return state +let get_state_of_lcc node_ctxt = + let open Lwt_result_syntax in + let lcc = Reference.get node_ctxt.lcc in + let* block_hash = + Node_context.hash_of_level node_ctxt (Raw_level.to_int32 lcc.level) + in + let* ctxt = Node_context.checkout_context node_ctxt block_hash in + let*! state = Context.PVMState.find ctxt in + return state - let proof_of_output node_ctxt output = - let open Lwt_result_syntax in - let* state = get_state_of_lcc node_ctxt in - let lcc = Reference.get node_ctxt.lcc in - match state with - | None -> - (* +let proof_of_output node_ctxt output = + let open Lwt_result_syntax in + let* state = get_state_of_lcc node_ctxt in + let lcc = Reference.get node_ctxt.lcc in + match state with + | None -> + (* This case should never happen as origination creates an LCC which must have been considered by the rollup node at startup time. *) - failwith "Error producing outbox proof (no cemented state in the node)" - | Some state -> ( - let*! proof = PVM.produce_output_proof node_ctxt.context state output in - match proof with - | Ok proof -> - let serialized_proof = - Data_encoding.Binary.to_string_exn PVM.output_proof_encoding proof - in - return @@ (lcc.commitment, serialized_proof) - | Error err -> - failwith - "Error producing outbox proof (%a)" - Environment.Error_monad.pp - err) -end + failwith "Error producing outbox proof (no cemented state in the node)" + | Some state -> ( + let module PVM = (val node_ctxt.pvm) in + let*! proof = PVM.produce_output_proof node_ctxt.context state output in + match proof with + | Ok proof -> + let serialized_proof = + Data_encoding.Binary.to_string_exn PVM.output_proof_encoding proof + in + return @@ (lcc.commitment, serialized_proof) + | Error err -> + failwith + "Error producing outbox proof (%a)" + Environment.Error_monad.pp + err) diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/outbox.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/outbox.mli index 613661e456a7..71e8c4a1f28d 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/outbox.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/outbox.mli @@ -27,11 +27,9 @@ open Protocol.Alpha_context -module Make (PVM : Pvm.S) : sig - (** [proof_of_output node_ctxt output] returns the last cemented commitment - hash and the proof of the output in the LCC. *) - val proof_of_output : - Node_context.rw -> - Sc_rollup.output -> - (Sc_rollup.Commitment.Hash.t * string) tzresult Lwt.t -end +(** [proof_of_output node_ctxt output] returns the last cemented commitment hash + and the proof of the output in the LCC. *) +val proof_of_output : + Node_context.rw -> + Sc_rollup.output -> + (Sc_rollup.Commitment.Hash.t * string) tzresult Lwt.t diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/publisher.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/publisher.ml new file mode 100644 index 000000000000..7265d13488f5 --- /dev/null +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/publisher.ml @@ -0,0 +1,521 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 TriliTech *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +(** The rollup node stores and publishes commitments for the PVM every + [Constants.sc_rollup_commitment_period_in_blocks] levels. + + Every time a finalized block is processed by the rollup node, the latter + determines whether the last commitment that the node has produced referred + to [sc_rollup.commitment_period_in_blocks] blocks earlier. For mainnet, + [sc_rollup.commitment_period_in_blocks = 30]. In this case, it computes and + stores a new commitment in a level-indexed map. + + Stored commitments are signed by the rollup node operator + and published on the layer1 chain. To ensure that commitments + produced by the rollup node are eventually published, + storing and publishing commitments are decoupled. Every time + a new head is processed, the node tries to publish the oldest + commitment that was not published already. +*) + +open Protocol +open Alpha_context +open Publisher_worker_types + +module Lwt_result_option_syntax = struct + let ( let** ) a f = + let open Lwt_result_syntax in + let* a in + match a with None -> return_none | Some a -> f a +end + +module Lwt_result_option_list_syntax = struct + (** A small monadic combinator to return an empty list on None results. *) + let ( let*& ) x f = + let open Lwt_result_syntax in + let* x in + match x with None -> return_nil | Some x -> f x +end + +let add_level level increment = + (* We only use this function with positive increments so it is safe *) + if increment < 0 then invalid_arg "Commitment.add_level negative increment" ; + Raw_level.Internal_for_tests.add level increment + +let sub_level level decrement = + (* We only use this function with positive increments so it is safe *) + if decrement < 0 then invalid_arg "Commitment.sub_level negative decrement" ; + Raw_level.Internal_for_tests.sub level decrement + +let sc_rollup_commitment_period node_ctxt = + node_ctxt.Node_context.protocol_constants.parametric.sc_rollup + .commitment_period_in_blocks + +let sc_rollup_challenge_window node_ctxt = + node_ctxt.Node_context.protocol_constants.parametric.sc_rollup + .challenge_window_in_blocks + +let next_commitment_level node_ctxt last_commitment_level = + add_level last_commitment_level (sc_rollup_commitment_period node_ctxt) + +type state = Node_context.ro + +let tick_of_level (node_ctxt : _ Node_context.t) inbox_level = + let open Lwt_result_syntax in + let* block = + Node_context.get_l2_block_by_level + node_ctxt + (Raw_level.to_int32 inbox_level) + in + return (Sc_rollup_block.final_tick block) + +let build_commitment (node_ctxt : _ Node_context.t) + (prev_commitment : Sc_rollup.Commitment.Hash.t) ~prev_commitment_level + ~inbox_level ctxt = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! pvm_state = PVM.State.find ctxt in + let*? pvm_state = + match pvm_state with + | Some pvm_state -> Ok pvm_state + | None -> + error_with + "PVM state for commitment at level %a is not available" + Raw_level.pp + inbox_level + in + let*! compressed_state = PVM.state_hash pvm_state in + let*! tick = PVM.get_tick pvm_state in + let* prev_commitment_tick = tick_of_level node_ctxt prev_commitment_level in + let number_of_ticks = + Sc_rollup.Tick.distance tick prev_commitment_tick + |> Z.to_int64 |> Sc_rollup.Number_of_ticks.of_value + in + let*? number_of_ticks = + match number_of_ticks with + | Some number_of_ticks -> + if number_of_ticks = Sc_rollup.Number_of_ticks.zero then + error_with "A 0-tick commitment is impossible" + else Ok number_of_ticks + | None -> error_with "Invalid number of ticks for commitment" + in + return + Sc_rollup.Commitment. + { + predecessor = prev_commitment; + inbox_level; + number_of_ticks; + compressed_state; + } + +let genesis_commitment (node_ctxt : _ Node_context.t) ctxt = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! pvm_state = PVM.State.find ctxt in + let*? pvm_state = + match pvm_state with + | Some pvm_state -> Ok pvm_state + | None -> error_with "PVM state for genesis commitment is not available" + in + let*! compressed_state = PVM.state_hash pvm_state in + let commitment = + Sc_rollup.Commitment. + { + predecessor = Hash.zero; + inbox_level = node_ctxt.genesis_info.level; + number_of_ticks = Sc_rollup.Number_of_ticks.zero; + compressed_state; + } + in + (* Ensure the initial state corresponds to the one of the rollup's in the + protocol. A mismatch is possible if a wrong external boot sector was + provided. *) + let commitment_hash = Sc_rollup.Commitment.hash_uncarbonated commitment in + let+ () = + fail_unless + Sc_rollup.Commitment.Hash.( + commitment_hash = node_ctxt.genesis_info.commitment_hash) + (Sc_rollup_node_errors.Invalid_genesis_state + { + expected = node_ctxt.genesis_info.commitment_hash; + actual = commitment_hash; + }) + in + commitment + +let create_commitment_if_necessary (node_ctxt : _ Node_context.t) ~predecessor + current_level ctxt = + let open Lwt_result_syntax in + if Raw_level.(current_level = node_ctxt.genesis_info.level) then + let*! () = Commitment_event.compute_commitment current_level in + let+ genesis_commitment = genesis_commitment node_ctxt ctxt in + Some genesis_commitment + else + let* last_commitment_hash = + let+ pred = Node_context.get_l2_block node_ctxt predecessor in + Sc_rollup_block.most_recent_commitment pred.header + in + let* last_commitment = + Node_context.get_commitment node_ctxt last_commitment_hash + in + let next_commitment_level = + next_commitment_level node_ctxt last_commitment.inbox_level + in + if Raw_level.(current_level = next_commitment_level) then + let*! () = Commitment_event.compute_commitment current_level in + let+ commitment = + build_commitment + node_ctxt + last_commitment_hash + ~prev_commitment_level:last_commitment.inbox_level + ~inbox_level:current_level + ctxt + in + Some commitment + else return_none + +let process_head (node_ctxt : _ Node_context.t) ~predecessor + Layer1.{level; header = _; _} ctxt = + let open Lwt_result_syntax in + let current_level = Raw_level.of_int32_exn level in + let* commitment = + create_commitment_if_necessary node_ctxt ~predecessor current_level ctxt + in + match commitment with + | None -> return_none + | Some commitment -> + let* commitment_hash = + Node_context.save_commitment node_ctxt commitment + in + return_some commitment_hash + +let missing_commitments (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let lpc_level = + match Reference.get node_ctxt.lpc with + | None -> node_ctxt.genesis_info.level + | Some lpc -> lpc.inbox_level + in + let* head = Node_context.last_processed_head_opt node_ctxt in + let next_head_level = + Option.map + (fun (b : Sc_rollup_block.t) -> Raw_level.succ b.header.level) + head + in + let sc_rollup_challenge_window_int32 = + sc_rollup_challenge_window node_ctxt |> Int32.of_int + in + let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = + let* commitment = Node_context.find_commitment node_ctxt commitment_hash in + let lcc = Reference.get node_ctxt.lcc in + match commitment with + | None -> return acc + | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> + (* Commitment is before or at the LCC, we have reached the end. *) + return acc + | Some commitment when Raw_level.(commitment.inbox_level <= lpc_level) -> + (* Commitment is before the last published one, we have also reached + the end because we only publish commitments that are for the inbox + of a finalized L1 block. *) + return acc + | Some commitment -> + let* published_info = + Node_context.commitment_published_at_level node_ctxt commitment_hash + in + let past_curfew = + match (published_info, next_head_level) with + | None, _ | _, None -> false + | Some {first_published_at_level; _}, Some next_head_level -> + Raw_level.diff next_head_level first_published_at_level + > sc_rollup_challenge_window_int32 + in + let acc = if past_curfew then acc else commitment :: acc in + (* We keep the commitment and go back to the previous one. *) + gather acc commitment.predecessor + in + let* finalized_block = Node_context.get_finalized_head_opt node_ctxt in + match finalized_block with + | None -> return_nil + | Some finalized -> + (* Start from finalized block's most recent commitment and gather all + commitments that are missing. *) + let commitment = + Sc_rollup_block.most_recent_commitment finalized.header + in + gather [] commitment + +let publish_commitment (node_ctxt : _ Node_context.t) ~source + (commitment : Sc_rollup.Commitment.t) = + let open Lwt_result_syntax in + let publish_operation = + L1_operation.Publish {rollup = node_ctxt.rollup_address; commitment} + in + let*! () = + Commitment_event.publish_commitment + (Sc_rollup.Commitment.hash_uncarbonated commitment) + commitment.inbox_level + in + let* _hash = Injector.add_pending_operation ~source publish_operation in + return_unit + +let on_publish_commitments (node_ctxt : state) = + let open Lwt_result_syntax in + let operator = Node_context.get_operator node_ctxt Publish in + if Node_context.is_accuser node_ctxt then + (* Accuser does not publish all commitments *) + return_unit + else + match operator with + | None -> + (* Configured to not publish commitments *) + return_unit + | Some source -> + let* commitments = missing_commitments node_ctxt in + List.iter_es (publish_commitment node_ctxt ~source) commitments + +let publish_single_commitment node_ctxt (commitment : Sc_rollup.Commitment.t) = + let open Lwt_result_syntax in + let operator = Node_context.get_operator node_ctxt Publish in + let lcc = Reference.get node_ctxt.lcc in + match operator with + | None -> + (* Configured to not publish commitments *) + return_unit + | Some source -> + when_ (commitment.inbox_level > lcc.level) @@ fun () -> + publish_commitment node_ctxt ~source commitment + +(* Commitments can only be cemented after [sc_rollup_challenge_window] has + passed since they were first published. *) +let earliest_cementing_level node_ctxt commitment_hash = + let open Lwt_result_option_syntax in + let** {first_published_at_level; _} = + Node_context.commitment_published_at_level node_ctxt commitment_hash + in + return_some + @@ add_level first_published_at_level (sc_rollup_challenge_window node_ctxt) + +(** [latest_cementable_commitment node_ctxt head] is the most recent commitment + hash that could be cemented in [head]'s successor if: + + - all its predecessors were cemented + - it would have been first published at the same level as its inbox + + It does not need to be exact but it must be an upper bound on which we can + start the search for cementable commitments. *) +let latest_cementable_commitment (node_ctxt : _ Node_context.t) + (head : Sc_rollup_block.t) = + let open Lwt_result_option_syntax in + let commitment_hash = Sc_rollup_block.most_recent_commitment head.header in + let** commitment = Node_context.find_commitment node_ctxt commitment_hash in + let** cementable_level_bound = + return + @@ sub_level commitment.inbox_level (sc_rollup_challenge_window node_ctxt) + in + let lcc = Reference.get node_ctxt.lcc in + if Raw_level.(cementable_level_bound <= lcc.level) then return_none + else + let** cementable_bound_block = + Node_context.find_l2_block_by_level + node_ctxt + (Raw_level.to_int32 cementable_level_bound) + in + let cementable_commitment = + Sc_rollup_block.most_recent_commitment cementable_bound_block.header + in + return_some cementable_commitment + +let cementable_commitments (node_ctxt : _ Node_context.t) = + let open Lwt_result_syntax in + let open Lwt_result_option_list_syntax in + let*& head = Node_context.last_processed_head_opt node_ctxt in + let head_level = head.header.level in + let lcc = Reference.get node_ctxt.lcc in + let rec gather acc (commitment_hash : Sc_rollup.Commitment.Hash.t) = + let* commitment = Node_context.find_commitment node_ctxt commitment_hash in + match commitment with + | None -> return acc + | Some commitment when Raw_level.(commitment.inbox_level <= lcc.level) -> + (* If we have moved backward passed or at the current LCC then we have + reached the end. *) + return acc + | Some commitment -> + let* earliest_cementing_level = + earliest_cementing_level node_ctxt commitment_hash + in + let acc = + match earliest_cementing_level with + | None -> acc + | Some earliest_cementing_level -> + if Raw_level.(earliest_cementing_level > head_level) then + (* Commitments whose cementing level are after the head's + successor won't be cementable in the next block. *) + acc + else commitment_hash :: acc + in + gather acc commitment.predecessor + in + (* We start our search from the last possible cementable commitment. This is + to avoid iterating over a large number of commitments + ([challenge_window_in_blocks / commitment_period_in_blocks], in the order + of 10^3 on mainnet). *) + let*& latest_cementable_commitment = + latest_cementable_commitment node_ctxt head + in + let* cementable = gather [] latest_cementable_commitment in + match cementable with + | [] -> return_nil + | first_cementable :: _ -> + (* Make sure that the first commitment can be cemented according to the + Layer 1 node as a failsafe. *) + let* green_light = + Plugin.RPC.Sc_rollup.can_be_cemented + node_ctxt.cctxt + (node_ctxt.cctxt#chain, `Head 0) + node_ctxt.rollup_address + first_cementable + in + if green_light then return cementable else return_nil + +let cement_commitment (node_ctxt : _ Node_context.t) ~source commitment_hash = + let open Lwt_result_syntax in + let cement_operation = + L1_operation.Cement + {rollup = node_ctxt.rollup_address; commitment = commitment_hash} + in + let* _hash = Injector.add_pending_operation ~source cement_operation in + return_unit + +let on_cement_commitments (node_ctxt : state) = + let open Lwt_result_syntax in + let operator = Node_context.get_operator node_ctxt Cement in + match operator with + | None -> + (* Configured to not cement commitments *) + return_unit + | Some source -> + let* cementable_commitments = cementable_commitments node_ctxt in + List.iter_es (cement_commitment node_ctxt ~source) cementable_commitments + +module Types = struct + type nonrec state = state + + type parameters = {node_ctxt : Node_context.ro} +end + +module Name = struct + (* We only have a single committer in the node *) + type t = unit + + let encoding = Data_encoding.unit + + let base = Commitment_event.section @ ["publisher"] + + let pp _ _ = () + + let equal () () = true +end + +module Worker = Worker.MakeSingle (Name) (Request) (Types) + +type worker = Worker.infinite Worker.queue Worker.t + +module Handlers = struct + type self = worker + + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with + | Request.Publish -> protect @@ fun () -> on_publish_commitments state + | Request.Cement -> protect @@ fun () -> on_cement_commitments state + + type launch_error = error trace + + let on_launch _w () Types.{node_ctxt} = return node_ctxt + + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = + let open Lwt_result_syntax in + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Commitment_event.Publisher.request_failed request_view st errs + in + return_unit + in + match r with + | Request.Publish -> emit_and_return_errors errs + | Request.Cement -> emit_and_return_errors errs + + let on_completion _w r _ st = + Commitment_event.Publisher.request_completed (Request.view r) st + + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit +end + +let table = Worker.create_table Queue + +let worker_promise, worker_waker = Lwt.task () + +let init node_ctxt = + let open Lwt_result_syntax in + let*! () = Commitment_event.starting () in + let node_ctxt = Node_context.readonly node_ctxt in + let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in + Lwt.wakeup worker_waker worker + +(* This is a publisher worker for a single scoru *) +let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> error Sc_rollup_node_errors.No_publisher) + +let publish_commitments () = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w Request.Publish in + return_unit + +let cement_commitments () = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w Request.Cement in + return_unit + +let shutdown () = + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no publisher, nothing to do *) + Lwt.return_unit + | Ok w -> Worker.shutdown w diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/commitment.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/publisher.mli similarity index 56% rename from src/proto_016_PtMumbai/lib_sc_rollup_node/commitment.mli rename to src/proto_016_PtMumbai/lib_sc_rollup_node/publisher.mli index cb6c364d87cd..79990b2198ad 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/commitment.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/publisher.mli @@ -24,12 +24,13 @@ (*****************************************************************************) (** The rollup node stores and publishes commitments for the PVM - every 20 levels. + every `Commitment.sc_rollup_commitment_period` levels. Every time a finalized block is processed by the rollup node, the latter determines whether the last commitment that the node - has produced referred to 20 blocks earlier. In this case, it - computes and stores a new commitment in a level-indexed map. + has produced referred to `Commitment.sc_rollup_commitment_period` blocks + earlier. In this case, it computes and stores a new commitment in a + level-indexed map. Stored commitments are signed by the rollup node operator and published on the layer1 chain. To ensure that commitments @@ -39,4 +40,40 @@ commitment that was not published already. *) -module Make (PVM : Pvm.S) : Commitment_sig.S with module PVM = PVM +(** [process_head node_ctxt ~predecessor head ctxt] builds a new commitment if + needed, by looking at the level of [head] and checking whether it is a + multiple of `Commitment.sc_rollup_commitment_period` levels away from + [node_ctxt.initial_level]. It uses the functionalities of [PVM] to compute + the hash of to be included in the commitment. *) +val process_head : + Node_context.rw -> + predecessor:Block_hash.t -> + Layer1.header -> + Context.rw -> + Protocol.Alpha_context.Sc_rollup.Commitment.Hash.t option tzresult Lwt.t + +(** [publish_single_commitment node_ctxt commitment] publishes a single + [commitment] if it is missing. This function is meant to be used by the {e + accuser} mode to sparingly publish commitments when it detects a + conflict. *) +val publish_single_commitment : + _ Node_context.t -> + Protocol.Alpha_context.Sc_rollup.Commitment.t -> + unit tzresult Lwt.t + +(** Initialize worker for publishing and cementing commitments. *) +val init : _ Node_context.t -> unit tzresult Lwt.t + +(** [publish_commitments node_ctxt] publishes the commitments that were not yet + published up to the finalized head and which are after the last cemented + commitment. *) +val publish_commitments : unit -> unit tzresult Lwt.t + +(** [cement_commitments node_ctxt] cements the commitments that can be cemented, + i.e. the commitments that are after the current last cemented commitment and + which have [sc_rollup_challenge_period] levels on top of them since they + were originally published. *) +val cement_commitments : unit -> unit tzresult Lwt.t + +(** Stop worker for publishing and cementing commitments. *) +val shutdown : unit -> unit Lwt.t diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/pvm.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/pvm.ml index ca8e5769b9f6..13917d6c8b45 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/pvm.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/pvm.ml @@ -32,6 +32,7 @@ module type S = sig include Sc_rollup.PVM.S with type context = Context.rw_index + and type state = Context.tree and type hash = Sc_rollup.State_hash.t (** Kind of the PVM (same as {!name}). *) @@ -69,11 +70,6 @@ module type S = sig our_stop_chunk:Sc_rollup.Dissection_chunk.t -> Sc_rollup.Tick.t list - module RPC : sig - (** Build RPC directory of the PVM *) - val build_directory : Node_context.rw -> unit Environment.RPC_directory.t - end - (** State storage for this PVM. *) module State : sig (** [empty ()] is the empty state. *) diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/components.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/pvm_rpc.ml similarity index 72% rename from src/proto_016_PtMumbai/lib_sc_rollup_node/components.ml rename to src/proto_016_PtMumbai/lib_sc_rollup_node/pvm_rpc.ml index 1d5b8c0984fa..06c5c60b5e51 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/components.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/pvm_rpc.ml @@ -1,8 +1,7 @@ (*****************************************************************************) (* *) (* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs, *) -(* Copyright (c) 2022 Trili Tech, *) +(* Copyright (c) 2023 Functori, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -24,17 +23,18 @@ (* *) (*****************************************************************************) -module Make (PVM : Pvm.S) = struct - module PVM = PVM - module Interpreter = Interpreter.Make (PVM) - module Commitment = Commitment.Make (PVM) - module Simulation = Simulation.Make (Interpreter) - module Refutation_coordinator = Refutation_coordinator.Make (Interpreter) - module Batcher = Batcher.Make (Simulation) - module RPC_server = RPC_server.Make (Simulation) (Batcher) +module type S = sig + (** Build RPC directory of the PVM *) + val build_directory : Node_context.rw -> unit Environment.RPC_directory.t end -let pvm_of_kind : Protocol.Alpha_context.Sc_rollup.Kind.t -> (module Pvm.S) = - function - | Example_arith -> (module Arith_pvm) - | Wasm_2_0_0 -> (module Wasm_2_0_0_pvm) +module No_rpc = struct + let build_directory _node_ctxt = Tezos_rpc.Directory.empty +end + +let no_rpc = (module No_rpc : S) + +let of_kind = function + | Protocol.Alpha_context.Sc_rollup.Kind.Example_arith -> no_rpc + | Wasm_2_0_0 -> + (module Wasm_2_0_0_rpc.Make_RPC (Wasm_2_0_0_pvm.Durable_state) : S) diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_coordinator.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_coordinator.ml index 183553ddda91..b841d2e7353c 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_coordinator.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_coordinator.ml @@ -26,223 +26,195 @@ open Protocol open Alpha_context open Refutation_coordinator_types +include Refutation_game +module Player = Refutation_player +module Pkh_map = Signature.Public_key_hash.Map +module Pkh_table = Signature.Public_key_hash.Table + +type state = {node_ctxt : Node_context.rw; pending_opponents : unit Pkh_table.t} + +let get_conflicts cctxt head_block = + Plugin.RPC.Sc_rollup.conflicts cctxt (cctxt#chain, head_block) + +let get_ongoing_games cctxt head_block = + Plugin.RPC.Sc_rollup.ongoing_refutation_games cctxt (cctxt#chain, head_block) + +let untracked_conflicts opponent_players conflicts = + List.filter + (fun conflict -> + not + @@ Pkh_map.mem + conflict.Sc_rollup.Refutation_storage.other + opponent_players) + conflicts + +(* Transform the list of ongoing games [(Game.t * pkh * pkh) list] + into a mapping from opponents' pkhs to their corresponding game + state. +*) +let make_game_map self ongoing_games = + List.fold_left + (fun acc (game, alice, bob) -> + let opponent_pkh = + if Signature.Public_key_hash.equal self alice then bob else alice + in + Pkh_map.add opponent_pkh game acc) + Pkh_map.empty + ongoing_games + +let on_process Layer1.{hash; level} state = + let node_ctxt = state.node_ctxt in + let head_block = `Hash (hash, 0) in + let open Lwt_result_syntax in + let refute_signer = Node_context.get_operator node_ctxt Refute in + match refute_signer with + | None -> + (* Not injecting refutations, don't play refutation games *) + return_unit + | Some self -> + let Node_context.{rollup_address; cctxt; _} = node_ctxt in + (* Current conflicts in L1 *) + let* conflicts = get_conflicts cctxt head_block rollup_address self in + (* Map of opponents the node is playing against to the corresponding + player worker *) + let opponent_players = + Pkh_map.of_seq @@ List.to_seq @@ Player.current_games () + in + (* Conflicts for which we need to start new refutation players. + Some of these might be ongoing. *) + let new_conflicts = untracked_conflicts opponent_players conflicts in + (* L1 ongoing games *) + let* ongoing_games = + get_ongoing_games cctxt head_block rollup_address self + in + (* Map between opponents and their corresponding games *) + let ongoing_game_map = make_game_map self ongoing_games in + (* Launch new players for new conflicts, and play one step *) + let* () = + List.iter_ep + (fun conflict -> + let other = conflict.Sc_rollup.Refutation_storage.other in + Pkh_table.replace state.pending_opponents other () ; + let game = Pkh_map.find_opt other ongoing_game_map in + Player.init_and_play node_ctxt ~self ~conflict ~game ~level) + new_conflicts + in + let*! () = + (* Play one step of the refutation game in every remaining player *) + Pkh_map.iter_p + (fun opponent worker -> + match Pkh_map.find opponent ongoing_game_map with + | Some game -> + Pkh_table.remove state.pending_opponents opponent ; + Player.play worker game ~level + | None -> + (* Kill finished players: those who don't aren't + playing against pending opponents that don't have + ongoing games in the L1 *) + if not @@ Pkh_table.mem state.pending_opponents opponent then + Player.shutdown worker + else Lwt.return_unit) + opponent_players + in + return_unit + +module Types = struct + type nonrec state = state + + type parameters = {node_ctxt : Node_context.rw} +end + +module Name = struct + (* We only have a single coordinator in the node *) + type t = unit -module type S = sig - module PVM : Pvm.S + let encoding = Data_encoding.unit - val init : Node_context.rw -> unit tzresult Lwt.t + let base = + (* But we can have multiple instances in the unit tests. This is just to + avoid conflicts in the events declarations. *) + Refutation_game_event.Coordinator.section @ ["worker"] - val process : Layer1.head -> unit tzresult Lwt.t + let pp _ _ = () - val shutdown : unit -> unit Lwt.t + let equal () () = true end -(* Count instances of the coordinator functor to allow for multiple - worker events without conflicts. *) -let instances_count = ref 0 - -module Make (Interpreter : Interpreter.S) = struct - include Refutation_game.Make (Interpreter) - module Player = Refutation_player.Make (Interpreter) - module Pkh_map = Signature.Public_key_hash.Map - module Pkh_table = Signature.Public_key_hash.Table - - let () = incr instances_count - - type state = { - node_ctxt : Node_context.rw; - pending_opponents : unit Pkh_table.t; - } - - let get_conflicts cctxt head_block = - Plugin.RPC.Sc_rollup.conflicts cctxt (cctxt#chain, head_block) - - let get_ongoing_games cctxt head_block = - Plugin.RPC.Sc_rollup.ongoing_refutation_games cctxt (cctxt#chain, head_block) - - let untracked_conflicts opponent_players conflicts = - List.filter - (fun conflict -> - not - @@ Pkh_map.mem - conflict.Sc_rollup.Refutation_storage.other - opponent_players) - conflicts - - (* Transform the list of ongoing games [(Game.t * pkh * pkh) list] - into a mapping from opponents' pkhs to their corresponding game - state. - *) - let make_game_map self ongoing_games = - List.fold_left - (fun acc (game, alice, bob) -> - let opponent_pkh = - if Signature.Public_key_hash.equal self alice then bob else alice - in - Pkh_map.add opponent_pkh game acc) - Pkh_map.empty - ongoing_games - - let on_process Layer1.{hash; level} state = - let node_ctxt = state.node_ctxt in - let head_block = `Hash (hash, 0) in - let open Lwt_result_syntax in - let refute_signer = Node_context.get_operator node_ctxt Refute in - match refute_signer with - | None -> - (* Not injecting refutations, don't play refutation games *) - return_unit - | Some self -> - let Node_context.{rollup_address; cctxt; _} = node_ctxt in - (* Current conflicts in L1 *) - let* conflicts = get_conflicts cctxt head_block rollup_address self in - (* Map of opponents the node is playing against to the corresponding - player worker *) - let opponent_players = - Pkh_map.of_seq @@ List.to_seq @@ Player.current_games () - in - (* Conflicts for which we need to start new refutation players. - Some of these might be ongoing. *) - let new_conflicts = untracked_conflicts opponent_players conflicts in - (* L1 ongoing games *) - let* ongoing_games = - get_ongoing_games cctxt head_block rollup_address self - in - (* Map between opponents and their corresponding games *) - let ongoing_game_map = make_game_map self ongoing_games in - (* Launch new players for new conflicts, and play one step *) - let* () = - List.iter_ep - (fun conflict -> - let other = conflict.Sc_rollup.Refutation_storage.other in - Pkh_table.replace state.pending_opponents other () ; - let game = Pkh_map.find_opt other ongoing_game_map in - Player.init_and_play node_ctxt ~self ~conflict ~game ~level) - new_conflicts - in - let*! () = - (* Play one step of the refutation game in every remaining player *) - Pkh_map.iter_p - (fun opponent worker -> - match Pkh_map.find opponent ongoing_game_map with - | Some game -> - Pkh_table.remove state.pending_opponents opponent ; - Player.play worker game ~level - | None -> - (* Kill finished players: those who don't aren't - playing against pending opponents that don't have - ongoing games in the L1 *) - if not @@ Pkh_table.mem state.pending_opponents opponent then - Player.shutdown worker - else Lwt.return_unit) - opponent_players - in - return_unit - - module Types = struct - type nonrec state = state - - type parameters = {node_ctxt : Node_context.rw} - end - - module Name = struct - (* We only have a single coordinator in the node *) - type t = unit - - let encoding = Data_encoding.unit - - let base = - (* But we can have multiple instances in the unit tests. This is just to - avoid conflicts in the events declarations. *) - Refutation_game_event.Coordinator.section - @ [ - ("worker" - ^ if !instances_count = 1 then "" else string_of_int !instances_count - ); - ] - - let pp _ _ = () - - let equal () () = true - end - - module Worker = Worker.MakeSingle (Name) (Request) (Types) - - type worker = Worker.infinite Worker.queue Worker.t - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with Request.Process b -> on_process b state - - type launch_error = error trace - - let on_launch _w () Types.{node_ctxt} = - return {node_ctxt; pending_opponents = Pkh_table.create 5} - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Refutation_game_event.Coordinator.request_failed request_view st errs - in - return_unit - in - match r with Request.Process _ -> emit_and_return_errors errs +module Worker = Worker.MakeSingle (Name) (Request) (Types) - let on_completion _w r _ st = - Refutation_game_event.Coordinator.request_completed (Request.view r) st +type worker = Worker.infinite Worker.queue Worker.t - let on_no_request _ = Lwt.return_unit +module Handlers = struct + type self = worker - let on_close _w = Lwt.return_unit - end + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with Request.Process b -> on_process b state - let table = Worker.create_table Queue + type launch_error = error trace - let worker_promise, worker_waker = Lwt.task () + let on_launch _w () Types.{node_ctxt} = + return {node_ctxt; pending_opponents = Pkh_table.create 5} - let init node_ctxt = - let open Lwt_result_syntax in - let*! () = Refutation_game_event.Coordinator.starting () in - let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in - Lwt.wakeup worker_waker worker - - (* This is a refutation coordinator for a single scoru *) - let worker = - lazy - (match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> - error Sc_rollup_node_errors.No_refutation_coordinator) - - let process b = + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let*? w = Lazy.force worker in - let*! (_pushed : bool) = Worker.Queue.push_request w (Request.Process b) in - return_unit - - let shutdown () = - let open Lwt_syntax in - let w = Lazy.force worker in - match w with - | Error _ -> - (* There is no refutation coordinator, nothing to do *) - Lwt.return_unit - | Ok w -> - (* Shut down all current refutation players *) - let games = Player.current_games () in - let* () = - List.iter_s (fun (_opponent, player) -> Player.shutdown player) games - in - Worker.shutdown w + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Refutation_game_event.Coordinator.request_failed request_view st errs + in + return_unit + in + match r with Request.Process _ -> emit_and_return_errors errs + + let on_completion _w r _ st = + Refutation_game_event.Coordinator.request_completed (Request.view r) st + + let on_no_request _ = Lwt.return_unit + + let on_close _w = Lwt.return_unit end + +let table = Worker.create_table Queue + +let worker_promise, worker_waker = Lwt.task () + +let init node_ctxt = + let open Lwt_result_syntax in + let*! () = Refutation_game_event.Coordinator.starting () in + let+ worker = Worker.launch table () {node_ctxt} (module Handlers) in + Lwt.wakeup worker_waker worker + +(* This is a refutation coordinator for a single scoru *) +let worker = + lazy + (match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> + error Sc_rollup_node_errors.No_refutation_coordinator) + +let process b = + let open Lwt_result_syntax in + let*? w = Lazy.force worker in + let*! (_pushed : bool) = Worker.Queue.push_request w (Request.Process b) in + return_unit + +let shutdown () = + let open Lwt_syntax in + let w = Lazy.force worker in + match w with + | Error _ -> + (* There is no refutation coordinator, nothing to do *) + Lwt.return_unit + | Ok w -> + (* Shut down all current refutation players *) + let games = Player.current_games () in + let* () = + List.iter_s (fun (_opponent, player) -> Player.shutdown player) games + in + Worker.shutdown w diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_coordinator.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_coordinator.mli index ca17d1eb19ab..12a35582b9b2 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_coordinator.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_coordinator.mli @@ -29,25 +29,19 @@ the refutation game players. (See {!Refutation_player}). *) -module type S = sig - module PVM : Pvm.S +(** Initiatilize the refuation coordinator. *) +val init : Node_context.rw -> unit tzresult Lwt.t - (** Initiatilize the refuation coordinator. *) - val init : Node_context.rw -> unit tzresult Lwt.t - - (** Process a new l1 head. This means that the coordinator will: - {ol - {li Gather all existing conflicts} - {li Launch new refutation players for each conflict that doesn't - have a player in this node} - {li Kill all players whose conflict has disappeared from L1} - {li Make all players play a step in the refutation} - } +(** Process a new l1 head. This means that the coordinator will: + {ol + {li Gather all existing conflicts} + {li Launch new refutation players for each conflict that doesn't + have a player in this node} + {li Kill all players whose conflict has disappeared from L1} + {li Make all players play a step in the refutation} + } *) - val process : Layer1.head -> unit tzresult Lwt.t - - (** Shutdown the refutation coordinator. *) - val shutdown : unit -> unit Lwt.t -end +val process : Layer1.head -> unit tzresult Lwt.t -module Make (Interpreter : Interpreter.S) : S +(** Shutdown the refutation coordinator. *) +val shutdown : unit -> unit Lwt.t diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_game.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_game.ml index 88ee48f9c02d..04948c246cf4 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_game.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_game.ml @@ -45,489 +45,457 @@ open Protocol open Alpha_context - -module type S = sig - module PVM : Pvm.S - - val play_opening_move : - [< `Read | `Write > `Read] Node_context.t -> - public_key_hash -> - Sc_rollup.Refutation_storage.conflict -> - (unit, tztrace) result Lwt.t - - val play : - Node_context.rw -> - self:public_key_hash -> - Sc_rollup.Game.t -> - public_key_hash -> - (unit, tztrace) result Lwt.t -end - -module Make (Interpreter : Interpreter.S) : - S with module PVM = Interpreter.PVM = struct - module PVM = Interpreter.PVM - open Sc_rollup.Game - - let node_role ~self Sc_rollup.Game.Index.{alice; bob} = - if Sc_rollup.Staker.equal alice self then Alice - else if Sc_rollup.Staker.equal bob self then Bob - else (* By validity of [ongoing_game] RPC. *) - assert false - - type role = Our_turn of {opponent : public_key_hash} | Their_turn - - let turn ~self game players = - let Sc_rollup.Game.Index.{alice; bob} = players in - match (node_role ~self players, game.turn) with - | Alice, Alice -> Our_turn {opponent = bob} - | Bob, Bob -> Our_turn {opponent = alice} - | Alice, Bob -> Their_turn - | Bob, Alice -> Their_turn - - (** [inject_next_move node_ctxt source ~refutation ~opponent ~commitment - ~opponent_commitment] submits an L1 operation (signed by [source]) to - issue the next move in the refutation game. *) - let inject_next_move node_ctxt source ~refutation ~opponent = - let open Lwt_result_syntax in - let refute_operation = - L1_operation.Refute - {rollup = node_ctxt.Node_context.rollup_address; refutation; opponent} - in - let* _hash = Injector.add_pending_operation ~source refute_operation in - return_unit - - (** This function computes the inclusion/membership proof of the page +open Sc_rollup.Game + +let node_role ~self Sc_rollup.Game.Index.{alice; bob} = + if Sc_rollup.Staker.equal alice self then Alice + else if Sc_rollup.Staker.equal bob self then Bob + else (* By validity of [ongoing_game] RPC. *) + assert false + +type role = Our_turn of {opponent : public_key_hash} | Their_turn + +let turn ~self game players = + let Sc_rollup.Game.Index.{alice; bob} = players in + match (node_role ~self players, game.turn) with + | Alice, Alice -> Our_turn {opponent = bob} + | Bob, Bob -> Our_turn {opponent = alice} + | Alice, Bob -> Their_turn + | Bob, Alice -> Their_turn + +(** [inject_next_move node_ctxt source ~refutation ~opponent ~commitment + ~opponent_commitment] submits an L1 operation (signed by [source]) to issue + the next move in the refutation game. *) +let inject_next_move node_ctxt source ~refutation ~opponent = + let open Lwt_result_syntax in + let refute_operation = + L1_operation.Refute + {rollup = node_ctxt.Node_context.rollup_address; refutation; opponent} + in + let* _hash = Injector.add_pending_operation ~source refute_operation in + return_unit + +(** This function computes the inclusion/membership proof of the page identified by [page_id] in the slot whose data are provided in [slot_data]. *) - let page_membership_proof params page_index slot_data = - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4048 - Rely on DAL node to compute page membership proof and drop - the dal-crypto dependency from the rollup node. *) - let proof = - let open Result_syntax in - (* The computation of the page's proof below can be a bit costly. In fact, - it involves initialising a cryptobox environment and some non-trivial - crypto processing. *) - let* dal = Cryptobox.make params in - let* polynomial = Cryptobox.polynomial_from_slot dal slot_data in - Cryptobox.prove_page dal polynomial page_index - in - let open Lwt_result_syntax in - match proof with - | Ok proof -> return proof - | Error e -> - failwith - "%s" - (match e with - | `Fail s -> "Fail " ^ s - | `Page_index_out_of_range -> "Page_index_out_of_range" - | `Slot_wrong_size s -> "Slot_wrong_size: " ^ s - | `Invalid_degree_strictly_less_than_expected _ as commit_error -> - Cryptobox.string_of_commit_error commit_error) - - (** When the PVM is waiting for a Dal page input, this function attempts to - retrieve the page's content from the store, the data of its slot. Then it - computes the proof that the page is part of the slot and returns the - content along with the proof. - - If the PVM is not waiting for a Dal page input, or if the slot is known to - be unconfirmed on L1, this function returns [None]. If the data of the - slot are not saved to the store, the function returns a failure - in the error monad. *) - let page_info_from_pvm_state node_ctxt ~dal_attestation_lag - (dal_params : Dal.parameters) start_state = - let open Lwt_result_syntax in - let*! input_request = PVM.is_input_state start_state in - match input_request with - | Sc_rollup.(Needs_reveal (Request_dal_page page_id)) -> ( - let Dal.Page.{slot_id; page_index} = page_id in - let* pages = - Dal_pages_request.slot_pages ~dal_attestation_lag node_ctxt slot_id - in - let* pages = Delayed_write_monad.apply node_ctxt pages in - match pages with - | None -> return_none (* The slot is not confirmed. *) - | Some pages -> ( - let pages_per_slot = dal_params.slot_size / dal_params.page_size in - (* check invariant that pages' length is correct. *) - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4031 - It's better to do the check when the slots are saved into disk. *) - (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997 - This check is not resilient to dal parameters change. *) - match List.nth_opt pages page_index with - | Some content -> - let* page_proof = - page_membership_proof dal_params page_index - @@ Bytes.concat Bytes.empty pages - in - return_some (content, page_proof) - | None -> - failwith - "Page index %d too big or negative.\n\ - Number of pages in a slot is %d." - page_index - pages_per_slot)) - | _ -> return_none - - let generate_proof node_ctxt game start_state = - let open Lwt_result_syntax in - let snapshot = game.inbox_snapshot in - (* NOTE: [snapshot_level_int32] below refers to the level of the snapshotted - inbox (from the skip list) which also matches [game.start_level - 1]. *) - let snapshot_level_int32 = - Raw_level.to_int32 (Sc_rollup.Inbox.Skip_list.content snapshot).level - in - let get_snapshot_head () = - let+ hash = Node_context.hash_of_level node_ctxt snapshot_level_int32 in - Layer1.{hash; level = snapshot_level_int32} - in - let* context = - let* start_hash = - Node_context.hash_of_level - node_ctxt - (Raw_level.to_int32 game.inbox_level) +let page_membership_proof params page_index slot_data = + (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4048 + Rely on DAL node to compute page membership proof and drop + the dal-crypto dependency from the rollup node. *) + let proof = + let open Result_syntax in + (* The computation of the page's proof below can be a bit costly. In fact, + it involves initialising a cryptobox environment and some non-trivial + crypto processing. *) + let* dal = Cryptobox.make params in + let* polynomial = Cryptobox.polynomial_from_slot dal slot_data in + Cryptobox.prove_page dal polynomial page_index + in + let open Lwt_result_syntax in + match proof with + | Ok proof -> return proof + | Error e -> + failwith + "%s" + (match e with + | `Fail s -> "Fail " ^ s + | `Page_index_out_of_range -> "Page_index_out_of_range" + | `Slot_wrong_size s -> "Slot_wrong_size: " ^ s + | `Invalid_degree_strictly_less_than_expected _ as commit_error -> + Cryptobox.string_of_commit_error commit_error) + +(** When the PVM is waiting for a Dal page input, this function attempts to + retrieve the page's content from the store, the data of its slot. Then it + computes the proof that the page is part of the slot and returns the content + along with the proof. + + If the PVM is not waiting for a Dal page input, or if the slot is known to + be unconfirmed on L1, this function returns [None]. If the data of the slot + are not saved to the store, the function returns a failure in the error + monad. *) +let page_info_from_pvm_state (node_ctxt : _ Node_context.t) ~dal_attestation_lag + (dal_params : Dal.parameters) start_state = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! input_request = PVM.is_input_state start_state in + match input_request with + | Sc_rollup.(Needs_reveal (Request_dal_page page_id)) -> ( + let Dal.Page.{slot_id; page_index} = page_id in + let* pages = + Dal_pages_request.slot_pages ~dal_attestation_lag node_ctxt slot_id in - let+ context = Node_context.checkout_context node_ctxt start_hash in - Context.index context - in - let* dal_slots_history = - if Node_context.dal_supported node_ctxt then - let* snapshot_head = get_snapshot_head () in - Dal_slots_tracker.slots_history_of_hash node_ctxt snapshot_head - else return Dal.Slots_history.genesis - in - let* dal_slots_history_cache = - if Node_context.dal_supported node_ctxt then - let* snapshot_head = get_snapshot_head () in - Dal_slots_tracker.slots_history_cache_of_hash node_ctxt snapshot_head - else return (Dal.Slots_history.History_cache.empty ~capacity:0L) - in - (* We fetch the value of protocol constants at block snapshot level - where the game started. *) - let* parametric_constants = - let cctxt = node_ctxt.cctxt in - Protocol.Constants_services.parametric - cctxt - (cctxt#chain, `Level snapshot_level_int32) - in - let dal_l1_parameters = parametric_constants.dal in - let dal_parameters = dal_l1_parameters.cryptobox_parameters in - let dal_attestation_lag = dal_l1_parameters.attestation_lag in - - let* page_info = - page_info_from_pvm_state - ~dal_attestation_lag - node_ctxt - dal_parameters - start_state + let* pages = Delayed_write_monad.apply node_ctxt pages in + match pages with + | None -> return_none (* The slot is not confirmed. *) + | Some pages -> ( + let pages_per_slot = dal_params.slot_size / dal_params.page_size in + (* check invariant that pages' length is correct. *) + (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/4031 + It's better to do the check when the slots are saved into disk. *) + (* FIXME/DAL: https://gitlab.com/tezos/tezos/-/issues/3997 + This check is not resilient to dal parameters change. *) + match List.nth_opt pages page_index with + | Some content -> + let* page_proof = + page_membership_proof dal_params page_index + @@ Bytes.concat Bytes.empty pages + in + return_some (content, page_proof) + | None -> + failwith + "Page index %d too big or negative.\n\ + Number of pages in a slot is %d." + page_index + pages_per_slot)) + | _ -> return_none + +let generate_proof (node_ctxt : _ Node_context.t) game start_state = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let snapshot = game.inbox_snapshot in + (* NOTE: [snapshot_level_int32] below refers to the level of the snapshotted + inbox (from the skip list) which also matches [game.start_level - 1]. *) + let snapshot_level_int32 = + Raw_level.to_int32 (Sc_rollup.Inbox.Skip_list.content snapshot).level + in + let get_snapshot_head () = + let+ hash = Node_context.hash_of_level node_ctxt snapshot_level_int32 in + Layer1.{hash; level = snapshot_level_int32} + in + let* context = + let* start_hash = + Node_context.hash_of_level node_ctxt (Raw_level.to_int32 game.inbox_level) in - let module P = struct - include PVM - - let context = context + let+ context = Node_context.checkout_context node_ctxt start_hash in + Context.index context + in + let* dal_slots_history = + if Node_context.dal_supported node_ctxt then + let* snapshot_head = get_snapshot_head () in + Dal_slots_tracker.slots_history_of_hash node_ctxt snapshot_head + else return Dal.Slots_history.genesis + in + let* dal_slots_history_cache = + if Node_context.dal_supported node_ctxt then + let* snapshot_head = get_snapshot_head () in + Dal_slots_tracker.slots_history_cache_of_hash node_ctxt snapshot_head + else return (Dal.Slots_history.History_cache.empty ~capacity:0L) + in + (* We fetch the value of protocol constants at block snapshot level + where the game started. *) + let* parametric_constants = + let cctxt = node_ctxt.cctxt in + Protocol.Constants_services.parametric + cctxt + (cctxt#chain, `Level snapshot_level_int32) + in + let dal_l1_parameters = parametric_constants.dal in + let dal_parameters = dal_l1_parameters.cryptobox_parameters in + let dal_attestation_lag = dal_l1_parameters.attestation_lag in + + let* page_info = + page_info_from_pvm_state + ~dal_attestation_lag + node_ctxt + dal_parameters + start_state + in + let module P = struct + include PVM + + let context = context + + let state = start_state + + let reveal hash = + let open Lwt_syntax in + let* res = + Reveals.get ~data_dir:node_ctxt.data_dir ~pvm_kind:PVM.kind ~hash + in + match res with Ok data -> return @@ Some data | Error _ -> return None - let state = start_state + module Inbox_with_history = struct + let inbox = snapshot - let reveal hash = + let get_history inbox_hash = let open Lwt_syntax in - let* res = - Reveals.get ~data_dir:node_ctxt.data_dir ~pvm_kind:PVM.kind ~hash + let+ inbox = Node_context.find_inbox node_ctxt inbox_hash in + match inbox with + | Error err -> + Format.kasprintf + Stdlib.failwith + "Refutation game: Cannot get inbox history for %a, %a" + Sc_rollup.Inbox.Hash.pp + inbox_hash + pp_print_trace + err + | Ok inbox -> Option.map Sc_rollup.Inbox.take_snapshot inbox + + let get_payloads_history witness = + Lwt.map + (WithExceptions.Result.to_exn_f + ~error:(Format.kasprintf Stdlib.failwith "%a" pp_print_trace)) + @@ + let open Lwt_result_syntax in + let* {predecessor; predecessor_timestamp; messages} = + Node_context.get_messages node_ctxt witness in - match res with Ok data -> return @@ Some data | Error _ -> return None - - module Inbox_with_history = struct - let inbox = snapshot - - let get_history inbox_hash = - let open Lwt_syntax in - let+ inbox = Node_context.find_inbox node_ctxt inbox_hash in - match inbox with - | Error err -> - Format.kasprintf - Stdlib.failwith - "Refutation game: Cannot get inbox history for %a, %a" - Sc_rollup.Inbox.Hash.pp - inbox_hash - pp_print_trace - err - | Ok inbox -> Option.map Sc_rollup.Inbox.take_snapshot inbox - - let get_payloads_history witness = - Lwt.map - (WithExceptions.Result.to_exn_f - ~error:(Format.kasprintf Stdlib.failwith "%a" pp_print_trace)) - @@ - let open Lwt_result_syntax in - let* {predecessor; predecessor_timestamp; messages} = - Node_context.get_messages node_ctxt witness - in - let*? hist = - Inbox.payloads_history_of_messages - ~predecessor - ~predecessor_timestamp - messages - in - return hist - end - - module Dal_with_history = struct - let confirmed_slots_history = dal_slots_history - - let get_history ptr = - Dal.Slots_history.History_cache.find ptr dal_slots_history_cache - |> Lwt.return - - let dal_attestation_lag = dal_attestation_lag - - let dal_parameters = dal_parameters - - let page_info = page_info - end - end in - let metadata = Node_context.metadata node_ctxt in - let* proof = - trace (Sc_rollup_node_errors.Cannot_produce_proof game) - @@ (Sc_rollup.Proof.produce ~metadata (module P) game.inbox_level - >|= Environment.wrap_tzresult) - in - let*? pvm_step = - Sc_rollup.Proof.unserialize_pvm_step ~pvm:(module PVM) proof.pvm_step - |> Environment.wrap_tzresult - in - let proof = {proof with pvm_step} in - let*! res = - Sc_rollup.Proof.valid - ~metadata - snapshot - game.inbox_level - dal_slots_history - dal_parameters - ~dal_attestation_lag - ~pvm:(module PVM) - proof - >|= Environment.wrap_tzresult - in - if Result.is_ok res then return proof else assert false - - type pvm_intermediate_state = - | Hash of PVM.hash - | Evaluated of Interpreter.Accounted_pvm.eval_state - - let new_dissection ~opponent ~default_number_of_sections node_ctxt last_level - ok our_view = - let open Lwt_result_syntax in - let state_of_tick ?start_state tick = - Interpreter.state_of_tick node_ctxt ?start_state tick last_level - in - let state_hash_of_eval_state Interpreter.Accounted_pvm.{state_hash; _} = - state_hash - in - let start_hash, start_tick, start_state = - match ok with - | Hash hash, tick -> (hash, tick, None) - | Evaluated ({state_hash; _} as state), tick -> - (state_hash, tick, Some state) - in - let start_chunk = - Sc_rollup.Dissection_chunk. - {state_hash = Some start_hash; tick = start_tick} - in - let our_state, our_tick = our_view in - let our_state_hash = - Option.map - (fun Interpreter.Accounted_pvm.{state_hash; _} -> state_hash) - our_state - in - let our_stop_chunk = - Sc_rollup.Dissection_chunk.{state_hash = our_state_hash; tick = our_tick} - in - let* dissection = - Game_helpers.make_dissection - ~state_of_tick - ~state_hash_of_eval_state - ?start_state - ~start_chunk - ~our_stop_chunk - @@ PVM.new_dissection - ~start_chunk - ~our_stop_chunk - ~default_number_of_sections - in - let*! () = - Refutation_game_event.computed_dissection - ~opponent - ~start_tick - ~end_tick:our_tick - dissection - in - return dissection - - (** [generate_from_dissection ~default_number_of_sections node_ctxt game - dissection] traverses the current [dissection] and returns a move which - performs a new dissection of the execution trace or provides a refutation - proof to serve as the next move of the [game]. *) - let generate_next_dissection ~default_number_of_sections node_ctxt ~opponent - game dissection = - let open Lwt_result_syntax in - let rec traverse ok = function - | [] -> - (* The game invariant states that the dissection from the - opponent must contain a tick we disagree with. If the - retrieved game does not respect this, we cannot trust the - Tezos node we are connected to and prefer to stop here. *) - tzfail - Sc_rollup_node_errors - .Unreliable_tezos_node_returning_inconsistent_game - | Sc_rollup.Dissection_chunk.{state_hash = their_hash; tick} :: dissection - -> ( - let start_state = - match ok with - | Hash _, _ -> None - | Evaluated ok_state, _ -> Some ok_state - in - let* our = - Interpreter.state_of_tick - node_ctxt - ?start_state - tick - game.inbox_level - in - match (their_hash, our) with - | None, None -> - (* This case is absurd since: [None] can only occur at the - end and the two players disagree about the end. *) - assert false - | Some _, None | None, Some _ -> return (ok, (our, tick)) - | Some their_hash, Some ({state_hash = our_hash; _} as our_state) -> - if Sc_rollup.State_hash.equal our_hash their_hash then - traverse (Evaluated our_state, tick) dissection - else return (ok, (our, tick))) - in - match dissection with - | Sc_rollup.Dissection_chunk.{state_hash = Some hash; tick} :: dissection -> - let* ok, ko = traverse (Hash hash, tick) dissection in - let* dissection = - new_dissection - ~opponent - ~default_number_of_sections - node_ctxt - game.inbox_level - ok - ko + let*? hist = + Inbox.payloads_history_of_messages + ~predecessor + ~predecessor_timestamp + messages + in + return hist + end + + module Dal_with_history = struct + let confirmed_slots_history = dal_slots_history + + let get_history ptr = + Dal.Slots_history.History_cache.find ptr dal_slots_history_cache + |> Lwt.return + + let dal_attestation_lag = dal_attestation_lag + + let dal_parameters = dal_parameters + + let page_info = page_info + end + end in + let metadata = Node_context.metadata node_ctxt in + let* proof = + trace (Sc_rollup_node_errors.Cannot_produce_proof game) + @@ (Sc_rollup.Proof.produce ~metadata (module P) game.inbox_level + >|= Environment.wrap_tzresult) + in + let*? pvm_step = + Sc_rollup.Proof.unserialize_pvm_step ~pvm:(module PVM) proof.pvm_step + |> Environment.wrap_tzresult + in + let unserialized_proof = {proof with pvm_step} in + let*! res = + Sc_rollup.Proof.valid + ~metadata + snapshot + game.inbox_level + dal_slots_history + dal_parameters + ~dal_attestation_lag + ~pvm:(module PVM) + unserialized_proof + >|= Environment.wrap_tzresult + in + if Result.is_ok res then return proof else assert false + +type pvm_intermediate_state = + | Hash of Sc_rollup.State_hash.t + | Evaluated of Fueled_pvm.Accounted.eval_state + +let new_dissection ~opponent ~default_number_of_sections node_ctxt last_level ok + our_view = + let open Lwt_result_syntax in + let state_of_tick ?start_state tick = + Interpreter.state_of_tick node_ctxt ?start_state tick last_level + in + let state_hash_of_eval_state Fueled_pvm.Accounted.{state_hash; _} = + state_hash + in + let start_hash, start_tick, start_state = + match ok with + | Hash hash, tick -> (hash, tick, None) + | Evaluated ({state_hash; _} as state), tick -> + (state_hash, tick, Some state) + in + let start_chunk = + Sc_rollup.Dissection_chunk.{state_hash = Some start_hash; tick = start_tick} + in + let our_state, our_tick = our_view in + let our_state_hash = + Option.map + (fun Fueled_pvm.Accounted.{state_hash; _} -> state_hash) + our_state + in + let our_stop_chunk = + Sc_rollup.Dissection_chunk.{state_hash = our_state_hash; tick = our_tick} + in + let module PVM = (val node_ctxt.pvm) in + let* dissection = + Game_helpers.make_dissection + ~state_of_tick + ~state_hash_of_eval_state + ?start_state + ~start_chunk + ~our_stop_chunk + @@ PVM.new_dissection + ~start_chunk + ~our_stop_chunk + ~default_number_of_sections + in + let*! () = + Refutation_game_event.computed_dissection + ~opponent + ~start_tick + ~end_tick:our_tick + dissection + in + return dissection + +(** [generate_from_dissection ~default_number_of_sections node_ctxt game + dissection] traverses the current [dissection] and returns a move which + performs a new dissection of the execution trace or provides a refutation + proof to serve as the next move of the [game]. *) +let generate_next_dissection ~default_number_of_sections node_ctxt ~opponent + game dissection = + let open Lwt_result_syntax in + let rec traverse ok = function + | [] -> + (* The game invariant states that the dissection from the + opponent must contain a tick we disagree with. If the + retrieved game does not respect this, we cannot trust the + Tezos node we are connected to and prefer to stop here. *) + tzfail + Sc_rollup_node_errors + .Unreliable_tezos_node_returning_inconsistent_game + | Sc_rollup.Dissection_chunk.{state_hash = their_hash; tick} :: dissection + -> ( + let start_state = + match ok with + | Hash _, _ -> None + | Evaluated ok_state, _ -> Some ok_state + in + let* our = + Interpreter.state_of_tick node_ctxt ?start_state tick game.inbox_level in - let _, choice = ok in - let _, ko_tick = ko in - let chosen_section_len = Sc_rollup.Tick.distance ko_tick choice in - return (choice, chosen_section_len, dissection) - | [] | {state_hash = None; _} :: _ -> - (* + match (their_hash, our) with + | None, None -> + (* This case is absurd since: [None] can only occur at the + end and the two players disagree about the end. *) + assert false + | Some _, None | None, Some _ -> return (ok, (our, tick)) + | Some their_hash, Some ({state_hash = our_hash; _} as our_state) -> + if Sc_rollup.State_hash.equal our_hash their_hash then + traverse (Evaluated our_state, tick) dissection + else return (ok, (our, tick))) + in + match dissection with + | Sc_rollup.Dissection_chunk.{state_hash = Some hash; tick} :: dissection -> + let* ok, ko = traverse (Hash hash, tick) dissection in + let* dissection = + new_dissection + ~opponent + ~default_number_of_sections + node_ctxt + game.inbox_level + ok + ko + in + let _, choice = ok in + let _, ko_tick = ko in + let chosen_section_len = Sc_rollup.Tick.distance ko_tick choice in + return (choice, chosen_section_len, dissection) + | [] | {state_hash = None; _} :: _ -> + (* By wellformedness of dissection. A dissection always starts with a tick of the form [(Some hash, tick)]. A dissection always contains strictly more than one element. *) + tzfail + Sc_rollup_node_errors.Unreliable_tezos_node_returning_inconsistent_game + +let next_move node_ctxt ~opponent game = + let open Lwt_result_syntax in + let final_move start_tick = + let* start_state = + Interpreter.state_of_tick node_ctxt start_tick game.inbox_level + in + match start_state with + | None -> tzfail Sc_rollup_node_errors .Unreliable_tezos_node_returning_inconsistent_game - - let next_move node_ctxt ~opponent game = - let open Lwt_result_syntax in - let final_move start_tick = - let* start_state = - Interpreter.state_of_tick node_ctxt start_tick game.inbox_level + | Some {state = start_state; _} -> + let* proof = generate_proof node_ctxt game start_state in + let choice = start_tick in + return (Move {choice; step = Proof proof}) + in + + match game.game_state with + | Dissecting {dissection; default_number_of_sections} -> + let* choice, chosen_section_len, dissection = + generate_next_dissection + ~default_number_of_sections + node_ctxt + ~opponent + game + dissection in - match start_state with - | None -> - tzfail - Sc_rollup_node_errors - .Unreliable_tezos_node_returning_inconsistent_game - | Some {state = start_state; _} -> - let* proof = generate_proof node_ctxt game start_state in - let*? pvm_step = - Sc_rollup.Proof.serialize_pvm_step ~pvm:(module PVM) proof.pvm_step - |> Environment.wrap_tzresult - in - let step = Proof {proof with pvm_step} in - let choice = start_tick in - return (Move {choice; step}) - in - - match game.game_state with - | Dissecting {dissection; default_number_of_sections} -> - let* choice, chosen_section_len, dissection = - generate_next_dissection - ~default_number_of_sections - node_ctxt - ~opponent - game - dissection - in - if Z.(equal chosen_section_len one) then final_move choice - else return (Move {choice; step = Dissection dissection}) - | Final_move {agreed_start_chunk; refuted_stop_chunk = _} -> - let choice = agreed_start_chunk.tick in - final_move choice - - let play_next_move node_ctxt game self opponent = - let open Lwt_result_syntax in - let* refutation = next_move node_ctxt ~opponent game in - inject_next_move node_ctxt self ~refutation ~opponent - - let play_timeout (node_ctxt : _ Node_context.t) self stakers = - let open Lwt_result_syntax in - let timeout_operation = - L1_operation.Timeout {rollup = node_ctxt.rollup_address; stakers} - in - let source = - Node_context.get_operator node_ctxt Timeout |> Option.value ~default:self - (* We fallback on the [Refute] operator if none is provided for [Timeout] *) - in - let* _hash = Injector.add_pending_operation ~source timeout_operation in - return_unit - - let timeout_reached ~self head_block node_ctxt staker1 staker2 = - let open Lwt_result_syntax in - let Node_context.{rollup_address; cctxt; _} = node_ctxt in - let* game_result = - Plugin.RPC.Sc_rollup.timeout_reached - cctxt - (cctxt#chain, head_block) - rollup_address - staker1 - staker2 - in - let open Sc_rollup.Game in - match game_result with - | Some (Loser {loser; _}) -> - let is_it_me = Signature.Public_key_hash.(self = loser) in - if is_it_me then return_none else return (Some loser) - | _ -> return_none - - let play node_ctxt ~self game opponent = - let open Lwt_result_syntax in - let index = Sc_rollup.Game.Index.make self opponent in - let head_block = `Head 0 in - match turn ~self game index with - | Our_turn {opponent} -> play_next_move node_ctxt game self opponent - | Their_turn -> ( - let* timeout_reached = - timeout_reached ~self head_block node_ctxt self opponent - in - match timeout_reached with - | Some opponent -> - let*! () = Refutation_game_event.timeout_detected opponent in - play_timeout node_ctxt self index - | None -> return_unit) - - let play_opening_move node_ctxt self conflict = - let open Lwt_syntax in - let open Sc_rollup.Refutation_storage in - let* () = Refutation_game_event.conflict_detected conflict in - let player_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated conflict.our_commitment - in - let opponent_commitment_hash = - Sc_rollup.Commitment.hash_uncarbonated conflict.their_commitment - in - let refutation = Start {player_commitment_hash; opponent_commitment_hash} in - inject_next_move node_ctxt self ~refutation ~opponent:conflict.other -end + if Z.(equal chosen_section_len one) then final_move choice + else return (Move {choice; step = Dissection dissection}) + | Final_move {agreed_start_chunk; refuted_stop_chunk = _} -> + let choice = agreed_start_chunk.tick in + final_move choice + +let play_next_move node_ctxt game self opponent = + let open Lwt_result_syntax in + let* refutation = next_move node_ctxt ~opponent game in + inject_next_move node_ctxt self ~refutation ~opponent + +let play_timeout (node_ctxt : _ Node_context.t) self stakers = + let open Lwt_result_syntax in + let timeout_operation = + L1_operation.Timeout {rollup = node_ctxt.rollup_address; stakers} + in + let source = + Node_context.get_operator node_ctxt Timeout |> Option.value ~default:self + (* We fallback on the [Refute] operator if none is provided for [Timeout] *) + in + let* _hash = Injector.add_pending_operation ~source timeout_operation in + return_unit + +let timeout_reached ~self head_block node_ctxt staker1 staker2 = + let open Lwt_result_syntax in + let Node_context.{rollup_address; cctxt; _} = node_ctxt in + let* game_result = + Plugin.RPC.Sc_rollup.timeout_reached + cctxt + (cctxt#chain, head_block) + rollup_address + staker1 + staker2 + in + let open Sc_rollup.Game in + match game_result with + | Some (Loser {loser; _}) -> + let is_it_me = Signature.Public_key_hash.(self = loser) in + if is_it_me then return_none else return (Some loser) + | _ -> return_none + +let play node_ctxt ~self game opponent = + let open Lwt_result_syntax in + let index = Sc_rollup.Game.Index.make self opponent in + let head_block = `Head 0 in + match turn ~self game index with + | Our_turn {opponent} -> play_next_move node_ctxt game self opponent + | Their_turn -> ( + let* timeout_reached = + timeout_reached ~self head_block node_ctxt self opponent + in + match timeout_reached with + | Some opponent -> + let*! () = Refutation_game_event.timeout_detected opponent in + play_timeout node_ctxt self index + | None -> return_unit) + +let play_opening_move node_ctxt self conflict = + let open Lwt_syntax in + let open Sc_rollup.Refutation_storage in + let* () = Refutation_game_event.conflict_detected conflict in + let player_commitment_hash = + Sc_rollup.Commitment.hash_uncarbonated conflict.our_commitment + in + let opponent_commitment_hash = + Sc_rollup.Commitment.hash_uncarbonated conflict.their_commitment + in + let refutation = Start {player_commitment_hash; opponent_commitment_hash} in + inject_next_move node_ctxt self ~refutation ~opponent:conflict.other diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_game.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_game.mli index 89399c86ae0a..3229857d1aa7 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_game.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_game.mli @@ -26,27 +26,21 @@ open Protocol open Alpha_context -(** This module implements the refutation game logic of the rollup - node. *) -module type S = sig - module PVM : Pvm.S +(** This module implements the refutation game logic of the rollup node. *) - (** [play_opening_move node_ctxt self conflict] injects the opening - refutation game move for [conflict]. *) - val play_opening_move : - [< `Read | `Write > `Read] Node_context.t -> - public_key_hash -> - Sc_rollup.Refutation_storage.conflict -> - (unit, tztrace) result Lwt.t +(** [play_opening_move node_ctxt self conflict] injects the opening refutation + game move for [conflict]. *) +val play_opening_move : + [< `Read | `Write > `Read] Node_context.t -> + public_key_hash -> + Sc_rollup.Refutation_storage.conflict -> + (unit, tztrace) result Lwt.t - (** [play head_block node_ctxt ~self game opponent] injects the next - move in the refutation [game] played by [self] and [opponent]. *) - val play : - Node_context.rw -> - self:public_key_hash -> - Sc_rollup.Game.t -> - public_key_hash -> - (unit, tztrace) result Lwt.t -end - -module Make (Interpreter : Interpreter.S) : S with module PVM = Interpreter.PVM +(** [play head_block node_ctxt ~self game opponent] injects the next move in the + refutation [game] played by [self] and [opponent]. *) +val play : + Node_context.rw -> + self:public_key_hash -> + Sc_rollup.Game.t -> + public_key_hash -> + (unit, tztrace) result Lwt.t diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_player.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_player.ml index 0d129f6f7bdc..1258a6fa25d6 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_player.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_player.ml @@ -26,6 +26,7 @@ open Protocol open Alpha_context open Refutation_player_types +open Refutation_game module Types = struct type state = { @@ -54,153 +55,131 @@ type worker = Worker.infinite Worker.queue Worker.t let table = Worker.create_table Queue -module type S = sig - val init_and_play : - Node_context.rw -> - self:public_key_hash -> - conflict:Sc_rollup.Refutation_storage.conflict -> - game:Sc_rollup.Game.t option -> - level:int32 -> - unit tzresult Lwt.t +let on_play game Types.{node_ctxt; self; opponent; _} = + play node_ctxt ~self game opponent - val play : worker -> Sc_rollup.Game.t -> level:int32 -> unit Lwt.t +let on_play_opening conflict (Types.{node_ctxt; self; _} : Types.state) = + play_opening_move node_ctxt self conflict - val shutdown : worker -> unit Lwt.t +module Handlers = struct + type self = worker - val current_games : unit -> (public_key_hash * worker) list -end - -module Make (Interpreter : Interpreter.S) : S = struct - open Refutation_game.Make (Interpreter) - - let on_play game Types.{node_ctxt; self; opponent; _} = - play node_ctxt ~self game opponent - - let on_play_opening conflict (Types.{node_ctxt; self; _} : Types.state) = - play_opening_move node_ctxt self conflict - - module Handlers = struct - type self = worker - - let on_request : - type r request_error. - worker -> - (r, request_error) Request.t -> - (r, request_error) result Lwt.t = - fun w request -> - let state = Worker.state w in - match request with - | Request.Play game -> on_play game state - | Request.Play_opening conflict -> on_play_opening conflict state - - type launch_error = error trace - - let on_launch _w _name Types.{node_ctxt; self; conflict} = - return - Types. - {node_ctxt; self; opponent = conflict.other; last_move_cache = None} - - let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : - unit tzresult Lwt.t = - let open Lwt_result_syntax in - let request_view = Request.view r in - let emit_and_return_errors errs = - let*! () = - Refutation_game_event.Player.request_failed request_view st errs - in - return_unit - in - match r with - | Request.Play _ -> emit_and_return_errors errs - | Request.Play_opening _ -> emit_and_return_errors errs - - let on_completion _w r _ st = - Refutation_game_event.Player.request_completed (Request.view r) st + let on_request : + type r request_error. + worker -> (r, request_error) Request.t -> (r, request_error) result Lwt.t + = + fun w request -> + let state = Worker.state w in + match request with + | Request.Play game -> on_play game state + | Request.Play_opening conflict -> on_play_opening conflict state - let on_no_request _ = Lwt.return_unit + type launch_error = error trace - let on_close w = - let open Lwt_syntax in - let state = Worker.state w in - let* () = Refutation_game_event.Player.stopped state.opponent in - return_unit - end + let on_launch _w _name Types.{node_ctxt; self; conflict} = + return + Types.{node_ctxt; self; opponent = conflict.other; last_move_cache = None} - let init node_ctxt ~self ~conflict = + let on_error (type a b) _w st (r : (a, b) Request.t) (errs : b) : + unit tzresult Lwt.t = let open Lwt_result_syntax in - let*! () = - Refutation_game_event.Player.started - conflict.Sc_rollup.Refutation_storage.other - conflict.Sc_rollup.Refutation_storage.our_commitment - in - let worker_promise, worker_waker = Lwt.task () in - let* worker = - trace Sc_rollup_node_errors.Refutation_player_failed_to_start - @@ Worker.launch - table - conflict.other - {node_ctxt; self; conflict} - (module Handlers) - in - let () = Lwt.wakeup worker_waker worker in - let worker = - match Lwt.state worker_promise with - | Lwt.Return worker -> ok worker - | Lwt.Fail _ | Lwt.Sleep -> - error Sc_rollup_node_errors.Refutation_player_failed_to_start - in - Lwt.return worker - - (* Number of levels the player waits until trying to play - for a game state it already played for. *) - let buffer_levels = 5l - - (* Play if: - - There's a new game state to play against or - - The current level is past the buffer for re-playing in the - same game state. - *) - let should_move ~level game last_move_cache = - match last_move_cache with - | None -> true - | Some (last_move_game_state, last_move_level) -> - (not - (Sc_rollup.Game.game_state_equal - game.Sc_rollup.Game.game_state - last_move_game_state)) - || Int32.(sub level last_move_level > buffer_levels) - - let play w game ~(level : int32) = - let open Lwt_syntax in - let state = Worker.state w in - if should_move ~level game state.last_move_cache then ( - let* pushed = Worker.Queue.push_request w (Request.Play game) in - if pushed then - state.last_move_cache <- Some (game.Sc_rollup.Game.game_state, level) ; - return_unit) - else return_unit - - let play_opening w conflict = - let open Lwt_syntax in - let* (_pushed : bool) = - Worker.Queue.push_request w (Request.Play_opening conflict) + let request_view = Request.view r in + let emit_and_return_errors errs = + let*! () = + Refutation_game_event.Player.request_failed request_view st errs + in + return_unit in - return_unit + match r with + | Request.Play _ -> emit_and_return_errors errs + | Request.Play_opening _ -> emit_and_return_errors errs - let init_and_play node_ctxt ~self ~conflict ~game ~level = - let open Lwt_result_syntax in - let* worker = init node_ctxt ~self ~conflict in - let*! () = - match game with - | None -> play_opening worker conflict - | Some game -> play worker game ~level - in - return_unit + let on_completion _w r _ st = + Refutation_game_event.Player.request_completed (Request.view r) st - let current_games () = - List.map - (fun (_name, worker) -> ((Worker.state worker).opponent, worker)) - (Worker.list table) + let on_no_request _ = Lwt.return_unit - let shutdown = Worker.shutdown + let on_close w = + let open Lwt_syntax in + let state = Worker.state w in + let* () = Refutation_game_event.Player.stopped state.opponent in + return_unit end + +let init node_ctxt ~self ~conflict = + let open Lwt_result_syntax in + let*! () = + Refutation_game_event.Player.started + conflict.Sc_rollup.Refutation_storage.other + conflict.Sc_rollup.Refutation_storage.our_commitment + in + let worker_promise, worker_waker = Lwt.task () in + let* worker = + trace Sc_rollup_node_errors.Refutation_player_failed_to_start + @@ Worker.launch + table + conflict.other + {node_ctxt; self; conflict} + (module Handlers) + in + let () = Lwt.wakeup worker_waker worker in + let worker = + match Lwt.state worker_promise with + | Lwt.Return worker -> ok worker + | Lwt.Fail _ | Lwt.Sleep -> + error Sc_rollup_node_errors.Refutation_player_failed_to_start + in + Lwt.return worker + +(* Number of levels the player waits until trying to play + for a game state it already played for. *) +let buffer_levels = 5l + +(* Play if: + - There's a new game state to play against or + - The current level is past the buffer for re-playing in the + same game state. +*) +let should_move ~level game last_move_cache = + match last_move_cache with + | None -> true + | Some (last_move_game_state, last_move_level) -> + (not + (Sc_rollup.Game.game_state_equal + game.Sc_rollup.Game.game_state + last_move_game_state)) + || Int32.(sub level last_move_level > buffer_levels) + +let play w game ~(level : int32) = + let open Lwt_syntax in + let state = Worker.state w in + if should_move ~level game state.last_move_cache then ( + let* pushed = Worker.Queue.push_request w (Request.Play game) in + if pushed then + state.last_move_cache <- Some (game.Sc_rollup.Game.game_state, level) ; + return_unit) + else return_unit + +let play_opening w conflict = + let open Lwt_syntax in + let* (_pushed : bool) = + Worker.Queue.push_request w (Request.Play_opening conflict) + in + return_unit + +let init_and_play node_ctxt ~self ~conflict ~game ~level = + let open Lwt_result_syntax in + let* worker = init node_ctxt ~self ~conflict in + let*! () = + match game with + | None -> play_opening worker conflict + | Some game -> play worker game ~level + in + return_unit + +let current_games () = + List.map + (fun (_name, worker) -> ((Worker.state worker).opponent, worker)) + (Worker.list table) + +let shutdown = Worker.shutdown diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_player.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_player.mli index 1c6bbed96676..92592e7c7cc5 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_player.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/refutation_player.mli @@ -26,43 +26,34 @@ open Protocol open Alpha_context -(** Worker module for a signle refutation game player. - The node's refutation coordinator will spawn a new refutation player - for each refutation game. +(** Worker module for a single refutation game player. The node's refutation + coordinator will spawn a new refutation player for each refutation game. *) module Worker : Worker.T (** Type for a refutation game player. *) type worker = Worker.infinite Worker.queue Worker.t -module type S = sig - (** [init_and_play node_ctxt ~self ~conflict ~game ~level] - initializes a new refutation game player for signer [self]. - After initizialization, the worker will play the next move - depending on the [game] state. - If no [game] is passed, the worker will play the opening - move for [conflict]. - *) - val init_and_play : - Node_context.rw -> - self:public_key_hash -> - conflict:Sc_rollup.Refutation_storage.conflict -> - game:Sc_rollup.Game.t option -> - level:int32 -> - unit tzresult Lwt.t - - (** [play worker game ~level] makes the [worker] play the next move depending +(** [init_and_play node_ctxt ~self ~conflict ~game ~level] initializes a new + refutation game player for signer [self]. After initizialization, the + worker will play the next move depending on the [game] state. If no [game] + is passed, the worker will play the opening move for [conflict]. *) +val init_and_play : + Node_context.rw -> + self:public_key_hash -> + conflict:Sc_rollup.Refutation_storage.conflict -> + game:Sc_rollup.Game.t option -> + level:int32 -> + unit tzresult Lwt.t + +(** [play worker game ~level] makes the [worker] play the next move depending on the [game] state for their conflict. *) - val play : worker -> Sc_rollup.Game.t -> level:int32 -> unit Lwt.t - - (** Shutdown a refutaiton game player. *) - val shutdown : worker -> unit Lwt.t +val play : worker -> Sc_rollup.Game.t -> level:int32 -> unit Lwt.t - (** [current_games ()] lists the opponents' this node is playing - refutation games against, alongside the worker that takes care - of each game. *) - val current_games : unit -> (public_key_hash * worker) list -end +(** Shutdown a refutaiton game player. *) +val shutdown : worker -> unit Lwt.t -module Make (Interpreter : Interpreter.S) : S +(** [current_games ()] lists the opponents' this node is playing refutation + games against, alongside the worker that takes care of each game. *) +val current_games : unit -> (public_key_hash * worker) list diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/simulation.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/simulation.ml index 58d0fbdebe06..3070ab805392 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/simulation.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/simulation.ml @@ -25,176 +25,133 @@ open Protocol open Alpha_context - -module type S = sig - module Interpreter : Interpreter.S - - module PVM = Interpreter.PVM - module Fueled_pvm = Interpreter.Free_pvm - - type level_position = Start | Middle | End - - type info_per_level = { - predecessor_timestamp : Timestamp.time; - predecessor : Block_hash.t; - } - - type t = { - ctxt : Context.ro; - inbox_level : Raw_level.t; - state : PVM.state; - reveal_map : string Sc_rollup_reveal_hash.Map.t option; - nb_messages_inbox : int; - level_position : level_position; - info_per_level : info_per_level; +module Fueled_pvm = Fueled_pvm.Free + +type level_position = Start | Middle | End + +type info_per_level = { + predecessor_timestamp : Timestamp.time; + predecessor : Block_hash.t; +} + +type t = { + ctxt : Context.ro; + inbox_level : Raw_level.t; + state : Context.tree; + reveal_map : string Sc_rollup_reveal_hash.Map.t option; + nb_messages_inbox : int; + level_position : level_position; + info_per_level : info_per_level; +} + +let simulate_info_per_level (node_ctxt : [`Read] Node_context.t) predecessor = + let open Lwt_result_syntax in + let* block_info = Layer1.fetch_tezos_block node_ctxt.cctxt predecessor in + let predecessor_timestamp = block_info.header.shell.timestamp in + return {predecessor_timestamp; predecessor} + +let start_simulation node_ctxt ~reveal_map (Layer1.{hash; level} as head) = + let open Lwt_result_syntax in + let*? level = Environment.wrap_tzresult @@ Raw_level.of_int32 level in + let*? () = + error_unless + Raw_level.(level >= node_ctxt.Node_context.genesis_info.level) + (Exn (Failure "Cannot simulate before origination level")) + in + let first_inbox_level = Raw_level.succ node_ctxt.genesis_info.level in + let* ctxt = + if Raw_level.(level < first_inbox_level) then + (* This is before we have interpreted the boot sector, so we start + with an empty context in genesis *) + return (Context.empty node_ctxt.context) + else Node_context.checkout_context node_ctxt hash + in + let* ctxt, state = Interpreter.state_of_head node_ctxt ctxt head in + let+ info_per_level = simulate_info_per_level node_ctxt hash in + let inbox_level = Raw_level.succ level in + { + ctxt; + inbox_level; + state; + reveal_map; + nb_messages_inbox = 0; + level_position = Start; + info_per_level; } - val start_simulation : - Node_context.ro -> - reveal_map:string Sc_rollup_reveal_hash.Map.t option -> - Layer1.head -> - t tzresult Lwt.t - - val simulate_messages : - Node_context.ro -> - t -> - Sc_rollup.Inbox_message.t list -> - (t * Z.t) tzresult Lwt.t - - val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t -end - -module Make (Interpreter : Interpreter.S) : - S with module Interpreter = Interpreter = struct - module Interpreter = Interpreter - module PVM = Interpreter.PVM - module Fueled_pvm = Interpreter.Free_pvm - - type level_position = Start | Middle | End - - type info_per_level = { - predecessor_timestamp : Timestamp.time; - predecessor : Block_hash.t; - } - - type t = { - ctxt : Context.ro; - inbox_level : Raw_level.t; - state : PVM.state; - reveal_map : string Sc_rollup_reveal_hash.Map.t option; - nb_messages_inbox : int; - level_position : level_position; - info_per_level : info_per_level; - } - - let simulate_info_per_level (node_ctxt : [`Read] Node_context.t) predecessor = - let open Lwt_result_syntax in - let* block_info = Layer1.fetch_tezos_block node_ctxt.cctxt predecessor in - let predecessor_timestamp = block_info.header.shell.timestamp in - return {predecessor_timestamp; predecessor} - - let start_simulation node_ctxt ~reveal_map (Layer1.{hash; level} as head) = - let open Lwt_result_syntax in - let*? level = Environment.wrap_tzresult @@ Raw_level.of_int32 level in - let*? () = - error_unless - Raw_level.(level >= node_ctxt.Node_context.genesis_info.level) - (Exn (Failure "Cannot simulate before origination level")) - in - let first_inbox_level = Raw_level.succ node_ctxt.genesis_info.level in - let* ctxt = - if Raw_level.(level < first_inbox_level) then - (* This is before we have interpreted the boot sector, so we start - with an empty context in genesis *) - return (Context.empty node_ctxt.context) - else Node_context.checkout_context node_ctxt hash - in - let* ctxt, state = Interpreter.state_of_head node_ctxt ctxt head in - let+ info_per_level = simulate_info_per_level node_ctxt hash in - let inbox_level = Raw_level.succ level in - { - ctxt; - inbox_level; - state; - reveal_map; - nb_messages_inbox = 0; - level_position = Start; - info_per_level; - } - - let simulate_messages_no_checks (node_ctxt : Node_context.ro) - ({ - ctxt; - state; - inbox_level; - reveal_map; - nb_messages_inbox; - level_position = _; - info_per_level = _; - } as sim) messages = - let open Lwt_result_syntax in - let*! state_hash = PVM.state_hash state in - let*! tick = PVM.get_tick state in - let eval_state = - Fueled_pvm. - { - state; - state_hash; - tick; - inbox_level; - message_counter_offset = nb_messages_inbox; - remaining_fuel = Fuel.Free.of_ticks 0L; - remaining_messages = messages; - } - in - (* Build new state *) - let* eval_result = - Fueled_pvm.eval_messages ?reveal_map node_ctxt eval_state - in - let Fueled_pvm.{state = {state; _}; num_ticks; num_messages; _} = - Delayed_write_monad.ignore eval_result - in - let*! ctxt = PVM.State.set ctxt state in - let nb_messages_inbox = nb_messages_inbox + num_messages in - return ({sim with ctxt; state; nb_messages_inbox}, num_ticks) - - let simulate_messages (node_ctxt : Node_context.ro) sim messages = - let open Lwt_result_syntax in - (* Build new inbox *) - let*? () = - error_when - (sim.level_position = End) - (Exn (Failure "Level for simulation is ended")) - in - let*? () = - error_when - (messages = []) - (Environment.wrap_tzerror Sc_rollup_errors.Sc_rollup_add_zero_messages) - in - let messages = - if sim.level_position = Start then - let {predecessor_timestamp; predecessor} = sim.info_per_level in - let open Sc_rollup.Inbox_message in - Internal Start_of_level - :: Internal (Info_per_level {predecessor_timestamp; predecessor}) - :: messages - else messages - in - let+ sim, num_ticks = simulate_messages_no_checks node_ctxt sim messages in - ({sim with level_position = Middle}, num_ticks) - - let end_simulation node_ctxt sim = - let open Lwt_result_syntax in - let*? () = - error_when - (sim.level_position = End) - (Exn (Failure "Level for simulation is ended")) - in - let+ sim, num_ticks = - simulate_messages_no_checks - node_ctxt - sim - [Sc_rollup.Inbox_message.Internal End_of_level] - in - ({sim with level_position = End}, num_ticks) -end +let simulate_messages_no_checks (node_ctxt : Node_context.ro) + ({ + ctxt; + state; + inbox_level; + reveal_map; + nb_messages_inbox; + level_position = _; + info_per_level = _; + } as sim) messages = + let open Lwt_result_syntax in + let module PVM = (val node_ctxt.pvm) in + let*! state_hash = PVM.state_hash state in + let*! tick = PVM.get_tick state in + let eval_state = + Fueled_pvm. + { + state; + state_hash; + tick; + inbox_level; + message_counter_offset = nb_messages_inbox; + remaining_fuel = Fuel.Free.of_ticks 0L; + remaining_messages = messages; + } + in + (* Build new state *) + let* eval_result = + Fueled_pvm.eval_messages ?reveal_map node_ctxt eval_state + in + let Fueled_pvm.{state = {state; _}; num_ticks; num_messages; _} = + Delayed_write_monad.ignore eval_result + in + let*! ctxt = PVM.State.set ctxt state in + let nb_messages_inbox = nb_messages_inbox + num_messages in + return ({sim with ctxt; state; nb_messages_inbox}, num_ticks) + +let simulate_messages (node_ctxt : Node_context.ro) sim messages = + let open Lwt_result_syntax in + (* Build new inbox *) + let*? () = + error_when + (sim.level_position = End) + (Exn (Failure "Level for simulation is ended")) + in + let*? () = + error_when + (messages = []) + (Environment.wrap_tzerror Sc_rollup_errors.Sc_rollup_add_zero_messages) + in + let messages = + if sim.level_position = Start then + let {predecessor_timestamp; predecessor} = sim.info_per_level in + let open Sc_rollup.Inbox_message in + Internal Start_of_level + :: Internal (Info_per_level {predecessor_timestamp; predecessor}) + :: messages + else messages + in + let+ sim, num_ticks = simulate_messages_no_checks node_ctxt sim messages in + ({sim with level_position = Middle}, num_ticks) + +let end_simulation node_ctxt sim = + let open Lwt_result_syntax in + let*? () = + error_when + (sim.level_position = End) + (Exn (Failure "Level for simulation is ended")) + in + let+ sim, num_ticks = + simulate_messages_no_checks + node_ctxt + sim + [Sc_rollup.Inbox_message.Internal End_of_level] + in + ({sim with level_position = End}, num_ticks) diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/simulation.mli b/src/proto_016_PtMumbai/lib_sc_rollup_node/simulation.mli index ad4faaedfd0e..317a8809e097 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/simulation.mli +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/simulation.mli @@ -25,54 +25,44 @@ open Protocol open Protocol.Alpha_context +module Fueled_pvm = Fueled_pvm.Free -module type S = sig - module Interpreter : Interpreter.S +type level_position = Start | Middle | End - module PVM = Interpreter.PVM - module Fueled_pvm = Interpreter.Free_pvm +type info_per_level = { + predecessor_timestamp : Timestamp.time; + predecessor : Block_hash.t; +} - type level_position = Start | Middle | End +(** Type of the state for a simulation. *) +type t = { + ctxt : Context.ro; + inbox_level : Raw_level.t; + state : Context.tree; + reveal_map : string Sc_rollup_reveal_hash.Map.t option; + nb_messages_inbox : int; + level_position : level_position; + info_per_level : info_per_level; +} - type info_per_level = { - predecessor_timestamp : Timestamp.time; - predecessor : Block_hash.t; - } +(** [start_simulation node_ctxt reveal_source block] starts a new simulation {e + on top} of [block], i.e. for an hypothetical new inbox (level). *) +val start_simulation : + Node_context.ro -> + reveal_map:string Sc_rollup_reveal_hash.Map.t option -> + Layer1.head -> + t tzresult Lwt.t - (** Type of the state for a simulation. *) - type t = { - ctxt : Context.ro; - inbox_level : Raw_level.t; - state : PVM.state; - reveal_map : string Sc_rollup_reveal_hash.Map.t option; - nb_messages_inbox : int; - level_position : level_position; - info_per_level : info_per_level; - } +(** [simulate_messages node_ctxt sim messages] runs a simulation of new + [messages] in the given simulation (state) [sim] and returns a new + simulation state, the remaining fuel (when [?fuel] is provided) and the + number of ticks that happened. *) +val simulate_messages : + Node_context.ro -> + t -> + Sc_rollup.Inbox_message.t list -> + (t * Z.t) tzresult Lwt.t - (** [start_simulation node_ctxt reveal_source block] starts a new simulation - {e on top} of [block], i.e. for an hypothetical new inbox (level). *) - val start_simulation : - Node_context.ro -> - reveal_map:string Sc_rollup_reveal_hash.Map.t option -> - Layer1.head -> - t tzresult Lwt.t - - (** [simulate_messages node_ctxt sim messages] runs a simulation of new - [messages] in the given simulation (state) [sim] and returns a new - simulation state, the remaining fuel (when [?fuel] is provided) and the - number of ticks that happened. *) - val simulate_messages : - Node_context.ro -> - t -> - Sc_rollup.Inbox_message.t list -> - (t * Z.t) tzresult Lwt.t - - (** [end_simulation node_ctxt sim] adds and [End_of_level] message and marks - the simulation as ended. *) - val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t -end - -(** Functor to construct a simulator for a given PVM with interpreter. *) -module Make (Interpreter : Interpreter.S) : - S with module Interpreter = Interpreter +(** [end_simulation node_ctxt sim] adds and [End_of_level] message and marks the + simulation as ended. *) +val end_simulation : Node_context.ro -> t -> (t * Z.t) tzresult Lwt.t diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/test/helpers/helpers.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/test/helpers/helpers.ml index 85fb36ce7ef4..b408c4b3c9f2 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/test/helpers/helpers.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/test/helpers/helpers.ml @@ -36,215 +36,166 @@ let block_hash_of_level level = in Block_hash.of_string_exn s -module type S = sig - val with_node_context : - ?constants:Constants.Parametric.t -> - Sc_rollup.Kind.t -> - boot_sector:string -> - ([`Read | `Write] Node_context.t -> - genesis:Sc_rollup_block.t -> - 'a tzresult Lwt.t) -> - 'a tzresult Lwt.t - - val add_l2_genesis_block : - [`Read | `Write] Node_context.t -> - boot_sector:string -> - ((Sc_rollup_block.header, unit) Sc_rollup_block.block, tztrace) result Lwt.t - - val append_l2_block : - [`Read | `Write] Node_context.t -> - Sc_rollup.Inbox_message.t trace -> - ((Sc_rollup_block.header, unit) Sc_rollup_block.block, tztrace) result Lwt.t -end - -module Make (PVM : Pvm.S) = struct - module Daemon = Daemon.Make (PVM) - module Components = Daemon.Components +let default_constants = + let constants = Default_parameters.constants_test in + let sc_rollup = + { + constants.sc_rollup with + arith_pvm_enable = true; + challenge_window_in_blocks = 4032; + commitment_period_in_blocks = 3; + } + in + {constants with sc_rollup} - let default_constants = - let constants = Default_parameters.constants_test in - let sc_rollup = +let add_l2_genesis_block (node_ctxt : _ Node_context.t) ~boot_sector = + let open Lwt_result_syntax in + let head = + Layer1. { - constants.sc_rollup with - arith_pvm_enable = true; - challenge_window_in_blocks = 4032; - commitment_period_in_blocks = 3; + hash = Block_hash.zero; + level = Raw_level.to_int32 node_ctxt.genesis_info.level; } - in - {constants with sc_rollup} - - let add_l2_genesis_block (node_ctxt : _ Node_context.t) ~boot_sector = - let open Lwt_result_syntax in - let head = - Layer1. - { - hash = Block_hash.zero; - level = Raw_level.to_int32 node_ctxt.genesis_info.level; - } - in - let* () = Node_context.save_level node_ctxt head in - let predecessor = head in - let predecessor_timestamp = Time.Protocol.epoch in - let*? inbox = - Environment.wrap_tzresult - @@ Sc_rollup.Inbox.genesis - ~predecessor_timestamp - ~predecessor:predecessor.hash - node_ctxt.genesis_info.level - in - let* inbox_hash = Node_context.save_inbox node_ctxt inbox in - let inbox_witness = Sc_rollup.Inbox.current_witness inbox in - let ctxt = Context.empty node_ctxt.context in - let num_ticks = 0L in - let initial_tick = Sc_rollup.Tick.initial in - let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in - let*! state = PVM.install_boot_sector initial_state boot_sector in - let*! genesis_state_hash = PVM.state_hash state in - let*! ctxt = PVM.State.set ctxt state in - let*! context_hash = Context.commit ctxt in - let commitment = - Sc_rollup.Commitment.genesis_commitment - ~origination_level:node_ctxt.genesis_info.level - ~genesis_state_hash - in - let* commitment_hash = Node_context.save_commitment node_ctxt commitment in - let previous_commitment_hash = node_ctxt.genesis_info.commitment_hash in - let header = - Sc_rollup_block. - { - block_hash = head.hash; - level = node_ctxt.genesis_info.level; - predecessor = predecessor.hash; - commitment_hash = Some commitment_hash; - previous_commitment_hash; - context = context_hash; - inbox_witness; - inbox_hash; - } - in - let l2_block = - Sc_rollup_block.{header; content = (); num_ticks; initial_tick} - in - let* () = Node_context.save_l2_head node_ctxt l2_block in - return l2_block - - let initialize_node_context ?(constants = default_constants) kind ~boot_sector - = - let open Lwt_result_syntax in - incr uid ; - (* To avoid any conflict with previous runs of this test. *) - let pid = Unix.getpid () in - let data_dir = - Filename.(concat @@ get_temp_dir_name ()) - (Format.sprintf "sc-rollup-node-test-%s-%d-%d" Protocol.name pid !uid) - in - let base_dir = - Filename.(concat @@ get_temp_dir_name ()) - (Format.sprintf - "sc-rollup-node-test-%s-base-%d-%d" - Protocol.name - pid - !uid) - in - let filesystem = String.Hashtbl.create 10 in - let cctxt = - new Protocol_client_context.wrap_full - (new Faked_client_context.unix_faked ~base_dir ~filesystem) - in - let* ctxt = - Node_context.Internal_for_tests.create_node_context - cctxt - ~constants - ~data_dir - kind - in - let* genesis = add_l2_genesis_block ctxt ~boot_sector in - let commitment_hash = - WithExceptions.Option.get ~loc:__LOC__ genesis.header.commitment_hash - in - let ctxt = - {ctxt with genesis_info = {ctxt.genesis_info with commitment_hash}} - in - return (ctxt, genesis, [data_dir; base_dir]) - - let with_node_context ?constants kind ~boot_sector f = - let open Lwt_result_syntax in - let* node_ctxt, genesis, dirs_to_clean = - initialize_node_context ?constants kind ~boot_sector - in - Lwt.finalize (fun () -> f node_ctxt ~genesis) @@ fun () -> - let open Lwt_syntax in - let* _ = Node_context.close node_ctxt in - let* () = - List.iter_s Tezos_stdlib_unix.Lwt_utils_unix.remove_dir dirs_to_clean - in - return_unit - - let head_of_level ~predecessor level = - let hash = block_hash_of_level level in - let timestamp = Time.Protocol.of_seconds (Int64.of_int32 level) in - let header : Block_header.shell_header = + in + let* () = Node_context.save_level node_ctxt head in + let predecessor = head in + let predecessor_timestamp = Time.Protocol.epoch in + let*? inbox = + Environment.wrap_tzresult + @@ Sc_rollup.Inbox.genesis + ~predecessor_timestamp + ~predecessor:predecessor.hash + node_ctxt.genesis_info.level + in + let* inbox_hash = Node_context.save_inbox node_ctxt inbox in + let inbox_witness = Sc_rollup.Inbox.current_witness inbox in + let ctxt = Context.empty node_ctxt.context in + let num_ticks = 0L in + let module PVM = (val node_ctxt.pvm) in + let initial_tick = Sc_rollup.Tick.initial in + let*! initial_state = PVM.initial_state ~empty:(PVM.State.empty ()) in + let*! state = PVM.install_boot_sector initial_state boot_sector in + let*! genesis_state_hash = PVM.state_hash state in + let*! ctxt = PVM.State.set ctxt state in + let*! context_hash = Context.commit ctxt in + let commitment = + Sc_rollup.Commitment.genesis_commitment + ~origination_level:node_ctxt.genesis_info.level + ~genesis_state_hash + in + let* commitment_hash = Node_context.save_commitment node_ctxt commitment in + let previous_commitment_hash = node_ctxt.genesis_info.commitment_hash in + let header = + Sc_rollup_block. { - level; - predecessor; - timestamp; - (* dummy values below *) - proto_level = 0; - validation_passes = 3; - operations_hash = Tezos_crypto.Hashed.Operation_list_list_hash.zero; - fitness = []; - context = Tezos_crypto.Hashed.Context_hash.zero; + block_hash = head.hash; + level = node_ctxt.genesis_info.level; + predecessor = predecessor.hash; + commitment_hash = Some commitment_hash; + previous_commitment_hash; + context = context_hash; + inbox_witness; + inbox_hash; } - in - {Layer1.hash; level; header} - - let append_l2_block (node_ctxt : _ Node_context.t) messages = - let open Lwt_result_syntax in - let* predecessor_l2_block = - Node_context.last_processed_head_opt node_ctxt - in - let* predecessor_l2_block = - match predecessor_l2_block with - | Some b -> return b - | None -> - failwith "No genesis block, please add one with add_l2_genesis_block" - in - let pred_level = Raw_level.to_int32 predecessor_l2_block.header.level in - let predecessor = - head_of_level - ~predecessor:predecessor_l2_block.header.predecessor - pred_level - in - let head = - head_of_level ~predecessor:predecessor.hash (Int32.succ pred_level) - in - Daemon.Internal_for_tests.process_messages - node_ctxt - ~predecessor - head - messages -end - -let l2_chain_builders = - List.map - (fun kind -> - let module PVM = (val Components.pvm_of_kind kind) in - (kind, (module Make (PVM) : S))) - Sc_rollup.Kind.all - -let l2_chain_builder kind = Stdlib.List.assoc kind l2_chain_builders + in + let l2_block = + Sc_rollup_block.{header; content = (); num_ticks; initial_tick} + in + let* () = Node_context.save_l2_head node_ctxt l2_block in + return l2_block -let with_node_context ?constants kind ~boot_sector = - let module L = (val l2_chain_builder kind) in - L.with_node_context ?constants kind ~boot_sector +let initialize_node_context ?(constants = default_constants) kind ~boot_sector = + let open Lwt_result_syntax in + incr uid ; + (* To avoid any conflict with previous runs of this test. *) + let pid = Unix.getpid () in + let data_dir = + Filename.(concat @@ get_temp_dir_name ()) + (Format.sprintf "sc-rollup-node-test-%s-%d-%d" Protocol.name pid !uid) + in + let base_dir = + Filename.(concat @@ get_temp_dir_name ()) + (Format.sprintf + "sc-rollup-node-test-%s-base-%d-%d" + Protocol.name + pid + !uid) + in + let filesystem = String.Hashtbl.create 10 in + let cctxt = + new Protocol_client_context.wrap_full + (new Faked_client_context.unix_faked ~base_dir ~filesystem) + in + let* ctxt = + Node_context.Internal_for_tests.create_node_context + cctxt + ~constants + ~data_dir + kind + in + let* genesis = add_l2_genesis_block ctxt ~boot_sector in + let commitment_hash = + WithExceptions.Option.get ~loc:__LOC__ genesis.header.commitment_hash + in + let ctxt = + {ctxt with genesis_info = {ctxt.genesis_info with commitment_hash}} + in + return (ctxt, genesis, [data_dir; base_dir]) -let add_l2_genesis_block (node_ctxt : _ Node_context.t) = - let module L = (val l2_chain_builder node_ctxt.kind) in - L.add_l2_genesis_block node_ctxt +let with_node_context ?constants kind ~boot_sector f = + let open Lwt_result_syntax in + let* node_ctxt, genesis, dirs_to_clean = + initialize_node_context ?constants kind ~boot_sector + in + Lwt.finalize (fun () -> f node_ctxt ~genesis) @@ fun () -> + let open Lwt_syntax in + let* _ = Node_context.close node_ctxt in + let* () = + List.iter_s Tezos_stdlib_unix.Lwt_utils_unix.remove_dir dirs_to_clean + in + return_unit + +let head_of_level ~predecessor level = + let hash = block_hash_of_level level in + let timestamp = Time.Protocol.of_seconds (Int64.of_int32 level) in + let header : Block_header.shell_header = + { + level; + predecessor; + timestamp; + (* dummy values below *) + proto_level = 0; + validation_passes = 3; + operations_hash = Tezos_crypto.Hashed.Operation_list_list_hash.zero; + fitness = []; + context = Tezos_crypto.Hashed.Context_hash.zero; + } + in + {Layer1.hash; level; header} -let append_l2_block (node_ctxt : _ Node_context.t) = - let module L = (val l2_chain_builder node_ctxt.kind) in - L.append_l2_block node_ctxt +let append_l2_block (node_ctxt : _ Node_context.t) messages = + let open Lwt_result_syntax in + let* predecessor_l2_block = Node_context.last_processed_head_opt node_ctxt in + let* predecessor_l2_block = + match predecessor_l2_block with + | Some b -> return b + | None -> + failwith "No genesis block, please add one with add_l2_genesis_block" + in + let pred_level = Raw_level.to_int32 predecessor_l2_block.header.level in + let predecessor = + head_of_level + ~predecessor:predecessor_l2_block.header.predecessor + pred_level + in + let head = + head_of_level ~predecessor:predecessor.hash (Int32.succ pred_level) + in + Daemon.Internal_for_tests.process_messages + node_ctxt + ~predecessor + head + messages let append_l2_blocks node_ctxt message_batches = List.map_es (append_l2_block node_ctxt) message_batches diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/wasm_2_0_0_pvm.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/wasm_2_0_0_pvm.ml index 6266648dd1b7..24bcb4f16f42 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/wasm_2_0_0_pvm.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/wasm_2_0_0_pvm.ml @@ -68,9 +68,27 @@ module Make_backend (Tree : TreeS) = struct let initial_state = initial_state V0 end +(** Durable part of the storage of this PVM. *) +module type Durable_state = sig + type state + + (** [value_length state key] returns the length of data stored + for the [key] in the durable storage of the PVM state [state], if any. *) + val value_length : state -> string -> int64 option Lwt.t + + (** [lookup state key] returns the data stored + for the [key] in the durable storage of the PVM state [state], if any. *) + val lookup : state -> string -> bytes option Lwt.t + + (** [subtrees state key] returns subtrees + for the [key] in the durable storage of the PVM state [state]. + Empty list in case if path doesn't exist. *) + val list : state -> string -> string list Lwt.t +end + module Make_durable_state (T : Tezos_tree_encoding.TREE with type tree = Context.tree) : - Wasm_2_0_0_rpc.Durable_state with type state = T.tree = struct + Durable_state with type state = T.tree = struct module Tree_encoding_runner = Tezos_tree_encoding.Runner.Make (T) type state = T.tree @@ -105,7 +123,13 @@ module Make_durable_state Tezos_scoru_wasm.Durable.list durable key end -module Impl : Pvm.S = struct +module type S = sig + module Durable_state : Durable_state with type state = Context.tree + + include Pvm.S +end + +module Impl : S = struct module PVM = Sc_rollup.Wasm_2_0_0PVM.Make (Make_backend) (Wasm_2_0_0_proof_format) include PVM @@ -117,7 +141,6 @@ module Impl : Pvm.S = struct module State = Context.PVMState module Durable_state = Make_durable_state (Make_wrapped_tree (Wasm_2_0_0_proof_format.Tree)) - module RPC = Wasm_2_0_0_rpc.Make_RPC (Durable_state) let string_of_status : status -> string = function | Waiting_for_input_message -> "Waiting for input message" diff --git a/src/proto_016_PtMumbai/lib_sc_rollup_node/wasm_2_0_0_rpc.ml b/src/proto_016_PtMumbai/lib_sc_rollup_node/wasm_2_0_0_rpc.ml index 8f410c55049e..c5a2210f19fa 100644 --- a/src/proto_016_PtMumbai/lib_sc_rollup_node/wasm_2_0_0_rpc.ml +++ b/src/proto_016_PtMumbai/lib_sc_rollup_node/wasm_2_0_0_rpc.ml @@ -26,25 +26,8 @@ open RPC_directory_helpers -(** Durable part of the storage of this PVM. *) -module type Durable_state = sig - type state - - (** [value_length state key] returns the length of data stored - for the [key] in the durable storage of the PVM state [state], if any. *) - val value_length : state -> string -> int64 option Lwt.t - - (** [lookup state key] returns the data stored - for the [key] in the durable storage of the PVM state [state], if any. *) - val lookup : state -> string -> bytes option Lwt.t - - (** [subtrees state key] returns subtrees - for the [key] in the durable storage of the PVM state [state]. - Empty list in case if path doesn't exist. *) - val list : state -> string -> string list Lwt.t -end - -module Make_RPC (Durable_state : Durable_state with type state = Context.tree) = +module Make_RPC + (Durable_state : Wasm_2_0_0_pvm.Durable_state with type state = Context.tree) = struct module Block_directory = Make_directory (struct include Sc_rollup_services.Global.Block @@ -89,7 +72,7 @@ struct let*! subkeys = Durable_state.list state key in return subkeys - let build_directory = + let build_directory node_ctxt = register () ; - Block_directory.build_directory + Block_directory.build_directory node_ctxt end -- GitLab