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

@@ -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: Context.test_network;
-    test_network: (Net_id.t * Time.t) option ;
   }
   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 ()
 

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: Context.test_network;
-    test_network: (Net_id.t * Time.t) option ;
   }
 
   val info:

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 ;

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 =
+let commit_test_network_genesis forked_block time ctxt =
-  raw_get v current_protocol_key >>= function
+  let net_id, genesis = compute_testnet_genesis forked_block in
-  | None -> assert false
+  let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in
-  | Some data -> Lwt.return (Protocol_hash.of_bytes_exn data)
+  GitStore.clone task ctxt.store (Block_hash.to_b58check genesis) >>= function
-let set_protocol v key =
+  | `Empty_head -> fail (Exn (Empty_head genesis))
-  raw_set v current_protocol_key (Protocol_hash.to_bytes key)
+  | `Duplicated_branch -> fail (Exn (Preexistent_context genesis))
-
-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)])
   | `Ok store ->
       let msg =
-        Format.asprintf "Fake block. Forking testnet: %a."
+        Format.asprintf "Forking testnet: %a." Net_id.pp_short net_id in
-          Block_hash.pp_short genesis in
+      GitStore.FunView.update_path (store msg) [] ctxt.view >>= fun () ->
-      GitStore.FunView.update_path (store msg) [] v.view >>= fun () ->
+      return (net_id, genesis)
-      return v
 
+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 })

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
+type test_network =
-val set_test_protocol: context -> Protocol_hash.t -> context Lwt.t
+  | 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 test_network_encoding: test_network Data_encoding.t
-val set_test_network: context -> Net_id.t -> context Lwt.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 reset_test_network: context -> Block_hash.t -> Time.t -> context 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 fork_test_network:
-val read_and_reset_fork_test_network: context -> (bool * context) Lwt.t
+  context -> protocol:Protocol_hash.t -> expiration:Time.t -> 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

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 =
+  module Allow_forked_network =
-    Store_helpers.Make_single_store
+    Indexed_store.Make_set (struct let name = ["allow_forked_network"] end)
-      (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))
 
 end
 

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
+  module Allow_forked_network : SET_STORE
-    with type t := store
+    with type t := t
-     and type value := Int64.t
+     and type elt := Net_id.t
 
 end
 

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
 

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
+      State.Net.create state genesis
-        ?test_protocol
-        ~forked_network_ttl:(48 * 3600) (* 2 days *)
-        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
+  let validator =
-  may_create_net state ?test_protocol genesis >>= fun mainnet_net ->
+    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: Context.test_network;
-    test_network: (Net_id.t * Time.t) option ;
  }
 
   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 ;
               }
 

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

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 ->

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: Context.test_network;
-    test_network: (Net_id.t * Time.t) option ;
   }
 
   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)
+               (dft "test_network"
-               (opt "test_network" (tup2 Net_id.encoding Time.encoding)))))
+                  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 =

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: Context.test_network;
-    test_network: (Net_id.t * Time.t) option ;
   }
 
   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

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

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_network: Context.test_network ;
-  test_protocol: (module Updater.REGISTRED_PROTOCOL) option ;
-  test_network: (Net_id.t * Time.t) option ;
   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
+      data ?initial_context ?expiration ?(allow_forked_network = false)
-      ?initial_context ?forked_network_ttl
+      net_id genesis =
-      ?test_protocol ?expiration genesis =
-    let net_id = Net_id.of_block_hash genesis.block in
     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_network: Context.test_network ;
-    test_protocol: (module Updater.REGISTRED_PROTOCOL) option ;
-    test_network: (Net_id.t * Time.t) option ;
     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
+                  hash vcontext >>=? fun valid_block ->
-                  net.forked_network_ttl >>=? 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
+      let context = block.context in
-        assert false (* This would mean a block is validated twice... *)
+      Context.set_test_network context Not_running >>= fun context ->
-      else
+      Context.set_protocol context protocol >>= fun context ->
-        Context.init_test_network block.context
+      Context.commit_test_network_genesis
-          ~time:genesis.time
+        block.hash block.timestamp context >>=? fun (net_id, genesis) ->
-          ~genesis:genesis.block >>=? fun initial_context ->
+      let genesis = {
-        Raw_net.locked_create data
+        block = genesis ;
-          ~initial_context
+        time = Time.add block.timestamp 1L ;
-          ~expiration
+        protocol ;
-          genesis >>= fun net ->
+      } in
-        return net
+      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
+        Raw_net.locked_create
-          ?test_protocol ?forked_network_ttl genesis >>= fun net ->
+          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 () ->

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
+  (** Initialize a network for a given [genesis]. By default,
-      never expirate and the test_protocol is the genesis protocol. *)
+      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 ->
+    ?allow_forked_network:bool ->
-    ?forked_network_ttl: int ->
     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 ;
+    test_network: Context.test_network ;
-    (** The protocol to be used for the next test network. *)
+    (** The current test network associated to the block. *)
-    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. *)
     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
 

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 "@[<v 2>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
+  Distributed_db.Protocol.fetch v.worker.db hash >>= fun protocol ->
-    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
+    match block.test_network with
-    | Some _ -> return false
+    | Not_running -> return false
-    | None -> fetch_protocol v block.test_protocol_hash in
+    | 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 ->
+  test_proto_updated >>=? fun _test_proto_updated ->
-  if test_proto_updated || proto_updated then
+  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 "@[<v 2>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 =
+  and create_child block protocol expiration =
-    begin
+    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 ;
+          Block_hash.equal (State.Net.genesis child.net).block genesis in
-          deactivate child
+    begin
-    end >>= fun () ->
+      match max_ttl with
-    match block.test_network with
+      | None -> Lwt.return expiration
-    | None -> return ()
+      | Some ttl ->
-    | Some (net_id, expiration) ->
+          Distributed_db.Block_header.fetch net_db genesis >>= fun genesis ->
-        begin
+          Lwt.return
-          State.Net.get state net_id >>= function
+            (Time.min expiration
-          | Ok net_store -> return net_store
+               (Time.add genesis.shell.timestamp (Int64.of_int ttl)))
-          | Error _ ->
+    end >>= fun local_expiration ->
-              State.Valid_block.fork_testnet
+    let expired = Time.(local_expiration <= current_time) in
-                state net block expiration >>=? fun net_store ->
+    if expired && activated then
-              State.Valid_block.Current.head net_store >>= fun block ->
+      deactivate_child () >>= return
-              Watcher.notify v.worker.valid_block_input block ;
+    else if not activated && not expired then
-              return net_store
+      fetch_block genesis >>=? fun genesis ->
-        end >>=? fun net_store ->
+      create_child genesis protocol expiration
-        worker.activate ~parent:v net_store >>= fun child ->
+    else
-        v.child <- Some child ;
+      return ()
-        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

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

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

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 =

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:
-val fork_test_network: Context.t -> Context.t Lwt.t
+  Context.t -> protocol:Protocol_hash.t -> expiration:Time.t -> Context.t Lwt.t
 
 val register: Protocol_hash.t -> (module REGISTRED_PROTOCOL) -> unit
 

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 proposal expiration >>= fun ctxt ->
-        fork_test_network ctxt >>= fun ctxt ->
         Vote.set_current_period_kind ctxt Testing >>=? fun ctxt ->
         return ctxt
       else

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 ->
+      let expiration = (* in two days maximum... *)
-      fork_test_network ctxt >>= fun ctxt ->
+        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 =

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) =
+let fork_test_network ({ context = c } as s) protocol expiration =
-  Updater.fork_test_network c >>= fun c -> Lwt.return { s with context = c }
+  Updater.fork_test_network c ~protocol ~expiration >>= fun c ->
-let set_test_protocol ({ context = c } as s) h =
+  Lwt.return { s with context = c }
-  Updater.set_test_protocol c h >>= fun c -> Lwt.return { s with context = c }
-
 
 (** Resolver *)
 

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 -> Protocol_hash.t -> Time.t -> t Lwt.t
-val fork_test_network: t -> t Lwt.t

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

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 -> Protocol_hash.t -> Time.t -> context Lwt.t
-val fork_test_network: context -> context Lwt.t

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
+(** Fork a test network. The forkerd network will use the current block
-val fork_test_network: Context.t -> Context.t Lwt.t
+    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

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)))
+           (obj2
-        (function (Activate_testnet hash) -> Some hash | _ -> None)
+              (req "hash" Protocol_hash.encoding)
-        (fun hash -> Activate_testnet hash) ;
+              (req "validity_time" int64)))
+        (function (Activate_testnet (hash, delay)) -> Some (hash, delay)
+                | _ -> None)
+        (fun (hash, delay) -> Activate_testnet (hash, delay)) ;
     ]
 
   let signed_encoding =

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
+  Data_encoding.Binary.length
-  | None -> assert false
+    Data.Command.encoding
-  | Some len -> len
+    (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 ->
+      let expiration = Time.add raw_block.shell.timestamp delay in
-      Updater.fork_test_network ctxt >>= fun ctxt ->
+      Updater.fork_test_network ctxt hash expiration >>= fun ctxt ->
       return { Updater.message ; context = ctxt ; fitness }
 
 let begin_construction

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
+    ~protocol:genesis.protocol >>= fun _ ->
-    ~test_protocol:genesis.protocol >>= fun _ ->
   create_block2 idx >>= fun () ->
   create_block3a idx >>= fun () ->
   create_block3b idx >>= fun () ->