From a731a47d3ca1876641159f419eb08957bf561fc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 10 Apr 2017 12:14:11 +0200 Subject: [PATCH 01/10] Proto: explicit fitness/timestamp in the signature This remove the data fomr the context where they "duplicate" the block header. --- src/node/db/context.ml | 64 ++------------ src/node/db/context.mli | 15 ++-- src/node/shell/node.ml | 39 +++++---- src/node/shell/prevalidation.ml | 7 +- src/node/shell/prevalidation.mli | 2 +- src/node/shell/prevalidator.ml | 2 +- src/node/shell/prevalidator.mli | 2 +- src/node/shell/state.ml | 13 ++- src/node/shell/state.mli | 3 +- src/node/shell/validator.ml | 9 +- src/node/updater/protocol.mli | 86 +++++-------------- src/node/updater/register.ml | 4 + src/node/updater/updater.ml | 20 +++-- src/node/updater/updater.mli | 20 +++-- src/proto/alpha/apply.ml | 17 ++-- src/proto/alpha/fitness_repr.ml | 8 +- src/proto/alpha/fitness_storage.ml | 16 +--- src/proto/alpha/init_storage.ml | 26 +++--- src/proto/alpha/main.ml | 26 ++++-- src/proto/alpha/mining.ml | 6 +- src/proto/alpha/reward_storage.ml | 2 +- src/proto/alpha/script_interpreter.ml | 2 +- src/proto/alpha/services_registration.ml | 19 +++-- src/proto/alpha/storage.ml | 41 ++++----- src/proto/alpha/storage.mli | 16 ++-- src/proto/alpha/storage_functors.ml | 101 ++++++++++++++--------- src/proto/alpha/storage_functors.mli | 7 +- src/proto/alpha/tezos_context.ml | 15 ++-- src/proto/alpha/tezos_context.mli | 23 +++--- src/proto/demo/main.ml | 65 ++++++--------- src/proto/demo/services.ml | 2 +- src/proto/environment/context.mli | 6 -- src/proto/environment/updater.mli | 19 ++++- src/proto/genesis/main.ml | 48 +++++------ src/proto/genesis/services.ml | 2 +- test/proto_alpha/proto_alpha_helpers.ml | 2 +- test/shell/test_context.ml | 2 + test/shell/test_state.ml | 5 +- 38 files changed, 342 insertions(+), 420 deletions(-) diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 54338d8f2..5301d1194 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -84,15 +84,11 @@ type t = context (*-- Version Access and Update -----------------------------------------------*) let current_protocol_key = ["protocol"] -let current_fitness_key = ["fitness"] -let current_timestamp_key = ["timestamp"] let current_test_protocol_key = ["test_protocol"] let current_test_network_key = ["test_network"] let current_test_network_expiration_key = ["test_network_expiration"] let current_fork_test_network_key = ["fork_test_network"] -let transient_commit_message_key = ["message"] - let exists { repo } key = GitStore.of_branch_id Irmin.Task.none (Block_hash.to_b58check key) repo >>= fun t -> @@ -134,59 +130,17 @@ let exists index key = Block_hash.pp_short key exists >>= fun () -> Lwt.return exists -let get_and_erase_commit_message ctxt = - GitStore.FunView.get ctxt.view transient_commit_message_key >>= function - | None -> Lwt.return (None, ctxt) - | Some bytes -> - GitStore.FunView.del ctxt.view transient_commit_message_key >>= fun view -> - Lwt.return (Some (MBytes.to_string bytes), { ctxt with view }) -let set_commit_message ctxt msg = - GitStore.FunView.set ctxt.view - transient_commit_message_key - (MBytes.of_string msg) >>= fun view -> - Lwt.return { ctxt with view } - -let get_fitness { view } = - GitStore.FunView.get view current_fitness_key >>= function - | None -> assert false - | Some data -> - match Data_encoding.Binary.of_bytes Fitness.encoding data with - | None -> assert false - | Some data -> Lwt.return data -let set_fitness ctxt data = - GitStore.FunView.set ctxt.view current_fitness_key - (Data_encoding.Binary.to_bytes Fitness.encoding data) >>= fun view -> - Lwt.return { ctxt with view } - -let get_timestamp { view } = - GitStore.FunView.get view current_timestamp_key >>= function - | None -> assert false - | Some time -> - Lwt.return (Time.of_notation_exn (MBytes.to_string time)) -let set_timestamp ctxt time = - GitStore.FunView.set ctxt.view current_timestamp_key - (MBytes.of_string (Time.to_notation time)) >>= fun view -> - Lwt.return { ctxt with view } - exception Preexistent_context of Block_hash.t exception Empty_head of Block_hash.t -let commit key context = - get_timestamp context >>= fun timestamp -> - get_fitness context >>= fun fitness -> - let task = - Irmin.Task.create ~date:(Time.to_seconds timestamp) ~owner:"Tezos" in +let commit key ~time ~message context = + let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in GitStore.clone task context.store (Block_hash.to_b58check key) >>= function | `Empty_head -> Lwt.fail (Empty_head key) | `Duplicated_branch -> Lwt.fail (Preexistent_context key) | `Ok store -> - get_and_erase_commit_message context >>= fun (msg, context) -> - let msg = match msg with - | None -> - Format.asprintf "%a %a" - Fitness.pp fitness Block_hash.pp_short key - | Some msg -> msg in - GitStore.FunView.update_path (store msg) [] context.view >>= fun () -> + GitStore.FunView.update_path + (store message) [] context.view >>= fun () -> context.index.commits <- context.index.commits + 1 ; if context.index.commits mod 200 = 0 then Lwt_utils.Idle_waiter.force_idle @@ -267,18 +221,15 @@ let init ?patch_context ~root = } let commit_genesis index ~id:block ~time ~protocol ~test_protocol = + let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in GitStore.of_branch_id - Irmin.Task.none (Block_hash.to_b58check block) + task (Block_hash.to_b58check block) index.repo >>= fun t -> - let store = t () in + let store = t "Genesis" in GitStore.FunView.of_path store [] >>= fun view -> let view = (view, index.repack_scheduler) in - GitStore.FunView.set view current_timestamp_key - (MBytes.of_string (Time.to_notation time)) >>= fun view -> GitStore.FunView.set view current_protocol_key (Protocol_hash.to_bytes protocol) >>= fun view -> - GitStore.FunView.set view current_fitness_key - (Data_encoding.Binary.to_bytes Fitness.encoding []) >>= fun view -> GitStore.FunView.set view current_test_protocol_key (Protocol_hash.to_bytes test_protocol) >>= fun view -> let ctxt = { index ; store ; view } in @@ -334,7 +285,6 @@ let init_test_network v ~time ~genesis = get_test_protocol v >>= fun test_protocol -> del_test_network_expiration v >>= fun v -> set_protocol v test_protocol >>= fun v -> - set_timestamp v time >>= fun v -> let task = Irmin.Task.create ~date:(Time.to_seconds time) diff --git a/src/node/db/context.mli b/src/node/db/context.mli index 67339fcf2..fb81a6477 100644 --- a/src/node/db/context.mli +++ b/src/node/db/context.mli @@ -40,7 +40,11 @@ exception Preexistent_context of Block_hash.t val exists: index -> Block_hash.t -> bool Lwt.t val checkout: index -> Block_hash.t -> context option Lwt.t val checkout_exn: index -> Block_hash.t -> context Lwt.t -val commit: Block_hash.t -> context -> unit Lwt.t +val commit: + Block_hash.t -> + time:Time.t -> + message:string -> + context -> unit Lwt.t (** {2 Predefined Fields} ****************************************************) @@ -58,16 +62,9 @@ val get_test_network_expiration: context -> Time.t option Lwt.t val set_test_network_expiration: context -> Time.t -> context Lwt.t val del_test_network_expiration: context -> context Lwt.t +(* FIXME split in two (reset after commit *) val read_and_reset_fork_test_network: context -> (bool * context) Lwt.t val fork_test_network: context -> context Lwt.t -val set_fitness: context -> Fitness.fitness -> context Lwt.t -val get_fitness: context -> Fitness.fitness Lwt.t - -val set_timestamp: context -> Time.t -> context Lwt.t -val get_timestamp: context -> Time.t Lwt.t - -val set_commit_message: context -> string -> context Lwt.t - val init_test_network: context -> time:Time.t -> genesis:Block_hash.t -> context tzresult Lwt.t diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index bc5304276..40c7211ad 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -278,9 +278,8 @@ module RPC = struct State.Valid_block.Current.head net_state >>= fun head -> Prevalidator.context pv >>= function | Error _ -> Lwt.fail Not_found - | Ok ctxt -> - Context.get_fitness ctxt >>= fun fitness -> - Context.get_protocol ctxt >>= fun protocol -> + | Ok { context ; fitness } -> + Context.get_protocol context >>= fun protocol -> let operations = let pv_result, _ = Prevalidator.operations pv in Some [ pv_result.applied ] in @@ -291,29 +290,36 @@ module RPC = struct protocol = Some protocol ; fitness ; operations ; timestamp } - let get_context node block = + let rpc_context block : Updater.rpc_context = + { context = block.State.Valid_block.context ; + fitness = block.fitness ; + timestamp = block. timestamp } + + let get_rpc_context node block = match block with | `Genesis -> State.Valid_block.Current.genesis node.mainnet_net >>= fun block -> - Lwt.return (Some block.context) + Lwt.return (Some (rpc_context block)) | ( `Head n | `Test_head n ) as block -> let validator = get_validator node block in let net_state = Validator.net_state validator in let net_db = Validator.net_db validator in State.Valid_block.Current.head net_state >>= fun head -> - get_pred net_db n head >>= fun { context } -> - Lwt.return (Some context) + get_pred net_db n head >>= fun block -> + Lwt.return (Some (rpc_context block)) | `Hash hash-> begin read_valid_block node hash >|= function | None -> None - | Some { context } -> Some context + | Some block -> Some (rpc_context block) end | ( `Prevalidation | `Test_prevalidation ) as block -> let validator, _net = get_net node block in let pv = Validator.prevalidator validator in Prevalidator.context pv >>= function | Error _ -> Lwt.fail Not_found - | Ok ctxt -> Lwt.return (Some ctxt) + | Ok { context ; fitness } -> + let timestamp = Prevalidator.timestamp pv in + Lwt.return (Some { Updater.context ; fitness ; timestamp }) let operations node block = match block with @@ -417,8 +423,7 @@ module RPC = struct ~predecessor ~timestamp >>=? fun validation_state -> Prevalidation.prevalidate validation_state ~sort rops >>=? fun (validation_state, r) -> - Prevalidation.end_prevalidation validation_state >>=? fun ctxt -> - Context.get_fitness ctxt >>= fun fitness -> + Prevalidation.end_prevalidation validation_state >>=? fun { fitness } -> return (fitness, { r with applied = List.rev r.applied }) let complete node ?block str = @@ -426,9 +431,9 @@ module RPC = struct | None -> Base58.complete str | Some block -> - get_context node block >>= function + get_rpc_context node block >>= function | None -> Lwt.fail Not_found - | Some ctxt -> + | Some { context = ctxt } -> Context.get_protocol ctxt >>= fun protocol_hash -> let (module Proto) = Updater.get_exn protocol_hash in Base58.complete str >>= fun l1 -> @@ -436,12 +441,12 @@ module RPC = struct Lwt.return (l1 @ l2) let context_dir node block = - get_context node block >>= function + get_rpc_context node block >>= function | None -> Lwt.return None - | Some ctxt -> - Context.get_protocol ctxt >>= fun protocol_hash -> + | Some rpc_context -> + Context.get_protocol rpc_context.context >>= fun protocol_hash -> let (module Proto) = Updater.get_exn protocol_hash in - let dir = RPC.map (fun () -> ctxt) Proto.rpc_services in + let dir = RPC.map (fun () -> rpc_context) Proto.rpc_services in Lwt.return (Some (RPC.map (fun _ -> ()) dir)) let heads node = diff --git a/src/node/shell/prevalidation.ml b/src/node/shell/prevalidation.ml index 0822bae23..84e6df095 100644 --- a/src/node/shell/prevalidation.ml +++ b/src/node/shell/prevalidation.ml @@ -135,7 +135,8 @@ let start_prevalidation { State.Valid_block.protocol ; hash = predecessor ; context = predecessor_context ; - timestamp = predecessor_timestamp } + timestamp = predecessor_timestamp ; + fitness = predecessor_fitness } ~timestamp = let (module Proto) = match protocol with @@ -144,8 +145,10 @@ let start_prevalidation Proto.begin_construction ~predecessor_context ~predecessor_timestamp + ~predecessor_fitness ~predecessor - ~timestamp >>=? fun state -> + ~timestamp + >>=? fun state -> return (State { proto = (module Proto) ; state }) let prevalidate diff --git a/src/node/shell/prevalidation.mli b/src/node/shell/prevalidation.mli index ce9a31cd8..21ef80df3 100644 --- a/src/node/shell/prevalidation.mli +++ b/src/node/shell/prevalidation.mli @@ -39,4 +39,4 @@ val prevalidate : (prevalidation_state * error preapply_result) tzresult Lwt.t val end_prevalidation : - prevalidation_state -> Context.t tzresult Lwt.t + prevalidation_state -> Updater.validation_result tzresult Lwt.t diff --git a/src/node/shell/prevalidator.ml b/src/node/shell/prevalidator.ml index 93fc62209..a8b47fc24 100644 --- a/src/node/shell/prevalidator.ml +++ b/src/node/shell/prevalidator.ml @@ -54,7 +54,7 @@ type t = { operations: unit -> error preapply_result * Operation_hash.Set.t ; pending: ?block:State.Valid_block.t -> unit -> Operation_hash.Set.t Lwt.t ; timestamp: unit -> Time.t ; - context: unit -> Context.t tzresult Lwt.t ; + context: unit -> Updater.validation_result tzresult Lwt.t ; shutdown: unit -> unit Lwt.t ; } diff --git a/src/node/shell/prevalidator.mli b/src/node/shell/prevalidator.mli index 47cf052ae..e44e257d1 100644 --- a/src/node/shell/prevalidator.mli +++ b/src/node/shell/prevalidator.mli @@ -44,6 +44,6 @@ val inject_operation: val flush: t -> State.Valid_block.t -> unit val timestamp: t -> Time.t val operations: t -> error Prevalidation.preapply_result * Operation_hash.Set.t -val context: t -> Context.t tzresult Lwt.t +val context: t -> Updater.validation_result tzresult Lwt.t val pending: ?block:State.Valid_block.t -> t -> Operation_hash.Set.t Lwt.t diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index bc4070dc2..653385fd2 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -996,14 +996,13 @@ module Valid_block = struct block_header_store (net_state: net_state) valid_block_watcher - hash context ttl = + hash { Updater.context ; fitness ; message } ttl = (* Read the block header. *) Raw_block_header.Locked.read block_header_store hash >>=? fun block -> Raw_block_header.Locked.read_discovery_time block_header_store hash >>=? fun discovery_time -> (* Check fitness coherency. *) - Context.get_fitness context >>= fun fitness -> fail_unless (Fitness.equal fitness block.Store.Block_header.shell.fitness) (Invalid_fitness @@ -1041,7 +1040,15 @@ module Valid_block = struct Operation_list.Locked.read_all block_header_store hash >>=? fun operations -> (* Let's commit the context. *) - Context.commit hash context >>= fun () -> + let message = + match message with + | Some message -> message + | None -> + Format.asprintf "%a: %a" + Block_hash.pp_short hash + Fitness.pp fitness in + Context.commit + hash ~time:block.shell.timestamp ~message context >>= fun () -> (* Update the chain state. *) let store = net_state.chain_store in let predecessor = block.shell.predecessor in diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index 6cab88577..b8c64f6ea 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -284,7 +284,8 @@ module Valid_block : sig val read_opt: Net.t -> Block_hash.t -> valid_block option Lwt.t val read_exn: Net.t -> Block_hash.t -> valid_block Lwt.t val store: - Net.t -> Block_hash.t -> Context.t -> valid_block option tzresult Lwt.t + Net.t -> Block_hash.t -> Updater.validation_result -> + valid_block option tzresult Lwt.t val watcher: Net.t -> valid_block Lwt_stream.t * Watcher.stopper diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 09af946f7..6b488bbe0 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -181,10 +181,8 @@ let apply_block net db begin match pred.protocol with | None -> fail (State.Unknown_protocol pred.protocol_hash) - | Some p -> - Context.set_timestamp pred.context block.shell.timestamp >>= fun c -> - return (p, c) - end >>=? fun ((module Proto), patched_context) -> + | Some p -> return p + end >>=? fun (module Proto) -> lwt_debug "validation of %a: Proto %a" Block_hash.pp_short hash Protocol_hash.pp_short Proto.hash >>= fun () -> @@ -201,8 +199,9 @@ let apply_block net db lwt_debug "validation of %a: applying block..." Block_hash.pp_short hash >>= fun () -> Proto.begin_application - ~predecessor_context:patched_context + ~predecessor_context:pred.context ~predecessor_timestamp:pred.timestamp + ~predecessor_fitness:pred.fitness block >>=? fun state -> fold_left_s (fun state op -> Proto.apply_operation state op >>=? fun state -> diff --git a/src/node/updater/protocol.mli b/src/node/updater/protocol.mli index c8fb8d788..dd6e9124e 100644 --- a/src/node/updater/protocol.mli +++ b/src/node/updater/protocol.mli @@ -9,11 +9,10 @@ (** Tezos Protocol Environment - Protocol Implementation Signature *) -(** The score of a block as a sequence of as unsigned bytes. Ordered - by length and then by contents lexicographically. *) +(* See `src/proto/updater.mli` for documentation. *) + type fitness = Fitness.fitness -(** The version agnostic toplevel structure of operations. *) type shell_operation = Store.Operation.shell_header = { net_id: Net_id.t ; } @@ -23,20 +22,12 @@ type raw_operation = Store.Operation.t = { proto: MBytes.t ; } -(** The version agnostic toplevel structure of blocks. *) type shell_block = Store.Block_header.shell_header = { net_id: Net_id.t ; - (** The genesis of the chain this block belongs to. *) predecessor: Block_hash.t ; - (** The preceding block in the chain. *) timestamp: Time.t ; - (** The date at which this block has been forged. *) operations: Operation_list_list_hash.t ; - (** The sequence of operations. *) fitness: MBytes.t list ; - (** The announced score of the block. As a sequence of sequences - of unsigned bytes. Ordered by length and then by contents - lexicographically. *) } type raw_block = Store.Block_header.t = { @@ -44,96 +35,59 @@ type raw_block = Store.Block_header.t = { proto: MBytes.t ; } -(** This is the signature of a Tezos protocol implementation. It has - access to the standard library and the Environment module. *) +type validation_result = { + context: Context.t ; + fitness: Fitness.fitness ; + message: string option ; +} + +type rpc_context = { + context: Context.t ; + timestamp: Time.t ; + fitness: Fitness.fitness ; +} + module type PROTOCOL = sig type error = .. type 'a tzresult = ('a, error list) result - (** The version specific type of operations. *) - type operation - - (** The maximum size of operations in bytes *) val max_operation_data_length : int - - (** The maximum size of block headers in bytes *) val max_block_length : int - - (** The maximum *) val max_number_of_operations : int - (** The parsing / preliminary validation function for - operations. Similar to {!parse_block}. *) + type operation + val parse_operation : Operation_hash.t -> raw_operation -> operation tzresult - - (** Basic ordering of operations. [compare_operations op1 op2] means - that [op1] should appear before [op2] in a block. *) val compare_operations : operation -> operation -> int - (** A functional state that is transmitted through the steps of a - block validation sequence. It must retain the current state of - the store (that can be extracted from the outside using - {!current_context}, and whose final value is produced by - {!finalize_block}). It can also contain the information that - must be remembered during the validation, which must be - immutable (as validator or baker implementations are allowed to - pause, replay or backtrack during the validation process). *) type validation_state - - (** Access the context at a given validation step. *) val current_context : validation_state -> Context.t tzresult Lwt.t - - (** Checks that a block is well formed in a given context. This - function should run quickly, as its main use is to reject bad - blocks from the network as early as possible. The input context - is the one resulting of an ancestor block of same protocol - version, not necessarily the one of its predecessor. *) val precheck_block : ancestor_context: Context.t -> ancestor_timestamp: Time.t -> raw_block -> unit tzresult Lwt.t - - (** The first step in a block validation sequence. Initializes a - validation context for validating a block. Takes as argument the - {!raw_block} to initialize the context for this block, patching - the context resulting of the application of the predecessor - block passed as parameter. The function {!precheck_block} may - not have been called before [begin_application], so all the - check performed by the former must be repeated in the latter. *) val begin_application : predecessor_context: Context.t -> predecessor_timestamp: Time.t -> + predecessor_fitness: Fitness.fitness -> raw_block -> validation_state tzresult Lwt.t - - (** Initializes a validation context for constructing a new block - (as opposed to validating an existing block). Since there is no - {!raw_block} header available, the parts that it provides are - passed as arguments (predecessor block hash, context resulting - of the application of the predecessor block, and timestamp). *) val begin_construction : predecessor_context: Context.t -> predecessor_timestamp: Time.t -> + predecessor_fitness: Fitness.fitness -> predecessor: Block_hash.t -> timestamp: Time.t -> validation_state tzresult Lwt.t - - (** Called after {!begin_application} (or {!begin_construction}) and - before {!finalize_block}, with each operation in the block. *) val apply_operation : validation_state -> operation -> validation_state tzresult Lwt.t - - (** The last step in a block validation sequence. It produces the - context that will be used as input for the validation of its - successor block candidates. *) val finalize_block : - validation_state -> Context.t tzresult Lwt.t + validation_state -> validation_result tzresult Lwt.t - (** The list of remote procedures exported by this implementation *) - val rpc_services : Context.t RPC.directory + val rpc_services : rpc_context RPC.directory val configure_sandbox : Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t diff --git a/src/node/updater/register.ml b/src/node/updater/register.ml index df950446d..4a9827872 100644 --- a/src/node/updater/register.ml +++ b/src/node/updater/register.ml @@ -41,15 +41,19 @@ let register (module Proto : Protocol.PACKED_PROTOCOL) = raw_block >|= wrap_error let begin_application ~predecessor_context ~predecessor_timestamp + ~predecessor_fitness raw_block = begin_application ~predecessor_context ~predecessor_timestamp + ~predecessor_fitness raw_block >|= wrap_error let begin_construction ~predecessor_context ~predecessor_timestamp + ~predecessor_fitness ~predecessor ~timestamp = begin_construction ~predecessor_context ~predecessor_timestamp + ~predecessor_fitness ~predecessor ~timestamp >|= wrap_error let current_context c = current_context c >|= wrap_error diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index a0462d5ee..fde64bebb 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -11,6 +11,18 @@ open Logging.Updater let (//) = Filename.concat +type validation_result = Protocol.validation_result = { + context: Context.t ; + fitness: Fitness.fitness ; + message: string option ; +} + +type rpc_context = Protocol.rpc_context = { + context: Context.t ; + timestamp: Time.t ; + fitness: Fitness.fitness ; +} + module type PROTOCOL = Protocol.PROTOCOL module type REGISTRED_PROTOCOL = sig val hash: Protocol_hash.t @@ -30,20 +42,12 @@ type raw_operation = Store.Operation.t = { } let raw_operation_encoding = Store.Operation.encoding -(** The version agnostic toplevel structure of blocks. *) type shell_block = Store.Block_header.shell_header = { net_id: Net_id.t ; - (** The genesis of the chain this block belongs to. *) predecessor: Block_hash.t ; - (** The preceding block in the chain. *) timestamp: Time.t ; - (** The date at which this block has been forged. *) operations: Operation_list_list_hash.t ; - (** The sequence of operations. *) fitness: MBytes.t list ; - (** The announced score of the block. As a sequence of sequences - of unsigned bytes. Ordered by length and then by contents - lexicographically. *) } let shell_block_encoding = Store.Block_header.shell_header_encoding diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index bda578c43..0848878c5 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -18,20 +18,12 @@ type raw_operation = Store.Operation.t = { } val raw_operation_encoding: raw_operation Data_encoding.t -(** The version agnostic toplevel structure of blocks. *) type shell_block = Store.Block_header.shell_header = { net_id: Net_id.t ; - (** The genesis of the chain this block belongs to. *) predecessor: Block_hash.t ; - (** The preceding block in the chain. *) timestamp: Time.t ; - (** The date at which this block has been forged. *) operations: Operation_list_list_hash.t ; - (** The sequence of operations. *) fitness: MBytes.t list ; - (** The announced score of the block. As a sequence of sequences - of unsigned bytes. Ordered by length and then by contents - lexicographically. *) } val shell_block_encoding: shell_block Data_encoding.t @@ -41,6 +33,18 @@ type raw_block = Store.Block_header.t = { } val raw_block_encoding: raw_block Data_encoding.t +type validation_result = Protocol.validation_result = { + context: Context.t ; + fitness: Fitness.fitness ; + message: string option ; +} + +type rpc_context = Protocol.rpc_context = { + context: Context.t ; + timestamp: Time.t ; + fitness: Fitness.fitness ; +} + module type PROTOCOL = Protocol.PROTOCOL module type REGISTRED_PROTOCOL = sig val hash: Protocol_hash.t diff --git a/src/proto/alpha/apply.ml b/src/proto/alpha/apply.ml index e959b8578..3ad030a05 100644 --- a/src/proto/alpha/apply.ml +++ b/src/proto/alpha/apply.ml @@ -51,7 +51,7 @@ let apply_delegate_operation_content (Block_hash.equal block pred_block) (Wrong_endorsement_predecessor (pred_block, block)) >>=? fun () -> Mining.check_signing_rights ctxt slot delegate >>=? fun () -> - Fitness.increase ctxt >>=? fun ctxt -> + let ctxt = Fitness.increase ctxt in Mining.pay_endorsement_bond ctxt delegate >>=? fun (ctxt, bond) -> Mining.endorsement_reward ~block_priority >>=? fun reward -> Level.current ctxt >>=? fun { cycle = current_cycle } -> @@ -238,7 +238,7 @@ let may_start_new_cycle ctxt = Seed.compute_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt -> Roll.clear_cycle ctxt last_cycle >>=? fun ctxt -> Roll.freeze_rolls_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt -> - Timestamp.get_current ctxt >>= fun timestamp -> + let timestamp = Timestamp.current ctxt in Lwt.return (Timestamp.(timestamp +? (Constants.time_before_reward ctxt))) >>=? fun reward_date -> Reward.set_reward_time_for_cycle @@ -254,10 +254,10 @@ let begin_application ctxt block pred_timestamp = Mining.check_mining_rights ctxt block pred_timestamp >>=? fun miner -> Mining.check_signature ctxt block miner >>=? fun () -> Mining.pay_mining_bond ctxt block miner >>=? fun ctxt -> - Fitness.increase ctxt >>=? fun ctxt -> + let ctxt = Fitness.increase ctxt in return (ctxt, miner) -let finalize_application ctxt block miner op_count = +let finalize_application ctxt block miner = (* end of level (from this point nothing should fail) *) let priority = block.Block.proto.mining_slot.priority in let reward = Mining.base_mining_reward ctxt ~priority in @@ -268,14 +268,7 @@ let finalize_application ctxt block miner op_count = (* end of cycle *) may_start_new_cycle ctxt >>=? fun ctxt -> Amendment.may_start_new_voting_cycle ctxt >>=? fun ctxt -> - Level.current ctxt >>=? fun { level } -> - let level = Raw_level.to_int32 level in - Fitness.get ctxt >>=? fun fitness -> - let commit_message = - Format.asprintf - "lvl %ld, fit %Ld, prio %ld, %d ops" - level fitness priority op_count in - return (commit_message, ctxt) + return ctxt let compare_operations op1 op2 = match op1.contents, op2.contents with diff --git a/src/proto/alpha/fitness_repr.ml b/src/proto/alpha/fitness_repr.ml index e94599593..c5bdafab6 100644 --- a/src/proto/alpha/fitness_repr.ml +++ b/src/proto/alpha/fitness_repr.ml @@ -16,9 +16,9 @@ let int64_to_bytes i = let int64_of_bytes b = if Compare.Int.(MBytes.length b <> 8) then - fail Invalid_fitness + error Invalid_fitness else - return (MBytes.get_int64 b 0) + ok (MBytes.get_int64 b 0) let from_int64 fitness = [ MBytes.of_string Constants_repr.version_number ; @@ -30,5 +30,5 @@ let to_int64 = function when Compare.String. (MBytes.to_string version = Constants_repr.version_number) -> int64_of_bytes fitness - | [] -> return 0L - | _ -> fail Invalid_fitness + | [] -> ok 0L + | _ -> error Invalid_fitness diff --git a/src/proto/alpha/fitness_storage.ml b/src/proto/alpha/fitness_storage.ml index 47683b625..58cf30d18 100644 --- a/src/proto/alpha/fitness_storage.ml +++ b/src/proto/alpha/fitness_storage.ml @@ -7,17 +7,7 @@ (* *) (**************************************************************************) -let get ctxt = - Storage.get_fitness ctxt >>= fun fitness -> - Fitness_repr.to_int64 fitness - -let set ctxt v = - Storage.set_fitness ctxt (Fitness_repr.from_int64 v) >>= fun ctxt -> - Lwt.return ctxt - +let current = Storage.current_fitness let increase ctxt = - get ctxt >>=? fun v -> - set ctxt (Int64.succ v) >>= fun ctxt -> - return ctxt - -let init ctxt = set ctxt 0L + let fitness = current ctxt in + Storage.set_current_fitness ctxt (Int64.succ fitness) diff --git a/src/proto/alpha/init_storage.ml b/src/proto/alpha/init_storage.ml index a51f2ed04..fdae35666 100644 --- a/src/proto/alpha/init_storage.ml +++ b/src/proto/alpha/init_storage.ml @@ -14,15 +14,9 @@ let version_key = ["version"] let version_value = "alpha" (* This is the genesis protocol: initialise the state *) -let initialize ~from_genesis (ctxt:Context.t) = +let initialize ~timestamp ~fitness (ctxt: Context.t) = Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt -> - Storage.prepare ctxt >>=? fun store -> - begin - if from_genesis then - Lwt.return store - else - Fitness_storage.init store - end >>= fun store -> + Storage.prepare ~timestamp ~fitness ctxt >>=? fun store -> Level_storage.init store >>=? fun store -> Roll_storage.init store >>=? fun store -> Nonce_storage.init store >>=? fun store -> @@ -41,19 +35,20 @@ type error += | Incompatiple_protocol_version | Unimplemented_sandbox_migration -let may_initialize ctxt = +let may_initialize ctxt ~timestamp ~fitness = Context.get ctxt version_key >>= function | None -> (* This is the genesis protocol: The only acceptable preceding version is an empty context *) - initialize ~from_genesis:false ctxt + initialize ~timestamp ~fitness ctxt | Some bytes -> let s = MBytes.to_string bytes in - if Compare.String.(s = version_value) - then Storage.prepare ctxt + if Compare.String.(s = version_value) then + Storage.prepare ~timestamp ~fitness ctxt else if Compare.String.(s = "genesis") then - initialize ~from_genesis:true ctxt - else fail Incompatiple_protocol_version + initialize ~timestamp ~fitness ctxt + else + fail Incompatiple_protocol_version let configure_sandbox ctxt json = let json = @@ -63,8 +58,7 @@ let configure_sandbox ctxt json = Context.get ctxt version_key >>= function | None -> Storage.set_sandboxed ctxt json >>= fun ctxt -> - initialize ~from_genesis:false ctxt >>=? fun ctxt -> - return (Storage.recover ctxt) + return ctxt | Some _ -> Storage.get_sandboxed ctxt >>=? function | None -> diff --git a/src/proto/alpha/main.ml b/src/proto/alpha/main.ml index b764fe923..7b3d632c4 100644 --- a/src/proto/alpha/main.ml +++ b/src/proto/alpha/main.ml @@ -34,7 +34,7 @@ type validation_state = op_count : int } let current_context { ctxt } = - Tezos_context.finalize ctxt + return (Tezos_context.finalize ctxt).context let precheck_block ~ancestor_context:_ @@ -47,9 +47,11 @@ let precheck_block let begin_application ~predecessor_context:ctxt ~predecessor_timestamp:pred_timestamp + ~predecessor_fitness:pred_fitness raw_block = Lwt.return (Tezos_context.Block.parse_header raw_block) >>=? fun header -> - Tezos_context.init ctxt >>=? fun ctxt -> + let timestamp = header.shell.timestamp in + Tezos_context.init ~timestamp ~fitness:pred_fitness ctxt >>=? fun ctxt -> Apply.begin_application ctxt header pred_timestamp >>=? fun (ctxt, miner) -> let mode = Application (header, miner) in return { mode ; ctxt ; op_count = 0 } @@ -57,11 +59,12 @@ let begin_application let begin_construction ~predecessor_context:ctxt ~predecessor_timestamp:_ + ~predecessor_fitness:pred_fitness ~predecessor:pred_block ~timestamp = let mode = Construction { pred_block ; timestamp } in - Tezos_context.init ctxt >>=? fun ctxt -> - Apply.begin_construction ctxt >>=? fun ctxt -> + Tezos_context.init ~timestamp ~fitness:pred_fitness ctxt >>=? fun ctxt -> + let ctxt = Apply.begin_construction ctxt in return { mode ; ctxt ; op_count = 0 } let apply_operation ({ mode ; ctxt ; op_count } as data) operation = @@ -81,12 +84,19 @@ let apply_operation ({ mode ; ctxt ; op_count } as data) operation = let finalize_block { mode ; ctxt ; op_count } = match mode with | Construction _ -> - Tezos_context.finalize ctxt >>=? fun ctxt -> + let ctxt = Tezos_context.finalize ctxt in return ctxt | Application (block, miner) -> - Apply.finalize_application - ctxt block miner op_count >>=? fun (commit_message, ctxt) -> - Tezos_context.finalize ~commit_message ctxt >>=? fun ctxt -> + Apply.finalize_application ctxt block miner >>=? fun ctxt -> + Tezos_context.Level.current ctxt >>=? fun { level } -> + let priority = block.proto.mining_slot.priority in + let level = Tezos_context.Raw_level.to_int32 level in + let fitness = Tezos_context.Fitness.current ctxt in + let commit_message = + Format.asprintf + "lvl %ld, fit %Ld, prio %ld, %d ops" + level fitness priority op_count in + let ctxt = Tezos_context.finalize ~commit_message ctxt in return ctxt let compare_operations op1 op2 = diff --git a/src/proto/alpha/mining.ml b/src/proto/alpha/mining.ml index e1b1b7392..c5e8b0094 100644 --- a/src/proto/alpha/mining.ml +++ b/src/proto/alpha/mining.ml @@ -128,7 +128,7 @@ let minimal_time c priority pred_timestamp = let check_timestamp c priority pred_timestamp = minimal_time c priority pred_timestamp >>=? fun minimal_time -> - Tezos_context.Timestamp.get_current c >>= fun timestamp -> + let timestamp = Tezos_context.Timestamp.current c in fail_unless Timestamp.(minimal_time <= timestamp) (Timestamp_too_early (minimal_time, timestamp)) @@ -273,8 +273,8 @@ let max_fitness_gap ctxt = Int64.add slots 1L let check_fitness_gap ctxt (block : Block.header) = - Fitness.get ctxt >>=? fun current_fitness -> - Fitness.to_int64 block.shell.fitness >>=? fun announced_fitness -> + let current_fitness = Fitness.current ctxt in + Lwt.return (Fitness.to_int64 block.shell.fitness) >>=? fun announced_fitness -> let gap = Int64.sub announced_fitness current_fitness in if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap)) diff --git a/src/proto/alpha/reward_storage.ml b/src/proto/alpha/reward_storage.ml index ef1a78759..15c3ca797 100644 --- a/src/proto/alpha/reward_storage.ml +++ b/src/proto/alpha/reward_storage.ml @@ -56,7 +56,7 @@ let pay_rewards_for_cycle c cycle = amount) let pay_due_rewards c = - Storage.get_timestamp c >>= fun timestamp -> + let timestamp = Storage.current_timestamp c in let rec loop c cycle = Storage.Rewards.Date.get_option c cycle >>=? function | None -> diff --git a/src/proto/alpha/script_interpreter.ml b/src/proto/alpha/script_interpreter.ml index 0e8db053c..d2f186432 100644 --- a/src/proto/alpha/script_interpreter.ml +++ b/src/proto/alpha/script_interpreter.ml @@ -475,7 +475,7 @@ let rec interp Contract.get_balance ctxt source >>=? fun balance -> logged_return (Item (balance, rest), qta - 1, ctxt) | Now, rest -> - Timestamp.get_current ctxt >>= fun now -> + let now = Timestamp.current ctxt in logged_return (Item (now, rest), qta - 1, ctxt) | Check_signature, Item (key, Item ((signature, message), rest)) -> Public_key.get ctxt key >>=? fun key -> diff --git a/src/proto/alpha/services_registration.ml b/src/proto/alpha/services_registration.ml index 0d2261c22..2d6bff8eb 100644 --- a/src/proto/alpha/services_registration.ml +++ b/src/proto/alpha/services_registration.ml @@ -9,24 +9,27 @@ open Tezos_context -let rpc_services = ref (RPC.empty : Context.t RPC.directory) +let rpc_init { Updater.context ; timestamp ; fitness } = + Tezos_context.init ~timestamp ~fitness context + +let rpc_services = ref (RPC.empty : Updater.rpc_context RPC.directory) let register0 s f = rpc_services := RPC.register !rpc_services (s RPC.Path.root) (fun ctxt () -> - ( Tezos_context.init ctxt >>=? fun ctxt -> + ( rpc_init ctxt >>=? fun ctxt -> f ctxt ) >>= RPC.Answer.return) let register1 s f = rpc_services := RPC.register !rpc_services (s RPC.Path.root) (fun ctxt arg -> - ( Tezos_context.init ctxt >>=? fun ctxt -> + ( rpc_init ctxt >>=? fun ctxt -> f ctxt arg ) >>= RPC.Answer.return) let register2 s f = rpc_services := RPC.register !rpc_services (s RPC.Path.root) (fun (ctxt, arg1) arg2 -> - ( Tezos_context.init ctxt >>=? fun ctxt -> + ( rpc_init ctxt >>=? fun ctxt -> f ctxt arg1 arg2 ) >>= RPC.Answer.return) let register1_noctxt s f = rpc_services := @@ -143,7 +146,7 @@ let () = rpc_services := RPC.register !rpc_services (s RPC.Path.root) (fun (ctxt, contract) arg -> - ( Tezos_context.init ctxt >>=? fun ctxt -> + ( rpc_init ctxt >>=? fun ctxt -> Contract.exists ctxt contract >>=? function | true -> f ctxt contract arg | false -> raise Not_found ) >>= RPC.Answer.return) in @@ -177,7 +180,7 @@ let minimal_timestamp ctxt prio = let () = register1 Services.Helpers.minimal_timestamp (fun ctxt slot -> - Tezos_context.Timestamp.get_current ctxt >>= fun timestamp -> + let timestamp = Tezos_context.Timestamp.current ctxt in minimal_timestamp ctxt slot timestamp) let () = @@ -305,7 +308,7 @@ let () = Lwt_list.filter_map_p (fun x -> x) @@ List.mapi (fun prio c -> - Tezos_context.Timestamp.get_current ctxt >>= fun timestamp -> + let timestamp = Timestamp.current ctxt in Mining.minimal_time ctxt (Int32.of_int prio) timestamp >>= function | Error _ -> Lwt.return None @@ -343,7 +346,7 @@ let mining_rights_for_delegate let raw_level = level.level in Error_monad.map_s (fun priority -> - Tezos_context.Timestamp.get_current ctxt >>= fun timestamp -> + let timestamp = Timestamp.current ctxt in Mining.minimal_time ctxt priority timestamp >>=? fun time -> return (raw_level, Int32.to_int priority, time)) priorities >>=? fun priorities -> diff --git a/src/proto/alpha/storage.ml b/src/proto/alpha/storage.ml index 7f65834d7..ee8df6062 100644 --- a/src/proto/alpha/storage.ml +++ b/src/proto/alpha/storage.ml @@ -12,19 +12,14 @@ open Storage_functors let version = "v1" let sandboxed_key = [ version ; "sandboxed" ] -let prevalidation_key = [ version ; "prevalidation" ] type t = Storage_functors.context type error += Invalid_sandbox_parameter -let get_fitness (c, _) = Context.get_fitness c -let set_fitness (c, csts) v = - Context.set_fitness c v >>= fun c -> Lwt.return (c, csts) - -let get_timestamp (c, _) = Context.get_timestamp c -let set_commit_message (c, csts) msg = - Context.set_commit_message c msg >>= fun c -> Lwt.return (c, csts) +let current_timestamp { timestamp } = timestamp +let current_fitness { fitness } = fitness +let set_current_fitness c fitness = { c with fitness } let get_sandboxed c = Context.get c sandboxed_key >>= function @@ -38,22 +33,14 @@ let set_sandboxed c json = Context.set c sandboxed_key (Data_encoding.Binary.to_bytes Data_encoding.json json) -let prepare (c : Context.t) : t tzresult Lwt.t = +let prepare ~timestamp ~fitness (c : Context.t) : t tzresult Lwt.t = + Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness -> get_sandboxed c >>=? fun sandbox -> Constants_repr.read sandbox >>=? function constants -> - return (c, constants) -let recover (c, _ : t) : Context.t = c + return { context = c ; constants ; timestamp ; fitness } +let recover { context } : Context.t = context -let get_prevalidation (c, _ : t) = - Context.get c prevalidation_key >>= function - | None -> Lwt.return false - | Some _ -> Lwt.return true -let set_prevalidation (c, constants : t) = - Context.set c prevalidation_key (MBytes.of_string "prevalidation") >>= fun c -> - Lwt.return (c, constants) - - -let constants : t -> _ = snd +let constants { constants } = constants module Key = struct @@ -510,12 +497,12 @@ module Rewards = struct end -let activate (c, constants) h = - Updater.activate c h >>= fun c -> Lwt.return (c, constants) -let fork_test_network (c, constants) = - Updater.fork_test_network c >>= fun c -> Lwt.return (c, constants) -let set_test_protocol (c, constants) h = - Updater.set_test_protocol c h >>= fun c -> Lwt.return (c, constants) +let activate ({ context = c } as s) h = + Updater.activate c h >>= fun c -> Lwt.return { s with context = c } +let fork_test_network ({ context = c } as s) = + Updater.fork_test_network c >>= fun c -> Lwt.return { s with context = c } +let set_test_protocol ({ context = c } as s) h = + Updater.set_test_protocol c h >>= fun c -> Lwt.return { s with context = c } (** Resolver *) diff --git a/src/proto/alpha/storage.mli b/src/proto/alpha/storage.mli index 7ff2503ae..9f9cb1109 100644 --- a/src/proto/alpha/storage.mli +++ b/src/proto/alpha/storage.mli @@ -25,7 +25,10 @@ type t (** Rerieves the state of the database and gives its abstract view *) -val prepare : Context.t -> t tzresult Lwt.t +val prepare : + timestamp: Time.t -> + fitness: Fitness.fitness -> + Context.t -> t tzresult Lwt.t (** Returns the state of the database resulting of operations on its abstract view *) @@ -34,15 +37,10 @@ val recover : t -> Context.t val get_sandboxed : Context.t -> Data_encoding.json option tzresult Lwt.t val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t -val get_fitness : t -> Fitness.fitness Lwt.t -val set_fitness : t -> Fitness.fitness -> t Lwt.t +val current_timestamp : t -> Time.t -val get_timestamp: t -> Time.t Lwt.t - -val set_commit_message: t -> string -> t Lwt.t - -val get_prevalidation : t -> bool Lwt.t -val set_prevalidation : t -> t Lwt.t +val current_fitness : t -> Int64.t +val set_current_fitness : t -> Int64.t -> t val constants : t -> Constants_repr.constants diff --git a/src/proto/alpha/storage_functors.ml b/src/proto/alpha/storage_functors.ml index d99455c72..c8c9fb2b4 100644 --- a/src/proto/alpha/storage_functors.ml +++ b/src/proto/alpha/storage_functors.ml @@ -11,7 +11,12 @@ open Misc -type context = Context.t * Constants_repr.constants +type context = { + context: Context.t ; + constants: Constants_repr.constants ; + timestamp: Time.t ; + fitness: Int64.t ; +} (*-- Errors ------------------------------------------------------------------*) @@ -52,7 +57,7 @@ module Make_raw_data_storage (P : Raw_data_description) = struct let key_to_string l = String.concat "/" (key l) - let get (c, _) k = + let get { context = c } k = Context.get c (key k) >>= function | None -> let msg = @@ -61,16 +66,16 @@ module Make_raw_data_storage (P : Raw_data_description) = struct | Some bytes -> Lwt.return (P.of_bytes bytes) - let mem (c, _) k = Context.mem c (key k) + let mem { context = c } k = Context.mem c (key k) - let get_option (c, _) k = + let get_option { context = c } k = Context.get c (key k) >>= function | None -> return None | Some bytes -> Lwt.return (P.of_bytes bytes >|? fun v -> Some v) (* Verify that the key is present before modifying *) - let set (c, x) k v = + let set ({ context = c } as s) k v = let key = key k in Context.get c key >>= function | None -> @@ -80,13 +85,13 @@ module Make_raw_data_storage (P : Raw_data_description) = struct | Some old -> let bytes = P.to_bytes v in if MBytes.(old = bytes) then - return (c, x) + return { s with context = c } else Context.set c key (P.to_bytes v) >>= fun c -> - return (c, x) + return { s with context = c } (* Verify that the key is not present before inserting *) - let init (c, x) k v = + let init ({ context = c } as s) k v = let key = key k in Context.get c key >>= function @@ -96,27 +101,29 @@ module Make_raw_data_storage (P : Raw_data_description) = struct fail (Storage_error msg) | None -> Context.set c key (P.to_bytes v) >>= fun c -> - return (c, x) + return { s with context = c } (* Does not verify that the key is present or not *) - let init_set (c, x) k v = - Context.set c (key k) (P.to_bytes v) >>= fun c -> return (c, x) + let init_set ({ context = c } as s) k v = + Context.set c (key k) (P.to_bytes v) >>= fun c -> + return { s with context = c } (* Verify that the key is present before deleting *) - let delete (c, x) k = + let delete ({ context = c } as s) k = let key = key k in Context.get c key >>= function | Some _ -> Context.del c key >>= fun c -> - return (c, x) + return { s with context = c } | None -> let msg = "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in fail (Storage_error msg) (* Do not verify before deleting *) - let remove (c, x) k = - Context.del c (key k) >>= fun c -> Lwt.return (c, x) + let remove ({ context = c } as s) k = + Context.del c (key k) >>= fun c -> + Lwt.return { s with context = c } end @@ -229,28 +236,34 @@ module Make_data_set_storage (P : Single_data_description) = struct error (Storage_error msg) | Some v -> Ok v - let add (c, x) v = + let add ({ context = c } as s) v = let hash, data = serial v in HashTbl.mem c hash >>= function - | true -> return (c, x) - | false -> HashTbl.set c hash data >>= fun c -> return (c, x) + | true -> + return { s with context = c } + | false -> + HashTbl.set c hash data >>= fun c -> + return { s with context = c } - let del (c, x) v = + let del ({ context = c } as s) v = let hash, _ = serial v in HashTbl.mem c hash >>= function - | false -> return (c, x) - | true -> HashTbl.del c hash >>= fun c -> return (c, x) + | false -> + return { s with context = c } + | true -> + HashTbl.del c hash >>= fun c -> + return { s with context = c } - let mem (c, _) v = + let mem { context = c } v = let hash, _ = serial v in HashTbl.mem c hash >>= fun v -> return v - let elements (c, _) = + let elements { context = c } = HashTbl.bindings c >>= fun elts -> map_s (fun (_, data) -> Lwt.return (unserial data)) elts - let fold (c, _) init ~f = + let fold { context = c } init ~f = HashTbl.fold c (ok init) ~f:(fun _ data acc -> match acc with @@ -262,9 +275,9 @@ module Make_data_set_storage (P : Single_data_description) = struct f data acc >>= fun acc -> return acc) - let clear (c, x) = + let clear ({ context = c } as s) = HashTbl.fold c c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c -> - return (c, x) + return { s with context = c } end @@ -284,7 +297,7 @@ module Raw_make_iterable_data_storage let key_to_string k = String.concat "/" (K.to_path k) - let get (c, _) k = + let get { context = c } k = HashTbl.get c k >>= function | None -> let msg = @@ -293,15 +306,15 @@ module Raw_make_iterable_data_storage | Some v -> return v - let mem (c, _) k = HashTbl.mem c k + let mem { context = c } k = HashTbl.mem c k - let get_option (c, _) k = + let get_option { context = c } k = HashTbl.get c k >>= function | None -> return None | Some v -> return (Some v) (* Verify that the key is present before modifying *) - let set (c, x) k v = + let set ({ context = c } as s) k v = HashTbl.get c k >>= function | None -> let msg = @@ -309,10 +322,10 @@ module Raw_make_iterable_data_storage fail (Storage_error msg) | Some _ -> HashTbl.set c k v >>= fun c -> - return (c, x) + return { s with context = c } (* Verify that the key is not present before inserting *) - let init (c, x) k v = + let init ({ context = c } as s) k v = HashTbl.get c k >>= function | Some _ -> @@ -321,29 +334,35 @@ module Raw_make_iterable_data_storage fail (Storage_error msg) | None -> HashTbl.set c k v >>= fun c -> - return (c, x) + return { s with context = c } (* Does not verify that the key is present or not *) - let init_set (c, x) k v = HashTbl.set c k v >>= fun c -> return (c, x) + let init_set ({ context = c } as s) k v = + HashTbl.set c k v >>= fun c -> + return { s with context = c } (* Verify that the key is present before deleting *) - let delete (c, x) k = + let delete ({ context = c } as s) k = HashTbl.get c k >>= function | Some _ -> HashTbl.del c k >>= fun c -> - return (c, x) + return { s with context = c } | None -> let msg = "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in fail (Storage_error msg) (* Do not verify before deleting *) - let remove (c, x) k = - HashTbl.del c k >>= fun c -> Lwt.return (c, x) + let remove ({ context = c } as s) k = + HashTbl.del c k >>= fun c -> + Lwt.return { s with context = c } - let clear (c, x) = HashTbl.clear c >>= fun c -> Lwt.return (c, x) - let fold (c, _) x ~f = HashTbl.fold c x ~f:(fun k v acc -> f k v acc) - let iter (c, _) ~f = HashTbl.fold c () ~f:(fun k v () -> f k v) + let clear ({ context = c } as s) = + HashTbl.clear c >>= fun c -> + Lwt.return { s with context = c } + + let fold { context = c } x ~f = HashTbl.fold c x ~f:(fun k v acc -> f k v acc) + let iter { context = c } ~f = HashTbl.fold c () ~f:(fun k v () -> f k v) end diff --git a/src/proto/alpha/storage_functors.mli b/src/proto/alpha/storage_functors.mli index 53593b868..ad1262a09 100644 --- a/src/proto/alpha/storage_functors.mli +++ b/src/proto/alpha/storage_functors.mli @@ -14,7 +14,12 @@ indexed data and homgeneous data set). *) -type context = Context.t * Constants_repr.constants +type context = { + context: Context.t ; + constants: Constants_repr.constants ; + timestamp: Time.t ; + fitness: Int64.t ; +} open Storage_sigs diff --git a/src/proto/alpha/tezos_context.ml b/src/proto/alpha/tezos_context.ml index 02810f9a1..f2a6c7646 100644 --- a/src/proto/alpha/tezos_context.ml +++ b/src/proto/alpha/tezos_context.ml @@ -22,7 +22,7 @@ module Period = Period_repr module Timestamp = struct include Time_repr - let get_current = Storage.get_timestamp + let current = Storage.current_timestamp end include Operation_repr @@ -110,17 +110,12 @@ end let init = Init_storage.may_initialize -let finalize ?commit_message c = - match commit_message with - | None -> - return (Storage.recover c) - | Some msg -> - Storage.set_commit_message c msg >>= fun c -> - return (Storage.recover c) +let finalize ?commit_message:message c = + let fitness = Fitness.from_int64 (Fitness.current c) in + let context = Storage.recover c in + { Updater.context ; fitness ; message } let configure_sandbox = Init_storage.configure_sandbox -let get_prevalidation = Storage.get_prevalidation -let set_prevalidation = Storage.set_prevalidation let activate = Storage.activate let fork_test_network = Storage.fork_test_network diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index 7e37928c4..3e8f33373 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -75,10 +75,7 @@ module Timestamp : sig val of_seconds: string -> time option val to_seconds: time -> string - val get_current: context -> Time.t Lwt.t - (** [get_current ctxt] returns the current timestamp of [ctxt]. When - [ctxt] is the context of a block, the block timestamp is used, - otherwise a timestamp is inferred otherwise. *) + val current: context -> Time.t end @@ -253,10 +250,11 @@ module Fitness : sig include (module type of Fitness) type t = fitness - val increase: context -> context tzresult Lwt.t + val increase: context -> context - val get: context -> int64 tzresult Lwt.t - val to_int64: fitness -> int64 tzresult Lwt.t + val current: context -> int64 + + val to_int64: fitness -> int64 tzresult end @@ -580,15 +578,16 @@ module Reward : sig end -val init: Context.t -> context tzresult Lwt.t -val finalize: ?commit_message:string -> context -> Context.t tzresult Lwt.t +val init: + Context.t -> + timestamp:Time.t -> + fitness:Fitness.t -> + context tzresult Lwt.t +val finalize: ?commit_message:string -> context -> Updater.validation_result val configure_sandbox: Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t -val get_prevalidation: context -> bool Lwt.t -val set_prevalidation: context -> context Lwt.t - val activate: context -> Protocol_hash.t -> context Lwt.t val set_test_protocol: context -> Protocol_hash.t -> context Lwt.t val fork_test_network: context -> context Lwt.t diff --git a/src/proto/demo/main.ml b/src/proto/demo/main.ml index 2dde8adf2..8bc1766db 100644 --- a/src/proto/demo/main.ml +++ b/src/proto/demo/main.ml @@ -17,9 +17,15 @@ let parse_operation h _ = Ok h let compare_operations _ _ = 0 -module Fitness = struct +type validation_state = { + context : Context.t ; + fitness : Int64.t ; +} - let version_number = "\000" +let current_context { context } = + return context + +module Fitness = struct type error += Invalid_fitness type error += Invalid_fitness2 @@ -36,67 +42,50 @@ module Fitness = struct return (MBytes.get_int64 b 0) let from_int64 fitness = - [ MBytes.of_string version_number ; - int64_to_bytes fitness ] + [ int64_to_bytes fitness ] let to_int64 = function - | [ version ; - fitness ] - when Compare.String. - (MBytes.to_string version = version_number) -> - int64_of_bytes fitness + | [ fitness ] -> int64_of_bytes fitness | [] -> return 0L | _ -> fail Invalid_fitness - let get ctxt = - Context.get_fitness ctxt >>= fun fitness -> - to_int64 fitness - - let set ctxt v = - Context.set_fitness ctxt (from_int64 v) >>= fun ctxt -> - Lwt.return ctxt - - let increase ctxt = - get ctxt >>=? fun v -> - set ctxt (Int64.succ v) >>= fun ctxt -> - return ctxt + let get { fitness } = fitness end -type validation_state = Context.t - -let current_context ctxt = - return ctxt - let precheck_block ~ancestor_context:_ ~ancestor_timestamp:_ - _raw_block = + raw_block = + Fitness.to_int64 raw_block.Updater.shell.fitness >>=? fun _ -> return () let begin_application - ~predecessor_context:ctxt + ~predecessor_context:context ~predecessor_timestamp:_ - _raw_block = - return ctxt + ~predecessor_fitness:_ + raw_block = + Fitness.to_int64 raw_block.Updater.shell.fitness >>=? fun fitness -> + return { context ; fitness } let begin_construction - ~predecessor_context:ctxt + ~predecessor_context:context ~predecessor_timestamp:_ + ~predecessor_fitness:pred_fitness ~predecessor:_ ~timestamp:_ = - return ctxt + Fitness.to_int64 pred_fitness >>=? function pred_fitness -> + let fitness = Int64.succ pred_fitness in + return { context ; fitness } let apply_operation ctxt _ = return ctxt let finalize_block ctxt = - Fitness.increase ctxt >>=? fun ctxt -> - Fitness.get ctxt >>=? fun fitness -> - let commit_message = - Format.asprintf "fitness <- %Ld" fitness in - Context.set_commit_message ctxt commit_message >>= fun ctxt -> - return ctxt + let fitness = Fitness.get ctxt in + let message = Some (Format.asprintf "fitness <- %Ld" fitness) in + let fitness = Fitness.from_int64 fitness in + return { Updater.message ; context = ctxt.context ; fitness } let rpc_services = Services.rpc_services diff --git a/src/proto/demo/services.ml b/src/proto/demo/services.ml index daa0bfdc3..5401cf579 100644 --- a/src/proto/demo/services.ml +++ b/src/proto/demo/services.ml @@ -45,7 +45,7 @@ let failing_service custom_root = ~output: (wrap_tzerror Data_encoding.empty) RPC.Path.(custom_root / "failing") -let rpc_services : Context.t RPC.directory = +let rpc_services : Updater.rpc_context RPC.directory = let dir = RPC.empty in let dir = RPC.register diff --git a/src/proto/environment/context.mli b/src/proto/environment/context.mli index fa5920f69..ea07889f0 100644 --- a/src/proto/environment/context.mli +++ b/src/proto/environment/context.mli @@ -5,12 +5,6 @@ open Hash include Persist.STORE -val get_fitness: t -> Fitness.fitness Lwt.t -val set_fitness: t -> Fitness.fitness -> t Lwt.t - -val get_timestamp: t -> Time.t Lwt.t -val set_commit_message: t -> string -> t Lwt.t - val register_resolver: 'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit diff --git a/src/proto/environment/updater.mli b/src/proto/environment/updater.mli index 223d32b09..404cde61a 100644 --- a/src/proto/environment/updater.mli +++ b/src/proto/environment/updater.mli @@ -2,6 +2,7 @@ open Hash +(** The version agnostic toplevel structure of operations. *) type shell_operation = { net_id: Net_id.t ; } @@ -37,6 +38,18 @@ type raw_block = { } val raw_block_encoding: raw_block Data_encoding.t +type validation_result = { + context: Context.t ; + fitness: Fitness.fitness ; + message: string option ; +} + +type rpc_context = { + context: Context.t ; + timestamp: Time.t ; + fitness: Fitness.fitness ; +} + (** This is the signature of a Tezos protocol implementation. It has access to the standard library and the Environment module. *) module type PROTOCOL = sig @@ -99,6 +112,7 @@ module type PROTOCOL = sig val begin_application : predecessor_context: Context.t -> predecessor_timestamp: Time.t -> + predecessor_fitness: Fitness.fitness -> raw_block -> validation_state tzresult Lwt.t @@ -110,6 +124,7 @@ module type PROTOCOL = sig val begin_construction : predecessor_context: Context.t -> predecessor_timestamp: Time.t -> + predecessor_fitness: Fitness.fitness -> predecessor: Block_hash.t -> timestamp: Time.t -> validation_state tzresult Lwt.t @@ -123,10 +138,10 @@ module type PROTOCOL = sig context that will be used as input for the validation of its successor block candidates. *) val finalize_block : - validation_state -> Context.t tzresult Lwt.t + validation_state -> validation_result tzresult Lwt.t (** The list of remote procedures exported by this implementation *) - val rpc_services : Context.t RPC.directory + val rpc_services : rpc_context RPC.directory val configure_sandbox : Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t diff --git a/src/proto/genesis/main.ml b/src/proto/genesis/main.ml index aeee3f4c5..0a0c73f2f 100644 --- a/src/proto/genesis/main.ml +++ b/src/proto/genesis/main.ml @@ -61,10 +61,10 @@ let check_signature ctxt { shell ; command ; signature } = (Ed25519.Signature.check public_key signature bytes) Invalid_signature -type validation_state = block * Context.t +type validation_state = Updater.validation_result -let current_context (_, ctxt) = - return ctxt +let current_context ({ context } : validation_state) = + return context let precheck_block ~ancestor_context:_ @@ -76,38 +76,38 @@ let precheck_block let begin_application ~predecessor_context:ctxt ~predecessor_timestamp:_ + ~predecessor_fitness:_ raw_block = + Data.Init.may_initialize ctxt >>=? fun ctxt -> Lwt.return (parse_block raw_block) >>=? fun block -> - return (block, ctxt) + check_signature ctxt block >>=? fun () -> + let fitness = raw_block.shell.fitness in + match block.command with + | Data.Command.Activate hash -> + let message = + Some (Format.asprintf "activate %a" Protocol_hash.pp_short hash) in + Updater.activate ctxt hash >>= fun ctxt -> + return { Updater.message ; context = ctxt ; fitness } + | Activate_testnet hash -> + let message = + Some (Format.asprintf "activate testnet %a" Protocol_hash.pp_short hash) in + Updater.set_test_protocol ctxt hash >>= fun ctxt -> + Updater.fork_test_network ctxt >>= fun ctxt -> + return { Updater.message ; context = ctxt ; fitness } let begin_construction - ~predecessor_context:_ + ~predecessor_context:context ~predecessor_timestamp:_ + ~predecessor_fitness:fitness ~predecessor:_ ~timestamp:_ = - Lwt.return (Error []) (* absurd *) + (* Dummy result. *) + return { Updater.message = None ; context ; fitness } let apply_operation _vctxt _ = Lwt.return (Error []) (* absurd *) -let finalize_block (header, ctxt) = - check_signature ctxt header >>=? fun () -> - Data.Init.may_initialize ctxt >>=? fun ctxt -> - Context.set_fitness ctxt header.shell.fitness >>= fun ctxt -> - match header.command with - | Activate hash -> - let commit_message = - Format.asprintf "activate %a" Protocol_hash.pp_short hash in - Context.set_commit_message ctxt commit_message >>= fun ctxt -> - Updater.activate ctxt hash >>= fun ctxt -> - return ctxt - | Activate_testnet hash -> - let commit_message = - Format.asprintf "activate testnet %a" Protocol_hash.pp_short hash in - Context.set_commit_message ctxt commit_message >>= fun ctxt -> - Updater.set_test_protocol ctxt hash >>= fun ctxt -> - Updater.fork_test_network ctxt >>= fun ctxt -> - return ctxt +let finalize_block state = return state let rpc_services = Services.rpc_services diff --git a/src/proto/genesis/services.ml b/src/proto/genesis/services.ml index 9f981c84e..cb800e0d0 100644 --- a/src/proto/genesis/services.ml +++ b/src/proto/genesis/services.ml @@ -56,7 +56,7 @@ let int64_to_bytes i = let operations = Operation_list_list_hash.compute [Operation_list_hash.empty] -let rpc_services : Context.t RPC.directory = +let rpc_services : Updater.rpc_context RPC.directory = let dir = RPC.empty in let dir = RPC.register diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index d3edbc882..3c08bb9c3 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -434,7 +434,7 @@ module Mining = struct Client_proto_rpcs.Context.level rpc_config block >>=? fun level -> let level = Raw_level.succ level.level in get_first_priority level contract block >>=? fun priority -> - (Fitness_repr.to_int64 bi.fitness >|= + (Lwt.return (Fitness_repr.to_int64 bi.fitness) >|= Register_client_embedded_proto_alpha.wrap_error) >>=? fun fitness -> let fitness = Fitness_repr.from_int64 @@ diff --git a/test/shell/test_context.ml b/test/shell/test_context.ml index f0afffe63..770e4bf4e 100644 --- a/test/shell/test_context.ml +++ b/test/shell/test_context.ml @@ -37,6 +37,8 @@ let net_id = Net_id.of_block_hash genesis_block (** Context creation *) +let commit = commit ~time:Time.epoch ~message:"" + let block2 = Block_hash.of_hex_exn "2222222222222222222222222222222222222222222222222222222222222222" diff --git a/test/shell/test_state.ml b/test/shell/test_state.ml index de2771c0d..0b4bd3e85 100644 --- a/test/shell/test_state.ml +++ b/test/shell/test_state.ml @@ -38,7 +38,7 @@ let net_id = Net_id.of_block_hash genesis_block let incr_fitness fitness = let new_fitness = match fitness with - | [ _ ; fitness ] -> + | [ fitness ] -> Pervasives.( Data_encoding.Binary.of_bytes Data_encoding.int64 fitness |> Utils.unopt ~default:0L @@ -47,7 +47,7 @@ let incr_fitness fitness = ) | _ -> Data_encoding.Binary.to_bytes Data_encoding.int64 1L in - [ MBytes.of_string "\000" ; new_fitness ] + [ new_fitness ] let incr_timestamp timestamp = Time.add timestamp (Int64.add 1L (Random.int64 10L)) @@ -166,6 +166,7 @@ let build_valid_chain state tbl vtbl otbl pred names = Proto.begin_application ~predecessor_context: pred.context ~predecessor_timestamp: pred.timestamp + ~predecessor_fitness: pred.fitness block >>=? fun vstate -> (* no operations *) Proto.finalize_block vstate From e276b0566e0021e197032a90e80b6aef88c170a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Tue, 11 Apr 2017 00:57:04 +0200 Subject: [PATCH 02/10] Alpha: minor changes in unit tests --- test/proto_alpha/proto_alpha_helpers.ml | 4 +-- test/proto_alpha/proto_alpha_helpers.mli | 1 + test/proto_alpha/test_endorsement.ml | 36 ++++++++++++------------ test/proto_alpha/test_origination.ml | 2 +- test/proto_alpha/test_transaction.ml | 2 +- 5 files changed, 23 insertions(+), 22 deletions(-) diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index 3c08bb9c3..3200188fc 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -422,6 +422,7 @@ module Mining = struct let mine ?(force = false) ?(operations = []) + ~fitness_gap contract block = Client_mining_blocks.info rpc_config block >>=? fun bi -> @@ -438,8 +439,7 @@ module Mining = struct Register_client_embedded_proto_alpha.wrap_error) >>=? fun fitness -> let fitness = Fitness_repr.from_int64 @@ - Int64.add fitness (Int64.of_int @@ List.length operations + 1) in - Level.pp_full Format.str_formatter bi.level ; + Int64.add fitness (Int64.of_int fitness_gap) in inject_block ~force ~priority diff --git a/test/proto_alpha/proto_alpha_helpers.mli b/test/proto_alpha/proto_alpha_helpers.mli index 689f5f77d..008d59756 100644 --- a/test/proto_alpha/proto_alpha_helpers.mli +++ b/test/proto_alpha/proto_alpha_helpers.mli @@ -122,6 +122,7 @@ module Mining : sig val mine : ?force:bool -> ?operations:Operation_hash.t list -> + fitness_gap:int -> Account.t -> Client_node_rpcs.Blocks.block -> Block_hash.t tzresult Lwt.t diff --git a/test/proto_alpha/test_endorsement.ml b/test/proto_alpha/test_endorsement.ml index 9c6db5770..86c61d5ec 100644 --- a/test/proto_alpha/test_endorsement.ml +++ b/test/proto_alpha/test_endorsement.ml @@ -16,25 +16,25 @@ module Assert = Helpers.Assert let test_double_endorsement contract block = (* Double endorsement for the same level *) - Helpers.Mining.mine contract block >>=? fun b1 -> + Helpers.Mining.mine ~fitness_gap:1 contract block >>=? fun b1 -> (* branch root *) - Helpers.Mining.mine contract (`Hash b1) >>=? fun b2 -> + Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b1) >>=? fun b2 -> (* changing branch *) - Helpers.Mining.mine contract (`Hash b1) >>=? fun b2' -> + Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b1) >>=? fun b2' -> (* branch root *) Helpers.Endorse.endorse ~force:true contract (`Hash b2) >>=? fun ops -> - Helpers.Mining.mine ~operations:[ ops ] contract (`Hash b2) >>=? fun _b3 -> + Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] contract (`Hash b2) >>=? fun _b3 -> Helpers.Endorse.endorse ~force:true contract (`Hash b2') >>=? fun ops -> - Helpers.Mining.mine ~operations:[ ops ] contract (`Hash b2') >>=? fun b3' -> + Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] contract (`Hash b2') >>=? fun b3' -> Helpers.Endorse.endorse ~force:true contract (`Hash b3') >>=? fun ops -> - Helpers.Mining.mine ~operations:[ ops ] contract (`Hash b3') >>=? fun b4' -> + Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] contract (`Hash b3') >>=? fun b4' -> (* TODO: Inject double endorsement op ! *) - Helpers.Mining.mine contract (`Hash b4') + Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b4') (* FIXME: Mining.Invalid_signature is unclassified *) let test_invalid_signature block = @@ -47,7 +47,7 @@ let test_invalid_signature block = DYfTKhq7rDQujdn5WWzwUMeV3agaZ6J2vPQT58jJAJPi" in let account = Helpers.Account.create ~keys:(secret_key, public_key) "WRONG SIGNATURE" in - Helpers.Mining.mine account block >>= fun res -> + Helpers.Mining.mine ~fitness_gap:1 account block >>= fun res -> Assert.generic_economic_error ~msg:__LOC__ res ; return () @@ -94,7 +94,7 @@ let test_endorsement_rewards get_endorser_except_b1 accounts >>=? fun (account0, slot0) -> Helpers.Account.balance account0 >>=? fun balance0 -> Helpers.Endorse.endorse ~slot:slot0 ~force:true account0 block >>=? fun ops -> - Helpers.Mining.mine ~operations:[ ops ] b1 block >>=? fun head0 -> + Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 block >>=? fun head0 -> Assert.balance_equal ~msg:__LOC__ account0 (Int64.sub (Tez.to_cents balance0) bond) >>=? fun () -> @@ -104,7 +104,7 @@ let test_endorsement_rewards get_endorser_except_b1 accounts >>=? fun (account1, slot1) -> Helpers.Account.balance account1 >>=? fun balance1 -> Helpers.Endorse.endorse ~slot:slot1 ~force:true account1 block0 >>=? fun ops -> - Helpers.Mining.mine ~operations:[ ops ] b1 block0 >>=? fun head1 -> + Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 block0 >>=? fun head1 -> Assert.balance_equal ~msg:__LOC__ account1 (Int64.sub (Tez.to_cents balance1) bond) >>=? fun () -> @@ -117,8 +117,8 @@ let test_endorsement_rewards Assert.balance_equal ~msg:__LOC__ account2 (Int64.sub (Tez.to_cents balance2) bond) >>=? fun () -> - Helpers.Mining.mine b1 (`Hash head1) >>=? fun head2 -> - Helpers.Mining.mine b1 (`Hash head2) >>=? fun head3 -> + Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head1) >>=? fun head2 -> + Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head2) >>=? fun head3 -> (* Check rewards after one cycle for account0 *) Helpers.Mining.endorsement_reward b1 block0 >>=? fun rw0 -> @@ -135,8 +135,8 @@ let test_endorsement_rewards ~msg:__LOC__ account2 (Tez.to_cents balance2) >>=? fun () -> (* #2 endorse and check reward only on the good chain *) - Helpers.Mining.mine b1 (`Hash head3) >>=? fun head -> - Helpers.Mining.mine b1 (`Hash head3) >>=? fun fork -> + Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun head -> + Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun fork -> (* working on head *) Helpers.Endorse.endorsers_list (`Hash head) baccounts >>=? fun accounts -> @@ -144,18 +144,18 @@ let test_endorsement_rewards Helpers.Account.balance account3 >>=? fun balance3 -> Helpers.Endorse.endorse ~slot:slot3 ~force:true account3 (`Hash head) >>=? fun ops -> - Helpers.Mining.mine ~operations:[ ops ] b1 (`Hash head) >>=? fun new_head -> + Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash head) >>=? fun new_head -> (* working on fork *) Helpers.Endorse.endorsers_list (`Hash fork) baccounts >>=? fun accounts -> get_endorser_except_b1 accounts >>=? fun (account4, slot4) -> Helpers.Account.balance account4 >>=? fun _balance4 -> Helpers.Endorse.endorse ~slot:slot4 ~force:true account4 (`Hash fork) >>=? fun ops -> - Helpers.Mining.mine ~operations:[ ops ] b1 (`Hash fork) >>=? fun _new_fork -> + Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash fork) >>=? fun _new_fork -> Helpers.Account.balance account4 >>=? fun balance4 -> - Helpers.Mining.mine b1 (`Hash new_head) >>=? fun head -> - Helpers.Mining.mine b1 (`Hash head) >>=? fun head -> + Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash new_head) >>=? fun head -> + Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head) >>=? fun head -> (* Check rewards after one cycle *) Helpers.Mining.endorsement_reward b1 (`Hash new_head) >>=? fun reward -> diff --git a/test/proto_alpha/test_origination.ml b/test/proto_alpha/test_origination.ml index d6523f68f..265cd41e9 100644 --- a/test/proto_alpha/test_origination.ml +++ b/test/proto_alpha/test_origination.ml @@ -15,7 +15,7 @@ module Assert = Helpers.Assert let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) = - Helpers.Mining.mine b1 blkid >>=? fun blkh -> + Helpers.Mining.mine ~fitness_gap:1 b1 blkid >>=? fun blkh -> let foo = Helpers.Account.create "foo" in (* Origination with amount = 0 tez *) diff --git a/test/proto_alpha/test_transaction.ml b/test/proto_alpha/test_transaction.ml index af3802f06..abf8a64ba 100644 --- a/test/proto_alpha/test_transaction.ml +++ b/test/proto_alpha/test_transaction.ml @@ -15,7 +15,7 @@ module Assert = Helpers.Assert let run blkid ({ b1 ; b2 ; b3 ; _ } : Helpers.Account.bootstrap_accounts) = - Helpers.Mining.mine b1 blkid >>=? fun blkh -> + Helpers.Mining.mine ~fitness_gap:1 b1 blkid >>=? fun blkh -> let foo = Helpers.Account.create "foo" in let bar = Helpers.Account.create "bar" in From 77d680566453c6111233d479eff99736aaac99f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Tue, 11 Apr 2017 00:57:34 +0200 Subject: [PATCH 03/10] P2p: remove compilation warning in unit test --- test/p2p/test_p2p_connection.ml | 20 ++++++++++---------- test/p2p/test_p2p_connection_pool.ml | 8 ++++---- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/test/p2p/test_p2p_connection.ml b/test/p2p/test_p2p_connection.ml index 6b5e7709d..86421ceaf 100644 --- a/test/p2p/test_p2p_connection.ml +++ b/test/p2p/test_p2p_connection.ml @@ -64,7 +64,7 @@ let sync_nodes nodes = sync_nodes nodes >>= function | Ok () | Error (Exn End_of_file :: _) -> return () - | Error e as err -> + | Error _ as err -> Lwt.return err let run_nodes client server = @@ -147,7 +147,7 @@ module Low_level = struct return () let server _ch sched socket = - raw_accept sched socket >>= fun (fd, point) -> + raw_accept sched socket >>= fun (fd, _point) -> P2p_io_scheduler.write fd simple_msg >>=? fun () -> P2p_io_scheduler.close fd >>=? fun _ -> return () @@ -190,7 +190,7 @@ module Kicked = struct let encoding = Data_encoding.bytes let server _ch sched socket = - accept sched socket >>=? fun (info, auth_fd) -> + accept sched socket >>=? fun (_info, auth_fd) -> P2p_connection.accept auth_fd encoding >>= fun conn -> _assert (Kick.is_rejected conn) __LOC__ "" >>=? fun () -> return () @@ -212,7 +212,7 @@ module Simple_message = struct let simple_msg2 = MBytes.create (1 lsl 4) let server ch sched socket = - accept sched socket >>=? fun (info, auth_fd) -> + accept sched socket >>=? fun (_info, auth_fd) -> P2p_connection.accept auth_fd encoding >>=? fun conn -> P2p_connection.write_sync conn simple_msg >>=? fun () -> P2p_connection.read conn >>=? fun (_msg_size, msg) -> @@ -242,7 +242,7 @@ module Close_on_read = struct let simple_msg = MBytes.create (1 lsl 4) let server _ch sched socket = - accept sched socket >>=? fun (info, auth_fd) -> + accept sched socket >>=? fun (_info, auth_fd) -> P2p_connection.accept auth_fd encoding >>=? fun conn -> P2p_connection.close conn >>= fun _stat -> return () @@ -266,7 +266,7 @@ module Close_on_write = struct let simple_msg = MBytes.create (1 lsl 4) let server ch sched socket = - accept sched socket >>=? fun (info, auth_fd) -> + accept sched socket >>=? fun (_info, auth_fd) -> P2p_connection.accept auth_fd encoding >>=? fun conn -> P2p_connection.close conn >>= fun _stat -> sync ch >>=? fun ()-> @@ -291,8 +291,8 @@ module Garbled_data = struct let garbled_msg = MBytes.create (1 lsl 4) - let server ch sched socket = - accept sched socket >>=? fun (info, auth_fd) -> + let server _ch sched socket = + accept sched socket >>=? fun (_info, auth_fd) -> P2p_connection.accept auth_fd encoding >>=? fun conn -> P2p_connection.raw_write_sync conn garbled_msg >>=? fun () -> P2p_connection.read conn >>= fun err -> @@ -300,7 +300,7 @@ module Garbled_data = struct P2p_connection.close conn >>= fun _stat -> return () - let client ch sched addr port = + let client _ch sched addr port = connect sched addr port id2 >>=? fun auth_fd -> P2p_connection.accept auth_fd encoding >>=? fun conn -> P2p_connection.read conn >>= fun err -> @@ -328,7 +328,7 @@ let spec = Arg.[ let main () = let open Utils in - let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in + let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in let usage_msg = "Usage: %s.\nArguments are:" in Arg.parse spec anon_fun usage_msg ; Test.run "p2p-connection." [ diff --git a/test/p2p/test_p2p_connection_pool.ml b/test/p2p/test_p2p_connection_pool.ml index f677f3796..e1a693617 100644 --- a/test/p2p/test_p2p_connection_pool.ml +++ b/test/p2p/test_p2p_connection_pool.ml @@ -54,7 +54,7 @@ let sync_nodes nodes = sync_nodes nodes >>= function | Ok () | Error (Exn End_of_file :: _) -> return () - | Error e as err -> + | Error _ as err -> Lwt.return err let detach_node f points n = @@ -100,7 +100,7 @@ let detach_node f points n = return () end -let detach_nodes ?(sync = 0) run_node points = +let detach_nodes run_node points = let open Utils in let clients = List.length points in Lwt_list.map_p @@ -196,7 +196,7 @@ module Random_connections = struct let rem = ref (n * total) in iter_p (fun point -> connect_random pool total rem point n) points - let node repeat channel pool points = + let node repeat _channel pool points = lwt_log_info "Begin random connections." >>= fun () -> connect_random_all pool points repeat >>=? fun () -> lwt_log_info "Random connections OK." >>= fun () -> @@ -267,7 +267,7 @@ let spec = Arg.[ let main () = let open Utils in - let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in + let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in let usage_msg = "Usage: %s .\nArguments are:" in Arg.parse spec anon_fun usage_msg ; let ports = !port -- (!port + !clients - 1) in From 6212af55f1049e563edff7eafe0d5723cf79527f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 10 Apr 2017 12:50:15 +0200 Subject: [PATCH 04/10] Proto/Alpha: use `uint16` for mining priority. --- .../alpha/baker/client_mining_forge.ml | 3 +-- .../embedded/alpha/client_proto_rpcs.mli | 2 +- src/proto/alpha/block_repr.ml | 4 +-- src/proto/alpha/block_repr.mli | 2 +- src/proto/alpha/constants_repr.ml | 10 ++++---- src/proto/alpha/main.ml | 4 +-- src/proto/alpha/mining.ml | 24 +++++++++--------- src/proto/alpha/mining.mli | 17 ++++++------- src/proto/alpha/roll_storage.ml | 4 +-- src/proto/alpha/roll_storage.mli | 2 +- src/proto/alpha/services.ml | 6 ++--- src/proto/alpha/services_registration.ml | 25 +++++++------------ src/proto/alpha/tezos_context.mli | 6 ++--- src/proto/environment/data_encoding.mli | 2 ++ test/proto_alpha/proto_alpha_helpers.ml | 6 ++--- 15 files changed, 55 insertions(+), 62 deletions(-) diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index a3c991391..dd0c0d1e4 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -53,8 +53,7 @@ let inject_block cctxt block let shell = { Store.Block_header.net_id = bi.net ; predecessor = bi.hash ; timestamp ; fitness ; operations } in - let slot = - { Block.level = level.level ; priority = Int32.of_int priority } in + let slot = { Block.level = level.level ; priority } in compute_stamp cctxt block src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce -> Client_proto_rpcs.Helpers.Forge.block cctxt diff --git a/src/client/embedded/alpha/client_proto_rpcs.mli b/src/client/embedded/alpha/client_proto_rpcs.mli index 1e76bf803..a81badd80 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.mli +++ b/src/client/embedded/alpha/client_proto_rpcs.mli @@ -35,7 +35,7 @@ module Constants : sig block -> (Period.t list) tzresult Lwt.t val first_free_mining_slot: Client_rpcs.config -> - block -> int32 tzresult Lwt.t + block -> int tzresult Lwt.t val max_signing_slot: Client_rpcs.config -> block -> int tzresult Lwt.t diff --git a/src/proto/alpha/block_repr.ml b/src/proto/alpha/block_repr.ml index 88acd4f4c..1f67188fb 100644 --- a/src/proto/alpha/block_repr.ml +++ b/src/proto/alpha/block_repr.ml @@ -26,7 +26,7 @@ and proto_header = { and mining_slot = { level: Raw_level_repr.t ; - priority: Int32.t ; + priority: int ; } let mining_slot_encoding = @@ -36,7 +36,7 @@ let mining_slot_encoding = (fun (level, priority) -> { level ; priority }) (obj2 (req "level" Raw_level_repr.encoding) - (req "proprity" int32)) + (req "priority" uint16)) let proto_header_encoding = let open Data_encoding in diff --git a/src/proto/alpha/block_repr.mli b/src/proto/alpha/block_repr.mli index 26da9e36e..7967cc4d2 100644 --- a/src/proto/alpha/block_repr.mli +++ b/src/proto/alpha/block_repr.mli @@ -24,7 +24,7 @@ and proto_header = { and mining_slot = { level: Raw_level_repr.t ; - priority: Int32.t ; + priority: int ; } val mining_slot_encoding: mining_slot Data_encoding.encoding diff --git a/src/proto/alpha/constants_repr.ml b/src/proto/alpha/constants_repr.ml index 3c94e977a..b35f56347 100644 --- a/src/proto/alpha/constants_repr.ml +++ b/src/proto/alpha/constants_repr.ml @@ -38,7 +38,7 @@ type constants = { voting_period_length: int32 ; time_before_reward: Period_repr.t ; slot_durations: Period_repr.t list ; - first_free_mining_slot: int32 ; + first_free_mining_slot: int ; max_signing_slot: int ; instructions_per_transaction: int ; proof_of_work_threshold: int64 ; @@ -58,7 +58,7 @@ let default = { Int64.(mul 365L (mul 24L 3600L)) ; slot_durations = List.map Period_repr.of_seconds_exn [ 60L ] ; - first_free_mining_slot = 16l ; + first_free_mining_slot = 16 ; max_signing_slot = 15 ; instructions_per_transaction = 16 * 1024 ; proof_of_work_threshold = @@ -103,7 +103,7 @@ let constants_encoding = opt Compare_slot_durations.(=) default.slot_durations c.slot_durations and first_free_mining_slot = - opt Compare.Int32.(=) + opt Compare.Int.(=) default.first_free_mining_slot c.first_free_mining_slot and max_signing_slot = opt Compare.Int.(=) @@ -171,8 +171,8 @@ let constants_encoding = (opt "voting_period_length" int32) (opt "time_before_reward" int64) (opt "slot_durations" (list Period_repr.encoding)) - (opt "first_free_mining_slot" int32) - (opt "max_signing_slot" int31) + (opt "first_free_mining_slot" uint16) + (opt "max_signing_slot" uint16) (opt "instructions_per_transaction" int31) (opt "proof_of_work_threshold" int64) (opt "bootstrap_keys" (list Ed25519.Public_key.encoding)) diff --git a/src/proto/alpha/main.ml b/src/proto/alpha/main.ml index 7b3d632c4..e3f7ede80 100644 --- a/src/proto/alpha/main.ml +++ b/src/proto/alpha/main.ml @@ -71,7 +71,7 @@ let apply_operation ({ mode ; ctxt ; op_count } as data) operation = let pred_block, block_prio, miner_contract = match mode with | Construction { pred_block } -> - pred_block, 0l, None + pred_block, 0, None | Application (block, delegate) -> block.shell.predecessor, block.proto.mining_slot.priority, @@ -94,7 +94,7 @@ let finalize_block { mode ; ctxt ; op_count } = match mode with let fitness = Tezos_context.Fitness.current ctxt in let commit_message = Format.asprintf - "lvl %ld, fit %Ld, prio %ld, %d ops" + "lvl %ld, fit %Ld, prio %d, %d ops" level fitness priority op_count in let ctxt = Tezos_context.finalize ~commit_message ctxt in return ctxt diff --git a/src/proto/alpha/mining.ml b/src/proto/alpha/mining.ml index c5e8b0094..32c8e3d8d 100644 --- a/src/proto/alpha/mining.ml +++ b/src/proto/alpha/mining.ml @@ -110,6 +110,7 @@ let () = (fun () -> Cannot_pay_endorsement_bond) let minimal_time c priority pred_timestamp = + let priority = Int32.of_int priority in let rec cumsum_slot_durations acc durations p = if Compare.Int32.(<=) p 0l then ok acc @@ -147,7 +148,7 @@ let check_mining_rights c let pay_mining_bond c { Block.proto = { mining_slot = { priority} } } id = - if Compare.Int32.(priority >= Constants.first_free_mining_slot c) + if Compare.Int.(priority >= Constants.first_free_mining_slot c) then return c else Contract.spend c (Contract.default_contract id) Constants.mining_bond_cost @@ -168,7 +169,7 @@ let check_signing_rights c slot delegate = (Wrong_delegate (owning_delegate, delegate)) let paying_priorities c = - 0l ---> Constants.first_free_mining_slot c + 0 --> Constants.first_free_mining_slot c let bond_and_reward = match Tez.(Constants.mining_bond_cost +? Constants.mining_reward) with @@ -176,25 +177,25 @@ let bond_and_reward = | Error _ -> assert false let base_mining_reward c ~priority = - if Compare.Int32.(priority < Constants.first_free_mining_slot c) + if Compare.Int.(priority < Constants.first_free_mining_slot c) then bond_and_reward else Constants.mining_reward type error += Incorect_priority let endorsement_reward ~block_priority:prio = - if Compare.Int32.(prio >= 0l) + if Compare.Int.(prio >= 0) then Lwt.return - Tez.(Constants.endorsement_reward /? (Int64.(succ (of_int32 prio)))) + Tez.(Constants.endorsement_reward /? (Int64.(succ (of_int prio)))) else fail Incorect_priority let mining_priorities c level = let rec f priority = Roll.mining_rights_owner c level ~priority >>=? fun delegate -> - return (LCons (delegate, (fun () -> f (Int32.succ priority)))) + return (LCons (delegate, (fun () -> f (succ priority)))) in - f 0l + f 0 let endorsement_priorities c level = let rec f slot = @@ -205,7 +206,7 @@ let endorsement_priorities c level = let select_delegate delegate delegate_list max_priority = let rec loop acc l n = - if Compare.Int32.(n >= max_priority) + if Compare.Int.(n >= max_priority) then return (List.rev acc) else let LCons (pkh, t) = l in @@ -214,9 +215,9 @@ let select_delegate delegate delegate_list max_priority = then n :: acc else acc in t () >>=? fun t -> - loop acc t (Int32.succ n) + loop acc t (succ n) in - loop [] delegate_list 0l + loop [] delegate_list 0 let first_mining_priorities ctxt @@ -227,8 +228,7 @@ let first_mining_priorities let first_endorsement_slots ctxt - ?(max_priority = - Int32.of_int (Constants.max_signing_slot ctxt)) + ?(max_priority = Constants.max_signing_slot ctxt) delegate level = endorsement_priorities ctxt level >>=? fun delegate_list -> select_delegate delegate delegate_list max_priority diff --git a/src/proto/alpha/mining.mli b/src/proto/alpha/mining.mli index 3d2fa2141..efa312019 100644 --- a/src/proto/alpha/mining.mli +++ b/src/proto/alpha/mining.mli @@ -19,10 +19,9 @@ type error += Wrong_delegate of public_key_hash * public_key_hash (* `Permanent type error += Cannot_pay_mining_bond (* `Permanent *) type error += Cannot_pay_endorsement_bond (* `Permanent *) -val paying_priorities: context -> int32 list +val paying_priorities: context -> int list -val minimal_time: - context -> int32 -> Time.t -> Time.t tzresult Lwt.t +val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t (** [minimal_time ctxt priority pred_block_time] returns the minimal time, given the predecessor block timestamp [pred_block_time], after which a miner with priority [priority] is allowed to @@ -56,9 +55,9 @@ val check_signing_rights: (** If this priority should have payed the bond it is the base mining reward and the bond, or just the base reward otherwise *) -val base_mining_reward: context -> priority:int32 -> Tez.t +val base_mining_reward: context -> priority:int -> Tez.t -val endorsement_reward: block_priority:int32 -> Tez.t tzresult Lwt.t +val endorsement_reward: block_priority:int -> Tez.t tzresult Lwt.t val mining_priorities: context -> Level.t -> public_key_hash lazy_list @@ -70,10 +69,10 @@ val endorsement_priorities: val first_mining_priorities: context -> - ?max_priority:int32 -> + ?max_priority:int -> public_key_hash -> Level.t -> - int32 list tzresult Lwt.t + int list tzresult Lwt.t (** [first_mining_priorities ctxt ?max_priority contract_hash level] is a list of priorities of max [?max_priority] elements, where the delegate of [contract_hash] is allowed to mine for [level]. If @@ -82,9 +81,9 @@ val first_mining_priorities: val first_endorsement_slots: context -> - ?max_priority:int32 -> + ?max_priority:int -> public_key_hash -> - Level.t -> int32 list tzresult Lwt.t + Level.t -> int list tzresult Lwt.t val check_signature: context -> Block.header -> public_key_hash -> unit tzresult Lwt.t diff --git a/src/proto/alpha/roll_storage.ml b/src/proto/alpha/roll_storage.ml index 2a568b586..171aa5840 100644 --- a/src/proto/alpha/roll_storage.ml +++ b/src/proto/alpha/roll_storage.ml @@ -73,7 +73,7 @@ module Random = struct let cycle = level.Level_repr.cycle in Seed_storage.for_cycle c cycle >>=? fun random_seed -> let rd = level_random random_seed kind level in - let sequence = Seed_repr.sequence rd offset in + let sequence = Seed_repr.sequence rd (Int32.of_int offset) in Storage.Roll.Last_for_cycle.get c cycle >>=? fun bound -> let roll, _ = Roll_repr.random sequence bound in Storage.Roll.Owner_for_cycle.get c (cycle, roll) @@ -84,7 +84,7 @@ let mining_rights_owner c level ~priority = Random.owner c "mining" level priority let endorsement_rights_owner c level ~slot = - Random.owner c "endorsement" level (Int32.of_int slot) + Random.owner c "endorsement" level slot module Contract = struct diff --git a/src/proto/alpha/roll_storage.mli b/src/proto/alpha/roll_storage.mli index 066d55117..9fd798b73 100644 --- a/src/proto/alpha/roll_storage.mli +++ b/src/proto/alpha/roll_storage.mli @@ -35,7 +35,7 @@ val clear_cycle : Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t val mining_rights_owner : - Storage.t -> Level_repr.t -> priority:int32 -> + Storage.t -> Level_repr.t -> priority:int -> Ed25519.Public_key_hash.t tzresult Lwt.t val endorsement_rights_owner : diff --git a/src/proto/alpha/services.ml b/src/proto/alpha/services.ml index 0ed8a43a2..71ee0c4d1 100644 --- a/src/proto/alpha/services.ml +++ b/src/proto/alpha/services.ml @@ -73,7 +73,7 @@ module Constants = struct ~description: "First free mining slot" ~input: empty ~output: (wrap_tzerror @@ - describe ~title: "first free mining slot" int32) + describe ~title: "first free mining slot" uint16) RPC.Path.(custom_root / "constants" / "first_free_mining_slot") let max_signing_slot custom_root = @@ -81,7 +81,7 @@ module Constants = struct ~description: "Max signing slot" ~input: empty ~output: (wrap_tzerror @@ - describe ~title: "max signing slot" int31) + describe ~title: "max signing slot" uint16) RPC.Path.(custom_root / "constants" / "max_signing_slot") let instructions_per_transaction custom_root = @@ -563,7 +563,7 @@ module Helpers = struct (req "fitness" Fitness.encoding) (req "operations" Operation_list_list_hash.encoding) (req "level" Raw_level.encoding) - (req "priority" int31) + (req "priority" uint16) (req "nonce_hash" Nonce_hash.encoding) (req "proof_of_work_nonce" (Fixed.bytes Tezos_context.Constants.proof_of_work_nonce_size))) diff --git a/src/proto/alpha/services_registration.ml b/src/proto/alpha/services_registration.ml index 2d6bff8eb..ced5e6d8b 100644 --- a/src/proto/alpha/services_registration.ml +++ b/src/proto/alpha/services_registration.ml @@ -174,7 +174,7 @@ let () = (*-- Helpers -----------------------------------------------------------------*) let minimal_timestamp ctxt prio = - let prio = match prio with None -> 0l | Some p -> Int32.of_int p in + let prio = match prio with None -> 0 | Some p -> p in Mining.minimal_time ctxt prio let () = register1 @@ -196,7 +196,7 @@ let () = Tezos_context.Level.current ctxt >>=? fun level -> Mining.mining_priorities ctxt level >>=? fun (Misc.LCons (miner_pkh, _)) -> let miner_contract = Contract.default_contract miner_pkh in - let block_prio = 0l in + let block_prio = 0 in Apply.apply_operation ctxt (Some miner_contract) pred_block block_prio operation >>=? function @@ -281,11 +281,11 @@ let () = register2 Services.Helpers.levels levels let default_max_mining_priority ctxt arg = let default = Constants.first_free_mining_slot ctxt in match arg with - | None -> Int32.mul 2l default - | Some m -> Int32.of_int m + | None -> 2 * default + | Some m -> m let mining_rights ctxt level max = - let max = Int32.to_int (default_max_mining_priority ctxt max) in + let max = default_max_mining_priority ctxt max in Mining.mining_priorities ctxt level >>=? fun contract_list -> let rec loop l n = match n with @@ -309,8 +309,7 @@ let () = List.mapi (fun prio c -> let timestamp = Timestamp.current ctxt in - Mining.minimal_time - ctxt (Int32.of_int prio) timestamp >>= function + Mining.minimal_time ctxt prio timestamp >>= function | Error _ -> Lwt.return None | Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp))) slots @@ -348,7 +347,7 @@ let mining_rights_for_delegate (fun priority -> let timestamp = Timestamp.current ctxt in Mining.minimal_time ctxt priority timestamp >>=? fun time -> - return (raw_level, Int32.to_int priority, time)) + return (raw_level, priority, time)) priorities >>=? fun priorities -> return (priorities @ t) in @@ -391,10 +390,8 @@ let () = let endorsement_rights_for_delegate ctxt contract (max_priority, min_level, max_level) = - let max_priority = - Int32.of_int @@ - default_max_endorsement_priority ctxt max_priority in Level.current ctxt >>=? fun current_level -> + let max_priority = default_max_endorsement_priority ctxt max_priority in let max_level = match max_level with | None -> @@ -412,10 +409,7 @@ let endorsement_rights_for_delegate Mining.first_endorsement_slots ctxt ~max_priority contract level >>=? fun slots -> let raw_level = level.level in - let slots = - List.rev_map - (fun slot -> (raw_level, Int32.to_int slot)) - slots in + let slots = List.rev_map (fun slot -> (raw_level, slot)) slots in return (List.rev_append slots t) in loop min_level @@ -442,7 +436,6 @@ let () = register1 Services.Helpers.Forge.operations forge_operations let forge_block _ctxt (net_id, predecessor, timestamp, fitness, operations, raw_level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t = - let priority = Int32.of_int priority in let mining_slot = { Block.level = raw_level ; priority } in return (Block.forge_header { net_id ; predecessor ; timestamp ; fitness ; operations } diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index 3e8f33373..9ec73165b 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -172,7 +172,7 @@ module Constants : sig val voting_period_length: context -> int32 val time_before_reward: context -> Period.t val slot_durations: context -> Period.t list - val first_free_mining_slot: context -> int32 + val first_free_mining_slot: context -> int val max_signing_slot: context -> int val instructions_per_transaction: context -> int val proof_of_work_threshold: context -> int64 @@ -530,7 +530,7 @@ module Block : sig and mining_slot = { level: Raw_level.t ; - priority: Int32.t ; + priority: int ; } val mining_slot_encoding: mining_slot Data_encoding.encoding @@ -556,7 +556,7 @@ module Roll : sig val clear_cycle: context -> Cycle.t -> context tzresult Lwt.t val mining_rights_owner: - context -> Level.t -> priority:int32 -> public_key_hash tzresult Lwt.t + context -> Level.t -> priority:int -> public_key_hash tzresult Lwt.t val endorsement_rights_owner: context -> Level.t -> slot:int -> public_key_hash tzresult Lwt.t diff --git a/src/proto/environment/data_encoding.mli b/src/proto/environment/data_encoding.mli index d13ff0e01..716f74816 100644 --- a/src/proto/environment/data_encoding.mli +++ b/src/proto/environment/data_encoding.mli @@ -28,7 +28,9 @@ val empty : unit encoding val unit : unit encoding val constant : string -> unit encoding val int8 : int encoding +val uint8 : int encoding val int16 : int encoding +val uint16 : int encoding val int31 : int encoding val int32 : int32 encoding val int64 : int64 encoding diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index 3200188fc..dbe78360d 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -399,7 +399,7 @@ module Mining = struct let shell = { Store.Block_header.net_id = bi.net ; predecessor = bi.hash ; timestamp ; fitness ; operations } in - let slot = { Block.level = level.level ; priority = Int32.of_int priority } in + let slot = { Block.level = level.level ; priority } in mine_stamp block src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce -> Client_proto_rpcs.Helpers.Forge.block rpc_config @@ -410,7 +410,7 @@ module Mining = struct ~fitness ~operations ~level:level.level - ~priority:priority + ~priority ~seed_nonce_hash ~proof_of_work_nonce () >>=? fun unsigned_header -> @@ -453,7 +453,7 @@ module Mining = struct let endorsement_reward contract block = Client_mining_blocks.info rpc_config block >>=? fun bi -> get_first_priority bi.level.level contract block >>=? fun prio -> - Mining.endorsement_reward ~block_priority:(Int32.of_int prio) >|= + Mining.endorsement_reward ~block_priority:prio >|= Register_client_embedded_proto_alpha.wrap_error >>|? Tez.to_cents From ab76b8fbf58b89abd826d8069aad0315cf2ef396 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 10 Apr 2017 12:58:31 +0200 Subject: [PATCH 05/10] Shell/State: consistent use of `pred` vs. `predecessor`. --- src/node/shell/node.ml | 2 +- src/node/shell/state.ml | 10 +++++----- src/node/shell/state.mli | 2 +- src/node/shell/validator.ml | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 40c7211ad..b3764cd14 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -152,7 +152,7 @@ module RPC = struct let convert (block: State.Valid_block.t) = { hash = block.hash ; - predecessor = block.pred ; + predecessor = block.predecessor ; fitness = block.fitness ; timestamp = block.timestamp ; protocol = Some block.protocol_hash ; diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index 653385fd2..c34dbc5a3 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -110,7 +110,7 @@ and net_state = { and valid_block = { net_id: Net_id.t ; hash: Block_hash.t ; - pred: Block_hash.t ; + predecessor: Block_hash.t ; timestamp: Time.t ; fitness: Protocol.fitness ; operations_hash: Operation_list_list_hash.t ; @@ -144,7 +144,7 @@ let build_valid_block let valid_block = { net_id = header.Store.Block_header.shell.net_id ; hash ; - pred = header.shell.predecessor ; + predecessor = header.shell.predecessor ; timestamp = header.shell.timestamp ; discovery_time ; operations_hash = header.shell.operations ; @@ -932,7 +932,7 @@ module Valid_block = struct type t = valid_block = { net_id: Net_id.t ; hash: Block_hash.t ; - pred: Block_hash.t ; + predecessor: Block_hash.t ; timestamp: Time.t ; fitness: Fitness.fitness ; operations_hash: Operation_list_list_hash.t ; @@ -1166,10 +1166,10 @@ module Valid_block = struct end | res -> res in let predecessor state b = - if Block_hash.equal b.hash b.pred then + if Block_hash.equal b.hash b.predecessor then Lwt.return None else - read_opt state b.pred in + read_opt state b.predecessor in Raw_helpers.iter_predecessors compare predecessor (fun b -> b.timestamp) (fun b -> b.fitness) diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index b8c64f6ea..e8a98d90e 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -245,7 +245,7 @@ module Valid_block : sig (** The genesis of the chain this block belongs to. *) hash: Block_hash.t ; (** The block hash. *) - pred: Block_hash.t ; + predecessor: Block_hash.t ; (** The preceding block in the chain. *) timestamp: Time.t ; (** The date at which this block has been forged. *) diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 6b488bbe0..4e11a0b82 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -129,7 +129,7 @@ let rec may_set_head v (block: State.Valid_block.t) = Fitness.pp block.fitness Time.pp_hum block.timestamp (fun ppf -> - if Block_hash.equal head.hash block.pred then + if Block_hash.equal head.hash block.predecessor then Format.fprintf ppf "same branch" else Format.fprintf ppf "changing branch") >>= fun () -> From 2480bfd2160541491559349a81a50c1325b90b2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 10 Apr 2017 12:59:04 +0200 Subject: [PATCH 06/10] Shell: remove dead code --- src/node/shell/validator.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 4e11a0b82..70689e0d2 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -749,7 +749,6 @@ let create_worker state db = let net_id = State.Net.id net in lwt_log_notice "activate network %a" Net_id.pp net_id >>= fun () -> - State.Valid_block.Current.genesis net >>= fun genesis -> get net_id >>= function | Error _ -> let v = create_validator ?parent worker state db net in From f8055077022476c5b8870f18255cf62e52215dcf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 10 Apr 2017 13:01:22 +0200 Subject: [PATCH 07/10] Shell: move `level` in th shell part of block. --- src/Makefile | 3 +- src/client/client_node_rpcs.ml | 8 +- src/client/client_node_rpcs.mli | 5 ++ .../alpha/baker/client_mining_forge.ml | 11 ++- .../embedded/alpha/client_proto_rpcs.ml | 6 +- .../embedded/genesis/client_proto_main.ml | 3 +- src/node/db/store.ml | 14 ++-- src/node/db/store.mli | 1 + src/node/shell/node.ml | 31 ++++++-- src/node/shell/node_rpc.ml | 12 ++- src/node/shell/node_rpc_services.ml | 22 ++++-- src/node/shell/node_rpc_services.mli | 5 +- src/node/shell/prevalidation.ml | 4 +- src/node/shell/state.ml | 51 ++++++------ src/node/shell/state.mli | 3 + src/node/shell/validator.ml | 19 +++++ src/node/updater/protocol.mli | 3 + src/node/updater/register.ml | 4 +- src/node/updater/updater.ml | 2 + src/node/updater/updater.mli | 2 + src/proto/alpha/amendment.ml | 9 ++- src/proto/alpha/apply.ml | 16 ++-- src/proto/alpha/block_repr.ml | 40 ++++------ src/proto/alpha/block_repr.mli | 9 +-- src/proto/alpha/init_storage.ml | 39 +++------- src/proto/alpha/level_repr.ml | 42 ++++++---- src/proto/alpha/level_repr.mli | 7 +- src/proto/alpha/level_storage.ml | 25 +++--- src/proto/alpha/level_storage.mli | 7 +- src/proto/alpha/main.ml | 16 ++-- src/proto/alpha/mining.ml | 39 +++------- src/proto/alpha/mining.mli | 1 - src/proto/alpha/nonce_storage.ml | 7 +- src/proto/alpha/nonce_storage.mli | 3 - src/proto/alpha/raw_level_repr.ml | 6 ++ src/proto/alpha/raw_level_repr.mli | 1 + src/proto/alpha/seed_storage.ml | 2 +- src/proto/alpha/services_registration.ml | 27 +++---- src/proto/alpha/storage.ml | 78 +++++++++++++++---- src/proto/alpha/storage.mli | 17 ++-- src/proto/alpha/storage_functors.ml | 2 + src/proto/alpha/storage_functors.mli | 2 + src/proto/alpha/tezos_context.mli | 16 ++-- src/proto/demo/main.ml | 1 + src/proto/environment/updater.mli | 4 + src/proto/genesis/main.ml | 1 + src/proto/genesis/services.ml | 9 ++- test/proto_alpha/proto_alpha_helpers.ml | 14 ++-- test/proto_alpha/proto_alpha_helpers.mli | 6 +- test/proto_alpha/test_endorsement.ml | 23 +++++- test/shell/test_state.ml | 2 + test/shell/test_store.ml | 1 + 52 files changed, 400 insertions(+), 281 deletions(-) diff --git a/src/Makefile b/src/Makefile index fb010fe50..455c7aac6 100644 --- a/src/Makefile +++ b/src/Makefile @@ -247,7 +247,7 @@ ${TZCLIENT}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa \ ${EMBEDDED_CLIENT_VERSIONS} \ ${CLIENT_IMPLS:.ml=.cmx} @echo LINK $(notdir $@) - @${OCAMLOPT} -linkpkg ${OCAMLFLAGS} -o $@ $^ + @${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^ clean:: -rm -f ${TZCLIENT} @@ -413,7 +413,6 @@ client/embedded/client_%.cmx: \ $(patsubst %.ml, %.cmx, $(NODE_LIB_IMPLS) $(CLIENT_LIB_IMPLS)) \ proto/client_embedded_proto_%.cmxa \ $$(shell find client/embedded/% \( -name webclient -or -name _tzbuild \) -prune -or \( -name \*.ml -print -or -name \*.mli -print \)) - @echo $^ @$(MAKE) -C client/embedded/$* ../client_$*.cmx client/embedded/webclient_%.cmx: \ diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index c6edf65a4..56398606f 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -15,9 +15,9 @@ module Services = Node_rpc_services let errors cctxt = call_service0 cctxt Services.Error.service () -let forge_block cctxt ?net ?predecessor ?timestamp fitness ops header = +let forge_block cctxt ?net ?level ?predecessor ?timestamp fitness ops header = call_service0 cctxt Services.forge_block - (net, predecessor, timestamp, fitness, ops, header) + (net, level, predecessor, timestamp, fitness, ops, header) let validate_block cctxt net block = call_err_service0 cctxt Services.validate_block (net, block) @@ -53,6 +53,7 @@ module Blocks = struct type block_info = Services.Blocks.block_info = { hash: Block_hash.t ; + level: Int32.t ; predecessor: Block_hash.t ; fitness: MBytes.t list ; timestamp: Time.t ; @@ -76,6 +77,8 @@ module Blocks = struct } let net cctxt h = call_service1 cctxt Services.Blocks.net h () + let level cctxt h = + call_service1 cctxt Services.Blocks.level h () let predecessor cctxt h = call_service1 cctxt Services.Blocks.predecessor h () let predecessors cctxt h l = @@ -94,6 +97,7 @@ module Blocks = struct call_service1 cctxt Services.Blocks.test_protocol h () let test_network cctxt h = call_service1 cctxt Services.Blocks.test_network h () + let preapply cctxt h ?timestamp ?(sort = false) operations = call_err_service1 cctxt Services.Blocks.preapply h diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index d22b59e7b..709ee3c80 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -15,6 +15,7 @@ val errors: val forge_block: config -> ?net:Net_id.t -> + ?level:Int32.t -> ?predecessor:Block_hash.t -> ?timestamp:Time.t -> Fitness.fitness -> @@ -67,6 +68,9 @@ module Blocks : sig val net: config -> block -> Net_id.t tzresult Lwt.t + val level: + config -> + block -> Int32.t tzresult Lwt.t val predecessor: config -> block -> Block_hash.t tzresult Lwt.t @@ -102,6 +106,7 @@ module Blocks : sig type block_info = { hash: Block_hash.t ; + level: Int32.t ; predecessor: Block_hash.t ; fitness: MBytes.t list ; timestamp: Time.t ; diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index dd0c0d1e4..a85e683de 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -22,14 +22,14 @@ let generate_seed_nonce () = | Ok nonce -> nonce let rec compute_stamp - cctxt block delegate_sk shell mining_slot seed_nonce_hash = + cctxt block delegate_sk shell priority seed_nonce_hash = Client_proto_rpcs.Constants.stamp_threshold cctxt block >>=? fun stamp_threshold -> let rec loop () = let proof_of_work_nonce = generate_proof_of_work_nonce () in let unsigned_header = Tezos_context.Block.forge_header - shell { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } in + shell { priority ; seed_nonce_hash ; proof_of_work_nonce } in let signed_header = Ed25519.Signature.append delegate_sk unsigned_header in let block_hash = Block_hash.hash_bytes [signed_header] in @@ -51,11 +51,10 @@ let inject_block cctxt block Operation_list_list_hash.compute (List.map Operation_list_hash.compute operation_list) in let shell = - { Store.Block_header.net_id = bi.net ; predecessor = bi.hash ; - timestamp ; fitness ; operations } in - let slot = { Block.level = level.level ; priority } in + { Store.Block_header.net_id = bi.net ; level = bi.level ; + predecessor = bi.hash ; timestamp ; fitness ; operations } in compute_stamp cctxt block - src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce -> + src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce -> Client_proto_rpcs.Helpers.Forge.block cctxt block ~net:bi.net diff --git a/src/client/embedded/alpha/client_proto_rpcs.ml b/src/client/embedded/alpha/client_proto_rpcs.ml index 6cd27cb3d..2cdf0c08f 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.ml +++ b/src/client/embedded/alpha/client_proto_rpcs.ml @@ -64,11 +64,7 @@ end module Context = struct let level cctxt block = - match block with - | `Genesis -> return Level.root - | `Hash h when Block_hash.equal Client_blocks.genesis h -> - return Level.root - | _ -> call_error_service1 cctxt Services.Context.level block () + call_error_service1 cctxt Services.Context.level block () let next_level cctxt block = call_error_service1 cctxt Services.Context.next_level block () diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index 93b18e40d..5be95a50e 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -26,9 +26,10 @@ let call_error_service1 rpc_config s block a1 = let forge_block rpc_config block net_id ?(timestamp = Time.now ()) command fitness = Client_blocks.get_block_hash rpc_config block >>=? fun pred -> + Client_node_rpcs.Blocks.level rpc_config block >>=? fun level -> call_service1 rpc_config Services.Forge.block block - ((net_id, pred, timestamp, fitness), command) + ((net_id, Int32.succ level, pred, timestamp, fitness), command) let mine rpc_config ?timestamp block command fitness seckey = Client_blocks.get_block_info rpc_config block >>=? fun bi -> diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 4fb28b30a..65c3b29cf 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -258,6 +258,7 @@ module Block_header = struct type shell_header = { net_id: Net_id.t ; + level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; operations: Operation_list_list_hash.t ; @@ -267,12 +268,15 @@ module Block_header = struct let shell_header_encoding = let open Data_encoding in conv - (fun { net_id ; predecessor ; timestamp ; operations ; fitness } -> - (net_id, predecessor, timestamp, operations, fitness)) - (fun (net_id, predecessor, timestamp, operations, fitness) -> - { net_id ; predecessor ; timestamp ; operations ; fitness }) - (obj5 + (fun { net_id ; level ; predecessor ; + timestamp ; operations ; fitness } -> + (net_id, level, predecessor, timestamp, operations, fitness)) + (fun (net_id, level, predecessor, timestamp, operations, fitness) -> + { net_id ; level ; predecessor ; + timestamp ; operations ; fitness }) + (obj6 (req "net_id" Net_id.encoding) + (req "level" int32) (req "predecessor" Block_hash.encoding) (req "timestamp" Time.encoding) (req "operations" Operation_list_list_hash.encoding) diff --git a/src/node/db/store.mli b/src/node/db/store.mli index 10da00986..395891caa 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -171,6 +171,7 @@ module Block_header : sig type shell_header = { net_id: Net_id.t ; + level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; operations: Operation_list_list_hash.t ; diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index b3764cd14..7e2121fde 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -138,6 +138,7 @@ module RPC = struct type block = Node_rpc_services.Blocks.block type block_info = Node_rpc_services.Blocks.block_info = { hash: Block_hash.t ; + level: Int32.t ; predecessor: Block_hash.t ; fitness: MBytes.t list ; timestamp: Time.t ; @@ -152,6 +153,7 @@ module RPC = struct let convert (block: State.Valid_block.t) = { hash = block.hash ; + level = block.level ; predecessor = block.predecessor ; fitness = block.fitness ; timestamp = block.timestamp ; @@ -167,6 +169,7 @@ module RPC = struct let convert_block hash ({ shell ; proto }: State.Block_header.t) = { net = shell.net_id ; hash = hash ; + level = shell.level ; predecessor = shell.predecessor ; fitness = shell.fitness ; timestamp = shell.timestamp ; @@ -282,16 +285,27 @@ module RPC = struct Context.get_protocol context >>= fun protocol -> let operations = let pv_result, _ = Prevalidator.operations pv in - Some [ pv_result.applied ] in - let timestamp = Prevalidator.timestamp pv in + [ pv_result.applied ] in Lwt.return - { (convert head) with - hash = prevalidation_hash ; + { hash = prevalidation_hash ; + level = Int32.succ head.level ; + predecessor = head.hash ; + fitness ; + timestamp = Prevalidator.timestamp pv ; protocol = Some protocol ; - fitness ; operations ; timestamp } + operations_hash = + Operation_list_list_hash.compute + (List.map Operation_list_hash.compute operations) ; + operations = Some operations ; + data = None ; + net = head.net_id ; + test_protocol = None ; + test_network = None ; + } let rpc_context block : Updater.rpc_context = { context = block.State.Valid_block.context ; + level = Int32.succ block.level ; fitness = block.fitness ; timestamp = block. timestamp } @@ -313,13 +327,16 @@ module RPC = struct | Some block -> Some (rpc_context block) end | ( `Prevalidation | `Test_prevalidation ) as block -> - let validator, _net = get_net node block in + let validator, net = get_net node block in let pv = Validator.prevalidator validator in Prevalidator.context pv >>= function | Error _ -> Lwt.fail Not_found | Ok { context ; fitness } -> let timestamp = Prevalidator.timestamp pv in - Lwt.return (Some { Updater.context ; fitness ; timestamp }) + State.Valid_block.Current.head + (Distributed_db.state net) >>= fun { level } -> + let level = Int32.succ level in + Lwt.return (Some { Updater.context ; fitness ; timestamp ; level }) let operations node block = match block with diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 9601b9179..7933d6dba 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -37,6 +37,12 @@ let register_bi_dir node dir = RPC.Answer.return bi.net in RPC.register1 dir Services.Blocks.net implementation in + let dir = + let implementation b () = + Node.RPC.block_info node b >>= fun bi -> + RPC.Answer.return bi.level in + RPC.register1 dir + Services.Blocks.level implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> @@ -404,14 +410,16 @@ let build_rpc_directory node = let dir = RPC.register1 dir Services.Protocols.contents (get_protocols node) in let dir = - let implementation (net_id, pred, time, fitness, operations, header) = + let implementation (net_id, level, pred, time, fitness, operations, header) = Node.RPC.block_info node (`Head 0) >>= fun bi -> let timestamp = Utils.unopt ~default:(Time.now ()) time in let net_id = Utils.unopt ~default:bi.net net_id in let predecessor = Utils.unopt ~default:bi.hash pred in + let level = Utils.unopt ~default:(Int32.succ bi.level) level in let res = Data_encoding.Binary.to_bytes Store.Block_header.encoding { - shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ; + shell = { net_id ; predecessor ; level ; + timestamp ; fitness ; operations } ; proto = header ; } in RPC.Answer.return res in diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index 1891d076a..806f6058f 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -57,6 +57,7 @@ module Blocks = struct type block_info = { hash: Block_hash.t ; + level: Int32.t ; predecessor: Block_hash.t ; fitness: MBytes.t list ; timestamp: Time.t ; @@ -71,21 +72,22 @@ module Blocks = struct let block_info_encoding = conv - (fun { hash ; predecessor ; fitness ; timestamp ; protocol ; + (fun { hash ; level ; predecessor ; fitness ; timestamp ; protocol ; operations_hash ; operations ; data ; net ; test_protocol ; test_network } -> - ((hash, predecessor, fitness, timestamp, protocol), + ((hash, level, predecessor, fitness, timestamp, protocol), (operations_hash, operations, data, net, test_protocol, test_network))) - (fun ((hash, predecessor, fitness, timestamp, protocol), + (fun ((hash, level, predecessor, fitness, timestamp, protocol), (operations_hash, operations, data, net, test_protocol, test_network)) -> - { hash ; predecessor ; fitness ; timestamp ; protocol ; + { hash ; level ; predecessor ; fitness ; timestamp ; protocol ; operations_hash ; operations ; data ; net ; test_protocol ; test_network }) (merge_objs - (obj5 + (obj6 (req "hash" Block_hash.encoding) + (req "level" int32) (req "predecessor" Block_hash.encoding) (req "fitness" Fitness.encoding) (req "timestamp" Time.encoding) @@ -193,6 +195,13 @@ module Blocks = struct ~output: (obj1 (req "net" Net_id.encoding)) RPC.Path.(block_path / "net") + let level = + RPC.service + ~description:"Returns the block's level." + ~input: empty + ~output: (obj1 (req "level" int32)) + RPC.Path.(block_path / "level") + let predecessor = RPC.service ~description:"Returns the previous block's id." @@ -642,8 +651,9 @@ let forge_block = RPC.service ~description: "Forge a block header" ~input: - (obj6 + (obj7 (opt "net_id" Net_id.encoding) + (opt "level" int32) (opt "predecessor" Block_hash.encoding) (opt "timestamp" Time.encoding) (req "fitness" Fitness.encoding) diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index fa24399bc..99861742d 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -28,6 +28,7 @@ module Blocks : sig type block_info = { hash: Block_hash.t ; + level: Int32.t ; predecessor: Block_hash.t ; fitness: MBytes.t list ; timestamp: Time.t ; @@ -44,6 +45,8 @@ module Blocks : sig (unit, unit * block, bool * bool, block_info) RPC.service val net: (unit, unit * block, unit, Net_id.t) RPC.service + val level: + (unit, unit * block, unit, Int32.t) RPC.service val predecessor: (unit, unit * block, unit, Block_hash.t) RPC.service val predecessors: @@ -179,7 +182,7 @@ end val forge_block: (unit, unit, - Net_id.t option * Block_hash.t option * Time.t option * + Net_id.t option * Int32.t option * Block_hash.t option * Time.t option * Fitness.fitness * Operation_list_list_hash.t * MBytes.t, MBytes.t) RPC.service diff --git a/src/node/shell/prevalidation.ml b/src/node/shell/prevalidation.ml index 84e6df095..1755aa55c 100644 --- a/src/node/shell/prevalidation.ml +++ b/src/node/shell/prevalidation.ml @@ -136,7 +136,8 @@ let start_prevalidation hash = predecessor ; context = predecessor_context ; timestamp = predecessor_timestamp ; - fitness = predecessor_fitness } + fitness = predecessor_fitness ; + level = predecessor_level } ~timestamp = let (module Proto) = match protocol with @@ -146,6 +147,7 @@ let start_prevalidation ~predecessor_context ~predecessor_timestamp ~predecessor_fitness + ~predecessor_level ~predecessor ~timestamp >>=? fun state -> diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index c34dbc5a3..de6f3a199 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -110,6 +110,7 @@ and net_state = { and valid_block = { net_id: Net_id.t ; hash: Block_hash.t ; + level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; fitness: Protocol.fitness ; @@ -144,6 +145,7 @@ let build_valid_block let valid_block = { net_id = header.Store.Block_header.shell.net_id ; hash ; + level = header.shell.level ; predecessor = header.shell.predecessor ; timestamp = header.shell.timestamp ; discovery_time ; @@ -540,6 +542,7 @@ module Raw_block_header = struct let store_genesis store genesis = let shell : Store.Block_header.shell_header = { net_id = Net_id.of_block_hash genesis.block; + level = 0l ; predecessor = genesis.block ; timestamp = genesis.time ; fitness = [] ; @@ -553,22 +556,23 @@ module Raw_block_header = struct Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () -> Lwt.return header - let store_testnet_genesis store genesis = - let shell : Store.Block_header.shell_header = { - net_id = Net_id.of_block_hash genesis.block; - predecessor = genesis.block ; - timestamp = genesis.time ; - fitness = [] ; - operations = Operation_list_list_hash.empty ; - } in - let bytes = - Data_encoding.Binary.to_bytes Store.Block_header.encoding { - shell ; - proto = MBytes.create 0 ; - } in - Locked.store_raw store genesis.block bytes >>= fun _created -> - Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () -> - Lwt.return shell + (* let store_testnet_genesis store genesis = *) + (* let shell : Store.Block_header.shell_header = { *) + (* net_id = Net_id.of_block_hash genesis.block; *) + (* level = 0l ; *) + (* predecessor = genesis.block ; *) + (* timestamp = genesis.time ; *) + (* fitness = [] ; *) + (* operations = Operation_list_list_hash.empty ; *) + (* } in *) + (* let bytes = *) + (* Data_encoding.Binary.to_bytes Store.Block_header.encoding { *) + (* shell ; *) + (* proto = MBytes.create 0 ; *) + (* } in *) + (* Locked.store_raw store genesis.block bytes >>= fun _created -> *) + (* Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () -> *) + (* Lwt.return shell *) end @@ -693,6 +697,7 @@ module Block_header = struct type shell_header = Store.Block_header.shell_header = { net_id: Net_id.t ; + level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; operations: Operation_list_list_hash.t ; @@ -932,6 +937,7 @@ module Valid_block = struct type t = valid_block = { net_id: Net_id.t ; hash: Block_hash.t ; + level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; fitness: Fitness.fitness ; @@ -996,7 +1002,7 @@ module Valid_block = struct block_header_store (net_state: net_state) valid_block_watcher - hash { Updater.context ; fitness ; message } ttl = + hash { Updater.context ; message ; fitness } ttl = (* Read the block header. *) Raw_block_header.Locked.read block_header_store hash >>=? fun block -> @@ -1044,11 +1050,11 @@ module Valid_block = struct match message with | Some message -> message | None -> - Format.asprintf "%a: %a" + Format.asprintf "%a(%ld): %a" Block_hash.pp_short hash + block.shell.level Fitness.pp fitness in - Context.commit - hash ~time:block.shell.timestamp ~message context >>= fun () -> + Context.commit hash block.shell.timestamp message context >>= fun () -> (* Update the chain state. *) let store = net_state.chain_store in let predecessor = block.shell.predecessor in @@ -1083,7 +1089,7 @@ module Valid_block = struct | Error _ -> Lwt.fail Not_found | Ok b -> Lwt.return b - let store net hash context = + let store net hash vcontext = Shared.use net.state begin fun net_state -> Shared.use net.block_header_store begin fun block_header_store -> Context.exists net_state.context_index hash >>= function @@ -1095,7 +1101,8 @@ module Valid_block = struct | None -> Locked.store block_header_store net_state net.valid_block_watcher - hash context net.forked_network_ttl >>=? fun valid_block -> + hash vcontext + net.forked_network_ttl >>=? fun valid_block -> return (Some valid_block) end end diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index e8a98d90e..88289eb71 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -144,6 +144,7 @@ module Block_header : sig type shell_header = Store.Block_header.shell_header = { net_id: Net_id.t ; + level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; operations: Operation_list_list_hash.t ; @@ -245,6 +246,8 @@ module Valid_block : sig (** The genesis of the chain this block belongs to. *) hash: Block_hash.t ; (** The block hash. *) + level: Int32.t ; + (** The number of preceding block in the chain. *) predecessor: Block_hash.t ; (** The preceding block in the chain. *) timestamp: Time.t ; diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 70689e0d2..e7870a843 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -142,6 +142,22 @@ type error += | Invalid_operation of Operation_hash.t | Non_increasing_timestamp | Non_increasing_fitness + | Wrong_level of Int32.t * Int32.t + +let () = + register_error_kind + `Permanent + ~id:"validator.wrong_level" + ~title:"Wrong level" + ~description:"The block level is not the expected one" + ~pp:(fun ppf (e, g) -> + Format.fprintf ppf + "The declared level %ld is not %ld" g e) + Data_encoding.(obj2 + (req "expected" int32) + (req "provided" int32)) + (function Wrong_level (e, g) -> Some (e, g) | _ -> None) + (fun (e, g) -> Wrong_level (e, g)) let apply_block net db (pred: State.Valid_block.t) hash (block: State.Block_header.t) = @@ -151,6 +167,9 @@ let apply_block net db Block_hash.pp_short block.shell.predecessor Net_id.pp id >>= fun () -> + fail_unless + (Int32.succ pred.level = block.shell.level) + (Wrong_level (Int32.succ pred.level, block.shell.level)) >>=? fun () -> lwt_log_info "validation of %a: looking for dependencies..." Block_hash.pp_short hash >>= fun () -> Distributed_db.Operation_list.fetch diff --git a/src/node/updater/protocol.mli b/src/node/updater/protocol.mli index dd6e9124e..829bfced7 100644 --- a/src/node/updater/protocol.mli +++ b/src/node/updater/protocol.mli @@ -24,6 +24,7 @@ type raw_operation = Store.Operation.t = { type shell_block = Store.Block_header.shell_header = { net_id: Net_id.t ; + level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; operations: Operation_list_list_hash.t ; @@ -43,6 +44,7 @@ type validation_result = { type rpc_context = { context: Context.t ; + level: Int32.t ; timestamp: Time.t ; fitness: Fitness.fitness ; } @@ -78,6 +80,7 @@ module type PROTOCOL = sig val begin_construction : predecessor_context: Context.t -> predecessor_timestamp: Time.t -> + predecessor_level: Int32.t -> predecessor_fitness: Fitness.fitness -> predecessor: Block_hash.t -> timestamp: Time.t -> diff --git a/src/node/updater/register.ml b/src/node/updater/register.ml index 4a9827872..0b4a37314 100644 --- a/src/node/updater/register.ml +++ b/src/node/updater/register.ml @@ -49,11 +49,11 @@ let register (module Proto : Protocol.PACKED_PROTOCOL) = raw_block >|= wrap_error let begin_construction ~predecessor_context ~predecessor_timestamp - ~predecessor_fitness + ~predecessor_level ~predecessor_fitness ~predecessor ~timestamp = begin_construction ~predecessor_context ~predecessor_timestamp - ~predecessor_fitness + ~predecessor_level ~predecessor_fitness ~predecessor ~timestamp >|= wrap_error let current_context c = current_context c >|= wrap_error diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index fde64bebb..e47a07f53 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -19,6 +19,7 @@ type validation_result = Protocol.validation_result = { type rpc_context = Protocol.rpc_context = { context: Context.t ; + level: Int32.t ; timestamp: Time.t ; fitness: Fitness.fitness ; } @@ -44,6 +45,7 @@ let raw_operation_encoding = Store.Operation.encoding type shell_block = Store.Block_header.shell_header = { net_id: Net_id.t ; + level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; operations: Operation_list_list_hash.t ; diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index 0848878c5..eab745b70 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -20,6 +20,7 @@ val raw_operation_encoding: raw_operation Data_encoding.t type shell_block = Store.Block_header.shell_header = { net_id: Net_id.t ; + level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; operations: Operation_list_list_hash.t ; @@ -41,6 +42,7 @@ type validation_result = Protocol.validation_result = { type rpc_context = Protocol.rpc_context = { context: Context.t ; + level: Int32.t ; timestamp: Time.t ; fitness: Fitness.fitness ; } diff --git a/src/proto/alpha/amendment.ml b/src/proto/alpha/amendment.ml index fa8934e43..2416070de 100644 --- a/src/proto/alpha/amendment.ml +++ b/src/proto/alpha/amendment.ml @@ -133,12 +133,13 @@ let record_ballot ctxt delegate proposal ballot = | Testing | Proposal -> fail Unexpected_ballot -let first_of_a_voting_period l = - Compare.Int32.(l.Level.voting_period_position = 0l) +let last_of_a_voting_period ctxt l = + Compare.Int32.(Int32.succ l.Level.voting_period_position = + Constants.voting_period_length ctxt ) let may_start_new_voting_cycle ctxt = - Level.current ctxt >>=? fun level -> - if first_of_a_voting_period level then + let level = Level.current ctxt in + if last_of_a_voting_period ctxt level then start_new_voting_cycle ctxt else return ctxt diff --git a/src/proto/alpha/apply.ml b/src/proto/alpha/apply.ml index 3ad030a05..6cc85a805 100644 --- a/src/proto/alpha/apply.ml +++ b/src/proto/alpha/apply.ml @@ -54,16 +54,16 @@ let apply_delegate_operation_content let ctxt = Fitness.increase ctxt in Mining.pay_endorsement_bond ctxt delegate >>=? fun (ctxt, bond) -> Mining.endorsement_reward ~block_priority >>=? fun reward -> - Level.current ctxt >>=? fun { cycle = current_cycle } -> + let { cycle = current_cycle } : Level.t = Level.current ctxt in Lwt.return Tez.(reward +? bond) >>=? fun full_reward -> Reward.record ctxt delegate current_cycle full_reward | Proposals { period ; proposals } -> - Level.current ctxt >>=? fun level -> + let level = Level.current ctxt in fail_unless Voting_period.(level.voting_period = period) (Wrong_voting_period (level.voting_period, period)) >>=? fun () -> Amendment.record_proposals ctxt delegate proposals | Ballot { period ; proposal ; ballot } -> - Level.current ctxt >>=? fun level -> + let level = Level.current ctxt in fail_unless Voting_period.(level.voting_period = period) (Wrong_voting_period (level.voting_period, period)) >>=? fun () -> Amendment.record_ballot ctxt delegate proposal ballot @@ -228,11 +228,8 @@ let apply_operation let may_start_new_cycle ctxt = Mining.dawn_of_a_new_cycle ctxt >>=? function | None -> return ctxt - | Some new_cycle -> - let last_cycle = - match Cycle.pred new_cycle with - | None -> assert false - | Some last_cycle -> last_cycle in + | Some last_cycle -> + let new_cycle = Cycle.succ last_cycle in Bootstrap.refill ctxt >>=? fun ctxt -> Seed.clear_cycle ctxt last_cycle >>=? fun ctxt -> Seed.compute_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt -> @@ -259,12 +256,11 @@ let begin_application ctxt block pred_timestamp = let finalize_application ctxt block miner = (* end of level (from this point nothing should fail) *) - let priority = block.Block.proto.mining_slot.priority in + let priority = block.Block.proto.priority in let reward = Mining.base_mining_reward ctxt ~priority in Nonce.record_hash ctxt miner reward block.proto.seed_nonce_hash >>=? fun ctxt -> Reward.pay_due_rewards ctxt >>=? fun ctxt -> - Level.increment_current ctxt >>=? fun ctxt -> (* end of cycle *) may_start_new_cycle ctxt >>=? fun ctxt -> Amendment.may_start_new_voting_cycle ctxt >>=? fun ctxt -> diff --git a/src/proto/alpha/block_repr.ml b/src/proto/alpha/block_repr.ml index 1f67188fb..28f5708a1 100644 --- a/src/proto/alpha/block_repr.ml +++ b/src/proto/alpha/block_repr.ml @@ -19,37 +19,23 @@ type header = { } and proto_header = { - mining_slot: mining_slot ; + priority: int ; seed_nonce_hash: Nonce_hash.t ; proof_of_work_nonce: MBytes.t ; } -and mining_slot = { - level: Raw_level_repr.t ; - priority: int ; -} - -let mining_slot_encoding = - let open Data_encoding in - conv - (fun { level ; priority } -> level, priority) - (fun (level, priority) -> { level ; priority }) - (obj2 - (req "level" Raw_level_repr.encoding) - (req "priority" uint16)) - let proto_header_encoding = let open Data_encoding in conv - (fun { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } -> - (mining_slot, (seed_nonce_hash, proof_of_work_nonce))) - (fun (mining_slot, (seed_nonce_hash, proof_of_work_nonce)) -> - { mining_slot ; seed_nonce_hash ; proof_of_work_nonce }) - (merge_objs - mining_slot_encoding - (obj2 - (req "seed_nonce_hash" Nonce_hash.encoding) - (req "proof_of_work_nonce" (Fixed.bytes Constants_repr.proof_of_work_nonce_size)))) + (fun { priority ; seed_nonce_hash ; proof_of_work_nonce } -> + (priority, seed_nonce_hash, proof_of_work_nonce)) + (fun (priority, seed_nonce_hash, proof_of_work_nonce) -> + { priority ; seed_nonce_hash ; proof_of_work_nonce }) + (obj3 + (req "priority" uint16) + (req "seed_nonce_hash" Nonce_hash.encoding) + (req "proof_of_work_nonce" + (Fixed.bytes Constants_repr.proof_of_work_nonce_size))) let signed_proto_header_encoding = let open Data_encoding in @@ -76,13 +62,15 @@ type error += | Cant_parse_proto_header let parse_header - ({ shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ; + ({ shell = { net_id ; level ; predecessor ; + timestamp ; fitness ; operations } ; proto } : Updater.raw_block) : header tzresult = match Data_encoding.Binary.of_bytes signed_proto_header_encoding proto with | None -> Error [Cant_parse_proto_header] | Some (proto, signature) -> let shell = - { Updater.net_id ; predecessor ; timestamp ; fitness ; operations } in + { Updater.net_id ; level ; predecessor ; + timestamp ; fitness ; operations } in Ok { shell ; proto ; signature } let forge_header shell proto = diff --git a/src/proto/alpha/block_repr.mli b/src/proto/alpha/block_repr.mli index 7967cc4d2..5d16c21ad 100644 --- a/src/proto/alpha/block_repr.mli +++ b/src/proto/alpha/block_repr.mli @@ -17,18 +17,11 @@ type header = { } and proto_header = { - mining_slot: mining_slot ; + priority: int ; seed_nonce_hash: Nonce_hash.t ; proof_of_work_nonce: MBytes.t ; } -and mining_slot = { - level: Raw_level_repr.t ; - priority: int ; -} - -val mining_slot_encoding: mining_slot Data_encoding.encoding - (** The maximum size of block headers in bytes *) val max_header_length: int diff --git a/src/proto/alpha/init_storage.ml b/src/proto/alpha/init_storage.ml index fdae35666..32e94c6e0 100644 --- a/src/proto/alpha/init_storage.ml +++ b/src/proto/alpha/init_storage.ml @@ -7,19 +7,9 @@ (* *) (**************************************************************************) -let version_key = ["version"] - -(* This key should always be populated for every version of the - protocol. It's absence meaning that the context is empty. *) -let version_value = "alpha" - (* This is the genesis protocol: initialise the state *) -let initialize ~timestamp ~fitness (ctxt: Context.t) = - Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt -> - Storage.prepare ~timestamp ~fitness ctxt >>=? fun store -> - Level_storage.init store >>=? fun store -> +let initialize store = Roll_storage.init store >>=? fun store -> - Nonce_storage.init store >>=? fun store -> Seed_storage.init store >>=? fun store -> Contract_storage.init store >>=? fun store -> Reward_storage.init store >>=? fun store -> @@ -32,34 +22,25 @@ let initialize ~timestamp ~fitness (ctxt: Context.t) = return store type error += - | Incompatiple_protocol_version | Unimplemented_sandbox_migration -let may_initialize ctxt ~timestamp ~fitness = - Context.get ctxt version_key >>= function - | None -> - (* This is the genesis protocol: The only acceptable preceding - version is an empty context *) - initialize ~timestamp ~fitness ctxt - | Some bytes -> - let s = MBytes.to_string bytes in - if Compare.String.(s = version_value) then - Storage.prepare ~timestamp ~fitness ctxt - else if Compare.String.(s = "genesis") then - initialize ~timestamp ~fitness ctxt - else - fail Incompatiple_protocol_version +let may_initialize ctxt ~level ~timestamp ~fitness = + Storage.prepare ~level ~timestamp ~fitness ctxt >>=? fun (ctxt, first_block) -> + if first_block then + initialize ctxt + else + return ctxt let configure_sandbox ctxt json = let json = match json with | None -> `O [] | Some json -> json in - Context.get ctxt version_key >>= function - | None -> + Storage.is_first_block ctxt >>=? function + | true -> Storage.set_sandboxed ctxt json >>= fun ctxt -> return ctxt - | Some _ -> + | false -> Storage.get_sandboxed ctxt >>=? function | None -> fail Unimplemented_sandbox_migration diff --git a/src/proto/alpha/level_repr.ml b/src/proto/alpha/level_repr.ml index 7972b3fcd..e99abbfb2 100644 --- a/src/proto/alpha/level_repr.ml +++ b/src/proto/alpha/level_repr.ml @@ -10,6 +10,7 @@ type t = { level: Raw_level_repr.t ; + level_position: int32 ; cycle: Cycle_repr.t ; cycle_position: int32 ; voting_period: Voting_period_repr.t ; @@ -22,47 +23,58 @@ let pp ppf { level } = Raw_level_repr.pp ppf level let pp_full ppf l = Format.fprintf ppf - "%a (cycle %a.%ld) (vote %a.%ld)" - Raw_level_repr.pp l.level + "%a.%ld (cycle %a.%ld) (vote %a.%ld)" + Raw_level_repr.pp l.level l.level_position Cycle_repr.pp l.cycle l.cycle_position Voting_period_repr.pp l.voting_period l.voting_period_position let encoding = let open Data_encoding in conv - (fun { level ; cycle ; cycle_position ; + (fun { level ; level_position ; + cycle ; cycle_position ; voting_period; voting_period_position } -> - (level, cycle, cycle_position, + (level, level_position, + cycle, cycle_position, voting_period, voting_period_position)) - (fun (level, cycle, cycle_position, + (fun (level, level_position, + cycle, cycle_position, voting_period, voting_period_position) -> - { level ; cycle ; cycle_position ; + { level ; level_position ; + cycle ; cycle_position ; voting_period ; voting_period_position }) - (obj5 + (obj6 (req "level" Raw_level_repr.encoding) + (req "level_position" int32) (req "cycle" Cycle_repr.encoding) (req "cycle_position" int32) (req "voting_period" Voting_period_repr.encoding) (req "voting_period_position" int32)) -let root = - { level = Raw_level_repr.root ; +let root first_level = + { level = first_level ; + level_position = 0l ; cycle = Cycle_repr.root ; cycle_position = 0l ; voting_period = Voting_period_repr.root ; voting_period_position = 0l ; } -let from_raw ~cycle_length ~voting_period_length level = +let from_raw ~first_level ~cycle_length ~voting_period_length level = let raw_level = Raw_level_repr.to_int32 level in - let cycle = Cycle_repr.of_int32_exn (Int32.div raw_level cycle_length) in - let cycle_position = Int32.rem raw_level cycle_length in + let first_level = Raw_level_repr.to_int32 first_level in + let level_position = + Compare.Int32.max 0l (Int32.sub raw_level first_level) in + let cycle = + Cycle_repr.of_int32_exn (Int32.div level_position cycle_length) in + let cycle_position = Int32.rem level_position cycle_length in let voting_period = Voting_period_repr.of_int32_exn - (Int32.div raw_level voting_period_length) in + (Int32.div level_position voting_period_length) in let voting_period_position = - Int32.rem raw_level voting_period_length in - { level ; cycle ; cycle_position ; + Int32.rem level_position voting_period_length in + { level ; level_position ; + cycle ; cycle_position ; voting_period ; voting_period_position } let diff { level = l1 } { level = l2 } = diff --git a/src/proto/alpha/level_repr.mli b/src/proto/alpha/level_repr.mli index 4358be1e5..8e954e39e 100644 --- a/src/proto/alpha/level_repr.mli +++ b/src/proto/alpha/level_repr.mli @@ -9,6 +9,7 @@ type t = private { level: Raw_level_repr.t ; + level_position: int32 ; cycle: Cycle_repr.t ; cycle_position: int32 ; voting_period: Voting_period_repr.t ; @@ -21,10 +22,12 @@ val pp: Format.formatter -> level -> unit val pp_full: Format.formatter -> level -> unit include Compare.S with type t := level -val root: level +val root: Raw_level_repr.t -> level val from_raw: - cycle_length:int32 -> voting_period_length:int32 -> + first_level:Raw_level_repr.t -> + cycle_length:int32 -> + voting_period_length:int32 -> Raw_level_repr.t -> level val diff: level -> level -> int32 diff --git a/src/proto/alpha/level_storage.ml b/src/proto/alpha/level_storage.ml index 923ed3a86..5c2e9015b 100644 --- a/src/proto/alpha/level_storage.ml +++ b/src/proto/alpha/level_storage.ml @@ -15,31 +15,29 @@ let from_raw c ?offset l = | None -> l | Some o -> Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) in let constants = Storage.constants c in + let first_level = Storage.first_level c in Level_repr.from_raw + ~first_level ~cycle_length:constants.Constants_repr.cycle_length ~voting_period_length:constants.Constants_repr.voting_period_length l +let root c = + Level_repr.root (Storage.first_level c) + let succ c l = from_raw c (Raw_level_repr.succ l.level) let pred c l = match Raw_level_repr.pred l.Level_repr.level with | None -> None | Some l -> Some (from_raw c l) -let current ctxt = - Storage.Current_level.get ctxt >>=? fun l -> - return (from_raw ctxt l) +let current ctxt = Storage.current_level ctxt let previous ctxt = - current ctxt >>=? fun l -> + let l = current ctxt in match pred ctxt l with - | None -> assert false (* Context inited with level = 1. *) - | Some p -> return p - -let increment_current ctxt = - Storage.Current_level.get ctxt >>=? fun l -> - Storage.Current_level.set ctxt (Raw_level_repr.succ l) - + | None -> assert false (* We never validate the Genesis... *) + | Some p -> p let first_level_in_cycle ctxt c = let constants = Storage.constants ctxt in @@ -60,8 +58,3 @@ let levels_in_cycle ctxt c = else acc in loop first [] - -let init ctxt = - Storage.Current_level.init ctxt Raw_level_repr.(succ root) - - diff --git a/src/proto/alpha/level_storage.mli b/src/proto/alpha/level_storage.mli index 117d348a8..1db9c1c10 100644 --- a/src/proto/alpha/level_storage.mli +++ b/src/proto/alpha/level_storage.mli @@ -7,11 +7,10 @@ (* *) (**************************************************************************) -val init: Storage.t -> Storage.t tzresult Lwt.t +val current: Storage.t -> Level_repr.t +val previous: Storage.t -> Level_repr.t -val increment_current: Storage.t -> Storage.t tzresult Lwt.t -val current: Storage.t -> Level_repr.t tzresult Lwt.t -val previous: Storage.t -> Level_repr.t tzresult Lwt.t +val root: Storage.t -> Level_repr.t val from_raw: Storage.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t val pred: Storage.t -> Level_repr.t -> Level_repr.t option diff --git a/src/proto/alpha/main.ml b/src/proto/alpha/main.ml index e3f7ede80..3c203d910 100644 --- a/src/proto/alpha/main.ml +++ b/src/proto/alpha/main.ml @@ -50,8 +50,10 @@ let begin_application ~predecessor_fitness:pred_fitness raw_block = Lwt.return (Tezos_context.Block.parse_header raw_block) >>=? fun header -> + let level = header.shell.level in + let fitness = pred_fitness in let timestamp = header.shell.timestamp in - Tezos_context.init ~timestamp ~fitness:pred_fitness ctxt >>=? fun ctxt -> + Tezos_context.init ~level ~timestamp ~fitness ctxt >>=? fun ctxt -> Apply.begin_application ctxt header pred_timestamp >>=? fun (ctxt, miner) -> let mode = Application (header, miner) in return { mode ; ctxt ; op_count = 0 } @@ -59,11 +61,14 @@ let begin_application let begin_construction ~predecessor_context:ctxt ~predecessor_timestamp:_ + ~predecessor_level:pred_level ~predecessor_fitness:pred_fitness ~predecessor:pred_block ~timestamp = let mode = Construction { pred_block ; timestamp } in - Tezos_context.init ~timestamp ~fitness:pred_fitness ctxt >>=? fun ctxt -> + let level = Int32.succ pred_level in + let fitness = pred_fitness in + Tezos_context.init ~timestamp ~level ~fitness ctxt >>=? fun ctxt -> let ctxt = Apply.begin_construction ctxt in return { mode ; ctxt ; op_count = 0 } @@ -74,7 +79,7 @@ let apply_operation ({ mode ; ctxt ; op_count } as data) operation = pred_block, 0, None | Application (block, delegate) -> block.shell.predecessor, - block.proto.mining_slot.priority, + block.proto.priority, Some (Tezos_context.Contract.default_contract delegate) in Apply.apply_operation ctxt miner_contract pred_block block_prio operation @@ -88,8 +93,9 @@ let finalize_block { mode ; ctxt ; op_count } = match mode with return ctxt | Application (block, miner) -> Apply.finalize_application ctxt block miner >>=? fun ctxt -> - Tezos_context.Level.current ctxt >>=? fun { level } -> - let priority = block.proto.mining_slot.priority in + let { level } : Tezos_context.Level.t = + Tezos_context. Level.current ctxt in + let priority = block.proto.priority in let level = Tezos_context.Raw_level.to_int32 level in let fitness = Tezos_context.Fitness.current ctxt in let commit_message = diff --git a/src/proto/alpha/mining.ml b/src/proto/alpha/mining.ml index 32c8e3d8d..2aa8b0f64 100644 --- a/src/proto/alpha/mining.ml +++ b/src/proto/alpha/mining.ml @@ -14,7 +14,6 @@ open Misc type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *) type error += Invalid_endorsement_slot of int * int (* `Permanent *) type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *) -type error += Wrong_level of Raw_level.t * Raw_level.t (* `Permanent *) type error += Wrong_delegate of public_key_hash * public_key_hash (* `Permanent *) type error += Cannot_pay_mining_bond (* `Permanent *) type error += Cannot_pay_endorsement_bond (* `Permanent *) @@ -60,20 +59,6 @@ let () = (req "provided" int16)) (function Invalid_endorsement_slot (m, g) -> Some (m, g) | _ -> None) (fun (m, g) -> Invalid_endorsement_slot (m, g)) ; - register_error_kind - `Permanent - ~id:"mining.wrong_level" - ~title:"Wrong level" - ~description:"The block level is not the expected one" - ~pp:(fun ppf (e, g) -> - Format.fprintf ppf - "The declared level %a is not %a" - Raw_level.pp g Raw_level.pp e) - Data_encoding.(obj2 - (req "expected" Raw_level.encoding) - (req "provided" Raw_level.encoding)) - (function Wrong_level (e, g) -> Some (e, g) | _ -> None) - (fun (e, g) -> Wrong_level (e, g)) ; register_error_kind `Permanent ~id:"mining.wrong_delegate" @@ -133,21 +118,14 @@ let check_timestamp c priority pred_timestamp = fail_unless Timestamp.(minimal_time <= timestamp) (Timestamp_too_early (minimal_time, timestamp)) -let check_mining_rights c - { Block.proto = { mining_slot = { level = raw_level ; priority } } } +let check_mining_rights c { Block.proto = { priority } } pred_timestamp = - Level.current c >>=? fun current_level -> - fail_unless - Raw_level.(raw_level = current_level.level) - (Wrong_level (current_level.Level.level, raw_level)) >>=? fun () -> - let level = Level.from_raw c raw_level in + let level = Level.current c in Roll.mining_rights_owner c level ~priority >>=? fun delegate -> check_timestamp c priority pred_timestamp >>=? fun () -> return delegate -let pay_mining_bond c - { Block.proto = { mining_slot = { priority} } } - id = +let pay_mining_bond c { Block.proto = { priority } } id = if Compare.Int.(priority >= Constants.first_free_mining_slot c) then return c else @@ -163,7 +141,7 @@ let pay_endorsement_bond c id = let check_signing_rights c slot delegate = fail_unless Compare.Int.(0 <= slot && slot <= Constants.max_signing_slot c) (Invalid_endorsement_slot (Constants.max_signing_slot c, slot)) >>=? fun () -> - Level.current c >>=? fun level -> + let level = Level.current c in Roll.endorsement_rights_owner c level ~slot >>=? fun owning_delegate -> fail_unless (Ed25519.Public_key_hash.equal owning_delegate delegate) (Wrong_delegate (owning_delegate, delegate)) @@ -281,12 +259,13 @@ let check_fitness_gap ctxt (block : Block.header) = else return () -let first_of_a_cycle l = - Compare.Int32.(l.Level.cycle_position = 0l) +let last_of_a_cycle ctxt l = + Compare.Int32.(Int32.succ l.Level.cycle_position = + Constants.cycle_length ctxt) let dawn_of_a_new_cycle ctxt = - Level.current ctxt >>=? fun level -> - if first_of_a_cycle level then + let level = Level.current ctxt in + if last_of_a_cycle ctxt level then return (Some level.cycle) else return None diff --git a/src/proto/alpha/mining.mli b/src/proto/alpha/mining.mli index efa312019..76b92fb26 100644 --- a/src/proto/alpha/mining.mli +++ b/src/proto/alpha/mining.mli @@ -14,7 +14,6 @@ open Misc type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *) type error += Invalid_endorsement_slot of int * int (* `Permanent *) type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *) -type error += Wrong_level of Raw_level.t * Raw_level.t (* `Permanent *) type error += Wrong_delegate of public_key_hash * public_key_hash (* `Permanent *) type error += Cannot_pay_mining_bond (* `Permanent *) type error += Cannot_pay_endorsement_bond (* `Permanent *) diff --git a/src/proto/alpha/nonce_storage.ml b/src/proto/alpha/nonce_storage.ml index 9b6fdb52f..f993601fb 100644 --- a/src/proto/alpha/nonce_storage.ml +++ b/src/proto/alpha/nonce_storage.ml @@ -18,7 +18,7 @@ type error += | Unexpected_nonce let get_unrevealed c level = - Level_storage.current c >>=? fun cur_level -> + let cur_level = Level_storage.current c in let min_cycle = match Cycle_repr.pred cur_level.cycle with | None -> Cycle_repr.root @@ -40,7 +40,7 @@ let get_unrevealed c level = (* return nonce_hash *) let record_hash c delegate_to_reward reward_amount nonce_hash = - Level_storage.current c >>=? fun level -> + let level = Level_storage.current c in Storage.Seed.Nonce.init c level (Unrevealed { nonce_hash; delegate_to_reward ; reward_amount }) @@ -65,6 +65,3 @@ let get c level = Storage.Seed.Nonce.get c level let of_bytes = Seed_repr.make_nonce let hash = Seed_repr.hash let check_hash = Seed_repr.check_hash - -let init c = - Storage.Seed.Nonce.init c Level_repr.root (Revealed Seed_repr.initial_nonce_0) diff --git a/src/proto/alpha/nonce_storage.mli b/src/proto/alpha/nonce_storage.mli index ea9d22a0b..2c0ab5a53 100644 --- a/src/proto/alpha/nonce_storage.mli +++ b/src/proto/alpha/nonce_storage.mli @@ -41,6 +41,3 @@ val get: Storage.t -> Level_repr.t -> status tzresult Lwt.t val of_bytes: MBytes.t -> nonce tzresult val hash: nonce -> Nonce_hash.t val check_hash: nonce -> Nonce_hash.t -> bool - -val init: - Storage.t -> Storage.t tzresult Lwt.t diff --git a/src/proto/alpha/raw_level_repr.ml b/src/proto/alpha/raw_level_repr.ml index 3047588c6..979c8a5ab 100644 --- a/src/proto/alpha/raw_level_repr.ml +++ b/src/proto/alpha/raw_level_repr.ml @@ -39,3 +39,9 @@ let of_int32_exn l = if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.of_int32" + +type error += Unexpected_level of Int32.t + +let of_int32 l = + try Ok (of_int32_exn l) + with _ -> Error [Unexpected_level l] diff --git a/src/proto/alpha/raw_level_repr.mli b/src/proto/alpha/raw_level_repr.mli index fac16df55..6c89eb1bc 100644 --- a/src/proto/alpha/raw_level_repr.mli +++ b/src/proto/alpha/raw_level_repr.mli @@ -16,6 +16,7 @@ include Compare.S with type t := raw_level val to_int32: raw_level -> int32 val of_int32_exn: int32 -> raw_level +val of_int32: int32 -> raw_level tzresult val diff: raw_level -> raw_level -> int32 diff --git a/src/proto/alpha/seed_storage.ml b/src/proto/alpha/seed_storage.ml index b0cfb7c32..d159dfd8c 100644 --- a/src/proto/alpha/seed_storage.ml +++ b/src/proto/alpha/seed_storage.ml @@ -45,7 +45,7 @@ let compute_for_cycle c cycle = | c -> Lwt.return c let for_cycle c cycle = - Level_storage.current c >>=? fun current_level -> + let current_level = Level_storage.current c in let current_cycle = current_level.cycle in let next_cycle = (Level_storage.succ c current_level).cycle in fail_unless diff --git a/src/proto/alpha/services_registration.ml b/src/proto/alpha/services_registration.ml index ced5e6d8b..3d35bb845 100644 --- a/src/proto/alpha/services_registration.ml +++ b/src/proto/alpha/services_registration.ml @@ -9,8 +9,8 @@ open Tezos_context -let rpc_init { Updater.context ; timestamp ; fitness } = - Tezos_context.init ~timestamp ~fitness context +let rpc_init { Updater.context ; level ; timestamp ; fitness } = + Tezos_context.init ~level ~timestamp ~fitness context let rpc_services = ref (RPC.empty : Updater.rpc_context RPC.directory) let register0 s f = @@ -95,7 +95,7 @@ let () = type error += Unexpected_level_in_context let level ctxt = - Level.current ctxt >>=? fun level -> + let level = Level.current ctxt in match Level.pred ctxt level with | None -> fail Unexpected_level_in_context | Some level -> return level @@ -103,7 +103,7 @@ let level ctxt = let () = register0 Services.Context.level level let next_level ctxt = - Level.current ctxt + return (Level.current ctxt) let () = register0 Services.Context.next_level next_level @@ -193,7 +193,7 @@ let () = | None -> Error_monad.fail Operation.Cannot_parse_operation | Some (shell, contents) -> let operation = { hash ; shell ; contents ; signature } in - Tezos_context.Level.current ctxt >>=? fun level -> + let level = Tezos_context.Level.current ctxt in Mining.mining_priorities ctxt level >>=? fun (Misc.LCons (miner_pkh, _)) -> let miner_contract = Contract.default_contract miner_pkh in let block_prio = 0 in @@ -302,7 +302,7 @@ let mining_rights ctxt level max = let () = register1 Services.Helpers.Rights.mining_rights (fun ctxt max -> - Level.current ctxt >>=? fun level -> + let level = Level.current ctxt in mining_rights ctxt level max >>=? fun (raw_level, slots) -> begin Lwt_list.filter_map_p (fun x -> x) @@ @@ -325,7 +325,7 @@ let () = let mining_rights_for_delegate ctxt contract (max_priority, min_level, max_level) = let max_priority = default_max_mining_priority ctxt max_priority in - Level.current ctxt >>=? fun current_level -> + let current_level = Level.current ctxt in let max_level = match max_level with | None -> @@ -381,7 +381,7 @@ let endorsement_rights ctxt level max = let () = register1 Services.Helpers.Rights.endorsement_rights (fun ctxt max -> - Level.current ctxt >>=? fun level -> + let level = Level.current ctxt in endorsement_rights ctxt (Level.succ ctxt level) max) ; register2 Services.Helpers.Rights.endorsement_rights_for_level (fun ctxt raw_level max -> @@ -390,7 +390,7 @@ let () = let endorsement_rights_for_delegate ctxt contract (max_priority, min_level, max_level) = - Level.current ctxt >>=? fun current_level -> + let current_level = Level.current ctxt in let max_priority = default_max_endorsement_priority ctxt max_priority in let max_level = match max_level with @@ -435,11 +435,12 @@ let () = register1 Services.Helpers.Forge.operations forge_operations let forge_block _ctxt (net_id, predecessor, timestamp, fitness, operations, - raw_level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t = - let mining_slot = { Block.level = raw_level ; priority } in + level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t = + let level = Raw_level.to_int32 level in return (Block.forge_header - { net_id ; predecessor ; timestamp ; fitness ; operations } - { mining_slot ; seed_nonce_hash ; proof_of_work_nonce }) + { net_id ; level ; predecessor ; + timestamp ; fitness ; operations } + { priority ; seed_nonce_hash ; proof_of_work_nonce }) let () = register1 Services.Helpers.Forge.block forge_block diff --git a/src/proto/alpha/storage.ml b/src/proto/alpha/storage.ml index ee8df6062..aae3b748d 100644 --- a/src/proto/alpha/storage.ml +++ b/src/proto/alpha/storage.ml @@ -10,17 +10,55 @@ open Tezos_hash open Storage_functors +(* This key should always be populated for every version of the + protocol. It's absence meaning that the context is empty. *) +let version_key = ["version"] +let version_value = "alpha" + +type error += Incompatiple_protocol_version + +let is_first_block ctxt = + Context.get ctxt version_key >>= function + | None -> + return true + | Some bytes -> + let s = MBytes.to_string bytes in + if Compare.String.(s = version_value) then + return false + else if Compare.String.(s = "genesis") then + return true + else + fail Incompatiple_protocol_version + let version = "v1" +let first_level_key = [ version ; "first_level" ] let sandboxed_key = [ version ; "sandboxed" ] type t = Storage_functors.context type error += Invalid_sandbox_parameter +let current_level { level } = level let current_timestamp { timestamp } = timestamp let current_fitness { fitness } = fitness let set_current_fitness c fitness = { c with fitness } +let get_first_level ctxt = + Context.get ctxt first_level_key >>= function + | None -> failwith "Invalid context" + | Some bytes -> + match + Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes + with + | None -> failwith "Invalid context" + | Some level -> return level + +let set_first_level ctxt level = + let bytes = + Data_encoding.Binary.to_bytes Raw_level_repr.encoding level in + Context.set ctxt first_level_key bytes >>= fun ctxt -> + return ctxt + let get_sandboxed c = Context.get c sandboxed_key >>= function | None -> return None @@ -33,21 +71,41 @@ let set_sandboxed c json = Context.set c sandboxed_key (Data_encoding.Binary.to_bytes Data_encoding.json json) -let prepare ~timestamp ~fitness (c : Context.t) : t tzresult Lwt.t = +let may_tag_first_block ctxt level = + is_first_block ctxt >>=? function + | false -> + get_first_level ctxt >>=? fun level -> + return (ctxt, false, level) + | true -> + Context.set ctxt version_key + (MBytes.of_string version_value) >>= fun ctxt -> + set_first_level ctxt level >>=? fun ctxt -> + return (ctxt, true, level) + +let prepare ~level ~timestamp ~fitness ctxt = + Lwt.return (Raw_level_repr.of_int32 level ) >>=? fun level -> Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness -> - get_sandboxed c >>=? fun sandbox -> + may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) -> + get_sandboxed ctxt >>=? fun sandbox -> Constants_repr.read sandbox >>=? function constants -> - return { context = c ; constants ; timestamp ; fitness } + let level = + Level_repr.from_raw + ~first_level + ~cycle_length:constants.Constants_repr.cycle_length + ~voting_period_length:constants.Constants_repr.voting_period_length + level in + return ({ context = ctxt ; constants ; level ; + timestamp ; fitness ; first_level}, + first_block) let recover { context } : Context.t = context +let first_level { first_level } = first_level let constants { constants } = constants module Key = struct let store_root tail = version :: "store" :: tail - let current_level = store_root ["level"] - let global_counter = store_root ["global_counter"] let next_cycle_to_be_rewarded = store_root ["next_cycle_to_be_rewarded"] @@ -119,16 +177,6 @@ module Key = struct end -(** Global *) - -module Current_level = - Make_single_data_storage(struct - type value = Raw_level_repr.t - let name = "level" - let key = Key.current_level - let encoding = Raw_level_repr.encoding - end) - (** Rolls *) module Roll = struct diff --git a/src/proto/alpha/storage.mli b/src/proto/alpha/storage.mli index 9f9cb1109..06a396de7 100644 --- a/src/proto/alpha/storage.mli +++ b/src/proto/alpha/storage.mli @@ -24,11 +24,17 @@ (** Abstract view of the database *) type t -(** Rerieves the state of the database and gives its abstract view *) +(** Is first block validated with this version of the protocol ? *) +val is_first_block: Context.t -> bool tzresult Lwt.t + +(** Retrieves the state of the database and gives its abstract view. + It also returns wether this is the first block validated + with this version of the protocol. *) val prepare : + level: Int32.t -> timestamp: Time.t -> fitness: Fitness.fitness -> - Context.t -> t tzresult Lwt.t + Context.t -> (t * bool) tzresult Lwt.t (** Returns the state of the database resulting of operations on its abstract view *) @@ -37,22 +43,19 @@ val recover : t -> Context.t val get_sandboxed : Context.t -> Data_encoding.json option tzresult Lwt.t val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t +val current_level : t -> Level_repr.t val current_timestamp : t -> Time.t val current_fitness : t -> Int64.t val set_current_fitness : t -> Int64.t -> t val constants : t -> Constants_repr.constants +val first_level : t -> Raw_level_repr.t (** {1 Entity Accessors} *****************************************************) open Storage_sigs -(** The level of the current block *) -module Current_level : Single_data_storage - with type value = Raw_level_repr.t - and type context := t - module Roll : sig (** Storage from this submodule must only be accessed through the diff --git a/src/proto/alpha/storage_functors.ml b/src/proto/alpha/storage_functors.ml index c8c9fb2b4..5c17a8eef 100644 --- a/src/proto/alpha/storage_functors.ml +++ b/src/proto/alpha/storage_functors.ml @@ -14,6 +14,8 @@ open Misc type context = { context: Context.t ; constants: Constants_repr.constants ; + first_level: Raw_level_repr.t ; + level: Level_repr.t ; timestamp: Time.t ; fitness: Int64.t ; } diff --git a/src/proto/alpha/storage_functors.mli b/src/proto/alpha/storage_functors.mli index ad1262a09..cc13680cc 100644 --- a/src/proto/alpha/storage_functors.mli +++ b/src/proto/alpha/storage_functors.mli @@ -17,6 +17,8 @@ type context = { context: Context.t ; constants: Constants_repr.constants ; + first_level: Raw_level_repr.t ; + level: Level_repr.t ; timestamp: Time.t ; fitness: Int64.t ; } diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index 9ec73165b..2eb2cfeba 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -219,6 +219,7 @@ module Level : sig type t = private { level: Raw_level.t ; + level_position: int32 ; cycle: Cycle.t ; cycle_position: int32 ; voting_period: Voting_period.t ; @@ -228,7 +229,7 @@ module Level : sig val pp_full: Format.formatter -> t -> unit type level = t - val root: level + val root: context -> level val succ: context -> level -> level val pred: context -> level -> level option @@ -237,8 +238,7 @@ module Level : sig val diff: level -> level -> int32 - val current: context -> level tzresult Lwt.t - val increment_current: context -> context tzresult Lwt.t + val current: context -> level val last_level_in_cycle: context -> Cycle.t -> level val levels_in_cycle: context -> Cycle.t -> level list @@ -523,18 +523,11 @@ module Block : sig } and proto_header = { - mining_slot: mining_slot ; + priority: int ; seed_nonce_hash: Nonce_hash.t ; proof_of_work_nonce: MBytes.t ; } - and mining_slot = { - level: Raw_level.t ; - priority: int ; - } - - val mining_slot_encoding: mining_slot Data_encoding.encoding - val max_header_length: int val parse_header: Updater.raw_block -> header tzresult @@ -580,6 +573,7 @@ end val init: Context.t -> + level:Int32.t -> timestamp:Time.t -> fitness:Fitness.t -> context tzresult Lwt.t diff --git a/src/proto/demo/main.ml b/src/proto/demo/main.ml index 8bc1766db..7fa64f434 100644 --- a/src/proto/demo/main.ml +++ b/src/proto/demo/main.ml @@ -71,6 +71,7 @@ let begin_application let begin_construction ~predecessor_context:context ~predecessor_timestamp:_ + ~predecessor_level:_ ~predecessor_fitness:pred_fitness ~predecessor:_ ~timestamp:_ = diff --git a/src/proto/environment/updater.mli b/src/proto/environment/updater.mli index 404cde61a..6eb799f0b 100644 --- a/src/proto/environment/updater.mli +++ b/src/proto/environment/updater.mli @@ -19,6 +19,8 @@ val raw_operation_encoding: raw_operation Data_encoding.t type shell_block = { net_id: Net_id.t ; (** The genesis of the chain this block belongs to. *) + level: Int32.t ; + (** The number of predecessing block in the chain. *) predecessor: Block_hash.t ; (** The preceding block in the chain. *) timestamp: Time.t ; @@ -46,6 +48,7 @@ type validation_result = { type rpc_context = { context: Context.t ; + level: Int32.t ; timestamp: Time.t ; fitness: Fitness.fitness ; } @@ -124,6 +127,7 @@ module type PROTOCOL = sig val begin_construction : predecessor_context: Context.t -> predecessor_timestamp: Time.t -> + predecessor_level: Int32.t -> predecessor_fitness: Fitness.fitness -> predecessor: Block_hash.t -> timestamp: Time.t -> diff --git a/src/proto/genesis/main.ml b/src/proto/genesis/main.ml index 0a0c73f2f..d8e9d2ebb 100644 --- a/src/proto/genesis/main.ml +++ b/src/proto/genesis/main.ml @@ -98,6 +98,7 @@ let begin_application let begin_construction ~predecessor_context:context ~predecessor_timestamp:_ + ~predecessor_level:_ ~predecessor_fitness:fitness ~predecessor:_ ~timestamp:_ = diff --git a/src/proto/genesis/services.ml b/src/proto/genesis/services.ml index cb800e0d0..9983df0a3 100644 --- a/src/proto/genesis/services.ml +++ b/src/proto/genesis/services.ml @@ -38,8 +38,9 @@ module Forge = struct ~description: "Forge a block" ~input: (merge_objs - (obj4 + (obj5 (req "net_id" Net_id.encoding) + (req "level" int32) (req "predecessor" Block_hash.encoding) (req "timestamp" Time.encoding) (req "fitness" Fitness.encoding)) @@ -62,9 +63,9 @@ let rpc_services : Updater.rpc_context RPC.directory = RPC.register dir (Forge.block RPC.Path.root) - (fun _ctxt ((net_id, predecessor, timestamp, fitness), command) -> - let shell = { Updater.net_id ; predecessor ; timestamp ; fitness ; - operations } in + (fun _ctxt ((net_id, level, predecessor, timestamp, fitness), command) -> + let shell = { Updater.net_id ; level ; predecessor ; + timestamp ; fitness ; operations } in let bytes = Data.Command.forge shell command in RPC.Answer.return bytes) in dir diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index dbe78360d..17575784c 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -361,7 +361,7 @@ module Mining = struct block delegate_sk shell - mining_slot + priority seed_nonce_hash = Client_proto_rpcs.Constants.stamp_threshold rpc_config block >>=? fun stamp_threshold -> @@ -370,7 +370,7 @@ module Mining = struct Sodium.Random.Bigbytes.generate Constants.proof_of_work_nonce_size in let unsigned_header = Block.forge_header - shell { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } in + shell { priority ; seed_nonce_hash ; proof_of_work_nonce } in let signed_header = Environment.Ed25519.Signature.append delegate_sk unsigned_header in let block_hash = Block_hash.hash_bytes [signed_header] in @@ -398,10 +398,9 @@ module Mining = struct [Operation_list_hash.compute operation_list] in let shell = { Store.Block_header.net_id = bi.net ; predecessor = bi.hash ; - timestamp ; fitness ; operations } in - let slot = { Block.level = level.level ; priority } in + timestamp ; fitness ; operations ; level = Raw_level.to_int32 level.level } in mine_stamp - block src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce -> + block src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce -> Client_proto_rpcs.Helpers.Forge.block rpc_config block ~net:bi.net @@ -553,3 +552,8 @@ module Endorse = struct block delegate () end + +let display_level block = + Client_proto_rpcs.Context.level rpc_config block >>=? fun lvl -> + Format.eprintf "Level: %a@." Level.pp_full lvl ; + return () diff --git a/test/proto_alpha/proto_alpha_helpers.mli b/test/proto_alpha/proto_alpha_helpers.mli index 008d59756..00543b498 100644 --- a/test/proto_alpha/proto_alpha_helpers.mli +++ b/test/proto_alpha/proto_alpha_helpers.mli @@ -105,7 +105,7 @@ module Mining : sig Client_proto_rpcs.block -> secret_key -> Updater.shell_block -> - Block.mining_slot -> + int -> Nonce_hash.t -> MBytes.t tzresult Lwt.t @@ -192,3 +192,7 @@ module Assert : sig val invalid_endorsement_slot : msg:string -> 'a tzresult -> unit end + +val rpc_config: Client_rpcs.config + +val display_level: Client_proto_rpcs.block -> unit tzresult Lwt.t diff --git a/test/proto_alpha/test_endorsement.ml b/test/proto_alpha/test_endorsement.ml index 86c61d5ec..dfebc21f1 100644 --- a/test/proto_alpha/test_endorsement.ml +++ b/test/proto_alpha/test_endorsement.ml @@ -9,6 +9,7 @@ open Client_embedded_proto_alpha open Tezos_context +open Client_alpha module Helpers = Proto_alpha_helpers module Assert = Helpers.Assert @@ -77,7 +78,7 @@ let test_invalid_endorsement_slot contract block = return () let test_endorsement_rewards - block ({ Helpers.Account.b1 ; _ } as baccounts) = + block ({ Helpers.Account.b5 = b1 ; _ } as baccounts) = let get_endorser_except_b1 accounts = let account, cpt = ref accounts.(0), ref 0 in while !account = b1 do @@ -95,9 +96,11 @@ let test_endorsement_rewards Helpers.Account.balance account0 >>=? fun balance0 -> Helpers.Endorse.endorse ~slot:slot0 ~force:true account0 block >>=? fun ops -> Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 block >>=? fun head0 -> + Helpers.display_level (`Hash head0) >>=? fun () -> Assert.balance_equal ~msg:__LOC__ account0 (Int64.sub (Tez.to_cents balance0) bond) >>=? fun () -> + (* #2 endorse & inject in a block *) let block0 = `Hash head0 in Helpers.Endorse.endorsers_list block0 baccounts >>=? fun accounts -> @@ -105,9 +108,11 @@ let test_endorsement_rewards Helpers.Account.balance account1 >>=? fun balance1 -> Helpers.Endorse.endorse ~slot:slot1 ~force:true account1 block0 >>=? fun ops -> Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 block0 >>=? fun head1 -> + Helpers.display_level (`Hash head1) >>=? fun () -> Assert.balance_equal ~msg:__LOC__ account1 (Int64.sub (Tez.to_cents balance1) bond) >>=? fun () -> + (* #3 endorse but the operation is not included in a block, so no reward *) let block1 = `Hash head1 in Helpers.Endorse.endorsers_list block1 baccounts >>=? fun accounts -> @@ -118,7 +123,11 @@ let test_endorsement_rewards (Int64.sub (Tez.to_cents balance2) bond) >>=? fun () -> Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head1) >>=? fun head2 -> + Helpers.display_level (`Hash head2) >>=? fun () -> Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head2) >>=? fun head3 -> + Helpers.display_level (`Hash head3) >>=? fun () -> + Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun head4 -> + Helpers.display_level (`Hash head4) >>=? fun () -> (* Check rewards after one cycle for account0 *) Helpers.Mining.endorsement_reward b1 block0 >>=? fun rw0 -> @@ -135,8 +144,10 @@ let test_endorsement_rewards ~msg:__LOC__ account2 (Tez.to_cents balance2) >>=? fun () -> (* #2 endorse and check reward only on the good chain *) - Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun head -> - Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun fork -> + Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head4) >>=? fun head -> + Helpers.display_level (`Hash head) >>=? fun () -> + Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head4) >>=? fun fork -> + Helpers.display_level (`Hash fork) >>=? fun () -> (* working on head *) Helpers.Endorse.endorsers_list (`Hash head) baccounts >>=? fun accounts -> @@ -145,6 +156,7 @@ let test_endorsement_rewards Helpers.Endorse.endorse ~slot:slot3 ~force:true account3 (`Hash head) >>=? fun ops -> Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash head) >>=? fun new_head -> + Helpers.display_level (`Hash new_head) >>=? fun () -> (* working on fork *) Helpers.Endorse.endorsers_list (`Hash fork) baccounts >>=? fun accounts -> @@ -152,10 +164,13 @@ let test_endorsement_rewards Helpers.Account.balance account4 >>=? fun _balance4 -> Helpers.Endorse.endorse ~slot:slot4 ~force:true account4 (`Hash fork) >>=? fun ops -> Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash fork) >>=? fun _new_fork -> + Helpers.display_level (`Hash _new_fork) >>=? fun () -> Helpers.Account.balance account4 >>=? fun balance4 -> Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash new_head) >>=? fun head -> + Helpers.display_level (`Hash head) >>=? fun () -> Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head) >>=? fun head -> + Helpers.display_level (`Hash head) >>=? fun () -> (* Check rewards after one cycle *) Helpers.Mining.endorsement_reward b1 (`Hash new_head) >>=? fun reward -> @@ -209,7 +224,7 @@ let run head (({ b1 ; b2 ; b3 ; b4 ; b5 } : Helpers.Account.bootstrap_accounts) (* FIXME: cannot inject double endorsement operation yet, but the code is still here Double endorsement *) - test_double_endorsement b5 (`Hash head) >>=? fun new_head -> + test_double_endorsement b4 (`Hash head) >>=? fun new_head -> return new_head diff --git a/test/shell/test_state.ml b/test/shell/test_state.ml index 0b4bd3e85..09e80c141 100644 --- a/test/shell/test_state.ml +++ b/test/shell/test_state.ml @@ -69,6 +69,7 @@ let block _state ?(operations = []) pred_hash pred name : Store.Block_header.t = let timestamp = incr_timestamp pred.shell.timestamp in { shell = { net_id = pred.shell.net_id ; + level = Int32.succ pred.shell.level ; predecessor = pred_hash ; timestamp ; operations; fitness } ; proto = MBytes.of_string name ; @@ -139,6 +140,7 @@ let block _state ?(operations = []) (pred: State.Valid_block.t) name let fitness = incr_fitness pred.fitness in let timestamp = incr_timestamp pred.timestamp in { shell = { net_id = pred.net_id ; + level = Int32.succ pred.level ; predecessor = pred.hash ; timestamp ; operations; fitness } ; proto = MBytes.of_string name ; diff --git a/test/shell/test_store.ml b/test/shell/test_store.ml index 9a057e2f2..c18968669 100644 --- a/test/shell/test_store.ml +++ b/test/shell/test_store.ml @@ -94,6 +94,7 @@ let lolblock ?(operations = []) header = [Operation_list_hash.compute operations] in { Store.Block_header.shell = { timestamp = Time.of_seconds (Random.int64 1500L) ; + level = 0l ; (* dummy *) net_id ; predecessor = genesis_block ; operations ; fitness = [MBytes.of_string @@ string_of_int @@ String.length header; From 1b6ecbfc815291920aa2a797f7ce47c5b3d1fe87 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 10 Apr 2017 15:54:34 +0200 Subject: [PATCH 08/10] Shell/RPC: simplify block-watcher signature --- src/node/shell/node.ml | 22 +--------------------- src/node/shell/node.mli | 2 +- 2 files changed, 2 insertions(+), 22 deletions(-) diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 7e2121fde..4cc5779fb 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -166,21 +166,6 @@ module RPC = struct test_network = block.test_network ; } - let convert_block hash ({ shell ; proto }: State.Block_header.t) = { - net = shell.net_id ; - hash = hash ; - level = shell.level ; - predecessor = shell.predecessor ; - fitness = shell.fitness ; - timestamp = shell.timestamp ; - protocol = None ; - operations_hash = shell.operations ; - operations = None ; - data = Some proto ; - test_protocol = None ; - test_network = None ; - } - let inject_block node = node.inject_block let inject_operation node = node.inject_operation let inject_protocol node = node.inject_protocol @@ -534,12 +519,7 @@ module RPC = struct heads >>= fun (_, blocks) -> Lwt.return (List.rev blocks) - let block_watcher node = - let stream, shutdown = Distributed_db.watch_block node.distributed_db in - Lwt_stream.map - (fun (hash, block) -> convert_block hash block) - stream, - shutdown + let block_watcher node = Distributed_db.watch_block node.distributed_db let valid_block_watcher node = let stream, shutdown = Validator.global_watcher node.validator in diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli index edfd4351d..705301a78 100644 --- a/src/node/shell/node.mli +++ b/src/node/shell/node.mli @@ -44,7 +44,7 @@ module RPC : sig val raw_block_info: t -> Block_hash.t -> block_info Lwt.t val block_watcher: - t -> block_info Lwt_stream.t * Watcher.stopper + t -> (Block_hash.t * Store.Block_header.t) Lwt_stream.t * Watcher.stopper val valid_block_watcher: t -> (block_info Lwt_stream.t * Watcher.stopper) val heads: t -> block_info Block_hash.Map.t Lwt.t From 495e887538214a330de422c779c78e4ffb423445 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 10 Apr 2017 17:06:11 +0200 Subject: [PATCH 09/10] RPC: minor improvements in naming consistency --- src/client/client_node_rpcs.ml | 26 +++--- src/client/client_node_rpcs.mli | 20 ++-- .../alpha/baker/client_mining_blocks.ml | 13 +-- .../alpha/baker/client_mining_blocks.mli | 6 +- .../alpha/baker/client_mining_forge.ml | 16 ++-- .../embedded/alpha/client_proto_rpcs.ml | 4 +- .../embedded/alpha/client_proto_rpcs.mli | 2 +- src/client/embedded/demo/client_proto_main.ml | 2 +- .../embedded/genesis/client_proto_main.ml | 3 +- src/node/db/store.ml | 16 ++-- src/node/db/store.mli | 2 +- src/node/shell/distributed_db.ml | 4 +- src/node/shell/node.ml | 39 ++++---- src/node/shell/node_rpc.ml | 19 ++-- src/node/shell/node_rpc_services.ml | 91 ++++++++----------- src/node/shell/node_rpc_services.mli | 17 ++-- src/node/shell/state.ml | 6 +- src/node/shell/state.mli | 2 +- src/node/shell/validator.ml | 2 +- src/node/updater/protocol.mli | 2 +- src/node/updater/updater.ml | 2 +- src/node/updater/updater.mli | 2 +- src/proto/alpha/block_repr.ml | 4 +- src/proto/alpha/services_registration.ml | 4 +- src/proto/environment/updater.mli | 4 +- src/proto/genesis/services.ml | 4 +- test/proto_alpha/proto_alpha_helpers.ml | 11 ++- test/shell/test_state.ml | 8 +- test/shell/test_store.ml | 4 +- 29 files changed, 166 insertions(+), 169 deletions(-) diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 56398606f..d7c6d67d3 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -15,9 +15,9 @@ module Services = Node_rpc_services let errors cctxt = call_service0 cctxt Services.Error.service () -let forge_block cctxt ?net ?level ?predecessor ?timestamp fitness ops header = +let forge_block cctxt ?net_id ?level ?predecessor ?timestamp fitness ops header = call_service0 cctxt Services.forge_block - (net, level, predecessor, timestamp, fitness, ops, header) + (net_id, level, predecessor, timestamp, fitness, ops, header) let validate_block cctxt net block = call_err_service0 cctxt Services.validate_block (net, block) @@ -53,16 +53,16 @@ module Blocks = struct type block_info = Services.Blocks.block_info = { hash: Block_hash.t ; + net_id: Net_id.t ; level: Int32.t ; predecessor: Block_hash.t ; - fitness: MBytes.t list ; timestamp: Time.t ; - protocol: Protocol_hash.t option ; operations_hash: Operation_list_list_hash.t ; + fitness: MBytes.t list ; + data: MBytes.t ; operations: Operation_hash.t list list option ; - data: MBytes.t option ; - net: Net_id.t ; - test_protocol: Protocol_hash.t option ; + protocol: Protocol_hash.t ; + test_protocol: Protocol_hash.t ; test_network: (Net_id.t * Time.t) option ; } type preapply_param = Services.Blocks.preapply_param = { @@ -104,19 +104,19 @@ module Blocks = struct { operations ; sort ; timestamp } let pending_operations cctxt block = call_service1 cctxt Services.Blocks.pending_operations block () - let info cctxt ?(operations = true) ?(data = true) h = - call_service1 cctxt Services.Blocks.info h (operations, data) + let info cctxt ?(include_ops = true) h = + call_service1 cctxt Services.Blocks.info h include_ops let complete cctxt block prefix = call_service2 cctxt Services.Blocks.complete block prefix () - let list cctxt ?(operations = false) ?(data = false) + let list cctxt ?(include_ops = false) ?length ?heads ?delay ?min_date ?min_heads () = call_service0 cctxt Services.Blocks.list - { operations ; data ; length ; heads ; monitor = Some false ; delay ; + { include_ops ; length ; heads ; monitor = Some false ; delay ; min_date ; min_heads } - let monitor cctxt ?(operations = false) ?(data = false) + let monitor cctxt ?(include_ops = false) ?length ?heads ?delay ?min_date ?min_heads () = call_streamed_service0 cctxt Services.Blocks.list - { operations ; data ; length ; heads ; monitor = Some true ; delay ; + { include_ops ; length ; heads ; monitor = Some true ; delay ; min_date ; min_heads } end diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index 709ee3c80..82e9b17cc 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -14,7 +14,7 @@ val errors: val forge_block: config -> - ?net:Net_id.t -> + ?net_id:Net_id.t -> ?level:Int32.t -> ?predecessor:Block_hash.t -> ?timestamp:Time.t -> @@ -94,7 +94,7 @@ module Blocks : sig block -> Protocol_hash.t tzresult Lwt.t val test_protocol: config -> - block -> Protocol_hash.t option tzresult Lwt.t + block -> Protocol_hash.t tzresult Lwt.t val test_network: config -> block -> (Net_id.t * Time.t) option tzresult Lwt.t @@ -106,32 +106,32 @@ module Blocks : sig type block_info = { hash: Block_hash.t ; + net_id: Net_id.t ; level: Int32.t ; predecessor: Block_hash.t ; - fitness: MBytes.t list ; timestamp: Time.t ; - protocol: Protocol_hash.t option ; operations_hash: Operation_list_list_hash.t ; + fitness: MBytes.t list ; + data: MBytes.t ; operations: Operation_hash.t list list option ; - data: MBytes.t option ; - net: Net_id.t ; - test_protocol: Protocol_hash.t option ; + protocol: Protocol_hash.t ; + test_protocol: Protocol_hash.t ; test_network: (Net_id.t * Time.t) option ; } val info: config -> - ?operations:bool -> ?data:bool -> block -> block_info tzresult Lwt.t + ?include_ops:bool -> block -> block_info tzresult Lwt.t val list: config -> - ?operations:bool -> ?data:bool -> ?length:int -> ?heads:Block_hash.t list -> + ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> unit -> block_info list list tzresult Lwt.t val monitor: config -> - ?operations:bool -> ?data:bool -> ?length:int -> ?heads:Block_hash.t list -> + ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t diff --git a/src/client/embedded/alpha/baker/client_mining_blocks.ml b/src/client/embedded/alpha/baker/client_mining_blocks.ml index 48c84f48d..e524b4284 100644 --- a/src/client/embedded/alpha/baker/client_mining_blocks.ml +++ b/src/client/embedded/alpha/baker/client_mining_blocks.ml @@ -12,7 +12,7 @@ type block_info = { predecessor: Block_hash.t ; fitness: MBytes.t list ; timestamp: Time.t ; - protocol: Protocol_hash.t option ; + protocol: Protocol_hash.t ; level: Level.t ; } @@ -21,7 +21,8 @@ let convert_block_info cctxt : Client_node_rpcs.Blocks.block_info ) = Client_proto_rpcs.Context.level cctxt (`Hash hash) >>= function | Ok level -> - Lwt.return (Some { hash ; predecessor ; fitness ; timestamp ; protocol ; level }) + Lwt.return + (Some { hash ; predecessor ; fitness ; timestamp ; protocol ; level }) | Error _ -> (* TODO log error *) Lwt.return_none @@ -32,8 +33,8 @@ let convert_block_info_err cctxt Client_proto_rpcs.Context.level cctxt (`Hash hash) >>=? fun level -> return { hash ; predecessor ; fitness ; timestamp ; protocol ; level } -let info cctxt ?operations block = - Client_node_rpcs.Blocks.info cctxt ?operations block >>=? fun block -> +let info cctxt ?include_ops block = + Client_node_rpcs.Blocks.info cctxt ?include_ops block >>=? fun block -> convert_block_info_err cctxt block let compare (bi1 : block_info) (bi2 : block_info) = @@ -54,10 +55,10 @@ let sort_blocks cctxt ?(compare = compare) blocks = List.sort compare blocks let monitor cctxt - ?operations ?length ?heads ?delay + ?include_ops ?length ?heads ?delay ?min_date ?min_heads ?compare () = Client_node_rpcs.Blocks.monitor cctxt - ?operations ?length ?heads ?delay ?min_date ?min_heads + ?include_ops ?length ?heads ?delay ?min_date ?min_heads () >>=? fun block_stream -> let convert blocks = Lwt.return blocks >>=? fun blocks -> diff --git a/src/client/embedded/alpha/baker/client_mining_blocks.mli b/src/client/embedded/alpha/baker/client_mining_blocks.mli index 1cda9483f..cb1567f2f 100644 --- a/src/client/embedded/alpha/baker/client_mining_blocks.mli +++ b/src/client/embedded/alpha/baker/client_mining_blocks.mli @@ -12,20 +12,20 @@ type block_info = { predecessor: Block_hash.t ; fitness: MBytes.t list ; timestamp: Time.t ; - protocol: Protocol_hash.t option ; + protocol: Protocol_hash.t ; level: Level.t ; } val info: Client_rpcs.config -> - ?operations:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t + ?include_ops:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t val compare: block_info -> block_info -> int val monitor: Client_rpcs.config -> - ?operations:bool -> ?length:int -> ?heads:Block_hash.t list -> + ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list -> ?delay:int -> ?min_date:Time.t -> ?min_heads:int -> ?compare:(block_info -> block_info -> int) -> unit -> block_info list tzresult Lwt_stream.t tzresult Lwt.t diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index a85e683de..30427c09b 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -42,26 +42,26 @@ let rec compute_stamp let inject_block cctxt block ?force ~priority ~timestamp ~fitness ~seed_nonce - ~src_sk operation_list = + ~src_sk operations = let block = match block with `Prevalidation -> `Head 0 | block -> block in Client_node_rpcs.Blocks.info cctxt block >>=? fun bi -> let seed_nonce_hash = Nonce.hash seed_nonce in Client_proto_rpcs.Context.next_level cctxt block >>=? fun level -> - let operations = + let operations_hash = Operation_list_list_hash.compute - (List.map Operation_list_hash.compute operation_list) in + (List.map Operation_list_hash.compute operations) in let shell = - { Store.Block_header.net_id = bi.net ; level = bi.level ; - predecessor = bi.hash ; timestamp ; fitness ; operations } in + { Store.Block_header.net_id = bi.net_id ; level = bi.level ; + predecessor = bi.hash ; timestamp ; fitness ; operations_hash } in compute_stamp cctxt block src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce -> Client_proto_rpcs.Helpers.Forge.block cctxt block - ~net:bi.net + ~net:bi.net_id ~predecessor:bi.hash ~timestamp ~fitness - ~operations + ~operations_hash ~level:level.level ~priority:priority ~seed_nonce_hash @@ -69,7 +69,7 @@ let inject_block cctxt block () >>=? fun unsigned_header -> let signed_header = Ed25519.Signature.append src_sk unsigned_header in Client_node_rpcs.inject_block cctxt - ?force signed_header operation_list >>=? fun block_hash -> + ?force signed_header operations >>=? fun block_hash -> return block_hash let forge_block cctxt block diff --git a/src/client/embedded/alpha/client_proto_rpcs.ml b/src/client/embedded/alpha/client_proto_rpcs.ml index 2cdf0c08f..b7f49553a 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.ml +++ b/src/client/embedded/alpha/client_proto_rpcs.ml @@ -245,10 +245,10 @@ module Helpers = struct operations cctxt block ~net [Faucet { id ; nonce }] end let block cctxt - block ~net ~predecessor ~timestamp ~fitness ~operations + block ~net ~predecessor ~timestamp ~fitness ~operations_hash ~level ~priority ~seed_nonce_hash ~proof_of_work_nonce () = call_error_service1 cctxt Services.Helpers.Forge.block block - (net, predecessor, timestamp, fitness, operations, + (net, predecessor, timestamp, fitness, operations_hash, level, priority, seed_nonce_hash, proof_of_work_nonce) end diff --git a/src/client/embedded/alpha/client_proto_rpcs.mli b/src/client/embedded/alpha/client_proto_rpcs.mli index a81badd80..64ab01a15 100644 --- a/src/client/embedded/alpha/client_proto_rpcs.mli +++ b/src/client/embedded/alpha/client_proto_rpcs.mli @@ -298,7 +298,7 @@ module Helpers : sig predecessor:Block_hash.t -> timestamp:Time.t -> fitness:Fitness.t -> - operations:Operation_list_list_hash.t -> + operations_hash:Operation_list_list_hash.t -> level:Raw_level.t -> priority:int -> seed_nonce_hash:Nonce_hash.t -> diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index 621eff46d..2dc1c5394 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -51,7 +51,7 @@ let mine cctxt = (cctxt.message "Cannot parse fitness: %a" Fitness.pp bi.fitness); exit 2 in Client_node_rpcs.forge_block cctxt.rpc_config - ~net:bi.net ~predecessor:bi.hash + ~net_id:bi.net_id ~predecessor:bi.hash fitness Operation_list_list_hash.empty (MBytes.create 0) >>=? fun bytes -> Client_node_rpcs.inject_block cctxt.rpc_config bytes [] >>=? fun hash -> cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index 5be95a50e..b9897eb87 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -33,7 +33,8 @@ let forge_block let mine rpc_config ?timestamp block command fitness seckey = Client_blocks.get_block_info rpc_config block >>=? fun bi -> - forge_block rpc_config ?timestamp block bi.net command fitness >>=? fun blk -> + forge_block + rpc_config ?timestamp block bi.net_id command fitness >>=? fun blk -> let signed_blk = Environment.Ed25519.Signature.append seckey blk in Client_node_rpcs.inject_block rpc_config signed_blk [[]] diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 65c3b29cf..f0c410234 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -261,7 +261,7 @@ module Block_header = struct level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; - operations: Operation_list_list_hash.t ; + operations_hash: Operation_list_list_hash.t ; fitness: MBytes.t list ; } @@ -269,17 +269,19 @@ module Block_header = struct let open Data_encoding in conv (fun { net_id ; level ; predecessor ; - timestamp ; operations ; fitness } -> - (net_id, level, predecessor, timestamp, operations, fitness)) - (fun (net_id, level, predecessor, timestamp, operations, fitness) -> + timestamp ; operations_hash ; fitness } -> + (net_id, level, predecessor, + timestamp, operations_hash, fitness)) + (fun (net_id, level, predecessor, + timestamp, operations_hash, fitness) -> { net_id ; level ; predecessor ; - timestamp ; operations ; fitness }) + timestamp ; operations_hash ; fitness }) (obj6 (req "net_id" Net_id.encoding) (req "level" int32) (req "predecessor" Block_hash.encoding) (req "timestamp" Time.encoding) - (req "operations" Operation_list_list_hash.encoding) + (req "operations_hash" Operation_list_list_hash.encoding) (req "fitness" Fitness.encoding)) module Encoding = struct @@ -311,7 +313,7 @@ module Block_header = struct Block_hash.compare b1.shell.predecessor b2.shell.predecessor >> fun () -> compare b1.proto b2.proto >> fun () -> Operation_list_list_hash.compare - b1.shell.operations b2.shell.operations >> fun () -> + b1.shell.operations_hash b2.shell.operations_hash >> fun () -> Time.compare b1.shell.timestamp b2.shell.timestamp >> fun () -> list compare b1.shell.fitness b2.shell.fitness diff --git a/src/node/db/store.mli b/src/node/db/store.mli index 395891caa..3e7552ab1 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -174,7 +174,7 @@ module Block_header : sig level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; - operations: Operation_list_list_hash.t ; + operations_hash: Operation_list_list_hash.t ; fitness: MBytes.t list ; } val shell_header_encoding: shell_header Data_encoding.t diff --git a/src/node/shell/distributed_db.ml b/src/node/shell/distributed_db.ml index a4e8720ed..cdc3e6d31 100644 --- a/src/node/shell/distributed_db.ml +++ b/src/node/shell/distributed_db.ml @@ -348,7 +348,7 @@ module P2p_reader = struct | None -> Lwt.return_unit | Some bh -> if Operation_list_list_hash.compare - found_hash bh.shell.operations <> 0 then + found_hash bh.shell.operations_hash <> 0 then Lwt.return_unit else Raw_operation_list.Table.notify @@ -624,7 +624,7 @@ let inject_block t bytes operations = (List.map Operation_list_hash.compute operations) in fail_unless (Operation_list_list_hash.compare - computed_hash block.shell.operations = 0) + computed_hash block.shell.operations_hash = 0) (Exn (Failure "Incoherent operation list")) >>=? fun () -> Raw_block_header.Table.inject net_db.block_header_db.table hash block >>= function diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 4cc5779fb..2620b193a 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -138,31 +138,31 @@ module RPC = struct type block = Node_rpc_services.Blocks.block type block_info = Node_rpc_services.Blocks.block_info = { hash: Block_hash.t ; + net_id: Net_id.t ; level: Int32.t ; predecessor: Block_hash.t ; - fitness: MBytes.t list ; timestamp: Time.t ; - protocol: Protocol_hash.t option ; operations_hash: Operation_list_list_hash.t ; + fitness: MBytes.t list ; + data: MBytes.t ; operations: Operation_hash.t list list option ; - data: MBytes.t option ; - net: Net_id.t ; - test_protocol: Protocol_hash.t option ; + protocol: Protocol_hash.t ; + test_protocol: Protocol_hash.t ; test_network: (Net_id.t * Time.t) option ; } - let convert (block: State.Valid_block.t) = { + let convert (block: State.Valid_block.t) = { hash = block.hash ; + net_id = block.net_id ; level = block.level ; predecessor = block.predecessor ; - fitness = block.fitness ; timestamp = block.timestamp ; - protocol = Some block.protocol_hash ; operations_hash = block.operations_hash ; + fitness = block.fitness ; + data = block.proto_header ; operations = Some block.operations ; - data = Some block.proto_header ; - net = block.net_id ; - test_protocol = Some block.test_protocol_hash ; + protocol = block.protocol_hash ; + test_protocol = block.test_protocol_hash ; test_network = block.test_network ; } @@ -268,6 +268,13 @@ module RPC = struct | Error _ -> Lwt.fail Not_found | Ok { context ; fitness } -> Context.get_protocol context >>= fun protocol -> + Context.get_test_protocol context >>= fun test_protocol -> + Context.get_test_network context >>= fun test_network -> + Context.get_test_network_expiration context >>= fun test_network_expiration -> + let test_network = + match test_network, test_network_expiration with + | Some n, Some t -> Some (n, t) + | _, None | None, _ -> None in let operations = let pv_result, _ = Prevalidator.operations pv in [ pv_result.applied ] in @@ -277,15 +284,15 @@ module RPC = struct predecessor = head.hash ; fitness ; timestamp = Prevalidator.timestamp pv ; - protocol = Some protocol ; + protocol ; operations_hash = Operation_list_list_hash.compute (List.map Operation_list_hash.compute operations) ; operations = Some operations ; - data = None ; - net = head.net_id ; - test_protocol = None ; - test_network = None ; + data = MBytes.of_string "" ; + net_id = head.net_id ; + test_protocol ; + test_network ; } let rpc_context block : Updater.rpc_context = diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 7933d6dba..862107e46 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -12,9 +12,8 @@ open Logging.RPC module Services = Node_rpc_services -let filter_bi (operations, data) (bi: Services.Blocks.block_info) = +let filter_bi operations (bi: Services.Blocks.block_info) = let bi = if operations then bi else { bi with operations = None } in - let bi = if data then bi else { bi with data = None } in bi let register_bi_dir node dir = @@ -34,7 +33,7 @@ let register_bi_dir node dir = let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.net in + RPC.Answer.return bi.net_id in RPC.register1 dir Services.Blocks.net implementation in let dir = @@ -71,9 +70,7 @@ let register_bi_dir node dir = let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> - match bi.protocol with - | None -> raise Not_found - | Some p -> RPC.Answer.return p in + RPC.Answer.return bi.protocol in RPC.register1 dir Services.Blocks.protocol implementation in let dir = @@ -220,11 +217,10 @@ let create_delayed_stream let list_blocks node - { Services.Blocks.operations ; data ; length ; heads ; monitor ; delay ; + { Services.Blocks.include_ops ; length ; heads ; monitor ; delay ; min_date; min_heads} = let len = match length with None -> 1 | Some x -> x in let monitor = match monitor with None -> false | Some x -> x in - let include_ops = (operations, data) in let time = match delay with | None -> None @@ -410,16 +406,17 @@ let build_rpc_directory node = let dir = RPC.register1 dir Services.Protocols.contents (get_protocols node) in let dir = - let implementation (net_id, level, pred, time, fitness, operations, header) = + let implementation + (net_id, level, pred, time, fitness, operations_hash, header) = Node.RPC.block_info node (`Head 0) >>= fun bi -> let timestamp = Utils.unopt ~default:(Time.now ()) time in - let net_id = Utils.unopt ~default:bi.net net_id in + let net_id = Utils.unopt ~default:bi.net_id net_id in let predecessor = Utils.unopt ~default:bi.hash pred in let level = Utils.unopt ~default:(Int32.succ bi.level) level in let res = Data_encoding.Binary.to_bytes Store.Block_header.encoding { shell = { net_id ; predecessor ; level ; - timestamp ; fitness ; operations } ; + timestamp ; fitness ; operations_hash } ; proto = header ; } in RPC.Answer.return res in diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index 806f6058f..30ea27ae1 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -57,48 +57,46 @@ module Blocks = struct type block_info = { hash: Block_hash.t ; + net_id: Net_id.t ; level: Int32.t ; predecessor: Block_hash.t ; - fitness: MBytes.t list ; timestamp: Time.t ; - protocol: Protocol_hash.t option ; operations_hash: Operation_list_list_hash.t ; + fitness: MBytes.t list ; + data: MBytes.t ; operations: Operation_hash.t list list option ; - data: MBytes.t option ; - net: Net_id.t ; - test_protocol: Protocol_hash.t option ; + protocol: Protocol_hash.t ; + test_protocol: Protocol_hash.t ; test_network: (Net_id.t * Time.t) option ; } let block_info_encoding = conv - (fun { hash ; level ; predecessor ; fitness ; timestamp ; protocol ; - operations_hash ; operations ; data ; net ; - test_protocol ; test_network } -> - ((hash, level, predecessor, fitness, timestamp, protocol), - (operations_hash, operations, data, - net, test_protocol, test_network))) - (fun ((hash, level, predecessor, fitness, timestamp, protocol), - (operations_hash, operations, data, - net, test_protocol, test_network)) -> - { hash ; level ; predecessor ; fitness ; timestamp ; protocol ; - operations_hash ; operations ; data ; net ; - test_protocol ; test_network }) - (merge_objs - (obj6 - (req "hash" Block_hash.encoding) - (req "level" int32) - (req "predecessor" Block_hash.encoding) - (req "fitness" Fitness.encoding) - (req "timestamp" Time.encoding) - (opt "protocol" Protocol_hash.encoding)) - (obj6 - (req "operations_hash" Operation_list_list_hash.encoding) - (opt "operations" (list (list Operation_hash.encoding))) - (opt "data" bytes) - (req "net" Net_id.encoding) - (opt "test_protocol" Protocol_hash.encoding) - (opt "test_network" (tup2 Net_id.encoding Time.encoding)))) + (fun { hash ; net_id ; level ; predecessor ; + fitness ; timestamp ; protocol ; operations_hash ; data ; + operations ; test_protocol ; test_network } -> + ({ Store.Block_header.shell = + { net_id ; level ; predecessor ; + timestamp ; operations_hash ; fitness } ; + proto = data }, + (hash, operations, protocol, test_protocol, test_network))) + (fun ({ Store.Block_header.shell = + { net_id ; level ; predecessor ; + timestamp ; operations_hash ; fitness } ; + proto = data }, + (hash, operations, protocol, test_protocol, test_network)) -> + { hash ; net_id ; level ; predecessor ; + fitness ; timestamp ; protocol ; operations_hash ; data ; + operations ; test_protocol ; test_network }) + (dynamic_size + (merge_objs + Store.Block_header.encoding + (obj5 + (req "hash" Block_hash.encoding) + (opt "operations" (list (list Operation_hash.encoding))) + (req "protocol" Protocol_hash.encoding) + (req "test_protocol" Protocol_hash.encoding) + (opt "test_network" (tup2 Net_id.encoding Time.encoding))))) let parse_block s = try @@ -181,10 +179,7 @@ module Blocks = struct let info = RPC.service ~description:"All the information about a block." - ~input: - (obj2 - (dft "operations" bool true) - (dft "data" bool true)) + ~input: (obj1 (dft "operations" bool true)) ~output: block_info_encoding block_path @@ -257,7 +252,7 @@ module Blocks = struct RPC.service ~description:"List the block test protocol." ~input: empty - ~output: (obj1 (opt "protocol" Protocol_hash.encoding)) + ~output: (obj1 (req "protocol" Protocol_hash.encoding)) RPC.Path.(block_path / "test_protocol") let test_network = @@ -329,8 +324,7 @@ module Blocks = struct RPC.Path.(block_path / "complete" /: prefix_arg ) type list_param = { - operations: bool ; - data: bool ; + include_ops: bool ; length: int option ; heads: Block_hash.t list option ; monitor: bool option ; @@ -340,25 +334,20 @@ module Blocks = struct } let list_param_encoding = conv - (fun { operations ; data ; length ; heads ; monitor ; + (fun { include_ops ; length ; heads ; monitor ; delay ; min_date ; min_heads } -> - (operations, data, length, heads, monitor, delay, min_date, min_heads)) - (fun (operations, data, length, heads, monitor, delay, min_date, min_heads) -> - { operations ; data ; length ; heads ; monitor ; + (include_ops, length, heads, monitor, delay, min_date, min_heads)) + (fun (include_ops, length, heads, monitor, + delay, min_date, min_heads) -> + { include_ops ; length ; heads ; monitor ; delay ; min_date ; min_heads }) - (obj8 - (dft "operations" + (obj7 + (dft "include_ops" (Data_encoding.describe ~description: "Whether the resulting block informations should include the \ list of operations' hashes. Default false." bool) false) - (dft "data" - (Data_encoding.describe - ~description: - "Whether the resulting block informations should include the \ - raw protocol dependent data. Default false." - bool) false) (opt "length" (Data_encoding.describe ~description: diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index 99861742d..4daa660f4 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -28,21 +28,21 @@ module Blocks : sig type block_info = { hash: Block_hash.t ; + net_id: Net_id.t ; level: Int32.t ; predecessor: Block_hash.t ; - fitness: MBytes.t list ; timestamp: Time.t ; - protocol: Protocol_hash.t option ; operations_hash: Operation_list_list_hash.t ; + fitness: MBytes.t list ; + data: MBytes.t ; operations: Operation_hash.t list list option ; - data: MBytes.t option ; - net: Net_id.t ; - test_protocol: Protocol_hash.t option ; + protocol: Protocol_hash.t ; + test_protocol: Protocol_hash.t ; test_network: (Net_id.t * Time.t) option ; } val info: - (unit, unit * block, bool * bool, block_info) RPC.service + (unit, unit * block, bool, block_info) RPC.service val net: (unit, unit * block, unit, Net_id.t) RPC.service val level: @@ -62,7 +62,7 @@ module Blocks : sig val protocol: (unit, unit * block, unit, Protocol_hash.t) RPC.service val test_protocol: - (unit, unit * block, unit, Protocol_hash.t option) RPC.service + (unit, unit * block, unit, Protocol_hash.t) RPC.service val test_network: (unit, unit * block, unit, (Net_id.t * Time.t) option) RPC.service val pending_operations: @@ -70,8 +70,7 @@ module Blocks : sig error Prevalidation.preapply_result * Hash.Operation_hash.Set.t) RPC.service type list_param = { - operations: bool ; - data: bool ; + include_ops: bool ; length: int option ; heads: Block_hash.t list option ; monitor: bool option ; diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index de6f3a199..ef6ec6196 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -149,7 +149,7 @@ let build_valid_block predecessor = header.shell.predecessor ; timestamp = header.shell.timestamp ; discovery_time ; - operations_hash = header.shell.operations ; + operations_hash = header.shell.operations_hash ; operations ; fitness = header.shell.fitness ; protocol_hash ; @@ -546,7 +546,7 @@ module Raw_block_header = struct predecessor = genesis.block ; timestamp = genesis.time ; fitness = [] ; - operations = Operation_list_list_hash.empty ; + operations_hash = Operation_list_list_hash.empty ; } in let header = { Store.Block_header.shell ; proto = MBytes.create 0 } in @@ -700,7 +700,7 @@ module Block_header = struct level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; - operations: Operation_list_list_hash.t ; + operations_hash: Operation_list_list_hash.t ; fitness: MBytes.t list ; } diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index 88289eb71..2b7e18d96 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -147,7 +147,7 @@ module Block_header : sig level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; - operations: Operation_list_list_hash.t ; + operations_hash: Operation_list_list_hash.t ; fitness: MBytes.t list ; } diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index e7870a843..95aed3d4e 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -173,7 +173,7 @@ let apply_block net db lwt_log_info "validation of %a: looking for dependencies..." Block_hash.pp_short hash >>= fun () -> Distributed_db.Operation_list.fetch - db (hash, 0) block.shell.operations >>= fun operation_hashes -> + db (hash, 0) block.shell.operations_hash >>= fun operation_hashes -> Lwt_list.map_p (fun op -> Distributed_db.Operation.fetch db op) operation_hashes >>= fun operations -> diff --git a/src/node/updater/protocol.mli b/src/node/updater/protocol.mli index 829bfced7..7ead89112 100644 --- a/src/node/updater/protocol.mli +++ b/src/node/updater/protocol.mli @@ -27,7 +27,7 @@ type shell_block = Store.Block_header.shell_header = level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; - operations: Operation_list_list_hash.t ; + operations_hash: Operation_list_list_hash.t ; fitness: MBytes.t list ; } diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index e47a07f53..a042ef063 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -48,7 +48,7 @@ type shell_block = Store.Block_header.shell_header = { level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; - operations: Operation_list_list_hash.t ; + operations_hash: Operation_list_list_hash.t ; fitness: MBytes.t list ; } let shell_block_encoding = Store.Block_header.shell_header_encoding diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index eab745b70..38b0b2728 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -23,7 +23,7 @@ type shell_block = Store.Block_header.shell_header = { level: Int32.t ; predecessor: Block_hash.t ; timestamp: Time.t ; - operations: Operation_list_list_hash.t ; + operations_hash: Operation_list_list_hash.t ; fitness: MBytes.t list ; } val shell_block_encoding: shell_block Data_encoding.t diff --git a/src/proto/alpha/block_repr.ml b/src/proto/alpha/block_repr.ml index 28f5708a1..22fda8587 100644 --- a/src/proto/alpha/block_repr.ml +++ b/src/proto/alpha/block_repr.ml @@ -63,14 +63,14 @@ type error += let parse_header ({ shell = { net_id ; level ; predecessor ; - timestamp ; fitness ; operations } ; + timestamp ; fitness ; operations_hash } ; proto } : Updater.raw_block) : header tzresult = match Data_encoding.Binary.of_bytes signed_proto_header_encoding proto with | None -> Error [Cant_parse_proto_header] | Some (proto, signature) -> let shell = { Updater.net_id ; level ; predecessor ; - timestamp ; fitness ; operations } in + timestamp ; fitness ; operations_hash } in Ok { shell ; proto ; signature } let forge_header shell proto = diff --git a/src/proto/alpha/services_registration.ml b/src/proto/alpha/services_registration.ml index 3d35bb845..b4bb98ef4 100644 --- a/src/proto/alpha/services_registration.ml +++ b/src/proto/alpha/services_registration.ml @@ -434,12 +434,12 @@ let forge_operations _ctxt (shell, proto) = let () = register1 Services.Helpers.Forge.operations forge_operations let forge_block _ctxt - (net_id, predecessor, timestamp, fitness, operations, + (net_id, predecessor, timestamp, fitness, operations_hash, level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t = let level = Raw_level.to_int32 level in return (Block.forge_header { net_id ; level ; predecessor ; - timestamp ; fitness ; operations } + timestamp ; fitness ; operations_hash } { priority ; seed_nonce_hash ; proof_of_work_nonce }) let () = register1 Services.Helpers.Forge.block forge_block diff --git a/src/proto/environment/updater.mli b/src/proto/environment/updater.mli index 6eb799f0b..8808ca0b1 100644 --- a/src/proto/environment/updater.mli +++ b/src/proto/environment/updater.mli @@ -25,8 +25,8 @@ type shell_block = { (** The preceding block in the chain. *) timestamp: Time.t ; (** The date at which this block has been forged. *) - operations: Operation_list_list_hash.t ; - (** The sequence of operations. *) + operations_hash: Operation_list_list_hash.t ; + (** The hash lf the merkle tree of operations. *) fitness: MBytes.t list ; (** The announced score of the block. As a sequence of sequences of unsigned bytes. Ordered by length and then by contents diff --git a/src/proto/genesis/services.ml b/src/proto/genesis/services.ml index 9983df0a3..36ffd1a53 100644 --- a/src/proto/genesis/services.ml +++ b/src/proto/genesis/services.ml @@ -54,7 +54,7 @@ let int64_to_bytes i = MBytes.set_int64 b 0 i; b -let operations = +let operations_hash = Operation_list_list_hash.compute [Operation_list_hash.empty] let rpc_services : Updater.rpc_context RPC.directory = @@ -65,7 +65,7 @@ let rpc_services : Updater.rpc_context RPC.directory = (Forge.block RPC.Path.root) (fun _ctxt ((net_id, level, predecessor, timestamp, fitness), command) -> let shell = { Updater.net_id ; level ; predecessor ; - timestamp ; fitness ; operations } in + timestamp ; fitness ; operations_hash } in let bytes = Data.Command.forge shell command in RPC.Answer.return bytes) in dir diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index 17575784c..592c3fd45 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -393,21 +393,22 @@ module Mining = struct Client_node_rpcs.Blocks.info rpc_config block >>=? fun bi -> let seed_nonce_hash = Nonce.hash seed_nonce in Client_proto_rpcs.Context.next_level rpc_config block >>=? fun level -> - let operations = + let operations_hash = Operation_list_list_hash.compute [Operation_list_hash.compute operation_list] in let shell = - { Store.Block_header.net_id = bi.net ; predecessor = bi.hash ; - timestamp ; fitness ; operations ; level = Raw_level.to_int32 level.level } in + { Store.Block_header.net_id = bi.net_id ; predecessor = bi.hash ; + timestamp ; fitness ; operations_hash ; + level = Raw_level.to_int32 level.level } in mine_stamp block src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce -> Client_proto_rpcs.Helpers.Forge.block rpc_config block - ~net:bi.net + ~net:bi.net_id ~predecessor:bi.hash ~timestamp ~fitness - ~operations + ~operations_hash ~level:level.level ~priority ~seed_nonce_hash diff --git a/test/shell/test_state.ml b/test/shell/test_state.ml index 09e80c141..b26911f8c 100644 --- a/test/shell/test_state.ml +++ b/test/shell/test_state.ml @@ -62,7 +62,7 @@ let operation op = Data_encoding.Binary.to_bytes Store.Operation.encoding op let block _state ?(operations = []) pred_hash pred name : Store.Block_header.t = - let operations = + let operations_hash = Operation_list_list_hash.compute [Operation_list_hash.compute operations] in let fitness = incr_fitness pred.Store.Block_header.shell.fitness in @@ -71,7 +71,7 @@ let block _state ?(operations = []) pred_hash pred name : Store.Block_header.t = net_id = pred.shell.net_id ; level = Int32.succ pred.shell.level ; predecessor = pred_hash ; - timestamp ; operations; fitness } ; + timestamp ; operations_hash ; fitness } ; proto = MBytes.of_string name ; } @@ -134,7 +134,7 @@ let build_chain state tbl otbl pred names = let block _state ?(operations = []) (pred: State.Valid_block.t) name : State.Block_header.t = - let operations = + let operations_hash = Operation_list_list_hash.compute [Operation_list_hash.compute operations] in let fitness = incr_fitness pred.fitness in @@ -142,7 +142,7 @@ let block _state ?(operations = []) (pred: State.Valid_block.t) name { shell = { net_id = pred.net_id ; level = Int32.succ pred.level ; predecessor = pred.hash ; - timestamp ; operations; fitness } ; + timestamp ; operations_hash ; fitness } ; proto = MBytes.of_string name ; } diff --git a/test/shell/test_store.ml b/test/shell/test_store.ml index c18968669..a5574be0c 100644 --- a/test/shell/test_store.ml +++ b/test/shell/test_store.ml @@ -89,14 +89,14 @@ let test_operation s = (** Block store *) let lolblock ?(operations = []) header = - let operations = + let operations_hash = Operation_list_list_hash.compute [Operation_list_hash.compute operations] in { Store.Block_header.shell = { timestamp = Time.of_seconds (Random.int64 1500L) ; level = 0l ; (* dummy *) net_id ; - predecessor = genesis_block ; operations ; + predecessor = genesis_block ; operations_hash ; fitness = [MBytes.of_string @@ string_of_int @@ String.length header; MBytes.of_string @@ string_of_int @@ 12] } ; proto = MBytes.of_string header ; From 2b0df39115148c3edf096c1ac7469b76cb6fb287 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 10 Apr 2017 21:14:17 +0200 Subject: [PATCH 10/10] Context: simplify the storage of 'test_network'. This prepares the context to the inclusion the hash of the context in the block header. By "looking" into the resulting context of a block, we are now know able to determine whether: - no testnet is currently associated to the branch; - a testnet must be forked after the block; - a previously forked testnet is running. --- src/client/client_node_rpcs.ml | 5 +- src/client/client_node_rpcs.mli | 8 +- .../embedded/genesis/client_proto_main.ml | 3 +- src/node/db/context.ml | 166 +++++++++++------- src/node/db/context.mli | 37 ++-- src/node/db/store.ml | 10 +- src/node/db/store.mli | 6 +- src/node/main/node_run_command.ml | 4 +- src/node/shell/node.ml | 28 +-- src/node/shell/node.mli | 2 +- src/node/shell/node_rpc.ml | 6 - src/node/shell/node_rpc_services.ml | 28 ++- src/node/shell/node_rpc_services.mli | 7 +- src/node/shell/prevalidation.ml | 3 + src/node/shell/state.ml | 116 ++++-------- src/node/shell/state.mli | 25 ++- src/node/shell/validator.ml | 140 +++++++++------ src/node/shell/validator.mli | 2 +- src/node/updater/environment.ml | 6 +- src/node/updater/updater.ml | 1 - src/node/updater/updater.mli | 4 +- src/proto/alpha/amendment.ml | 5 +- src/proto/alpha/apply.ml | 5 +- src/proto/alpha/storage.ml | 8 +- src/proto/alpha/storage.mli | 3 +- src/proto/alpha/tezos_context.ml | 1 - src/proto/alpha/tezos_context.mli | 3 +- src/proto/environment/updater.mli | 9 +- src/proto/genesis/data.ml | 16 +- src/proto/genesis/main.ml | 18 +- test/shell/test_context.ml | 3 +- 31 files changed, 340 insertions(+), 338 deletions(-) diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index d7c6d67d3..479a8000c 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -62,8 +62,7 @@ module Blocks = struct data: MBytes.t ; operations: Operation_hash.t list list option ; protocol: Protocol_hash.t ; - test_protocol: Protocol_hash.t ; - test_network: (Net_id.t * Time.t) option ; + test_network: Context.test_network; } type preapply_param = Services.Blocks.preapply_param = { operations: Operation_hash.t list ; @@ -93,8 +92,6 @@ module Blocks = struct call_service1 cctxt Services.Blocks.operations h () let protocol cctxt h = call_service1 cctxt Services.Blocks.protocol h () - let test_protocol cctxt h = - call_service1 cctxt Services.Blocks.test_protocol h () let test_network cctxt h = call_service1 cctxt Services.Blocks.test_network h () diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index 82e9b17cc..3ca3f3ae3 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -92,12 +92,9 @@ module Blocks : sig val protocol: config -> block -> Protocol_hash.t tzresult Lwt.t - val test_protocol: - config -> - block -> Protocol_hash.t tzresult Lwt.t val test_network: config -> - block -> (Net_id.t * Time.t) option tzresult Lwt.t + block -> Context.test_network tzresult Lwt.t val pending_operations: config -> @@ -115,8 +112,7 @@ module Blocks : sig data: MBytes.t ; operations: Operation_hash.t list list option ; protocol: Protocol_hash.t ; - test_protocol: Protocol_hash.t ; - test_network: (Net_id.t * Time.t) option ; + test_network: Context.test_network; } val info: diff --git a/src/client/embedded/genesis/client_proto_main.ml b/src/client/embedded/genesis/client_proto_main.ml index b9897eb87..3ecd0a140 100644 --- a/src/client/embedded/genesis/client_proto_main.ml +++ b/src/client/embedded/genesis/client_proto_main.ml @@ -88,7 +88,8 @@ let commands () = let fitness = Client_embedded_proto_alpha.Fitness_repr.from_int64 fitness in mine cctxt.rpc_config ?timestamp cctxt.config.block - (Activate_testnet hash) fitness seckey >>=? fun hash -> + (Activate_testnet (hash, Int64.mul 24L 3600L)) + fitness seckey >>=? fun hash -> cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () -> return () end ; diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 5301d1194..8605991c1 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -84,10 +84,7 @@ type t = context (*-- Version Access and Update -----------------------------------------------*) let current_protocol_key = ["protocol"] -let current_test_protocol_key = ["test_protocol"] let current_test_network_key = ["test_network"] -let current_test_network_expiration_key = ["test_network_expiration"] -let current_fork_test_network_key = ["fork_test_network"] let exists { repo } key = GitStore.of_branch_id @@ -204,6 +201,77 @@ let remove_rec ctxt key = GitStore.FunView.remove_rec ctxt.view (data_key key) >>= fun view -> Lwt.return { ctxt with view } +(*-- Predefined Fields -------------------------------------------------------*) + +let get_protocol v = + raw_get v current_protocol_key >>= function + | None -> assert false + | Some data -> Lwt.return (Protocol_hash.of_bytes_exn data) +let set_protocol v key = + raw_set v current_protocol_key (Protocol_hash.to_bytes key) + +type test_network = + | Not_running + | Forking of { + protocol: Protocol_hash.t ; + expiration: Time.t ; + } + | Running of { + net_id: Net_id.t ; + genesis: Block_hash.t ; + protocol: Protocol_hash.t ; + expiration: Time.t ; + } + +let test_network_encoding = + let open Data_encoding in + union [ + case ~tag:0 + (obj1 (req "status" (constant "not_running"))) + (function Not_running -> Some () | _ -> None) + (fun () -> Not_running) ; + case ~tag:1 + (obj3 + (req "status" (constant "forking")) + (req "protocol" Protocol_hash.encoding) + (req "expiration" Time.encoding)) + (function + | Forking { protocol ; expiration } -> + Some ((), protocol, expiration) + | _ -> None) + (fun ((), protocol, expiration) -> + Forking { protocol ; expiration }) ; + case ~tag:2 + (obj5 + (req "status" (constant "running")) + (req "net_id" Net_id.encoding) + (req "genesis" Block_hash.encoding) + (req "protocol" Protocol_hash.encoding) + (req "expiration" Time.encoding)) + (function + | Running { net_id ; genesis ; protocol ; expiration } -> + Some ((), net_id, genesis, protocol, expiration) + | _ -> None) + (fun ((), net_id, genesis, protocol, expiration) -> + Running { net_id ; genesis ;protocol ; expiration }) ; + ] + +let get_test_network v = + raw_get v current_test_network_key >>= function + | None -> Lwt.fail (Failure "Unexpected error (Context.get_test_network)") + | Some data -> + match Data_encoding.Binary.of_bytes test_network_encoding data with + | None -> Lwt.fail (Failure "Unexpected error (Context.get_test_network)") + | Some r -> Lwt.return r + +let set_test_network v id = + raw_set v current_test_network_key + (Data_encoding.Binary.to_bytes test_network_encoding id) +let del_test_network v = raw_del v current_test_network_key + +let fork_test_network v ~protocol ~expiration = + set_test_network v (Forking { protocol ; expiration }) + (*-- Initialisation ----------------------------------------------------------*) let init ?patch_context ~root = @@ -220,7 +288,7 @@ let init ?patch_context ~root = | Some patch_context -> patch_context } -let commit_genesis index ~id:block ~time ~protocol ~test_protocol = +let commit_genesis index ~id:block ~time ~protocol = let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in GitStore.of_branch_id task (Block_hash.to_b58check block) @@ -228,74 +296,40 @@ let commit_genesis index ~id:block ~time ~protocol ~test_protocol = let store = t "Genesis" in GitStore.FunView.of_path store [] >>= fun view -> let view = (view, index.repack_scheduler) in - GitStore.FunView.set view current_protocol_key - (Protocol_hash.to_bytes protocol) >>= fun view -> - GitStore.FunView.set view current_test_protocol_key - (Protocol_hash.to_bytes test_protocol) >>= fun view -> let ctxt = { index ; store ; view } in + set_protocol ctxt protocol >>= fun ctxt -> + set_test_network ctxt Not_running >>= fun ctxt -> index.patch_context ctxt >>= fun ctxt -> GitStore.FunView.update_path ctxt.store [] ctxt.view >>= fun () -> Lwt.return ctxt -(*-- Predefined Fields -------------------------------------------------------*) +let compute_testnet_genesis forked_block = + let genesis = Block_hash.hash_bytes [Block_hash.to_bytes forked_block] in + let net_id = Net_id.of_block_hash genesis in + net_id, genesis -let get_protocol v = - raw_get v current_protocol_key >>= function - | None -> assert false - | Some data -> Lwt.return (Protocol_hash.of_bytes_exn data) -let set_protocol v key = - raw_set v current_protocol_key (Protocol_hash.to_bytes key) - -let get_test_protocol v = - raw_get v current_test_protocol_key >>= function - | None -> assert false - | Some data -> Lwt.return (Protocol_hash.of_bytes_exn data) -let set_test_protocol v data = - raw_set v current_test_protocol_key (Protocol_hash.to_bytes data) - -let get_test_network v = - raw_get v current_test_network_key >>= function - | None -> Lwt.return_none - | Some data -> Lwt.return (Some (Net_id.of_bytes_exn data)) -let set_test_network v id = - raw_set v current_test_network_key (Net_id.to_bytes id) -let del_test_network v = raw_del v current_test_network_key - -let get_test_network_expiration v = - raw_get v current_test_network_expiration_key >>= function - | None -> Lwt.return_none - | Some data -> Lwt.return (Time.of_notation @@ MBytes.to_string data) -let set_test_network_expiration v data = - raw_set v current_test_network_expiration_key - (MBytes.of_string @@ Time.to_notation data) -let del_test_network_expiration v = - raw_del v current_test_network_expiration_key - -let read_and_reset_fork_test_network v = - raw_get v current_fork_test_network_key >>= function - | None -> Lwt.return (false, v) - | Some _ -> - raw_del v current_fork_test_network_key >>= fun v -> - Lwt.return (true, v) - -let fork_test_network v = - raw_set v current_fork_test_network_key (MBytes.of_string "fork") - -let init_test_network v ~time ~genesis = - get_test_protocol v >>= fun test_protocol -> - del_test_network_expiration v >>= fun v -> - set_protocol v test_protocol >>= fun v -> - let task = - Irmin.Task.create - ~date:(Time.to_seconds time) - ~owner:"tezos" in - GitStore.clone task v.store (Block_hash.to_b58check genesis) >>= function - | `Empty_head -> Lwt.return (Error [Exn (Empty_head genesis)]) - | `Duplicated_branch -> Lwt.return (Error [Exn (Preexistent_context genesis)]) +let commit_test_network_genesis forked_block time ctxt = + let net_id, genesis = compute_testnet_genesis forked_block in + let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in + GitStore.clone task ctxt.store (Block_hash.to_b58check genesis) >>= function + | `Empty_head -> fail (Exn (Empty_head genesis)) + | `Duplicated_branch -> fail (Exn (Preexistent_context genesis)) | `Ok store -> let msg = - Format.asprintf "Fake block. Forking testnet: %a." - Block_hash.pp_short genesis in - GitStore.FunView.update_path (store msg) [] v.view >>= fun () -> - return v + Format.asprintf "Forking testnet: %a." Net_id.pp_short net_id in + GitStore.FunView.update_path (store msg) [] ctxt.view >>= fun () -> + return (net_id, genesis) +let reset_test_network ctxt forked_block timestamp = + get_test_network ctxt >>= function + | Not_running -> Lwt.return ctxt + | Running { expiration } -> + if Time.(expiration <= timestamp) then + set_test_network ctxt Not_running + else + Lwt.return ctxt + | Forking { protocol ; expiration } -> + let net_id, genesis = compute_testnet_genesis forked_block in + set_test_network ctxt + (Running { net_id ; genesis ; + protocol ; expiration }) diff --git a/src/node/db/context.mli b/src/node/db/context.mli index fb81a6477..9d94f9c69 100644 --- a/src/node/db/context.mli +++ b/src/node/db/context.mli @@ -27,9 +27,12 @@ val commit_genesis: id:Block_hash.t -> time:Time.t -> protocol:Protocol_hash.t -> - test_protocol:Protocol_hash.t -> context Lwt.t +val commit_test_network_genesis: + Block_hash.t -> Time.t -> context -> + (Net_id.t * Block_hash.t) tzresult Lwt.t + (** {2 Generic interface} ****************************************************) include Persist.STORE with type t := context @@ -51,20 +54,26 @@ val commit: val get_protocol: context -> Protocol_hash.t Lwt.t val set_protocol: context -> Protocol_hash.t -> context Lwt.t -val get_test_protocol: context -> Protocol_hash.t Lwt.t -val set_test_protocol: context -> Protocol_hash.t -> context Lwt.t +type test_network = + | Not_running + | Forking of { + protocol: Protocol_hash.t ; + expiration: Time.t ; + } + | Running of { + net_id: Net_id.t ; + genesis: Block_hash.t ; + protocol: Protocol_hash.t ; + expiration: Time.t ; + } -val get_test_network: context -> Net_id.t option Lwt.t -val set_test_network: context -> Net_id.t -> context Lwt.t +val test_network_encoding: test_network Data_encoding.t + +val get_test_network: context -> test_network Lwt.t +val set_test_network: context -> test_network -> context Lwt.t val del_test_network: context -> context Lwt.t -val get_test_network_expiration: context -> Time.t option Lwt.t -val set_test_network_expiration: context -> Time.t -> context Lwt.t -val del_test_network_expiration: context -> context Lwt.t +val reset_test_network: context -> Block_hash.t -> Time.t -> context Lwt.t -(* FIXME split in two (reset after commit *) -val read_and_reset_fork_test_network: context -> (bool * context) Lwt.t -val fork_test_network: context -> context Lwt.t - -val init_test_network: - context -> time:Time.t -> genesis:Block_hash.t -> context tzresult Lwt.t +val fork_test_network: + context -> protocol:Protocol_hash.t -> expiration:Time.t -> context Lwt.t diff --git a/src/node/db/store.ml b/src/node/db/store.ml index f0c410234..be1e8cb41 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -61,14 +61,8 @@ module Net = struct (struct let name = ["expiration"] end) (Store_helpers.Make_value(Time)) - module Forked_network_ttl = - Store_helpers.Make_single_store - (Indexed_store.Store) - (struct let name = ["forked_network_ttl"] end) - (Store_helpers.Make_value(struct - type t = Int64.t - let encoding = Data_encoding.int64 - end)) + module Allow_forked_network = + Indexed_store.Make_set (struct let name = ["allow_forked_network"] end) end diff --git a/src/node/db/store.mli b/src/node/db/store.mli index 3e7552ab1..ff8431baa 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -46,9 +46,9 @@ module Net : sig with type t := store and type value := Time.t - module Forked_network_ttl : SINGLE_STORE - with type t := store - and type value := Int64.t + module Allow_forked_network : SET_STORE + with type t := t + and type elt := Net_id.t end diff --git a/src/node/main/node_run_command.ml b/src/node/main/node_run_command.ml index e29484469..c4202a686 100644 --- a/src/node/main/node_run_command.ml +++ b/src/node/main/node_run_command.ml @@ -27,8 +27,6 @@ let context_dir data_dir = data_dir // "context" let protocol_dir data_dir = data_dir // "protocol" let lock_file data_dir = data_dir // "lock" -let test_protocol = None - let init_logger ?verbosity (log_config : Node_config_file.log) = let open Logging in begin @@ -116,11 +114,11 @@ let init_node ?sandbox (config : Node_config_file.t) = end >>=? fun p2p_config -> let node_config : Node.config = { genesis ; - test_protocol ; patch_context ; store_root = store_dir config.data_dir ; context_root = context_dir config.data_dir ; p2p = p2p_config ; + test_network_max_tll = Some (48 * 3600) ; (* 2 days *) } in Node.create node_config diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 2620b193a..876cd23fe 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -87,29 +87,28 @@ type config = { genesis: State.Net.genesis ; store_root: string ; context_root: string ; - test_protocol: Protocol_hash.t option ; patch_context: (Context.t -> Context.t Lwt.t) option ; p2p: (P2p.config * P2p.limits) option ; + test_network_max_tll: int option ; } -let may_create_net state ?test_protocol genesis = +let may_create_net state genesis = State.Net.get state (Net_id.of_block_hash genesis.State.Net.block) >>= function | Ok net -> Lwt.return net | Error _ -> - State.Net.create state - ?test_protocol - ~forked_network_ttl:(48 * 3600) (* 2 days *) - genesis + State.Net.create state genesis let create { genesis ; store_root ; context_root ; - test_protocol ; patch_context ; p2p = net_params } = + patch_context ; p2p = net_params ; + test_network_max_tll = max_ttl } = init_p2p net_params >>= fun p2p -> State.read ~store_root ~context_root ?patch_context () >>=? fun state -> let distributed_db = Distributed_db.create state p2p in - let validator = Validator.create_worker state distributed_db in - may_create_net state ?test_protocol genesis >>= fun mainnet_net -> + let validator = + Validator.create_worker ?max_ttl state distributed_db in + may_create_net state genesis >>= fun mainnet_net -> Validator.activate validator mainnet_net >>= fun mainnet_validator -> let mainnet_db = Validator.net_db mainnet_validator in let shutdown () = @@ -147,8 +146,7 @@ module RPC = struct data: MBytes.t ; operations: Operation_hash.t list list option ; protocol: Protocol_hash.t ; - test_protocol: Protocol_hash.t ; - test_network: (Net_id.t * Time.t) option ; + test_network: Context.test_network; } let convert (block: State.Valid_block.t) = { @@ -162,7 +160,6 @@ module RPC = struct data = block.proto_header ; operations = Some block.operations ; protocol = block.protocol_hash ; - test_protocol = block.test_protocol_hash ; test_network = block.test_network ; } @@ -268,13 +265,7 @@ module RPC = struct | Error _ -> Lwt.fail Not_found | Ok { context ; fitness } -> Context.get_protocol context >>= fun protocol -> - Context.get_test_protocol context >>= fun test_protocol -> Context.get_test_network context >>= fun test_network -> - Context.get_test_network_expiration context >>= fun test_network_expiration -> - let test_network = - match test_network, test_network_expiration with - | Some n, Some t -> Some (n, t) - | _, None | None, _ -> None in let operations = let pv_result, _ = Prevalidator.operations pv in [ pv_result.applied ] in @@ -291,7 +282,6 @@ module RPC = struct operations = Some operations ; data = MBytes.of_string "" ; net_id = head.net_id ; - test_protocol ; test_network ; } diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli index 705301a78..f4ddbe605 100644 --- a/src/node/shell/node.mli +++ b/src/node/shell/node.mli @@ -13,9 +13,9 @@ type config = { genesis: State.Net.genesis ; store_root: string ; context_root: string ; - test_protocol: Protocol_hash.t option ; patch_context: (Context.t -> Context.t Lwt.t) option ; p2p: (P2p.config * P2p.limits) option ; + test_network_max_tll: int option ; } val create: config -> t tzresult Lwt.t diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 862107e46..309f2d966 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -73,12 +73,6 @@ let register_bi_dir node dir = RPC.Answer.return bi.protocol in RPC.register1 dir Services.Blocks.protocol implementation in - let dir = - let implementation b () = - Node.RPC.block_info node b >>= fun bi -> - RPC.Answer.return bi.test_protocol in - RPC.register1 dir - Services.Blocks.test_protocol implementation in let dir = let implementation b () = Node.RPC.block_info node b >>= fun bi -> diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index 30ea27ae1..5ac00f63f 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -66,37 +66,36 @@ module Blocks = struct data: MBytes.t ; operations: Operation_hash.t list list option ; protocol: Protocol_hash.t ; - test_protocol: Protocol_hash.t ; - test_network: (Net_id.t * Time.t) option ; + test_network: Context.test_network; } let block_info_encoding = conv (fun { hash ; net_id ; level ; predecessor ; fitness ; timestamp ; protocol ; operations_hash ; data ; - operations ; test_protocol ; test_network } -> + operations ; test_network } -> ({ Store.Block_header.shell = { net_id ; level ; predecessor ; timestamp ; operations_hash ; fitness } ; proto = data }, - (hash, operations, protocol, test_protocol, test_network))) + (hash, operations, protocol, test_network))) (fun ({ Store.Block_header.shell = { net_id ; level ; predecessor ; timestamp ; operations_hash ; fitness } ; proto = data }, - (hash, operations, protocol, test_protocol, test_network)) -> + (hash, operations, protocol, test_network)) -> { hash ; net_id ; level ; predecessor ; fitness ; timestamp ; protocol ; operations_hash ; data ; - operations ; test_protocol ; test_network }) + operations ; test_network }) (dynamic_size (merge_objs Store.Block_header.encoding - (obj5 + (obj4 (req "hash" Block_hash.encoding) (opt "operations" (list (list Operation_hash.encoding))) (req "protocol" Protocol_hash.encoding) - (req "test_protocol" Protocol_hash.encoding) - (opt "test_network" (tup2 Net_id.encoding Time.encoding))))) + (dft "test_network" + Context.test_network_encoding Context.Not_running)))) let parse_block s = try @@ -248,18 +247,11 @@ module Blocks = struct ~output: (obj1 (req "protocol" Protocol_hash.encoding)) RPC.Path.(block_path / "protocol") - let test_protocol = - RPC.service - ~description:"List the block test protocol." - ~input: empty - ~output: (obj1 (req "protocol" Protocol_hash.encoding)) - RPC.Path.(block_path / "test_protocol") - let test_network = RPC.service - ~description:"Returns the associated test network." + ~description:"Returns the status of the associated test network." ~input: empty - ~output: (obj1 (opt "net" (tup2 Net_id.encoding Time.encoding))) + ~output: Context.test_network_encoding RPC.Path.(block_path / "test_network") let pending_operations = diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index 4daa660f4..010a16297 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -37,8 +37,7 @@ module Blocks : sig data: MBytes.t ; operations: Operation_hash.t list list option ; protocol: Protocol_hash.t ; - test_protocol: Protocol_hash.t ; - test_network: (Net_id.t * Time.t) option ; + test_network: Context.test_network; } val info: @@ -61,10 +60,8 @@ module Blocks : sig (unit, unit * block, unit, Operation_hash.t list list) RPC.service val protocol: (unit, unit * block, unit, Protocol_hash.t) RPC.service - val test_protocol: - (unit, unit * block, unit, Protocol_hash.t) RPC.service val test_network: - (unit, unit * block, unit, (Net_id.t * Time.t) option) RPC.service + (unit, unit * block, unit, Context.test_network) RPC.service val pending_operations: (unit, unit * block, unit, error Prevalidation.preapply_result * Hash.Operation_hash.Set.t) RPC.service diff --git a/src/node/shell/prevalidation.ml b/src/node/shell/prevalidation.ml index 1755aa55c..c033b5eed 100644 --- a/src/node/shell/prevalidation.ml +++ b/src/node/shell/prevalidation.ml @@ -143,6 +143,9 @@ let start_prevalidation match protocol with | None -> assert false (* FIXME, this should not happen! *) | Some protocol -> protocol in + Context.reset_test_network + predecessor_context predecessor + timestamp >>= fun predecessor_context -> Proto.begin_construction ~predecessor_context ~predecessor_timestamp diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index ef6ec6196..9ee199372 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -89,7 +89,7 @@ and net = { state: net_state Shared.t ; genesis: genesis ; expiration: Time.t option ; - forked_network_ttl: Int64.t option ; + allow_forked_network: bool ; operation_store: Store.Operation.store Shared.t ; block_header_store: Store.Block_header.store Shared.t ; valid_block_watcher: valid_block Watcher.input ; @@ -119,9 +119,7 @@ and valid_block = { discovery_time: Time.t ; protocol_hash: Protocol_hash.t ; protocol: (module Updater.REGISTRED_PROTOCOL) option ; - test_protocol_hash: Protocol_hash.t ; - test_protocol: (module Updater.REGISTRED_PROTOCOL) option ; - test_network: (Net_id.t * Time.t) option ; + test_network: Context.test_network ; context: Context.t ; successors: Block_hash.Set.t ; invalid_successors: Block_hash.Set.t ; @@ -132,16 +130,8 @@ let build_valid_block hash header operations context discovery_time successors invalid_successors = Context.get_protocol context >>= fun protocol_hash -> - Context.get_test_protocol context >>= fun test_protocol_hash -> Context.get_test_network context >>= fun test_network -> - Context.get_test_network_expiration - context >>= fun test_network_expiration -> - let test_network = - match test_network, test_network_expiration with - | None, _ | _, None -> None - | Some net_id, Some time -> Some (net_id, time) in let protocol = Updater.get protocol_hash in - let test_protocol = Updater.get test_protocol_hash in let valid_block = { net_id = header.Store.Block_header.shell.net_id ; hash ; @@ -154,8 +144,6 @@ let build_valid_block fitness = header.shell.fitness ; protocol_hash ; protocol ; - test_protocol_hash ; - test_protocol ; test_network ; context ; successors ; @@ -857,7 +845,7 @@ module Raw_net = struct ~genesis ~genesis_block ~expiration - ~forked_network_ttl + ~allow_forked_network context_index chain_store block_header_store @@ -872,18 +860,16 @@ module Raw_net = struct state = Shared.create net_state ; genesis ; expiration ; + allow_forked_network ; operation_store = Shared.create operation_store ; - forked_network_ttl ; block_header_store = Shared.create block_header_store ; valid_block_watcher = Watcher.create_input (); } in net let locked_create - data - ?initial_context ?forked_network_ttl - ?test_protocol ?expiration genesis = - let net_id = Net_id.of_block_hash genesis.block in + data ?initial_context ?expiration ?(allow_forked_network = false) + net_id genesis = let net_store = Store.Net.get data.global_store net_id in let operation_store = Store.Operation.get net_store and block_header_store = Store.Block_header.get net_store @@ -891,8 +877,6 @@ module Raw_net = struct Store.Net.Genesis_hash.store net_store genesis.block >>= fun () -> Store.Net.Genesis_time.store net_store genesis.time >>= fun () -> Store.Net.Genesis_protocol.store net_store genesis.protocol >>= fun () -> - let test_protocol = Utils.unopt ~default:genesis.protocol test_protocol in - Store.Net.Genesis_test_protocol.store net_store test_protocol >>= fun () -> Store.Chain.Current_head.store chain_store genesis.block >>= fun () -> Store.Chain.Known_heads.store chain_store genesis.block >>= fun () -> data.init_index net_id >>= fun context_index -> @@ -901,6 +885,12 @@ module Raw_net = struct | None -> Lwt.return_unit | Some time -> Store.Net.Expiration.store net_store time end >>= fun () -> + begin + if allow_forked_network then + Store.Net.Allow_forked_network.store data.global_store net_id + else + Lwt.return_unit + end >>= fun () -> Raw_block_header.store_genesis block_header_store genesis >>= fun header -> begin @@ -911,7 +901,6 @@ module Raw_net = struct ~id:genesis.block ~time:genesis.time ~protocol:genesis.protocol - ~test_protocol | Some context -> Lwt.return context end >>= fun context -> @@ -923,7 +912,7 @@ module Raw_net = struct ~genesis ~genesis_block ~expiration - ~forked_network_ttl + ~allow_forked_network context_index chain_store block_header_store @@ -946,9 +935,7 @@ module Valid_block = struct discovery_time: Time.t ; protocol_hash: Protocol_hash.t ; protocol: (module Updater.REGISTRED_PROTOCOL) option ; - test_protocol_hash: Protocol_hash.t ; - test_protocol: (module Updater.REGISTRED_PROTOCOL) option ; - test_network: (Net_id.t * Time.t) option ; + test_network: Context.test_network ; context: Context.t ; successors: Block_hash.Set.t ; invalid_successors: Block_hash.Set.t ; @@ -1002,7 +989,7 @@ module Valid_block = struct block_header_store (net_state: net_state) valid_block_watcher - hash { Updater.context ; message ; fitness } ttl = + hash { Updater.context ; message ; fitness } = (* Read the block header. *) Raw_block_header.Locked.read block_header_store hash >>=? fun block -> @@ -1016,30 +1003,6 @@ module Valid_block = struct expected = block.Store.Block_header.shell.fitness ; found = fitness ; }) >>=? fun () -> - begin (* Patch context about the associated test network. *) - Context.read_and_reset_fork_test_network - context >>= fun (fork, context) -> - if fork then - match ttl with - | None -> - (* Ignore fork on forked networks. *) - Context.del_test_network context >>= fun context -> - Context.del_test_network_expiration context - | Some ttl -> - let eol = Time.(add block.shell.timestamp ttl) in - Context.set_test_network - context (Net_id.of_block_hash hash) >>= fun context -> - Context.set_test_network_expiration - context eol >>= fun context -> - Lwt.return context - else - Context.get_test_network_expiration context >>= function - | Some eol when Time.(eol <= now ()) -> - Context.del_test_network context >>= fun context -> - Context.del_test_network_expiration context - | None | Some _ -> - Lwt.return context - end >>= fun context -> Raw_block_header.Locked.mark_valid block_header_store hash >>= fun _marked -> (* TODO fail if the block was previsouly stored ... ??? *) @@ -1101,8 +1064,7 @@ module Valid_block = struct | None -> Locked.store block_header_store net_state net.valid_block_watcher - hash vcontext - net.forked_network_ttl >>=? fun valid_block -> + hash vcontext >>=? fun valid_block -> return (Some valid_block) end end @@ -1110,26 +1072,22 @@ module Valid_block = struct let watcher net = Watcher.create_stream net.valid_block_watcher - let fork_testnet state net block expiration = + let fork_testnet state net block protocol expiration = assert (Net_id.equal block.net_id (Net_id.of_block_hash net.genesis.block)) ; - let hash = Block_hash.hash_bytes [Block_hash.to_bytes block.hash] in - let genesis : genesis = { - block = hash ; - time = Time.add block.timestamp 1L ; - protocol = block.test_protocol_hash ; - } in Shared.use state.global_data begin fun data -> - if Net_id.Table.mem data.nets (Net_id.of_block_hash hash) then - assert false (* This would mean a block is validated twice... *) - else - Context.init_test_network block.context - ~time:genesis.time - ~genesis:genesis.block >>=? fun initial_context -> - Raw_net.locked_create data - ~initial_context - ~expiration - genesis >>= fun net -> - return net + let context = block.context in + Context.set_test_network context Not_running >>= fun context -> + Context.set_protocol context protocol >>= fun context -> + Context.commit_test_network_genesis + block.hash block.timestamp context >>=? fun (net_id, genesis) -> + let genesis = { + block = genesis ; + time = Time.add block.timestamp 1L ; + protocol ; + } in + Raw_net.locked_create data + net_id ~initial_context:context ~expiration genesis >>= fun net -> + return net end module Helpers = struct @@ -1334,15 +1292,14 @@ module Net = struct (req "block" Block_hash.encoding) (req "protocol" Protocol_hash.encoding)) - let create state ?test_protocol ?forked_network_ttl genesis = + let create state ?allow_forked_network genesis = let net_id = Net_id.of_block_hash genesis.block in - let forked_network_ttl = map_option Int64.of_int forked_network_ttl in Shared.use state.global_data begin fun data -> if Net_id.Table.mem data.nets net_id then Pervasives.failwith "State.Net.create" else - Raw_net.locked_create data - ?test_protocol ?forked_network_ttl genesis >>= fun net -> + Raw_net.locked_create + data ?allow_forked_network net_id genesis >>= fun net -> Net_id.Table.add data.nets net_id net ; Lwt.return net end @@ -1356,7 +1313,8 @@ module Net = struct Store.Net.Genesis_time.read net_store >>=? fun time -> Store.Net.Genesis_protocol.read net_store >>=? fun protocol -> Store.Net.Expiration.read_opt net_store >>= fun expiration -> - Store.Net.Forked_network_ttl.read_opt net_store >>= fun forked_network_ttl -> + Store.Net.Allow_forked_network.known + data.global_store id >>= fun allow_forked_network -> let genesis = { time ; protocol ; block = genesis_hash } in Store.Chain.Current_head.read chain_store >>=? fun genesis_hash -> data.init_index id >>= fun context_index -> @@ -1372,7 +1330,7 @@ module Net = struct ~genesis ~genesis_block ~expiration - ~forked_network_ttl + ~allow_forked_network context_index chain_store block_header_store @@ -1407,7 +1365,7 @@ module Net = struct let id { id } = id let genesis { genesis } = genesis let expiration { expiration } = expiration - let forked_network_ttl { forked_network_ttl } = forked_network_ttl + let allow_forked_network { allow_forked_network } = allow_forked_network let destroy state net = lwt_debug "destroy %a" Net_id.pp (id net) >>= fun () -> diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index 2b7e18d96..f054542b0 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -62,12 +62,12 @@ module Net : sig } val genesis_encoding: genesis Data_encoding.t - (** Initialize a network for a given [genesis]. By default the network - never expirate and the test_protocol is the genesis protocol. *) + (** Initialize a network for a given [genesis]. By default, + the network does accept forking test network. When + [~allow_forked_network:true] is provided, test network are allowed. *) val create: global_state -> - ?test_protocol: Protocol_hash.t -> - ?forked_network_ttl: int -> + ?allow_forked_network:bool -> genesis -> net Lwt.t (** Look up for a network by the hash of its genesis block. *) @@ -88,7 +88,7 @@ module Net : sig val id: net -> Net_id.t val genesis: net -> genesis val expiration: net -> Time.t option - val forked_network_ttl: net -> Int64.t option + val allow_forked_network: net -> bool end @@ -264,14 +264,8 @@ module Valid_block : sig protocol: (module Updater.REGISTRED_PROTOCOL) option ; (** The actual implementation of the protocol to be used for validating the following blocks. *) - test_protocol_hash: Protocol_hash.t ; - (** The protocol to be used for the next test network. *) - test_protocol: (module Updater.REGISTRED_PROTOCOL) option ; - (** The actual implementatino of the protocol to be used for the - next test network. *) - test_network: (Net_id.t * Time.t) option ; - (** The current test network associated to the block, and the date - of its expiration date. *) + test_network: Context.test_network ; + (** The current test network associated to the block. *) context: Context.t ; (** The validation context that was produced by the block validation. *) successors: Block_hash.Set.t ; @@ -296,7 +290,10 @@ module Valid_block : sig val known_heads: Net.t -> valid_block list Lwt.t val fork_testnet: - global_state -> Net.t -> valid_block -> Time.t -> Net.t tzresult Lwt.t + global_state -> + Net.t -> valid_block -> + Protocol_hash.t -> Time.t -> + Net.t tzresult Lwt.t module Current : sig diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 95aed3d4e..e11b1b36f 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -33,7 +33,11 @@ and t = { net_db: Distributed_db.net ; notify_block: Block_hash.t -> Store.Block_header.t -> unit Lwt.t ; fetch_block: Block_hash.t -> State.Valid_block.t tzresult Lwt.t ; - create_child: State.Valid_block.t -> unit tzresult Lwt.t ; + create_child: + State.Valid_block.t -> Protocol_hash.t -> Time.t -> unit tzresult Lwt.t ; + check_child: + Block_hash.t -> Protocol_hash.t -> Time.t -> Time.t -> unit tzresult Lwt.t ; + deactivate_child: unit -> unit Lwt.t ; test_validator: unit -> (t * Distributed_db.net) option ; shutdown: unit -> unit Lwt.t ; valid_block_input: State.Valid_block.t Watcher.input ; @@ -59,29 +63,10 @@ let bootstrapped v = v.bootstrapped (** Current block computation *) -let may_change_test_network v (block: State.Valid_block.t) = - let change = - match block.test_network, v.child with - | None, None -> false - | Some _, None - | None, Some _ -> true - | Some (net_id, _), Some { net } -> - let net_id' = State.Net.id net in - not (Net_id.equal net_id net_id') in - if change then begin - v.create_child block >>= function - | Ok () -> Lwt.return_unit - | Error err -> - lwt_log_error "@[Error while switch test network:@ %a@]" - Error_monad.pp_print_error err - end else - Lwt.return_unit - let fetch_protocol v hash = lwt_log_notice "Fetching protocol %a" Protocol_hash.pp_short hash >>= fun () -> - Distributed_db.Protocol.fetch - v.worker.db hash >>= fun protocol -> + Distributed_db.Protocol.fetch v.worker.db hash >>= fun protocol -> Updater.compile hash protocol >>= fun valid -> if valid then begin lwt_log_notice "Successfully compiled protocol %a" @@ -101,12 +86,16 @@ let fetch_protocols v (block: State.Valid_block.t) = | Some _ -> return false | None -> fetch_protocol v block.protocol_hash and test_proto_updated = - match block.test_protocol with - | Some _ -> return false - | None -> fetch_protocol v block.test_protocol_hash in + match block.test_network with + | Not_running -> return false + | Forking { protocol } + | Running { protocol } -> + Distributed_db.Protocol.known v.worker.db protocol >>= fun known -> + if known then return false + else fetch_protocol v protocol in proto_updated >>=? fun proto_updated -> - test_proto_updated >>=? fun test_proto_updated -> - if test_proto_updated || proto_updated then + test_proto_updated >>=? fun _test_proto_updated -> + if proto_updated then State.Valid_block.read_exn v.net block.hash >>= return else return block @@ -122,7 +111,20 @@ let rec may_set_head v (block: State.Valid_block.t) = | true -> Distributed_db.broadcast_head v.net_db block.hash [] ; Prevalidator.flush v.prevalidator block ; - may_change_test_network v block >>= fun () -> + begin + begin + match block.test_network with + | Not_running -> v.deactivate_child () >>= return + | Running { genesis ; protocol ; expiration } -> + v.check_child genesis protocol expiration block.timestamp + | Forking { protocol ; expiration } -> + v.create_child block protocol expiration + end >>= function + | Ok () -> Lwt.return_unit + | Error err -> + lwt_log_error "@[Error while switch test network:@ %a@]" + Error_monad.pp_print_error err + end >>= fun () -> Watcher.notify v.new_head_input block ; lwt_log_notice "update current head %a %a %a(%t)" Block_hash.pp_short block.hash @@ -217,8 +219,10 @@ let apply_block net db operations >>=? fun parsed_operations -> lwt_debug "validation of %a: applying block..." Block_hash.pp_short hash >>= fun () -> + Context.reset_test_network + pred.context pred.hash block.shell.timestamp >>= fun context -> Proto.begin_application - ~predecessor_context:pred.context + ~predecessor_context:context ~predecessor_timestamp:pred.timestamp ~predecessor_fitness:pred.fitness block >>=? fun state -> @@ -484,7 +488,7 @@ module Context_db = struct end -let rec create_validator ?parent worker state db net = +let rec create_validator ?max_ttl ?parent worker state db net = let queue = Lwt_pipe.create () in let current_ops = ref (fun () -> []) in @@ -568,6 +572,8 @@ let rec create_validator ?parent worker state db net = notify_block ; fetch_block ; create_child ; + check_child ; + deactivate_child ; test_validator ; bootstrapped ; new_head_input ; @@ -585,36 +591,62 @@ let rec create_validator ?parent worker state db net = and fetch_block hash = Context_db.fetch session v hash - and create_child block = - begin + and create_child block protocol expiration = + if State.Net.allow_forked_network net then begin + deactivate_child () >>= fun () -> + begin + State.Net.get state net_id >>= function + | Ok net_store -> return net_store + | Error _ -> + State.Valid_block.fork_testnet + state net block protocol expiration >>=? fun net_store -> + State.Valid_block.Current.head net_store >>= fun block -> + Watcher.notify v.worker.valid_block_input block ; + return net_store + end >>=? fun net_store -> + worker.activate ~parent:v net_store >>= fun child -> + v.child <- Some child ; + return () + end else begin + (* Ignoring request... *) + return () + end + + and deactivate_child () = + match v.child with + | None -> Lwt.return_unit + | Some child -> + v.child <- None ; + deactivate child + + and check_child genesis protocol expiration current_time = + let activated = match v.child with - | None -> Lwt.return_unit + | None -> false | Some child -> - v.child <- None ; - deactivate child - end >>= fun () -> - match block.test_network with - | None -> return () - | Some (net_id, expiration) -> - begin - State.Net.get state net_id >>= function - | Ok net_store -> return net_store - | Error _ -> - State.Valid_block.fork_testnet - state net block expiration >>=? fun net_store -> - State.Valid_block.Current.head net_store >>= fun block -> - Watcher.notify v.worker.valid_block_input block ; - return net_store - end >>=? fun net_store -> - worker.activate ~parent:v net_store >>= fun child -> - v.child <- Some child ; - return () + Block_hash.equal (State.Net.genesis child.net).block genesis in + begin + match max_ttl with + | None -> Lwt.return expiration + | Some ttl -> + Distributed_db.Block_header.fetch net_db genesis >>= fun genesis -> + Lwt.return + (Time.min expiration + (Time.add genesis.shell.timestamp (Int64.of_int ttl))) + end >>= fun local_expiration -> + let expired = Time.(local_expiration <= current_time) in + if expired && activated then + deactivate_child () >>= return + else if not activated && not expired then + fetch_block genesis >>=? fun genesis -> + create_child genesis protocol expiration + else + return () and test_validator () = match v.child with | None -> None | Some child -> Some (child, child.net_db) - in new_blocks := begin @@ -637,7 +669,7 @@ let rec create_validator ?parent worker state db net = type error += Unknown_network of Net_id.t -let create_worker state db = +let create_worker ?max_ttl state db = let validators : t Lwt.t Net_id.Table.t = Net_id.Table.create 7 in @@ -770,7 +802,7 @@ let create_worker state db = Net_id.pp net_id >>= fun () -> get net_id >>= function | Error _ -> - let v = create_validator ?parent worker state db net in + let v = create_validator ?max_ttl ?parent worker state db net in Net_id.Table.add validators net_id v ; v | Ok v -> Lwt.return v diff --git a/src/node/shell/validator.mli b/src/node/shell/validator.mli index e203cb357..676228227 100644 --- a/src/node/shell/validator.mli +++ b/src/node/shell/validator.mli @@ -9,7 +9,7 @@ type worker -val create_worker: State.t -> Distributed_db.t -> worker +val create_worker: ?max_ttl:int -> State.t -> Distributed_db.t -> worker val shutdown: worker -> unit Lwt.t val notify_block: worker -> Block_hash.t -> State.Block_header.t -> unit Lwt.t diff --git a/src/node/updater/environment.ml b/src/node/updater/environment.ml index e3f3e76bd..936fa0f05 100644 --- a/src/node/updater/environment.ml +++ b/src/node/updater/environment.ml @@ -82,7 +82,7 @@ module Ed25519 = struct (conv Sodium.Sign.Bigbytes.of_public_key Sodium.Sign.Bigbytes.to_public_key - bytes) + (Fixed.bytes Sodium.Sign.public_key_size)) let hash v = Public_key_hash.hash_bytes @@ -144,7 +144,7 @@ module Ed25519 = struct (conv Sodium.Sign.Bigbytes.of_secret_key Sodium.Sign.Bigbytes.to_secret_key - bytes) + (Fixed.bytes Sodium.Sign.secret_key_size)) end @@ -199,7 +199,7 @@ module Ed25519 = struct | None -> Data_encoding.Json.cannot_destruct "Ed25519 signature: unexpected prefix.") string) - ~binary: (Fixed.bytes 64) + ~binary: (Fixed.bytes Sodium.Sign.signature_size) let check public_key signature msg = try diff --git a/src/node/updater/updater.ml b/src/node/updater/updater.ml index a042ef063..38c3d184f 100644 --- a/src/node/updater/updater.ml +++ b/src/node/updater/updater.ml @@ -71,7 +71,6 @@ let register hash proto = let activate = Context.set_protocol let fork_test_network = Context.fork_test_network -let set_test_protocol = Context.set_test_protocol let get_exn hash = VersionTable.find versions hash let get hash = diff --git a/src/node/updater/updater.mli b/src/node/updater/updater.mli index 38b0b2728..247ee3c19 100644 --- a/src/node/updater/updater.mli +++ b/src/node/updater/updater.mli @@ -66,8 +66,8 @@ val extract: Lwt_io.file_name -> Protocol_hash.t -> component list -> unit Lwt.t val compile: Protocol_hash.t -> component list -> bool Lwt.t val activate: Context.t -> Protocol_hash.t -> Context.t Lwt.t -val set_test_protocol: Context.t -> Protocol_hash.t -> Context.t Lwt.t -val fork_test_network: Context.t -> Context.t Lwt.t +val fork_test_network: + Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t val register: Protocol_hash.t -> (module REGISTRED_PROTOCOL) -> unit diff --git a/src/proto/alpha/amendment.ml b/src/proto/alpha/amendment.ml index 2416070de..82f7b9687 100644 --- a/src/proto/alpha/amendment.ml +++ b/src/proto/alpha/amendment.ml @@ -67,9 +67,10 @@ let start_new_voting_cycle ctxt = Vote.clear_ballots ctxt >>= fun ctxt -> Vote.clear_listings ctxt >>=? fun ctxt -> if approved then + let expiration = (* in two days maximum... *) + Time.add (Timestamp.current ctxt) (Int64.mul 48L 3600L) in Vote.get_current_proposal ctxt >>=? fun proposal -> - set_test_protocol ctxt proposal >>= fun ctxt -> - fork_test_network ctxt >>= fun ctxt -> + fork_test_network ctxt proposal expiration >>= fun ctxt -> Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> return ctxt else diff --git a/src/proto/alpha/apply.ml b/src/proto/alpha/apply.ml index 6cc85a805..2c8438d66 100644 --- a/src/proto/alpha/apply.ml +++ b/src/proto/alpha/apply.ml @@ -175,8 +175,9 @@ let apply_sourced_operation | Dictator_operation (Activate_testnet hash) -> let dictator_pubkey = Constants.dictator_pubkey ctxt in Operation.check_signature dictator_pubkey operation >>=? fun () -> - set_test_protocol ctxt hash >>= fun ctxt -> - fork_test_network ctxt >>= fun ctxt -> + let expiration = (* in two days maximum... *) + Time.add (Timestamp.current ctxt) (Int64.mul 48L 3600L) in + fork_test_network ctxt hash expiration >>= fun ctxt -> return (ctxt, origination_nonce, None) let apply_anonymous_operation ctxt miner_contract origination_nonce kind = diff --git a/src/proto/alpha/storage.ml b/src/proto/alpha/storage.ml index aae3b748d..8b9adaffe 100644 --- a/src/proto/alpha/storage.ml +++ b/src/proto/alpha/storage.ml @@ -547,11 +547,9 @@ end let activate ({ context = c } as s) h = Updater.activate c h >>= fun c -> Lwt.return { s with context = c } -let fork_test_network ({ context = c } as s) = - Updater.fork_test_network c >>= fun c -> Lwt.return { s with context = c } -let set_test_protocol ({ context = c } as s) h = - Updater.set_test_protocol c h >>= fun c -> Lwt.return { s with context = c } - +let fork_test_network ({ context = c } as s) protocol expiration = + Updater.fork_test_network c ~protocol ~expiration >>= fun c -> + Lwt.return { s with context = c } (** Resolver *) diff --git a/src/proto/alpha/storage.mli b/src/proto/alpha/storage.mli index 06a396de7..a02c82663 100644 --- a/src/proto/alpha/storage.mli +++ b/src/proto/alpha/storage.mli @@ -275,5 +275,4 @@ module Rewards : sig end val activate: t -> Protocol_hash.t -> t Lwt.t -val set_test_protocol: t -> Protocol_hash.t -> t Lwt.t -val fork_test_network: t -> t Lwt.t +val fork_test_network: t -> Protocol_hash.t -> Time.t -> t Lwt.t diff --git a/src/proto/alpha/tezos_context.ml b/src/proto/alpha/tezos_context.ml index f2a6c7646..f871a642a 100644 --- a/src/proto/alpha/tezos_context.ml +++ b/src/proto/alpha/tezos_context.ml @@ -119,4 +119,3 @@ let configure_sandbox = Init_storage.configure_sandbox let activate = Storage.activate let fork_test_network = Storage.fork_test_network -let set_test_protocol = Storage.set_test_protocol diff --git a/src/proto/alpha/tezos_context.mli b/src/proto/alpha/tezos_context.mli index 2eb2cfeba..2884bcd3a 100644 --- a/src/proto/alpha/tezos_context.mli +++ b/src/proto/alpha/tezos_context.mli @@ -583,5 +583,4 @@ val configure_sandbox: Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t val activate: context -> Protocol_hash.t -> context Lwt.t -val set_test_protocol: context -> Protocol_hash.t -> context Lwt.t -val fork_test_network: context -> context Lwt.t +val fork_test_network: context -> Protocol_hash.t -> Time.t -> context Lwt.t diff --git a/src/proto/environment/updater.mli b/src/proto/environment/updater.mli index 8808ca0b1..181499bd0 100644 --- a/src/proto/environment/updater.mli +++ b/src/proto/environment/updater.mli @@ -174,5 +174,10 @@ val compile : Protocol_hash.t -> component list -> bool Lwt.t been previously compiled successfully. *) val activate : Context.t -> Protocol_hash.t -> Context.t Lwt.t -val set_test_protocol: Context.t -> Protocol_hash.t -> Context.t Lwt.t -val fork_test_network: Context.t -> Context.t Lwt.t +(** Fork a test network. The forkerd network will use the current block + as genesis, and [protocol] as economic protocol. The network will + be destroyed when a (successor) block will have a timestamp greater + than [expiration]. The protocol must have been previously compiled + successfully. *) +val fork_test_network: + Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t diff --git a/src/proto/genesis/data.ml b/src/proto/genesis/data.ml index 78d7c9a77..62fc6b18d 100644 --- a/src/proto/genesis/data.ml +++ b/src/proto/genesis/data.ml @@ -14,7 +14,7 @@ module Command = struct | Activate of Protocol_hash.t (* Activate a protocol as a testnet *) - | Activate_testnet of Protocol_hash.t + | Activate_testnet of Protocol_hash.t * Int64.t let mk_case name args = let open Data_encoding in @@ -22,7 +22,7 @@ module Command = struct (fun o -> ((), o)) (fun ((), o) -> o) (merge_objs - (obj1 (req "network" (constant name))) + (obj1 (req "command" (constant name))) args) let encoding = @@ -30,14 +30,18 @@ module Command = struct union ~tag_size:`Uint8 [ case ~tag:0 (mk_case "activate" - (obj1 (req "hash" Protocol_hash.encoding))) + (obj1 + (req "hash" Protocol_hash.encoding))) (function (Activate hash) -> Some hash | _ -> None) (fun hash -> Activate hash) ; case ~tag:1 (mk_case "activate_testnet" - (obj1 (req "hash" Protocol_hash.encoding))) - (function (Activate_testnet hash) -> Some hash | _ -> None) - (fun hash -> Activate_testnet hash) ; + (obj2 + (req "hash" Protocol_hash.encoding) + (req "validity_time" int64))) + (function (Activate_testnet (hash, delay)) -> Some (hash, delay) + | _ -> None) + (fun (hash, delay) -> Activate_testnet (hash, delay)) ; ] let signed_encoding = diff --git a/src/proto/genesis/main.ml b/src/proto/genesis/main.ml index d8e9d2ebb..2d6d5805a 100644 --- a/src/proto/genesis/main.ml +++ b/src/proto/genesis/main.ml @@ -45,9 +45,15 @@ type block = { } let max_block_length = - match Data_encoding.Binary.fixed_length Data.Command.signed_encoding with - | None -> assert false - | Some len -> len + Data_encoding.Binary.length + Data.Command.encoding + (Activate_testnet (Protocol_hash.hash_bytes [], 0L)) + + + begin + match Data_encoding.Binary.fixed_length Ed25519.Signature.encoding with + | None -> assert false + | Some len -> len + end let parse_block { Updater.shell ; proto } : block tzresult = match Data_encoding.Binary.of_bytes Data.Command.signed_encoding proto with @@ -88,11 +94,11 @@ let begin_application Some (Format.asprintf "activate %a" Protocol_hash.pp_short hash) in Updater.activate ctxt hash >>= fun ctxt -> return { Updater.message ; context = ctxt ; fitness } - | Activate_testnet hash -> + | Activate_testnet (hash, delay) -> let message = Some (Format.asprintf "activate testnet %a" Protocol_hash.pp_short hash) in - Updater.set_test_protocol ctxt hash >>= fun ctxt -> - Updater.fork_test_network ctxt >>= fun ctxt -> + let expiration = Time.add raw_block.shell.timestamp delay in + Updater.fork_test_network ctxt hash expiration >>= fun ctxt -> return { Updater.message ; context = ctxt ; fitness } let begin_construction diff --git a/test/shell/test_context.ml b/test/shell/test_context.ml index 770e4bf4e..8329dce20 100644 --- a/test/shell/test_context.ml +++ b/test/shell/test_context.ml @@ -89,8 +89,7 @@ let wrap_context_init f base_dir = Context.commit_genesis idx ~id:genesis.block ~time:genesis.time - ~protocol:genesis.protocol - ~test_protocol:genesis.protocol >>= fun _ -> + ~protocol:genesis.protocol >>= fun _ -> create_block2 idx >>= fun () -> create_block3a idx >>= fun () -> create_block3b idx >>= fun () ->