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] 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 () ->