Merge branch 'level_in_block_header' into 'master'

Move the `level` in the shell part of the block header

See merge request !177

src/Makefile

@@ -247,7 +247,7 @@ ${TZCLIENT}: minutils.cmxa utils.cmxa compiler.cmxa node.cmxa \
              ${EMBEDDED_CLIENT_VERSIONS} \
              ${CLIENT_IMPLS:.ml=.cmx}
 	@echo LINK $(notdir $@)
-	@${OCAMLOPT} -linkpkg ${OCAMLFLAGS} -o $@ $^
+	@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
 
 clean::
 	-rm -f ${TZCLIENT}
@@ -413,7 +413,6 @@ client/embedded/client_%.cmx: \
   $(patsubst %.ml, %.cmx, $(NODE_LIB_IMPLS) $(CLIENT_LIB_IMPLS)) \
   proto/client_embedded_proto_%.cmxa \
   $$(shell find client/embedded/% \( -name webclient -or -name _tzbuild \) -prune -or \( -name \*.ml -print -or -name \*.mli -print \))
-	@echo $^
 	@$(MAKE) -C client/embedded/$* ../client_$*.cmx
 
 client/embedded/webclient_%.cmx: \

src/client/client_node_rpcs.ml

@@ -15,9 +15,9 @@ module Services = Node_rpc_services
 let errors cctxt =
   call_service0 cctxt Services.Error.service ()
 
-let forge_block cctxt ?net ?predecessor ?timestamp fitness ops header =
+let forge_block cctxt ?net_id ?level ?predecessor ?timestamp fitness ops header =
   call_service0 cctxt Services.forge_block
-    (net, predecessor, timestamp, fitness, ops, header)
+    (net_id, level, predecessor, timestamp, fitness, ops, header)
 
 let validate_block cctxt net block =
   call_err_service0 cctxt Services.validate_block (net, block)
@@ -53,16 +53,16 @@ module Blocks = struct
 
   type block_info = Services.Blocks.block_info = {
     hash: Block_hash.t ;
+    net_id: Net_id.t ;
+    level: Int32.t ;
     predecessor: Block_hash.t ;
-    fitness: MBytes.t list ;
     timestamp: Time.t ;
-    protocol: Protocol_hash.t option ;
     operations_hash: Operation_list_list_hash.t ;
+    fitness: MBytes.t list ;
+    data: MBytes.t ;
     operations: Operation_hash.t list list option ;
-    data: MBytes.t option ;
+    protocol: Protocol_hash.t ;
-    net: Net_id.t ;
+    test_network: Context.test_network;
-    test_protocol: Protocol_hash.t option ;
-    test_network: (Net_id.t * Time.t) option ;
   }
   type preapply_param = Services.Blocks.preapply_param = {
     operations: Operation_hash.t list ;
@@ -76,6 +76,8 @@ module Blocks = struct
   }
   let net cctxt h =
     call_service1 cctxt Services.Blocks.net h ()
+  let level cctxt h =
+    call_service1 cctxt Services.Blocks.level h ()
   let predecessor cctxt h =
     call_service1 cctxt Services.Blocks.predecessor h ()
   let predecessors cctxt h l =
@@ -90,29 +92,28 @@ 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 ()
+
   let preapply cctxt h ?timestamp ?(sort = false) operations =
     call_err_service1
       cctxt Services.Blocks.preapply h
       { operations ; sort ; timestamp }
   let pending_operations cctxt block =
     call_service1 cctxt Services.Blocks.pending_operations block ()
-  let info cctxt ?(operations = true) ?(data = true) h =
+  let info cctxt ?(include_ops = true) h =
-    call_service1 cctxt Services.Blocks.info h (operations, data)
+    call_service1 cctxt Services.Blocks.info h include_ops
   let complete cctxt block prefix =
     call_service2 cctxt Services.Blocks.complete block prefix ()
-  let list cctxt ?(operations = false) ?(data = false)
+  let list cctxt ?(include_ops = false)
       ?length ?heads ?delay ?min_date ?min_heads () =
     call_service0 cctxt Services.Blocks.list
-      { operations ; data ; length ; heads ; monitor = Some false ; delay ;
+      { include_ops ; length ; heads ; monitor = Some false ; delay ;
         min_date ; min_heads }
-  let monitor cctxt ?(operations = false) ?(data = false)
+  let monitor cctxt ?(include_ops = false)
       ?length ?heads ?delay ?min_date ?min_heads () =
     call_streamed_service0 cctxt Services.Blocks.list
-      { operations ; data ; length ; heads ; monitor = Some true ; delay ;
+      { include_ops ; length ; heads ; monitor = Some true ; delay ;
         min_date ; min_heads }
 
 end

src/client/client_node_rpcs.mli

@@ -14,7 +14,8 @@ val errors:
 
 val forge_block:
   config ->
-  ?net:Net_id.t ->
+  ?net_id:Net_id.t ->
+  ?level:Int32.t ->
   ?predecessor:Block_hash.t ->
   ?timestamp:Time.t ->
   Fitness.fitness ->
@@ -67,6 +68,9 @@ module Blocks : sig
   val net:
     config ->
     block -> Net_id.t tzresult Lwt.t
+  val level:
+    config ->
+    block -> Int32.t tzresult Lwt.t
   val predecessor:
     config ->
     block -> Block_hash.t tzresult Lwt.t
@@ -88,12 +92,9 @@ module Blocks : sig
   val protocol:
     config ->
     block -> Protocol_hash.t tzresult Lwt.t
-  val test_protocol:
-    config ->
-    block -> Protocol_hash.t option 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 ->
@@ -102,31 +103,31 @@ module Blocks : sig
 
   type block_info = {
     hash: Block_hash.t ;
+    net_id: Net_id.t ;
+    level: Int32.t ;
     predecessor: Block_hash.t ;
-    fitness: MBytes.t list ;
     timestamp: Time.t ;
-    protocol: Protocol_hash.t option ;
     operations_hash: Operation_list_list_hash.t ;
+    fitness: MBytes.t list ;
+    data: MBytes.t ;
     operations: Operation_hash.t list list option ;
-    data: MBytes.t option ;
+    protocol: Protocol_hash.t ;
-    net: Net_id.t ;
+    test_network: Context.test_network;
-    test_protocol: Protocol_hash.t option ;
-    test_network: (Net_id.t * Time.t) option ;
   }
 
   val info:
     config ->
-    ?operations:bool -> ?data:bool -> block -> block_info tzresult Lwt.t
+    ?include_ops:bool -> block -> block_info tzresult Lwt.t
 
   val list:
     config ->
-    ?operations:bool -> ?data:bool -> ?length:int -> ?heads:Block_hash.t list ->
+    ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
     ?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
     unit -> block_info list list tzresult Lwt.t
 
   val monitor:
     config ->
-    ?operations:bool -> ?data:bool -> ?length:int -> ?heads:Block_hash.t list ->
+    ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
     ?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
     unit -> block_info list list tzresult Lwt_stream.t tzresult Lwt.t
 

src/client/embedded/alpha/baker/client_mining_blocks.ml

@@ -12,7 +12,7 @@ type block_info = {
   predecessor: Block_hash.t ;
   fitness: MBytes.t list ;
   timestamp: Time.t ;
-  protocol: Protocol_hash.t option ;
+  protocol: Protocol_hash.t ;
   level: Level.t ;
 }
 
@@ -21,7 +21,8 @@ let convert_block_info cctxt
       : Client_node_rpcs.Blocks.block_info ) =
   Client_proto_rpcs.Context.level cctxt (`Hash hash) >>= function
   | Ok level ->
-      Lwt.return (Some { hash ; predecessor ; fitness ; timestamp ; protocol ; level })
+      Lwt.return
+        (Some { hash ; predecessor ; fitness ; timestamp ; protocol ; level })
   | Error _ ->
       (* TODO log error *)
       Lwt.return_none
@@ -32,8 +33,8 @@ let convert_block_info_err cctxt
   Client_proto_rpcs.Context.level cctxt (`Hash hash) >>=? fun level ->
   return { hash ; predecessor ; fitness ; timestamp ; protocol ; level }
 
-let info cctxt ?operations block =
+let info cctxt ?include_ops block =
-  Client_node_rpcs.Blocks.info cctxt ?operations block >>=? fun block ->
+  Client_node_rpcs.Blocks.info cctxt ?include_ops block >>=? fun block ->
   convert_block_info_err cctxt block
 
 let compare (bi1 : block_info) (bi2 : block_info) =
@@ -54,10 +55,10 @@ let sort_blocks cctxt ?(compare = compare) blocks =
   List.sort compare blocks
 
 let monitor cctxt
-    ?operations ?length ?heads ?delay
+    ?include_ops ?length ?heads ?delay
     ?min_date ?min_heads ?compare () =
   Client_node_rpcs.Blocks.monitor cctxt
-    ?operations ?length ?heads ?delay ?min_date ?min_heads
+    ?include_ops ?length ?heads ?delay ?min_date ?min_heads
     () >>=? fun block_stream ->
   let convert blocks =
     Lwt.return blocks >>=? fun blocks ->

src/client/embedded/alpha/baker/client_mining_blocks.mli

@@ -12,20 +12,20 @@ type block_info = {
   predecessor: Block_hash.t ;
   fitness: MBytes.t list ;
   timestamp: Time.t ;
-  protocol: Protocol_hash.t option ;
+  protocol: Protocol_hash.t ;
   level: Level.t ;
 }
 
 val info:
   Client_rpcs.config ->
-  ?operations:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t
+  ?include_ops:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t
 
 val compare:
   block_info -> block_info -> int
 
 val monitor:
   Client_rpcs.config ->
-  ?operations:bool -> ?length:int -> ?heads:Block_hash.t list ->
+  ?include_ops:bool -> ?length:int -> ?heads:Block_hash.t list ->
   ?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
   ?compare:(block_info -> block_info -> int) ->
   unit -> block_info list tzresult Lwt_stream.t tzresult Lwt.t

src/client/embedded/alpha/baker/client_mining_forge.ml

@@ -22,14 +22,14 @@ let generate_seed_nonce () =
   | Ok nonce -> nonce
 
 let rec compute_stamp
-    cctxt block delegate_sk shell mining_slot seed_nonce_hash =
+    cctxt block delegate_sk shell priority seed_nonce_hash =
   Client_proto_rpcs.Constants.stamp_threshold
     cctxt block >>=? fun stamp_threshold ->
   let rec loop () =
     let proof_of_work_nonce = generate_proof_of_work_nonce () in
     let unsigned_header =
       Tezos_context.Block.forge_header
-        shell { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } in
+        shell { priority ; seed_nonce_hash ; proof_of_work_nonce } in
     let signed_header =
       Ed25519.Signature.append delegate_sk unsigned_header in
     let block_hash = Block_hash.hash_bytes [signed_header] in
@@ -42,28 +42,26 @@ let rec compute_stamp
 let inject_block cctxt block
     ?force
     ~priority ~timestamp ~fitness ~seed_nonce
-    ~src_sk operation_list =
+    ~src_sk operations =
   let block = match block with `Prevalidation -> `Head 0 | block -> block in
   Client_node_rpcs.Blocks.info cctxt block >>=? fun bi ->
   let seed_nonce_hash = Nonce.hash seed_nonce in
   Client_proto_rpcs.Context.next_level cctxt block >>=? fun level ->
-  let operations =
+  let operations_hash =
     Operation_list_list_hash.compute
-      (List.map Operation_list_hash.compute operation_list) in
+      (List.map Operation_list_hash.compute operations) in
   let shell =
-    { Store.Block_header.net_id = bi.net ; predecessor = bi.hash ;
+    { Store.Block_header.net_id = bi.net_id ; level = bi.level ;
-      timestamp ; fitness ; operations } in
+      predecessor = bi.hash ; timestamp ; fitness ; operations_hash } in
-  let slot =
-    { Block.level = level.level ; priority = Int32.of_int priority } in
   compute_stamp cctxt block
-    src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce ->
+    src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce ->
   Client_proto_rpcs.Helpers.Forge.block cctxt
     block
-    ~net:bi.net
+    ~net:bi.net_id
     ~predecessor:bi.hash
     ~timestamp
     ~fitness
-    ~operations
+    ~operations_hash
     ~level:level.level
     ~priority:priority
     ~seed_nonce_hash
@@ -71,7 +69,7 @@ let inject_block cctxt block
     () >>=? fun unsigned_header ->
   let signed_header = Ed25519.Signature.append src_sk unsigned_header in
   Client_node_rpcs.inject_block cctxt
-    ?force signed_header operation_list >>=? fun block_hash ->
+    ?force signed_header operations >>=? fun block_hash ->
   return block_hash
 
 let forge_block cctxt block

src/client/embedded/alpha/client_proto_rpcs.ml

@@ -64,11 +64,7 @@ end
 module Context = struct
 
   let level cctxt block =
-    match block with
+    call_error_service1 cctxt Services.Context.level block ()
-    | `Genesis -> return Level.root
-    | `Hash h when Block_hash.equal Client_blocks.genesis h ->
-        return Level.root
-    | _ -> call_error_service1 cctxt Services.Context.level block ()
 
   let next_level cctxt block =
     call_error_service1 cctxt Services.Context.next_level block ()
@@ -249,10 +245,10 @@ module Helpers = struct
         operations cctxt block ~net [Faucet { id ; nonce }]
     end
     let block cctxt
-        block ~net ~predecessor ~timestamp ~fitness ~operations
+        block ~net ~predecessor ~timestamp ~fitness ~operations_hash
         ~level ~priority ~seed_nonce_hash ~proof_of_work_nonce () =
       call_error_service1 cctxt Services.Helpers.Forge.block block
-        (net, predecessor, timestamp, fitness, operations,
+        (net, predecessor, timestamp, fitness, operations_hash,
          level, priority, seed_nonce_hash, proof_of_work_nonce)
   end
 

src/client/embedded/alpha/client_proto_rpcs.mli

@@ -35,7 +35,7 @@ module Constants : sig
     block -> (Period.t list) tzresult Lwt.t
   val first_free_mining_slot:
     Client_rpcs.config ->
-    block -> int32 tzresult Lwt.t
+    block -> int tzresult Lwt.t
   val max_signing_slot:
     Client_rpcs.config ->
     block -> int tzresult Lwt.t
@@ -298,7 +298,7 @@ module Helpers : sig
       predecessor:Block_hash.t ->
       timestamp:Time.t ->
       fitness:Fitness.t ->
-      operations:Operation_list_list_hash.t ->
+      operations_hash:Operation_list_list_hash.t ->
       level:Raw_level.t ->
       priority:int ->
       seed_nonce_hash:Nonce_hash.t ->

src/client/embedded/demo/client_proto_main.ml

@@ -51,7 +51,7 @@ let mine cctxt =
           (cctxt.message "Cannot parse fitness: %a" Fitness.pp bi.fitness);
         exit 2 in
   Client_node_rpcs.forge_block cctxt.rpc_config
-    ~net:bi.net ~predecessor:bi.hash
+    ~net_id:bi.net_id ~predecessor:bi.hash
     fitness Operation_list_list_hash.empty (MBytes.create 0) >>=? fun bytes ->
   Client_node_rpcs.inject_block cctxt.rpc_config bytes [] >>=? fun hash ->
   cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->

src/client/embedded/genesis/client_proto_main.ml

@@ -26,13 +26,15 @@ let call_error_service1 rpc_config s block a1 =
 let forge_block
     rpc_config block net_id ?(timestamp = Time.now ()) command fitness =
   Client_blocks.get_block_hash rpc_config block >>=? fun pred ->
+  Client_node_rpcs.Blocks.level rpc_config block >>=? fun level ->
   call_service1 rpc_config
     Services.Forge.block block
-    ((net_id, pred, timestamp, fitness), command)
+    ((net_id, Int32.succ level, pred, timestamp, fitness), command)
 
 let mine rpc_config ?timestamp block command fitness seckey =
   Client_blocks.get_block_info rpc_config block >>=? fun bi ->
-  forge_block rpc_config ?timestamp block bi.net command fitness >>=? fun blk ->
+  forge_block
+    rpc_config ?timestamp block bi.net_id command fitness >>=? fun blk ->
   let signed_blk = Environment.Ed25519.Signature.append seckey blk in
   Client_node_rpcs.inject_block rpc_config signed_blk [[]]
 
@@ -86,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,14 +84,7 @@ type t = context
 (*-- Version Access and Update -----------------------------------------------*)
 
 let current_protocol_key = ["protocol"]
-let current_fitness_key = ["fitness"]
-let current_timestamp_key = ["timestamp"]
-let current_test_protocol_key = ["test_protocol"]
 let current_test_network_key = ["test_network"]
-let current_test_network_expiration_key = ["test_network_expiration"]
-let current_fork_test_network_key = ["fork_test_network"]
-
-let transient_commit_message_key = ["message"]
 
 let exists { repo } key =
   GitStore.of_branch_id
@@ -134,59 +127,17 @@ let exists index key =
     Block_hash.pp_short key exists >>= fun () ->
   Lwt.return exists
 
-let get_and_erase_commit_message ctxt =
-  GitStore.FunView.get ctxt.view transient_commit_message_key >>= function
-  | None -> Lwt.return (None, ctxt)
-  | Some bytes ->
-     GitStore.FunView.del ctxt.view transient_commit_message_key >>= fun view ->
-     Lwt.return (Some (MBytes.to_string bytes), { ctxt with view })
-let set_commit_message ctxt msg =
-  GitStore.FunView.set ctxt.view
-    transient_commit_message_key
-    (MBytes.of_string msg) >>= fun view ->
-  Lwt.return { ctxt with view }
-
-let get_fitness { view } =
-  GitStore.FunView.get view current_fitness_key >>= function
-  | None -> assert false
-  | Some data ->
-      match Data_encoding.Binary.of_bytes Fitness.encoding data with
-      | None -> assert false
-      | Some data -> Lwt.return data
-let set_fitness ctxt data =
-  GitStore.FunView.set ctxt.view current_fitness_key
-    (Data_encoding.Binary.to_bytes Fitness.encoding data) >>= fun view ->
-  Lwt.return { ctxt with view }
-
-let get_timestamp { view } =
-  GitStore.FunView.get view current_timestamp_key >>= function
-  | None -> assert false
-  | Some time ->
-     Lwt.return (Time.of_notation_exn (MBytes.to_string time))
-let set_timestamp ctxt time =
-  GitStore.FunView.set ctxt.view current_timestamp_key
-    (MBytes.of_string (Time.to_notation time)) >>= fun view ->
-  Lwt.return { ctxt with view }
-
 exception Preexistent_context of Block_hash.t
 exception Empty_head of Block_hash.t
 
-let commit key context =
+let commit key ~time ~message context =
-  get_timestamp context >>= fun timestamp ->
+  let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in
-  get_fitness context >>= fun fitness ->
-  let task =
-    Irmin.Task.create ~date:(Time.to_seconds timestamp) ~owner:"Tezos" in
   GitStore.clone task context.store (Block_hash.to_b58check key) >>= function
   | `Empty_head -> Lwt.fail (Empty_head key)
   | `Duplicated_branch -> Lwt.fail (Preexistent_context key)
   | `Ok store ->
-     get_and_erase_commit_message context >>= fun (msg, context) ->
+      GitStore.FunView.update_path
-     let msg = match msg with
+        (store message) [] context.view >>= fun () ->
-       | None ->
-          Format.asprintf "%a %a"
-            Fitness.pp fitness Block_hash.pp_short key
-       | Some msg -> msg in
-     GitStore.FunView.update_path (store msg) [] context.view >>= fun () ->
      context.index.commits <- context.index.commits + 1 ;
      if context.index.commits mod 200 = 0 then
        Lwt_utils.Idle_waiter.force_idle
@@ -250,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 =
@@ -266,86 +288,48 @@ 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
-    Irmin.Task.none (Block_hash.to_b58check block)
+    task (Block_hash.to_b58check block)
     index.repo >>= fun t ->
-  let store = t () in
+  let store = t "Genesis" in
   GitStore.FunView.of_path store [] >>= fun view ->
   let view = (view, index.repack_scheduler) in
-  GitStore.FunView.set view current_timestamp_key
-    (MBytes.of_string (Time.to_notation time)) >>= fun view ->
-  GitStore.FunView.set view current_protocol_key
-    (Protocol_hash.to_bytes protocol) >>= fun view ->
-  GitStore.FunView.set view current_fitness_key
-    (Data_encoding.Binary.to_bytes Fitness.encoding []) >>= fun view ->
-  GitStore.FunView.set view current_test_protocol_key
-    (Protocol_hash.to_bytes test_protocol) >>= fun view ->
   let ctxt = { index ; store ; view } in
+  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 ->
-  set_timestamp v time >>= 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
@@ -40,34 +43,37 @@ exception Preexistent_context of Block_hash.t
 val exists: index -> Block_hash.t -> bool Lwt.t
 val checkout: index -> Block_hash.t -> context option Lwt.t
 val checkout_exn: index -> Block_hash.t -> context Lwt.t
-val commit: Block_hash.t -> context -> unit Lwt.t
+val commit:
+  Block_hash.t ->
+  time:Time.t ->
+  message:string ->
+  context -> unit Lwt.t
 
 (** {2 Predefined Fields} ****************************************************)
 
 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
 
-val read_and_reset_fork_test_network: context -> (bool * context) Lwt.t
+val fork_test_network:
-val fork_test_network: context -> context Lwt.t
+  context -> protocol:Protocol_hash.t -> expiration:Time.t -> context Lwt.t
-
-val set_fitness: context -> Fitness.fitness -> context Lwt.t
-val get_fitness: context -> Fitness.fitness Lwt.t
-
-val set_timestamp: context -> Time.t -> context Lwt.t
-val get_timestamp: context -> Time.t Lwt.t
-
-val set_commit_message: context -> string -> context Lwt.t
-
-val init_test_network:
-  context ->  time:Time.t -> genesis:Block_hash.t -> context tzresult Lwt.t

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
 
@@ -258,24 +252,30 @@ module Block_header = struct
 
   type shell_header = {
     net_id: Net_id.t ;
+    level: Int32.t ;
     predecessor: Block_hash.t ;
     timestamp: Time.t ;
-    operations: Operation_list_list_hash.t ;
+    operations_hash: Operation_list_list_hash.t ;
     fitness: MBytes.t list ;
   }
 
   let shell_header_encoding =
     let open Data_encoding in
     conv
-      (fun { net_id ; predecessor ; timestamp ; operations ; fitness } ->
+      (fun { net_id ; level ; predecessor ;
-         (net_id, predecessor, timestamp, operations, fitness))
+             timestamp ; operations_hash ; fitness } ->
-      (fun (net_id, predecessor, timestamp, operations, fitness) ->
+        (net_id, level, predecessor,
-         { net_id ; predecessor ; timestamp ; operations ; fitness })
+         timestamp, operations_hash, fitness))
-      (obj5
+      (fun (net_id, level, predecessor,
+            timestamp, operations_hash, fitness) ->
+         { net_id ; level ; predecessor ;
+           timestamp ; operations_hash ; fitness })
+      (obj6
          (req "net_id" Net_id.encoding)
+         (req "level" int32)
          (req "predecessor" Block_hash.encoding)
          (req "timestamp" Time.encoding)
-         (req "operations" Operation_list_list_hash.encoding)
+         (req "operations_hash" Operation_list_list_hash.encoding)
          (req "fitness" Fitness.encoding))
 
   module Encoding = struct
@@ -307,7 +307,7 @@ module Block_header = struct
     Block_hash.compare b1.shell.predecessor b2.shell.predecessor >> fun () ->
     compare b1.proto b2.proto >> fun () ->
     Operation_list_list_hash.compare
-      b1.shell.operations b2.shell.operations >> fun () ->
+      b1.shell.operations_hash b2.shell.operations_hash >> fun () ->
     Time.compare b1.shell.timestamp b2.shell.timestamp >> fun () ->
     list compare b1.shell.fitness b2.shell.fitness
 

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
 
@@ -171,9 +171,10 @@ module Block_header : sig
 
   type shell_header = {
     net_id: Net_id.t ;
+    level: Int32.t ;
     predecessor: Block_hash.t ;
     timestamp: Time.t ;
-    operations: Operation_list_list_hash.t ;
+    operations_hash: Operation_list_list_hash.t ;
     fitness: MBytes.t list ;
   }
   val shell_header_encoding: shell_header Data_encoding.t

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/distributed_db.ml

@@ -348,7 +348,7 @@ module P2p_reader = struct
           | None -> Lwt.return_unit
           | Some bh ->
               if Operation_list_list_hash.compare
-                   found_hash bh.shell.operations <> 0 then
+                   found_hash bh.shell.operations_hash <> 0 then
                 Lwt.return_unit
               else
                 Raw_operation_list.Table.notify
@@ -624,7 +624,7 @@ let inject_block t bytes operations =
                   (List.map Operation_list_hash.compute operations) in
               fail_unless
                 (Operation_list_list_hash.compare
-                   computed_hash block.shell.operations = 0)
+                   computed_hash block.shell.operations_hash = 0)
                 (Exn (Failure "Incoherent operation list")) >>=? fun () ->
               Raw_block_header.Table.inject
                 net_db.block_header_db.table hash block >>= function

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 () =
@@ -138,46 +137,32 @@ module RPC = struct
   type block = Node_rpc_services.Blocks.block
   type block_info = Node_rpc_services.Blocks.block_info = {
     hash: Block_hash.t ;
+    net_id: Net_id.t ;
+    level: Int32.t ;
     predecessor: Block_hash.t ;
-    fitness: MBytes.t list ;
     timestamp: Time.t ;
-    protocol: Protocol_hash.t option ;
     operations_hash: Operation_list_list_hash.t ;
+    fitness: MBytes.t list ;
+    data: MBytes.t ;
     operations: Operation_hash.t list list option ;
-    data: MBytes.t option ;
+    protocol: Protocol_hash.t ;
-    net: Net_id.t ;
+    test_network: Context.test_network;
-    test_protocol: Protocol_hash.t option ;
-    test_network: (Net_id.t * Time.t) option ;
  }
 
-  let convert (block: State.Valid_block.t)  = {
+  let convert (block: State.Valid_block.t) = {
     hash = block.hash ;
-    predecessor = block.pred ;
+    net_id = block.net_id ;
-    fitness = block.fitness ;
+    level = block.level ;
+    predecessor = block.predecessor ;
     timestamp = block.timestamp ;
-    protocol = Some block.protocol_hash ;
     operations_hash = block.operations_hash ;
+    fitness = block.fitness ;
+    data = block.proto_header ;
     operations = Some block.operations ;
-    data = Some block.proto_header ;
+    protocol = block.protocol_hash ;
-    net = block.net_id ;
-    test_protocol = Some block.test_protocol_hash ;
     test_network = block.test_network ;
   }
 
-  let convert_block hash ({ shell ; proto }: State.Block_header.t)  = {
-    net = shell.net_id ;
-    hash = hash ;
-    predecessor = shell.predecessor ;
-    fitness = shell.fitness ;
-    timestamp = shell.timestamp ;
-    protocol = None ;
-    operations_hash = shell.operations ;
-    operations = None ;
-    data = Some proto ;
-    test_protocol = None ;
-    test_network = None ;
-  }
-
   let inject_block node = node.inject_block
   let inject_operation node = node.inject_operation
   let inject_protocol node = node.inject_protocol
@@ -278,42 +263,62 @@ module RPC = struct
         State.Valid_block.Current.head net_state >>= fun head ->
         Prevalidator.context pv >>= function
         | Error _ -> Lwt.fail Not_found
-        | Ok ctxt ->
+        | Ok { context ; fitness } ->
-            Context.get_fitness ctxt >>= fun fitness ->
+            Context.get_protocol context >>= fun protocol ->
-            Context.get_protocol ctxt >>= fun protocol ->
+            Context.get_test_network context >>= fun test_network ->
             let operations =
               let pv_result, _ = Prevalidator.operations pv in
-              Some [ pv_result.applied ] in
+              [ pv_result.applied ] in
-            let timestamp = Prevalidator.timestamp pv in
             Lwt.return
-              { (convert head) with
+              { hash = prevalidation_hash ;
-                hash = prevalidation_hash ;
+                level = Int32.succ head.level ;
-                protocol = Some protocol ;
+                predecessor = head.hash ;
-                fitness ; operations ; timestamp }
+                fitness ;
+                timestamp = Prevalidator.timestamp pv ;
+                protocol ;
+                operations_hash =
+                  Operation_list_list_hash.compute
+                    (List.map Operation_list_hash.compute operations) ;
+                operations = Some operations ;
+                data = MBytes.of_string "" ;
+                net_id = head.net_id ;
+                test_network ;
+              }
 
-  let get_context node block =
+  let rpc_context block : Updater.rpc_context =
+    { context = block.State.Valid_block.context ;
+      level = Int32.succ  block.level ;
+      fitness = block.fitness ;
+      timestamp = block. timestamp }
+
+  let get_rpc_context node block =
     match block with
     | `Genesis ->
         State.Valid_block.Current.genesis node.mainnet_net >>= fun block ->
-        Lwt.return (Some block.context)
+        Lwt.return (Some (rpc_context block))
     | ( `Head n | `Test_head n ) as block ->
         let validator = get_validator node block in
         let net_state = Validator.net_state validator in
         let net_db = Validator.net_db validator in
         State.Valid_block.Current.head net_state >>= fun head ->
-        get_pred net_db n head >>= fun { context } ->
+        get_pred net_db n head >>= fun block ->
-        Lwt.return (Some context)
+        Lwt.return (Some (rpc_context block))
     | `Hash hash-> begin
         read_valid_block node hash >|= function
         | None -> None
-        | Some { context } -> Some context
+        | Some block -> Some (rpc_context block)
       end
     | ( `Prevalidation | `Test_prevalidation ) as block ->
-        let validator, _net = get_net node block in
+        let validator, net = get_net node block in
         let pv = Validator.prevalidator validator in
         Prevalidator.context pv >>= function
         | Error _ -> Lwt.fail Not_found
-        | Ok ctxt -> Lwt.return (Some ctxt)
+        | Ok { context ; fitness } ->
+            let timestamp = Prevalidator.timestamp pv in
+            State.Valid_block.Current.head
+              (Distributed_db.state net) >>= fun { level } ->
+            let level = Int32.succ level in
+            Lwt.return (Some { Updater.context ; fitness ; timestamp ; level })
 
   let operations node block =
     match block with
@@ -417,8 +422,7 @@ module RPC = struct
       ~predecessor ~timestamp >>=? fun validation_state ->
     Prevalidation.prevalidate
       validation_state ~sort rops >>=? fun (validation_state, r) ->
-    Prevalidation.end_prevalidation validation_state >>=? fun ctxt ->
+    Prevalidation.end_prevalidation validation_state >>=? fun { fitness } ->
-    Context.get_fitness ctxt >>= fun fitness ->
     return (fitness, { r with applied = List.rev r.applied })
 
   let complete node ?block str =
@@ -426,9 +430,9 @@ module RPC = struct
     | None ->
         Base58.complete str
     | Some block ->
-        get_context node block >>= function
+        get_rpc_context node block >>= function
         | None -> Lwt.fail Not_found
-        | Some ctxt ->
+        | Some { context = ctxt } ->
             Context.get_protocol ctxt >>= fun protocol_hash ->
             let (module Proto) = Updater.get_exn protocol_hash in
             Base58.complete str >>= fun l1 ->
@@ -436,12 +440,12 @@ module RPC = struct
             Lwt.return (l1 @ l2)
 
   let context_dir node block =
-    get_context node block >>= function
+    get_rpc_context node block >>= function
     | None -> Lwt.return None
-    | Some ctxt ->
+    | Some rpc_context ->
-        Context.get_protocol ctxt >>= fun protocol_hash ->
+        Context.get_protocol rpc_context.context >>= fun protocol_hash ->
         let (module Proto) = Updater.get_exn protocol_hash in
-        let dir =  RPC.map (fun () -> ctxt) Proto.rpc_services in
+        let dir = RPC.map (fun () -> rpc_context) Proto.rpc_services in
         Lwt.return (Some (RPC.map (fun _ -> ()) dir))
 
   let heads node =
@@ -512,12 +516,7 @@ module RPC = struct
       heads >>= fun (_, blocks) ->
     Lwt.return (List.rev blocks)
 
-  let block_watcher node =
+  let block_watcher node = Distributed_db.watch_block node.distributed_db
-    let stream, shutdown = Distributed_db.watch_block node.distributed_db in
-    Lwt_stream.map
-      (fun (hash, block) -> convert_block hash block)
-      stream,
-    shutdown
 
   let valid_block_watcher node =
     let stream, shutdown = Validator.global_watcher node.validator in

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
@@ -44,7 +44,7 @@ module RPC : sig
   val raw_block_info:
     t -> Block_hash.t -> block_info Lwt.t
   val block_watcher:
-    t -> block_info Lwt_stream.t * Watcher.stopper
+    t -> (Block_hash.t * Store.Block_header.t) Lwt_stream.t * Watcher.stopper
   val valid_block_watcher:
     t -> (block_info Lwt_stream.t * Watcher.stopper)
   val heads: t -> block_info Block_hash.Map.t Lwt.t

src/node/shell/node_rpc.ml

@@ -12,9 +12,8 @@ open Logging.RPC
 
 module Services = Node_rpc_services
 
-let filter_bi (operations, data) (bi: Services.Blocks.block_info)  =
+let filter_bi operations (bi: Services.Blocks.block_info)  =
   let bi = if operations then bi else { bi with operations = None } in
-  let bi = if data then bi else { bi with data = None } in
   bi
 
 let register_bi_dir node dir =
@@ -34,9 +33,15 @@ let register_bi_dir node dir =
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      RPC.Answer.return bi.net in
+      RPC.Answer.return bi.net_id in
     RPC.register1 dir
       Services.Blocks.net implementation in
+  let dir =
+    let implementation b () =
+      Node.RPC.block_info node b >>= fun bi ->
+      RPC.Answer.return bi.level in
+    RPC.register1 dir
+      Services.Blocks.level implementation in
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
@@ -65,17 +70,9 @@ let register_bi_dir node dir =
   let dir =
     let implementation b () =
       Node.RPC.block_info node b >>= fun bi ->
-      match bi.protocol with
+      RPC.Answer.return bi.protocol in
-      | None -> raise Not_found
-      | Some p -> RPC.Answer.return p 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 ->
@@ -214,11 +211,10 @@ let create_delayed_stream
 
 let list_blocks
     node
-    { Services.Blocks.operations ; data ; length ; heads ; monitor ; delay ;
+    { Services.Blocks.include_ops ; length ; heads ; monitor ; delay ;
       min_date; min_heads} =
   let len = match length with None -> 1 | Some x -> x in
   let monitor = match monitor with None -> false | Some x -> x in
-  let include_ops = (operations, data) in
   let time =
     match delay with
     | None -> None
@@ -404,14 +400,17 @@ let build_rpc_directory node =
   let dir =
     RPC.register1 dir Services.Protocols.contents (get_protocols node) in
   let dir =
-    let implementation (net_id, pred, time, fitness, operations, header) =
+    let implementation
+        (net_id, level, pred, time, fitness, operations_hash, header) =
       Node.RPC.block_info node (`Head 0) >>= fun bi ->
       let timestamp = Utils.unopt ~default:(Time.now ()) time in
-      let net_id = Utils.unopt ~default:bi.net net_id in
+      let net_id = Utils.unopt ~default:bi.net_id net_id in
       let predecessor = Utils.unopt ~default:bi.hash pred in
+      let level = Utils.unopt ~default:(Int32.succ bi.level) level in
       let res =
         Data_encoding.Binary.to_bytes Store.Block_header.encoding {
-          shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ;
+          shell = { net_id ; predecessor ; level ;
+                    timestamp ; fitness ; operations_hash } ;
           proto = header ;
         } in
       RPC.Answer.return res in

src/node/shell/node_rpc_services.ml

@@ -57,46 +57,45 @@ module Blocks = struct
 
   type block_info = {
     hash: Block_hash.t ;
+    net_id: Net_id.t ;
+    level: Int32.t ;
     predecessor: Block_hash.t ;
-    fitness: MBytes.t list ;
     timestamp: Time.t ;
-    protocol: Protocol_hash.t option ;
     operations_hash: Operation_list_list_hash.t ;
+    fitness: MBytes.t list ;
+    data: MBytes.t ;
     operations: Operation_hash.t list list option ;
-    data: MBytes.t option ;
+    protocol: Protocol_hash.t ;
-    net: Net_id.t ;
+    test_network: Context.test_network;
-    test_protocol: Protocol_hash.t option ;
-    test_network: (Net_id.t * Time.t) option ;
   }
 
   let block_info_encoding =
     conv
-      (fun { hash ; predecessor ; fitness ; timestamp ; protocol ;
+      (fun { hash ; net_id ; level ; predecessor ;
-             operations_hash ; operations ; data ; net ;
+             fitness ; timestamp ; protocol ; operations_hash ; data ;
-             test_protocol ; test_network } ->
+             operations ; test_network } ->
-        ((hash, predecessor, fitness, timestamp, protocol),
+        ({ Store.Block_header.shell =
-         (operations_hash, operations, data,
+             { net_id ; level ; predecessor ;
-          net, test_protocol, test_network)))
+               timestamp ; operations_hash ; fitness } ;
-      (fun ((hash, predecessor, fitness, timestamp, protocol),
+           proto = data },
-            (operations_hash, operations, data,
+         (hash, operations, protocol, test_network)))
-             net, test_protocol, test_network)) ->
+      (fun ({ Store.Block_header.shell =
-        { hash ; predecessor ; fitness ; timestamp ; protocol ;
+                { net_id ; level ; predecessor ;
-          operations_hash ; operations ; data ; net ;
+                  timestamp ; operations_hash ; fitness } ;
-          test_protocol ; test_network })
+              proto = data },
-      (merge_objs
+            (hash, operations, protocol, test_network)) ->
-        (obj5
+        { hash ; net_id ; level ; predecessor ;
-           (req "hash" Block_hash.encoding)
+          fitness ; timestamp ; protocol ; operations_hash ; data ;
-           (req "predecessor" Block_hash.encoding)
+          operations ; test_network })
-           (req "fitness" Fitness.encoding)
+      (dynamic_size
-           (req "timestamp" Time.encoding)
+         (merge_objs
-           (opt "protocol" Protocol_hash.encoding))
+            Store.Block_header.encoding
-        (obj6
+            (obj4
-           (req "operations_hash" Operation_list_list_hash.encoding)
+               (req "hash" Block_hash.encoding)
-           (opt "operations" (list (list Operation_hash.encoding)))
+               (opt "operations" (list (list Operation_hash.encoding)))
-           (opt "data" bytes)
+               (req "protocol" Protocol_hash.encoding)
-           (req "net" Net_id.encoding)
+               (dft "test_network"
-           (opt "test_protocol" Protocol_hash.encoding)
+                  Context.test_network_encoding Context.Not_running))))
-           (opt "test_network" (tup2 Net_id.encoding Time.encoding))))
 
   let parse_block s =
     try
@@ -179,10 +178,7 @@ module Blocks = struct
   let info =
     RPC.service
       ~description:"All the information about a block."
-      ~input:
+      ~input: (obj1 (dft "operations" bool true))
-        (obj2
-           (dft "operations" bool true)
-           (dft "data" bool true))
       ~output: block_info_encoding
       block_path
 
@@ -193,6 +189,13 @@ module Blocks = struct
       ~output: (obj1 (req "net" Net_id.encoding))
       RPC.Path.(block_path / "net")
 
+  let level =
+    RPC.service
+      ~description:"Returns the block's level."
+      ~input: empty
+      ~output: (obj1 (req "level" int32))
+      RPC.Path.(block_path / "level")
+
   let predecessor =
     RPC.service
       ~description:"Returns the previous block's id."
@@ -244,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 (opt "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 =
@@ -320,8 +316,7 @@ module Blocks = struct
       RPC.Path.(block_path / "complete" /: prefix_arg )
 
   type list_param = {
-    operations: bool ;
+    include_ops: bool ;
-    data: bool ;
     length: int option ;
     heads: Block_hash.t list option ;
     monitor: bool option ;
@@ -331,25 +326,20 @@ module Blocks = struct
   }
   let list_param_encoding =
     conv
-      (fun { operations ; data ; length ; heads ; monitor ;
+      (fun { include_ops ; length ; heads ; monitor ;
              delay ; min_date ; min_heads } ->
-        (operations, data, length, heads, monitor, delay, min_date, min_heads))
+        (include_ops, length, heads, monitor, delay, min_date, min_heads))
-      (fun (operations, data, length, heads, monitor, delay, min_date, min_heads) ->
+      (fun (include_ops, length, heads, monitor,
-         { operations ; data ; length ; heads ; monitor ;
+            delay, min_date, min_heads) ->
+         { include_ops ; length ; heads ; monitor ;
            delay ; min_date ; min_heads })
-      (obj8
+      (obj7
-         (dft "operations"
+         (dft "include_ops"
             (Data_encoding.describe
                ~description:
                  "Whether the resulting block informations should include the \
                   list of operations' hashes. Default false."
                bool) false)
-         (dft "data"
-            (Data_encoding.describe
-               ~description:
-                 "Whether the resulting block informations should include the \
-                  raw protocol dependent data. Default false."
-               bool) false)
          (opt "length"
             (Data_encoding.describe
                ~description:
@@ -642,8 +632,9 @@ let forge_block =
   RPC.service
     ~description: "Forge a block header"
     ~input:
-      (obj6
+      (obj7
          (opt "net_id" Net_id.encoding)
+         (opt "level" int32)
          (opt "predecessor" Block_hash.encoding)
          (opt "timestamp" Time.encoding)
          (req "fitness" Fitness.encoding)

src/node/shell/node_rpc_services.mli

@@ -28,22 +28,24 @@ module Blocks : sig
 
   type block_info = {
     hash: Block_hash.t ;
+    net_id: Net_id.t ;
+    level: Int32.t ;
     predecessor: Block_hash.t ;
-    fitness: MBytes.t list ;
     timestamp: Time.t ;
-    protocol: Protocol_hash.t option ;
     operations_hash: Operation_list_list_hash.t ;
+    fitness: MBytes.t list ;
+    data: MBytes.t ;
     operations: Operation_hash.t list list option ;
-    data: MBytes.t option ;
+    protocol: Protocol_hash.t ;
-    net: Net_id.t ;
+    test_network: Context.test_network;
-    test_protocol: Protocol_hash.t option ;
-    test_network: (Net_id.t * Time.t) option ;
   }
 
   val info:
-    (unit, unit * block, bool * bool, block_info) RPC.service
+    (unit, unit * block, bool, block_info) RPC.service
   val net:
     (unit, unit * block, unit, Net_id.t) RPC.service
+  val level:
+    (unit, unit * block, unit, Int32.t) RPC.service
   val predecessor:
     (unit, unit * block, unit, Block_hash.t) RPC.service
   val predecessors:
@@ -58,17 +60,14 @@ 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 option) 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
 
   type list_param = {
-    operations: bool ;
+    include_ops: bool ;
-    data: bool ;
     length: int option ;
     heads: Block_hash.t list option ;
     monitor: bool option ;
@@ -179,7 +178,7 @@ end
 
 val forge_block:
   (unit, unit,
-   Net_id.t option * Block_hash.t option * Time.t option *
+   Net_id.t option * Int32.t option * Block_hash.t option * Time.t option *
    Fitness.fitness * Operation_list_list_hash.t * MBytes.t,
    MBytes.t) RPC.service
 

src/node/shell/prevalidation.ml

@@ -135,17 +135,25 @@ let start_prevalidation
     { State.Valid_block.protocol ;
       hash = predecessor ;
       context = predecessor_context ;
-      timestamp = predecessor_timestamp }
+      timestamp = predecessor_timestamp ;
+      fitness = predecessor_fitness ;
+      level = predecessor_level }
     ~timestamp =
   let (module Proto) =
     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
+    ~predecessor_fitness
+    ~predecessor_level
     ~predecessor
-    ~timestamp >>=? fun state ->
+    ~timestamp
+  >>=? fun state ->
   return (State { proto = (module Proto) ; state })
 
 let prevalidate

src/node/shell/prevalidation.mli

@@ -39,4 +39,4 @@ val prevalidate :
   (prevalidation_state * error preapply_result) tzresult Lwt.t
 
 val end_prevalidation :
-  prevalidation_state -> Context.t tzresult Lwt.t
+  prevalidation_state -> Updater.validation_result tzresult Lwt.t

src/node/shell/prevalidator.ml

@@ -54,7 +54,7 @@ type t = {
   operations: unit -> error preapply_result * Operation_hash.Set.t ;
   pending: ?block:State.Valid_block.t -> unit -> Operation_hash.Set.t Lwt.t ;
   timestamp: unit -> Time.t ;
-  context: unit -> Context.t tzresult Lwt.t ;
+  context: unit -> Updater.validation_result tzresult Lwt.t ;
   shutdown: unit -> unit Lwt.t ;
 }
 

src/node/shell/prevalidator.mli

@@ -44,6 +44,6 @@ val inject_operation:
 val flush: t -> State.Valid_block.t -> unit
 val timestamp: t -> Time.t
 val operations: t -> error Prevalidation.preapply_result * Operation_hash.Set.t
-val context: t -> Context.t tzresult Lwt.t
+val context: t -> Updater.validation_result tzresult Lwt.t
 
 val pending: ?block:State.Valid_block.t -> t -> Operation_hash.Set.t Lwt.t

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 ;
@@ -110,7 +110,8 @@ and net_state = {
 and valid_block = {
   net_id: Net_id.t ;
   hash: Block_hash.t ;
-  pred: Block_hash.t ;
+  level: Int32.t ;
+  predecessor: Block_hash.t ;
   timestamp: Time.t ;
   fitness: Protocol.fitness ;
   operations_hash: Operation_list_list_hash.t ;
@@ -118,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 ;
@@ -131,29 +130,20 @@ 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 ;
-    pred = header.shell.predecessor ;
+    level = header.shell.level ;
+    predecessor = header.shell.predecessor ;
     timestamp = header.shell.timestamp ;
     discovery_time ;
-    operations_hash = header.shell.operations ;
+    operations_hash = header.shell.operations_hash ;
     operations ;
     fitness = header.shell.fitness ;
     protocol_hash ;
     protocol ;
-    test_protocol_hash ;
-    test_protocol ;
     test_network ;
     context ;
     successors ;
@@ -540,10 +530,11 @@ module Raw_block_header = struct
   let store_genesis store genesis =
     let shell : Store.Block_header.shell_header = {
       net_id = Net_id.of_block_hash genesis.block;
+      level = 0l ;
       predecessor = genesis.block ;
       timestamp = genesis.time ;
       fitness = [] ;
-      operations = Operation_list_list_hash.empty ;
+      operations_hash = Operation_list_list_hash.empty ;
     } in
     let header =
       { Store.Block_header.shell ; proto = MBytes.create 0 } in
@@ -553,22 +544,23 @@ module Raw_block_header = struct
     Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () ->
     Lwt.return header
 
-  let store_testnet_genesis store genesis =
+  (* let store_testnet_genesis store genesis = *)
-    let shell : Store.Block_header.shell_header = {
+    (* let shell : Store.Block_header.shell_header = { *)
-      net_id = Net_id.of_block_hash genesis.block;
+      (* net_id = Net_id.of_block_hash genesis.block; *)
-      predecessor = genesis.block ;
+      (* level = 0l ; *)
-      timestamp = genesis.time ;
+      (* predecessor = genesis.block ; *)
-      fitness = [] ;
+      (* timestamp = genesis.time ; *)
-      operations = Operation_list_list_hash.empty ;
+      (* fitness = [] ; *)
-    } in
+      (* operations = Operation_list_list_hash.empty ; *)
-    let bytes =
+    (* } in *)
-      Data_encoding.Binary.to_bytes Store.Block_header.encoding {
+    (* let bytes = *)
-        shell ;
+      (* Data_encoding.Binary.to_bytes Store.Block_header.encoding { *)
-        proto = MBytes.create 0 ;
+        (* shell ; *)
-      } in
+        (* proto = MBytes.create 0 ; *)
-    Locked.store_raw store genesis.block bytes >>= fun _created ->
+      (* } in *)
-    Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () ->
+    (* Locked.store_raw store genesis.block bytes >>= fun _created -> *)
-    Lwt.return shell
+    (* Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () -> *)
+    (* Lwt.return shell *)
 
 end
 
@@ -693,9 +685,10 @@ module Block_header = struct
 
   type shell_header = Store.Block_header.shell_header = {
     net_id: Net_id.t ;
+    level: Int32.t ;
     predecessor: Block_hash.t ;
     timestamp: Time.t ;
-    operations: Operation_list_list_hash.t ;
+    operations_hash: Operation_list_list_hash.t ;
     fitness: MBytes.t list ;
   }
 
@@ -852,7 +845,7 @@ module Raw_net = struct
     ~genesis
     ~genesis_block
     ~expiration
-    ~forked_network_ttl
+    ~allow_forked_network
     context_index
     chain_store
     block_header_store
@@ -867,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
@@ -886,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 ->
@@ -896,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
@@ -906,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 ->
@@ -918,7 +912,7 @@ module Raw_net = struct
       ~genesis
       ~genesis_block
       ~expiration
-      ~forked_network_ttl
+      ~allow_forked_network
       context_index
       chain_store
       block_header_store
@@ -932,7 +926,8 @@ module Valid_block = struct
   type t = valid_block = {
     net_id: Net_id.t ;
     hash: Block_hash.t ;
-    pred: Block_hash.t ;
+    level: Int32.t ;
+    predecessor: Block_hash.t ;
     timestamp: Time.t ;
     fitness: Fitness.fitness ;
     operations_hash: Operation_list_list_hash.t ;
@@ -940,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 ;
@@ -996,14 +989,13 @@ module Valid_block = struct
         block_header_store
         (net_state: net_state)
         valid_block_watcher
-        hash context ttl =
+        hash { Updater.context ; message ; fitness } =
       (* Read the block header. *)
       Raw_block_header.Locked.read
         block_header_store hash >>=? fun block ->
       Raw_block_header.Locked.read_discovery_time
         block_header_store hash >>=? fun discovery_time ->
       (* Check fitness coherency. *)
-      Context.get_fitness context >>= fun fitness ->
       fail_unless
         (Fitness.equal fitness block.Store.Block_header.shell.fitness)
         (Invalid_fitness
@@ -1011,37 +1003,21 @@ 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 ... ??? *)
       Operation_list.Locked.read_all
         block_header_store hash >>=? fun operations ->
       (* Let's commit the context. *)
-      Context.commit hash context >>= fun () ->
+      let message =
+        match message with
+        | Some message -> message
+        | None ->
+            Format.asprintf "%a(%ld): %a"
+              Block_hash.pp_short hash
+              block.shell.level
+              Fitness.pp fitness in
+      Context.commit hash block.shell.timestamp message context >>= fun () ->
       (* Update the chain state. *)
       let store = net_state.chain_store in
       let predecessor = block.shell.predecessor in
@@ -1076,7 +1052,7 @@ module Valid_block = struct
     | Error _ -> Lwt.fail Not_found
     | Ok b -> Lwt.return b
 
-  let store net hash context =
+  let store net hash vcontext =
     Shared.use net.state begin fun net_state ->
       Shared.use net.block_header_store begin fun block_header_store ->
         Context.exists net_state.context_index hash >>= function
@@ -1088,7 +1064,7 @@ module Valid_block = struct
             | None ->
                 Locked.store
                   block_header_store net_state net.valid_block_watcher
-                  hash context net.forked_network_ttl >>=? fun valid_block ->
+                  hash vcontext >>=? fun valid_block ->
                 return (Some valid_block)
       end
     end
@@ -1096,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
@@ -1159,10 +1131,10 @@ module Valid_block = struct
           end
         | res -> res in
       let predecessor state b =
-        if Block_hash.equal b.hash b.pred then
+        if Block_hash.equal b.hash b.predecessor then
           Lwt.return None
         else
-          read_opt state b.pred in
+          read_opt state b.predecessor in
       Raw_helpers.iter_predecessors compare predecessor
         (fun b -> b.timestamp) (fun b -> b.fitness)
 
@@ -1320,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
@@ -1342,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 ->
@@ -1358,7 +1330,7 @@ module Net = struct
       ~genesis
       ~genesis_block
       ~expiration
-      ~forked_network_ttl
+      ~allow_forked_network
       context_index
       chain_store
       block_header_store
@@ -1393,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
 
@@ -144,9 +144,10 @@ module Block_header : sig
 
   type shell_header = Store.Block_header.shell_header = {
     net_id: Net_id.t ;
+    level: Int32.t ;
     predecessor: Block_hash.t ;
     timestamp: Time.t ;
-    operations: Operation_list_list_hash.t ;
+    operations_hash: Operation_list_list_hash.t ;
     fitness: MBytes.t list ;
   }
 
@@ -245,7 +246,9 @@ module Valid_block : sig
     (** The genesis of the chain this block belongs to. *)
     hash: Block_hash.t ;
     (** The block hash. *)
-    pred: Block_hash.t ;
+    level: Int32.t ;
+    (** The number of preceding block in the chain. *)
+    predecessor: Block_hash.t ;
     (** The preceding block in the chain. *)
     timestamp: Time.t ;
     (** The date at which this block has been forged. *)
@@ -261,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 ;
@@ -284,7 +281,8 @@ module Valid_block : sig
   val read_opt: Net.t -> Block_hash.t -> valid_block option Lwt.t
   val read_exn: Net.t -> Block_hash.t -> valid_block Lwt.t
   val store:
-    Net.t -> Block_hash.t -> Context.t -> valid_block option tzresult Lwt.t
+    Net.t -> Block_hash.t -> Updater.validation_result ->
+    valid_block option tzresult Lwt.t
 
   val watcher: Net.t -> valid_block Lwt_stream.t * Watcher.stopper
 
@@ -292,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,14 +111,27 @@ 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
           Fitness.pp block.fitness
           Time.pp_hum block.timestamp
           (fun ppf ->
-             if Block_hash.equal head.hash block.pred then
+             if Block_hash.equal head.hash block.predecessor then
                Format.fprintf ppf "same branch"
              else
                Format.fprintf ppf "changing branch") >>= fun () ->
@@ -142,6 +144,22 @@ type error +=
    | Invalid_operation of Operation_hash.t
    | Non_increasing_timestamp
    | Non_increasing_fitness
+   | Wrong_level of Int32.t * Int32.t
+
+let () =
+  register_error_kind
+    `Permanent
+    ~id:"validator.wrong_level"
+    ~title:"Wrong level"
+    ~description:"The block level is not the expected one"
+    ~pp:(fun ppf (e, g) ->
+        Format.fprintf ppf
+          "The declared level %ld is not %ld" g e)
+    Data_encoding.(obj2
+                     (req "expected" int32)
+                     (req "provided" int32))
+    (function Wrong_level (e, g)   -> Some (e, g) | _ -> None)
+    (fun (e, g) -> Wrong_level (e, g))
 
 let apply_block net db
     (pred: State.Valid_block.t) hash (block: State.Block_header.t) =
@@ -151,10 +169,13 @@ let apply_block net db
     Block_hash.pp_short block.shell.predecessor
     Net_id.pp id
   >>= fun () ->
+  fail_unless
+    (Int32.succ pred.level = block.shell.level)
+    (Wrong_level (Int32.succ pred.level, block.shell.level)) >>=? fun () ->
   lwt_log_info "validation of %a: looking for dependencies..."
     Block_hash.pp_short hash >>= fun () ->
   Distributed_db.Operation_list.fetch
-    db (hash, 0) block.shell.operations >>= fun operation_hashes ->
+    db (hash, 0) block.shell.operations_hash >>= fun operation_hashes ->
   Lwt_list.map_p
     (fun op -> Distributed_db.Operation.fetch db op)
     operation_hashes >>= fun operations ->
@@ -181,10 +202,8 @@ let apply_block net db
   begin
     match pred.protocol with
     | None -> fail (State.Unknown_protocol pred.protocol_hash)
-    | Some p ->
+    | Some p -> return p
-       Context.set_timestamp pred.context block.shell.timestamp >>= fun c ->
+  end >>=? fun (module Proto) ->
-       return (p, c)
-  end >>=? fun ((module Proto), patched_context) ->
   lwt_debug "validation of %a: Proto %a"
     Block_hash.pp_short hash
     Protocol_hash.pp_short Proto.hash >>= fun () ->
@@ -200,9 +219,12 @@ 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:patched_context
+    ~predecessor_context:context
     ~predecessor_timestamp:pred.timestamp
+    ~predecessor_fitness:pred.fitness
     block >>=? fun state ->
   fold_left_s (fun state op ->
       Proto.apply_operation state op >>=? fun state ->
@@ -466,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
@@ -550,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 ;
@@ -567,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
@@ -619,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
@@ -750,10 +800,9 @@ let create_worker state db =
     let net_id = State.Net.id net in
     lwt_log_notice "activate network %a"
       Net_id.pp net_id >>= fun () ->
-    State.Valid_block.Current.genesis net >>= fun genesis ->
     get net_id >>= function
     | Error _ ->
-        let v = create_validator ?parent worker state db net in
+        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/protocol.mli

@@ -9,11 +9,10 @@
 
 (** Tezos Protocol Environment - Protocol Implementation Signature *)
 
-(** The score of a block as a sequence of as unsigned bytes. Ordered
+(* See `src/proto/updater.mli` for documentation. *)
-    by length and then by contents lexicographically. *)
+
 type fitness = Fitness.fitness
 
-(** The version agnostic toplevel structure of operations. *)
 type shell_operation = Store.Operation.shell_header = {
   net_id: Net_id.t ;
 }
@@ -23,20 +22,13 @@ type raw_operation = Store.Operation.t = {
   proto: MBytes.t ;
 }
 
-(** The version agnostic toplevel structure of blocks. *)
 type shell_block = Store.Block_header.shell_header =
   { net_id: Net_id.t ;
-    (** The genesis of the chain this block belongs to. *)
+    level: Int32.t ;
     predecessor: Block_hash.t ;
-    (** The preceding block in the chain. *)
     timestamp: Time.t ;
-    (** The date at which this block has been forged. *)
+    operations_hash: Operation_list_list_hash.t ;
-    operations: Operation_list_list_hash.t ;
-    (** The sequence of operations. *)
     fitness: MBytes.t list ;
-    (** The announced score of the block. As a sequence of sequences
-        of unsigned bytes. Ordered by length and then by contents
-        lexicographically. *)
   }
 
 type raw_block = Store.Block_header.t = {
@@ -44,96 +36,61 @@ type raw_block = Store.Block_header.t = {
   proto: MBytes.t ;
 }
 
-(** This is the signature of a Tezos protocol implementation. It has
+type validation_result = {
-    access to the standard library and the Environment module. *)
+  context: Context.t ;
+  fitness: Fitness.fitness ;
+  message: string option ;
+}
+
+type rpc_context = {
+  context: Context.t ;
+  level: Int32.t ;
+  timestamp: Time.t ;
+  fitness: Fitness.fitness ;
+}
+
 module type PROTOCOL = sig
 
   type error = ..
   type 'a tzresult = ('a, error list) result
 
-  (** The version specific type of operations. *)
-  type operation
-
-  (** The maximum size of operations in bytes *)
   val max_operation_data_length : int
-
-  (** The maximum size of block headers in bytes *)
   val max_block_length : int
-
-  (** The maximum *)
   val max_number_of_operations : int
 
-  (** The parsing / preliminary validation function for
+  type operation
-      operations. Similar to {!parse_block}. *)
+
   val parse_operation :
     Operation_hash.t -> raw_operation -> operation tzresult
-
-  (** Basic ordering of operations. [compare_operations op1 op2] means
-      that [op1] should appear before [op2] in a block. *)
   val compare_operations : operation -> operation -> int
 
-  (** A functional state that is transmitted through the steps of a
-      block validation sequence. It must retain the current state of
-      the store (that can be extracted from the outside using
-      {!current_context}, and whose final value is produced by
-      {!finalize_block}). It can also contain the information that
-      must be remembered during the validation, which must be
-      immutable (as validator or baker implementations are allowed to
-      pause, replay or backtrack during the validation process). *)
   type validation_state
-
-  (** Access the context at a given validation step. *)
   val current_context : validation_state -> Context.t tzresult Lwt.t
-
-  (** Checks that a block is well formed in a given context. This
-      function should run quickly, as its main use is to reject bad
-      blocks from the network as early as possible. The input context
-      is the one resulting of an ancestor block of same protocol
-      version, not necessarily the one of its predecessor. *)
   val precheck_block :
     ancestor_context: Context.t ->
     ancestor_timestamp: Time.t ->
     raw_block ->
     unit tzresult Lwt.t
-
-  (** The first step in a block validation sequence. Initializes a
-      validation context for validating a block. Takes as argument the
-      {!raw_block} to initialize the context for this block, patching
-      the context resulting of the application of the predecessor
-      block passed as parameter. The function {!precheck_block} may
-      not have been called before [begin_application], so all the
-      check performed by the former must be repeated in the latter. *)
   val begin_application :
     predecessor_context: Context.t ->
     predecessor_timestamp: Time.t ->
+    predecessor_fitness: Fitness.fitness ->
     raw_block ->
     validation_state tzresult Lwt.t
-
-  (** Initializes a validation context for constructing a new block
-      (as opposed to validating an existing block). Since there is no
-      {!raw_block} header available, the parts that it provides are
-      passed as arguments (predecessor block hash, context resulting
-      of the application of the predecessor block, and timestamp). *)
   val begin_construction :
     predecessor_context: Context.t ->
     predecessor_timestamp: Time.t ->
+    predecessor_level: Int32.t ->
+    predecessor_fitness: Fitness.fitness ->
     predecessor: Block_hash.t ->
     timestamp: Time.t ->
     validation_state tzresult Lwt.t
-
-  (** Called after {!begin_application} (or {!begin_construction}) and
-      before {!finalize_block}, with each operation in the block. *)
   val apply_operation :
     validation_state -> operation -> validation_state tzresult Lwt.t
-
-  (** The last step in a block validation sequence. It produces the
-      context that will be used as input for the validation of its
-      successor block candidates. *)
   val finalize_block :
-    validation_state -> Context.t tzresult Lwt.t
+    validation_state -> validation_result tzresult Lwt.t
 
-  (** The list of remote procedures exported by this implementation *)
+  val rpc_services : rpc_context RPC.directory
-  val rpc_services : Context.t RPC.directory
 
   val configure_sandbox :
     Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t

src/node/updater/register.ml

@@ -41,15 +41,19 @@ let register (module Proto : Protocol.PACKED_PROTOCOL) =
         raw_block >|= wrap_error
     let begin_application
         ~predecessor_context ~predecessor_timestamp
+        ~predecessor_fitness
         raw_block =
       begin_application
         ~predecessor_context ~predecessor_timestamp
+        ~predecessor_fitness
         raw_block >|= wrap_error
     let begin_construction
         ~predecessor_context ~predecessor_timestamp
+        ~predecessor_level ~predecessor_fitness
         ~predecessor ~timestamp =
       begin_construction
         ~predecessor_context ~predecessor_timestamp
+        ~predecessor_level ~predecessor_fitness
         ~predecessor ~timestamp >|= wrap_error
     let current_context c =
       current_context c >|= wrap_error

src/node/updater/updater.ml

@@ -11,6 +11,19 @@ open Logging.Updater
 
 let (//) = Filename.concat
 
+type validation_result = Protocol.validation_result = {
+  context: Context.t ;
+  fitness: Fitness.fitness ;
+  message: string option ;
+}
+
+type rpc_context = Protocol.rpc_context = {
+  context: Context.t ;
+  level: Int32.t ;
+  timestamp: Time.t ;
+  fitness: Fitness.fitness ;
+}
+
 module type PROTOCOL = Protocol.PROTOCOL
 module type REGISTRED_PROTOCOL = sig
   val hash: Protocol_hash.t
@@ -30,20 +43,13 @@ type raw_operation = Store.Operation.t = {
 }
 let raw_operation_encoding = Store.Operation.encoding
 
-(** The version agnostic toplevel structure of blocks. *)
 type shell_block = Store.Block_header.shell_header = {
   net_id: Net_id.t ;
-  (** The genesis of the chain this block belongs to. *)
+  level: Int32.t ;
   predecessor: Block_hash.t ;
-  (** The preceding block in the chain. *)
   timestamp: Time.t ;
-  (** The date at which this block has been forged. *)
+  operations_hash: Operation_list_list_hash.t ;
-  operations: Operation_list_list_hash.t ;
-  (** The sequence of operations. *)
   fitness: MBytes.t list ;
-  (** The announced score of the block. As a sequence of sequences
-      of unsigned bytes. Ordered by length and then by contents
-      lexicographically. *)
 }
 let shell_block_encoding = Store.Block_header.shell_header_encoding
 
@@ -65,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

@@ -18,20 +18,13 @@ type raw_operation = Store.Operation.t = {
 }
 val raw_operation_encoding: raw_operation Data_encoding.t
 
-(** The version agnostic toplevel structure of blocks. *)
 type shell_block = Store.Block_header.shell_header = {
   net_id: Net_id.t ;
-  (** The genesis of the chain this block belongs to. *)
+  level: Int32.t ;
   predecessor: Block_hash.t ;
-  (** The preceding block in the chain. *)
   timestamp: Time.t ;
-  (** The date at which this block has been forged. *)
+  operations_hash: Operation_list_list_hash.t ;
-  operations: Operation_list_list_hash.t ;
-  (** The sequence of operations. *)
   fitness: MBytes.t list ;
-  (** The announced score of the block. As a sequence of sequences
-      of unsigned bytes. Ordered by length and then by contents
-      lexicographically. *)
 }
 val shell_block_encoding: shell_block Data_encoding.t
 
@@ -41,6 +34,19 @@ type raw_block = Store.Block_header.t = {
 }
 val raw_block_encoding: raw_block Data_encoding.t
 
+type validation_result = Protocol.validation_result = {
+  context: Context.t ;
+  fitness: Fitness.fitness ;
+  message: string option ;
+}
+
+type rpc_context = Protocol.rpc_context = {
+  context: Context.t ;
+  level: Int32.t ;
+  timestamp: Time.t ;
+  fitness: Fitness.fitness ;
+}
+
 module type PROTOCOL = Protocol.PROTOCOL
 module type REGISTRED_PROTOCOL = sig
   val hash: Protocol_hash.t
@@ -60,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
@@ -133,12 +134,13 @@ let record_ballot ctxt delegate proposal ballot =
   | Testing | Proposal ->
       fail Unexpected_ballot
 
-let first_of_a_voting_period l =
+let last_of_a_voting_period ctxt l =
-  Compare.Int32.(l.Level.voting_period_position = 0l)
+  Compare.Int32.(Int32.succ l.Level.voting_period_position =
+                 Constants.voting_period_length ctxt )
 
 let may_start_new_voting_cycle ctxt =
-  Level.current ctxt >>=? fun level ->
+  let level = Level.current ctxt in
-  if first_of_a_voting_period level then
+  if last_of_a_voting_period ctxt level then
     start_new_voting_cycle ctxt
   else
     return ctxt

src/proto/alpha/apply.ml

@@ -51,19 +51,19 @@ let apply_delegate_operation_content
         (Block_hash.equal block pred_block)
         (Wrong_endorsement_predecessor (pred_block, block)) >>=? fun () ->
       Mining.check_signing_rights ctxt slot delegate >>=? fun () ->
-      Fitness.increase ctxt >>=? fun ctxt ->
+      let ctxt = Fitness.increase ctxt in
       Mining.pay_endorsement_bond ctxt delegate >>=? fun (ctxt, bond) ->
       Mining.endorsement_reward ~block_priority >>=? fun reward ->
-      Level.current ctxt >>=? fun { cycle = current_cycle } ->
+      let { cycle = current_cycle } : Level.t = Level.current ctxt in
       Lwt.return Tez.(reward +? bond) >>=? fun full_reward ->
       Reward.record ctxt delegate current_cycle full_reward
   | Proposals { period ; proposals } ->
-      Level.current ctxt >>=? fun level ->
+      let level = Level.current ctxt in
       fail_unless Voting_period.(level.voting_period = period)
         (Wrong_voting_period (level.voting_period, period)) >>=? fun () ->
       Amendment.record_proposals ctxt delegate proposals
   | Ballot { period ; proposal ; ballot } ->
-      Level.current ctxt >>=? fun level ->
+      let level = Level.current ctxt in
       fail_unless Voting_period.(level.voting_period = period)
         (Wrong_voting_period (level.voting_period, period)) >>=? fun () ->
       Amendment.record_ballot ctxt delegate proposal ballot
@@ -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 =
@@ -228,17 +229,14 @@ let apply_operation
 let may_start_new_cycle ctxt =
   Mining.dawn_of_a_new_cycle ctxt >>=? function
   | None -> return ctxt
-  | Some new_cycle ->
+  | Some last_cycle ->
-      let last_cycle =
+      let new_cycle = Cycle.succ last_cycle in
-        match Cycle.pred new_cycle with
-        | None -> assert false
-        | Some last_cycle -> last_cycle in
       Bootstrap.refill ctxt >>=? fun ctxt ->
       Seed.clear_cycle ctxt last_cycle >>=? fun ctxt ->
       Seed.compute_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt ->
       Roll.clear_cycle ctxt last_cycle >>=? fun ctxt ->
       Roll.freeze_rolls_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt ->
-      Timestamp.get_current ctxt >>= fun timestamp ->
+      let timestamp = Timestamp.current ctxt in
       Lwt.return (Timestamp.(timestamp +? (Constants.time_before_reward ctxt)))
       >>=? fun reward_date ->
       Reward.set_reward_time_for_cycle
@@ -254,28 +252,20 @@ let begin_application ctxt block pred_timestamp =
   Mining.check_mining_rights ctxt block pred_timestamp >>=? fun miner ->
   Mining.check_signature ctxt block miner >>=? fun () ->
   Mining.pay_mining_bond ctxt block miner >>=? fun ctxt ->
-  Fitness.increase ctxt >>=? fun ctxt ->
+  let ctxt = Fitness.increase ctxt in
   return (ctxt, miner)
 
-let finalize_application ctxt block miner op_count =
+let finalize_application ctxt block miner =
   (* end of level (from this point nothing should fail) *)
-  let priority = block.Block.proto.mining_slot.priority in
+  let priority = block.Block.proto.priority in
   let reward = Mining.base_mining_reward ctxt ~priority in
   Nonce.record_hash ctxt
     miner reward block.proto.seed_nonce_hash >>=? fun ctxt ->
   Reward.pay_due_rewards ctxt >>=? fun ctxt ->
-  Level.increment_current ctxt >>=? fun ctxt ->
   (* end of cycle *)
   may_start_new_cycle ctxt >>=? fun ctxt ->
   Amendment.may_start_new_voting_cycle ctxt >>=? fun ctxt ->
-  Level.current ctxt >>=? fun { level } ->
+  return ctxt
-  let level = Raw_level.to_int32 level in
-  Fitness.get ctxt >>=? fun fitness ->
-  let commit_message =
-    Format.asprintf
-      "lvl %ld, fit %Ld, prio %ld, %d ops"
-      level fitness priority op_count in
-  return (commit_message, ctxt)
 
 let compare_operations op1 op2 =
   match op1.contents, op2.contents with

src/proto/alpha/block_repr.ml

@@ -19,37 +19,23 @@ type header = {
 }
 
 and proto_header = {
-  mining_slot: mining_slot ;
+  priority: int ;
   seed_nonce_hash: Nonce_hash.t ;
   proof_of_work_nonce: MBytes.t ;
 }
 
-and mining_slot = {
-  level: Raw_level_repr.t ;
-  priority: Int32.t ;
-}
-
-let mining_slot_encoding =
-  let open Data_encoding in
-  conv
-    (fun { level ; priority } -> level, priority)
-    (fun (level, priority) -> { level ; priority })
-    (obj2
-       (req "level" Raw_level_repr.encoding)
-       (req "proprity" int32))
-
 let proto_header_encoding =
   let open Data_encoding in
   conv
-    (fun { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } ->
+    (fun { priority ; seed_nonce_hash ; proof_of_work_nonce } ->
-       (mining_slot, (seed_nonce_hash, proof_of_work_nonce)))
+       (priority, seed_nonce_hash, proof_of_work_nonce))
-    (fun (mining_slot, (seed_nonce_hash, proof_of_work_nonce)) ->
+    (fun (priority, seed_nonce_hash, proof_of_work_nonce) ->
-       { mining_slot ; seed_nonce_hash ; proof_of_work_nonce })
+       { priority ; seed_nonce_hash ; proof_of_work_nonce })
-    (merge_objs
+    (obj3
-       mining_slot_encoding
+      (req "priority" uint16)
-       (obj2
+      (req "seed_nonce_hash" Nonce_hash.encoding)
-          (req "seed_nonce_hash" Nonce_hash.encoding)
+      (req "proof_of_work_nonce"
-          (req "proof_of_work_nonce" (Fixed.bytes Constants_repr.proof_of_work_nonce_size))))
+         (Fixed.bytes Constants_repr.proof_of_work_nonce_size)))
 
 let signed_proto_header_encoding =
   let open Data_encoding in
@@ -76,13 +62,15 @@ type error +=
   | Cant_parse_proto_header
 
 let parse_header
-    ({ shell = { net_id ; predecessor ; timestamp ; fitness ; operations } ;
+    ({ shell = { net_id ; level ; predecessor ;
+                 timestamp ; fitness ; operations_hash } ;
        proto } : Updater.raw_block) : header tzresult =
   match Data_encoding.Binary.of_bytes signed_proto_header_encoding proto with
   | None -> Error [Cant_parse_proto_header]
   | Some (proto, signature) ->
       let shell =
-        { Updater.net_id ; predecessor ; timestamp ; fitness ; operations } in
+        { Updater.net_id ; level ; predecessor ;
+          timestamp ; fitness ; operations_hash } in
       Ok { shell ; proto ; signature }
 
 let forge_header shell proto =

src/proto/alpha/block_repr.mli

@@ -17,18 +17,11 @@ type header = {
 }
 
 and proto_header = {
-  mining_slot: mining_slot ;
+  priority: int ;
   seed_nonce_hash: Nonce_hash.t ;
   proof_of_work_nonce: MBytes.t ;
 }
 
-and mining_slot = {
-  level: Raw_level_repr.t ;
-  priority: Int32.t ;
-}
-
-val mining_slot_encoding: mining_slot Data_encoding.encoding
-
 (** The maximum size of block headers in bytes *)
 val max_header_length: int
 

src/proto/alpha/constants_repr.ml

@@ -38,7 +38,7 @@ type constants = {
   voting_period_length: int32 ;
   time_before_reward: Period_repr.t ;
   slot_durations: Period_repr.t list ;
-  first_free_mining_slot: int32 ;
+  first_free_mining_slot: int ;
   max_signing_slot: int ;
   instructions_per_transaction: int ;
   proof_of_work_threshold: int64 ;
@@ -58,7 +58,7 @@ let default = {
     Int64.(mul 365L (mul 24L 3600L)) ;
   slot_durations =
     List.map Period_repr.of_seconds_exn [ 60L ] ;
-  first_free_mining_slot = 16l ;
+  first_free_mining_slot = 16 ;
   max_signing_slot = 15 ;
   instructions_per_transaction = 16 * 1024 ;
   proof_of_work_threshold =
@@ -103,7 +103,7 @@ let constants_encoding =
          opt Compare_slot_durations.(=)
            default.slot_durations c.slot_durations
        and first_free_mining_slot =
-         opt Compare.Int32.(=)
+         opt Compare.Int.(=)
            default.first_free_mining_slot c.first_free_mining_slot
        and max_signing_slot =
          opt Compare.Int.(=)
@@ -171,8 +171,8 @@ let constants_encoding =
             (opt "voting_period_length" int32)
             (opt "time_before_reward" int64)
             (opt "slot_durations" (list Period_repr.encoding))
-            (opt "first_free_mining_slot" int32)
+            (opt "first_free_mining_slot" uint16)
-            (opt "max_signing_slot" int31)
+            (opt "max_signing_slot" uint16)
             (opt "instructions_per_transaction" int31)
             (opt "proof_of_work_threshold" int64)
             (opt "bootstrap_keys" (list Ed25519.Public_key.encoding))

src/proto/alpha/fitness_repr.ml

@@ -16,9 +16,9 @@ let int64_to_bytes i =
 
 let int64_of_bytes b =
   if Compare.Int.(MBytes.length b <> 8) then
-    fail Invalid_fitness
+    error Invalid_fitness
   else
-    return (MBytes.get_int64 b 0)
+    ok (MBytes.get_int64 b 0)
 
 let from_int64 fitness =
   [ MBytes.of_string Constants_repr.version_number ;
@@ -30,5 +30,5 @@ let to_int64 = function
     when Compare.String.
            (MBytes.to_string version = Constants_repr.version_number) ->
       int64_of_bytes fitness
-  | [] -> return 0L
+  | [] -> ok 0L
-  | _ -> fail Invalid_fitness
+  | _ -> error Invalid_fitness

src/proto/alpha/fitness_storage.ml

@@ -7,17 +7,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-let get ctxt =
+let current = Storage.current_fitness
-  Storage.get_fitness ctxt >>= fun fitness ->
-  Fitness_repr.to_int64 fitness
-
-let set ctxt v =
-  Storage.set_fitness ctxt (Fitness_repr.from_int64 v) >>= fun ctxt ->
-  Lwt.return ctxt
-
 let increase ctxt =
-  get ctxt >>=? fun v ->
+  let fitness = current ctxt in
-  set ctxt (Int64.succ v) >>= fun ctxt ->
+  Storage.set_current_fitness ctxt (Int64.succ fitness)
-  return ctxt
-
-let init ctxt = set ctxt 0L

src/proto/alpha/init_storage.ml

@@ -7,25 +7,9 @@
 (*                                                                        *)
 (**************************************************************************)
 
-let version_key = ["version"]
-
-(* This key should always be populated for every version of the
-   protocol.  It's absence meaning that the context is empty. *)
-let version_value = "alpha"
-
 (* This is the genesis protocol: initialise the state *)
-let initialize ~from_genesis (ctxt:Context.t) =
+let initialize store =
-  Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
-  Storage.prepare ctxt >>=? fun store ->
-  begin
-    if from_genesis then
-      Lwt.return store
-    else
-      Fitness_storage.init store
-  end >>= fun store ->
-  Level_storage.init store >>=? fun store ->
   Roll_storage.init store >>=? fun store ->
-  Nonce_storage.init store >>=? fun store ->
   Seed_storage.init store >>=? fun store ->
   Contract_storage.init store >>=? fun store ->
   Reward_storage.init store >>=? fun store ->
@@ -38,34 +22,25 @@ let initialize ~from_genesis (ctxt:Context.t) =
   return store
 
 type error +=
-  | Incompatiple_protocol_version
   | Unimplemented_sandbox_migration
 
-let may_initialize ctxt =
+let may_initialize ctxt ~level ~timestamp ~fitness =
-  Context.get ctxt version_key >>= function
+  Storage.prepare ~level ~timestamp ~fitness ctxt >>=? fun (ctxt, first_block) ->
-  | None ->
+  if first_block then
-      (* This is the genesis protocol: The only acceptable preceding
+    initialize ctxt
-         version is an empty context *)
+  else
-      initialize ~from_genesis:false ctxt
+    return ctxt
-  | Some bytes ->
-      let s = MBytes.to_string bytes in
-      if Compare.String.(s = version_value)
-      then Storage.prepare ctxt
-      else if Compare.String.(s = "genesis") then
-        initialize ~from_genesis:true ctxt
-      else fail Incompatiple_protocol_version
 
 let configure_sandbox ctxt json =
   let json =
     match json with
     | None -> `O []
     | Some json -> json in
-  Context.get ctxt version_key >>= function
+  Storage.is_first_block ctxt >>=? function
-  | None ->
+  | true ->
       Storage.set_sandboxed ctxt json >>= fun ctxt ->
-      initialize ~from_genesis:false ctxt >>=? fun ctxt ->
+      return ctxt
-      return (Storage.recover ctxt)
+  | false ->
-  | Some _ ->
       Storage.get_sandboxed ctxt >>=? function
       | None ->
           fail Unimplemented_sandbox_migration

src/proto/alpha/level_repr.ml

@@ -10,6 +10,7 @@
 
 type t = {
   level: Raw_level_repr.t ;
+  level_position: int32 ;
   cycle: Cycle_repr.t ;
   cycle_position: int32 ;
   voting_period: Voting_period_repr.t ;
@@ -22,47 +23,58 @@ let pp ppf { level } = Raw_level_repr.pp ppf level
 
 let pp_full ppf l =
   Format.fprintf ppf
-    "%a (cycle %a.%ld) (vote %a.%ld)"
+    "%a.%ld (cycle %a.%ld) (vote %a.%ld)"
-    Raw_level_repr.pp l.level
+    Raw_level_repr.pp l.level l.level_position
     Cycle_repr.pp l.cycle l.cycle_position
     Voting_period_repr.pp l.voting_period l.voting_period_position
 
 let encoding =
   let open Data_encoding in
   conv
-    (fun { level ; cycle ; cycle_position ;
+    (fun { level ; level_position ;
+           cycle ; cycle_position ;
            voting_period; voting_period_position } ->
-      (level, cycle, cycle_position,
+      (level, level_position,
+       cycle, cycle_position,
        voting_period, voting_period_position))
-    (fun (level, cycle, cycle_position,
+    (fun (level, level_position,
+          cycle, cycle_position,
           voting_period, voting_period_position) ->
-       { level ; cycle ; cycle_position ;
+      { level ; level_position ;
+        cycle ; cycle_position ;
          voting_period ; voting_period_position })
-    (obj5
+    (obj6
        (req "level" Raw_level_repr.encoding)
+       (req "level_position" int32)
        (req "cycle" Cycle_repr.encoding)
        (req "cycle_position" int32)
        (req "voting_period" Voting_period_repr.encoding)
        (req "voting_period_position" int32))
 
-let root =
+let root first_level =
-  { level = Raw_level_repr.root ;
+  { level = first_level ;
+    level_position = 0l ;
     cycle = Cycle_repr.root ;
     cycle_position = 0l ;
     voting_period = Voting_period_repr.root ;
     voting_period_position = 0l ;
   }
 
-let from_raw ~cycle_length ~voting_period_length level =
+let from_raw ~first_level ~cycle_length ~voting_period_length level =
   let raw_level = Raw_level_repr.to_int32 level in
-  let cycle = Cycle_repr.of_int32_exn (Int32.div raw_level cycle_length) in
+  let first_level = Raw_level_repr.to_int32 first_level in
-  let cycle_position = Int32.rem raw_level cycle_length in
+  let level_position =
+    Compare.Int32.max 0l (Int32.sub raw_level first_level) in
+  let cycle =
+    Cycle_repr.of_int32_exn (Int32.div level_position cycle_length) in
+  let cycle_position = Int32.rem level_position cycle_length in
   let voting_period =
     Voting_period_repr.of_int32_exn
-      (Int32.div raw_level voting_period_length) in
+      (Int32.div level_position voting_period_length) in
   let voting_period_position =
-    Int32.rem raw_level voting_period_length in
+    Int32.rem level_position voting_period_length in
-  { level ; cycle ; cycle_position ;
+  { level ; level_position ;
+    cycle ; cycle_position ;
     voting_period ; voting_period_position }
 
 let diff { level = l1 } { level = l2 } =

src/proto/alpha/level_repr.mli

@@ -9,6 +9,7 @@
 
 type t = private {
   level: Raw_level_repr.t ;
+  level_position: int32 ;
   cycle: Cycle_repr.t ;
   cycle_position: int32 ;
   voting_period: Voting_period_repr.t ;
@@ -21,10 +22,12 @@ val pp: Format.formatter -> level -> unit
 val pp_full: Format.formatter -> level -> unit
 include Compare.S with type t := level
 
-val root: level
+val root: Raw_level_repr.t -> level
 
 val from_raw:
-  cycle_length:int32 -> voting_period_length:int32 ->
+  first_level:Raw_level_repr.t ->
+  cycle_length:int32 ->
+  voting_period_length:int32 ->
   Raw_level_repr.t -> level
 
 val diff: level -> level -> int32

src/proto/alpha/level_storage.ml

@@ -15,31 +15,29 @@ let from_raw c ?offset l =
     | None -> l
     | Some o -> Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o)) in
   let constants = Storage.constants c in
+  let first_level = Storage.first_level c in
   Level_repr.from_raw
+    ~first_level
     ~cycle_length:constants.Constants_repr.cycle_length
     ~voting_period_length:constants.Constants_repr.voting_period_length
     l
 
+let root c =
+  Level_repr.root (Storage.first_level c)
+
 let succ c l = from_raw c (Raw_level_repr.succ l.level)
 let pred c l =
   match Raw_level_repr.pred l.Level_repr.level with
   | None -> None
   | Some l -> Some (from_raw c l)
 
-let current ctxt =
+let current ctxt = Storage.current_level ctxt
-  Storage.Current_level.get ctxt >>=? fun l ->
-  return (from_raw ctxt l)
 
 let previous ctxt =
-  current ctxt >>=? fun l ->
+  let l = current ctxt in
   match pred ctxt l with
-  | None -> assert false (* Context inited with level = 1. *)
+  | None -> assert false (* We never validate the Genesis... *)
-  | Some p -> return p
+  | Some p -> p
-
-let increment_current ctxt =
-  Storage.Current_level.get ctxt >>=? fun l ->
-  Storage.Current_level.set ctxt (Raw_level_repr.succ l)
-
 
 let first_level_in_cycle ctxt c =
   let constants = Storage.constants ctxt in
@@ -60,8 +58,3 @@ let levels_in_cycle ctxt c =
     else acc
   in
   loop first []
-
-let init ctxt =
-  Storage.Current_level.init ctxt Raw_level_repr.(succ root)
-
-

src/proto/alpha/level_storage.mli

@@ -7,11 +7,10 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val init: Storage.t -> Storage.t tzresult Lwt.t
+val current: Storage.t -> Level_repr.t
+val previous: Storage.t -> Level_repr.t
 
-val increment_current: Storage.t -> Storage.t tzresult Lwt.t
+val root: Storage.t -> Level_repr.t
-val current: Storage.t -> Level_repr.t tzresult Lwt.t
-val previous: Storage.t -> Level_repr.t tzresult Lwt.t
 
 val from_raw: Storage.t -> ?offset:int32 -> Raw_level_repr.t -> Level_repr.t
 val pred: Storage.t -> Level_repr.t -> Level_repr.t option

src/proto/alpha/main.ml

@@ -34,7 +34,7 @@ type validation_state =
     op_count : int }
 
 let current_context { ctxt } =
-  Tezos_context.finalize ctxt
+  return (Tezos_context.finalize ctxt).context
 
 let precheck_block
     ~ancestor_context:_
@@ -47,9 +47,13 @@ let precheck_block
 let begin_application
     ~predecessor_context:ctxt
     ~predecessor_timestamp:pred_timestamp
+    ~predecessor_fitness:pred_fitness
     raw_block =
   Lwt.return (Tezos_context.Block.parse_header raw_block) >>=? fun header ->
-  Tezos_context.init ctxt >>=? fun ctxt ->
+  let level = header.shell.level in
+  let fitness = pred_fitness in
+  let timestamp = header.shell.timestamp in
+  Tezos_context.init ~level ~timestamp ~fitness ctxt >>=? fun ctxt ->
   Apply.begin_application ctxt header pred_timestamp >>=? fun (ctxt, miner) ->
   let mode = Application (header, miner) in
   return { mode ; ctxt ; op_count = 0 }
@@ -57,21 +61,25 @@ let begin_application
 let begin_construction
     ~predecessor_context:ctxt
     ~predecessor_timestamp:_
+    ~predecessor_level:pred_level
+    ~predecessor_fitness:pred_fitness
     ~predecessor:pred_block
     ~timestamp =
   let mode = Construction { pred_block ; timestamp } in
-  Tezos_context.init ctxt >>=? fun ctxt ->
+  let level = Int32.succ pred_level in
-  Apply.begin_construction ctxt >>=? fun ctxt ->
+  let fitness = pred_fitness in
+  Tezos_context.init ~timestamp ~level ~fitness ctxt >>=? fun ctxt ->
+  let ctxt = Apply.begin_construction ctxt in
   return { mode ; ctxt ; op_count = 0 }
 
 let apply_operation ({ mode ; ctxt ; op_count } as data) operation =
   let pred_block, block_prio, miner_contract =
     match mode with
     | Construction { pred_block } ->
-        pred_block, 0l, None
+        pred_block, 0, None
     | Application (block, delegate) ->
         block.shell.predecessor,
-        block.proto.mining_slot.priority,
+        block.proto.priority,
         Some (Tezos_context.Contract.default_contract delegate) in
   Apply.apply_operation
     ctxt miner_contract pred_block block_prio operation
@@ -81,12 +89,20 @@ let apply_operation ({ mode ; ctxt ; op_count } as data) operation =
 
 let finalize_block { mode ; ctxt ; op_count } = match mode with
   | Construction _ ->
-      Tezos_context.finalize ctxt >>=? fun ctxt ->
+      let ctxt = Tezos_context.finalize ctxt in
       return ctxt
   | Application (block, miner) ->
-      Apply.finalize_application
+      Apply.finalize_application ctxt block miner >>=? fun ctxt ->
-        ctxt block miner op_count >>=? fun (commit_message, ctxt) ->
+      let { level } : Tezos_context.Level.t =
-      Tezos_context.finalize ~commit_message ctxt >>=? fun ctxt ->
+        Tezos_context. Level.current ctxt in
+      let priority = block.proto.priority in
+      let level = Tezos_context.Raw_level.to_int32 level in
+      let fitness = Tezos_context.Fitness.current ctxt in
+      let commit_message =
+        Format.asprintf
+          "lvl %ld, fit %Ld, prio %d, %d ops"
+          level fitness priority op_count in
+      let ctxt = Tezos_context.finalize ~commit_message ctxt in
       return ctxt
 
 let compare_operations op1 op2 =

src/proto/alpha/mining.ml

@@ -14,7 +14,6 @@ open Misc
 type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
 type error += Invalid_endorsement_slot of int * int (* `Permanent *)
 type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *)
-type error += Wrong_level of Raw_level.t * Raw_level.t (* `Permanent *)
 type error += Wrong_delegate of public_key_hash * public_key_hash (* `Permanent *)
 type error += Cannot_pay_mining_bond (* `Permanent *)
 type error += Cannot_pay_endorsement_bond (* `Permanent *)
@@ -60,20 +59,6 @@ let () =
                      (req "provided" int16))
     (function Invalid_endorsement_slot (m, g)   -> Some (m, g) | _ -> None)
     (fun (m, g) -> Invalid_endorsement_slot (m, g)) ;
-  register_error_kind
-    `Permanent
-    ~id:"mining.wrong_level"
-    ~title:"Wrong level"
-    ~description:"The block level is not the expected one"
-    ~pp:(fun ppf (e, g) ->
-        Format.fprintf ppf
-          "The declared level %a is not %a"
-          Raw_level.pp g Raw_level.pp e)
-    Data_encoding.(obj2
-                     (req "expected" Raw_level.encoding)
-                     (req "provided" Raw_level.encoding))
-    (function Wrong_level (e, g)   -> Some (e, g) | _ -> None)
-    (fun (e, g) -> Wrong_level (e, g)) ;
   register_error_kind
     `Permanent
     ~id:"mining.wrong_delegate"
@@ -110,6 +95,7 @@ let () =
     (fun () -> Cannot_pay_endorsement_bond)
 
 let minimal_time c priority pred_timestamp =
+  let priority = Int32.of_int priority in
   let rec cumsum_slot_durations acc durations p =
     if Compare.Int32.(<=) p 0l then
       ok acc
@@ -128,26 +114,19 @@ let minimal_time c priority pred_timestamp =
 
 let check_timestamp c priority pred_timestamp =
   minimal_time c priority pred_timestamp >>=? fun minimal_time ->
-  Tezos_context.Timestamp.get_current c >>= fun timestamp ->
+  let timestamp = Tezos_context.Timestamp.current c in
   fail_unless Timestamp.(minimal_time <= timestamp)
     (Timestamp_too_early (minimal_time, timestamp))
 
-let check_mining_rights c
+let check_mining_rights c { Block.proto = { priority } }
-    { Block.proto = { mining_slot = { level = raw_level ; priority } } }
     pred_timestamp =
-  Level.current c >>=? fun current_level ->
+  let level = Level.current c in
-  fail_unless
-    Raw_level.(raw_level = current_level.level)
-    (Wrong_level (current_level.Level.level, raw_level)) >>=? fun () ->
-  let level = Level.from_raw c raw_level in
   Roll.mining_rights_owner c level ~priority >>=? fun delegate ->
   check_timestamp c priority pred_timestamp >>=? fun () ->
   return delegate
 
-let pay_mining_bond c
+let pay_mining_bond c { Block.proto = { priority } } id =
-    { Block.proto = { mining_slot = { priority} } }
+  if Compare.Int.(priority >= Constants.first_free_mining_slot c)
-    id =
-  if Compare.Int32.(priority >= Constants.first_free_mining_slot c)
   then return c
   else
     Contract.spend c (Contract.default_contract id) Constants.mining_bond_cost
@@ -162,13 +141,13 @@ let pay_endorsement_bond c id =
 let check_signing_rights c slot delegate =
   fail_unless Compare.Int.(0 <= slot && slot <= Constants.max_signing_slot c)
     (Invalid_endorsement_slot (Constants.max_signing_slot c, slot)) >>=? fun () ->
-  Level.current c >>=? fun level ->
+  let level = Level.current c in
   Roll.endorsement_rights_owner c level ~slot >>=? fun owning_delegate ->
   fail_unless (Ed25519.Public_key_hash.equal owning_delegate delegate)
     (Wrong_delegate (owning_delegate, delegate))
 
 let paying_priorities c =
-  0l ---> Constants.first_free_mining_slot c
+  0 --> Constants.first_free_mining_slot c
 
 let bond_and_reward =
   match Tez.(Constants.mining_bond_cost +? Constants.mining_reward) with
@@ -176,25 +155,25 @@ let bond_and_reward =
   | Error _ -> assert false
 
 let base_mining_reward c ~priority =
-  if Compare.Int32.(priority < Constants.first_free_mining_slot c)
+  if Compare.Int.(priority < Constants.first_free_mining_slot c)
   then bond_and_reward
   else Constants.mining_reward
 
 type error += Incorect_priority
 
 let endorsement_reward ~block_priority:prio =
-  if Compare.Int32.(prio >= 0l)
+  if Compare.Int.(prio >= 0)
   then
     Lwt.return
-      Tez.(Constants.endorsement_reward /? (Int64.(succ (of_int32 prio))))
+      Tez.(Constants.endorsement_reward /? (Int64.(succ (of_int prio))))
   else fail Incorect_priority
 
 let mining_priorities c level =
   let rec f priority =
     Roll.mining_rights_owner c level ~priority >>=? fun delegate ->
-    return (LCons (delegate, (fun () -> f (Int32.succ priority))))
+    return (LCons (delegate, (fun () -> f (succ priority))))
   in
-  f 0l
+  f 0
 
 let endorsement_priorities c level =
   let rec f slot =
@@ -205,7 +184,7 @@ let endorsement_priorities c level =
 
 let select_delegate delegate delegate_list max_priority =
   let rec loop acc l n =
-    if Compare.Int32.(n >= max_priority)
+    if Compare.Int.(n >= max_priority)
     then return (List.rev acc)
     else
       let LCons (pkh, t) = l in
@@ -214,9 +193,9 @@ let select_delegate delegate delegate_list max_priority =
         then n :: acc
         else acc in
       t () >>=? fun t ->
-      loop acc t (Int32.succ n)
+      loop acc t (succ n)
   in
-  loop [] delegate_list 0l
+  loop [] delegate_list 0
 
 let first_mining_priorities
     ctxt
@@ -227,8 +206,7 @@ let first_mining_priorities
 
 let first_endorsement_slots
     ctxt
-    ?(max_priority =
+    ?(max_priority = Constants.max_signing_slot ctxt)
-      Int32.of_int (Constants.max_signing_slot ctxt))
     delegate level =
   endorsement_priorities ctxt level >>=? fun delegate_list ->
   select_delegate delegate delegate_list max_priority
@@ -273,20 +251,21 @@ let max_fitness_gap ctxt =
   Int64.add slots 1L
 
 let check_fitness_gap ctxt (block : Block.header) =
-  Fitness.get ctxt >>=? fun current_fitness ->
+  let current_fitness = Fitness.current ctxt in
-  Fitness.to_int64 block.shell.fitness >>=? fun announced_fitness ->
+  Lwt.return (Fitness.to_int64 block.shell.fitness) >>=? fun announced_fitness ->
   let gap = Int64.sub announced_fitness current_fitness in
   if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then
     fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
   else
     return ()
 
-let first_of_a_cycle l =
+let last_of_a_cycle ctxt l =
-  Compare.Int32.(l.Level.cycle_position = 0l)
+  Compare.Int32.(Int32.succ l.Level.cycle_position =
+                 Constants.cycle_length ctxt)
 
 let dawn_of_a_new_cycle ctxt =
-  Level.current ctxt >>=? fun level ->
+  let level = Level.current ctxt in
-  if first_of_a_cycle level then
+  if last_of_a_cycle ctxt level then
     return (Some level.cycle)
   else
     return None

src/proto/alpha/mining.mli

@@ -14,15 +14,13 @@ open Misc
 type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
 type error += Invalid_endorsement_slot of int * int (* `Permanent *)
 type error += Timestamp_too_early of Timestamp.t * Timestamp.t (* `Permanent *)
-type error += Wrong_level of Raw_level.t * Raw_level.t (* `Permanent *)
 type error += Wrong_delegate of public_key_hash * public_key_hash (* `Permanent *)
 type error += Cannot_pay_mining_bond (* `Permanent *)
 type error += Cannot_pay_endorsement_bond (* `Permanent *)
 
-val paying_priorities: context -> int32 list
+val paying_priorities: context -> int list
 
-val minimal_time:
+val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t
-  context -> int32 -> Time.t -> Time.t tzresult Lwt.t
 (** [minimal_time ctxt priority pred_block_time] returns the minimal
     time, given the predecessor block timestamp [pred_block_time],
     after which a miner with priority [priority] is allowed to
@@ -56,9 +54,9 @@ val check_signing_rights:
 
 (** If this priority should have payed the bond it is the base mining
     reward and the bond, or just the base reward otherwise *)
-val base_mining_reward: context -> priority:int32 -> Tez.t
+val base_mining_reward: context -> priority:int -> Tez.t
 
-val endorsement_reward: block_priority:int32 -> Tez.t tzresult Lwt.t
+val endorsement_reward: block_priority:int -> Tez.t tzresult Lwt.t
 
 val mining_priorities:
   context -> Level.t -> public_key_hash lazy_list
@@ -70,10 +68,10 @@ val endorsement_priorities:
 
 val first_mining_priorities:
   context ->
-  ?max_priority:int32 ->
+  ?max_priority:int ->
   public_key_hash ->
   Level.t ->
-  int32 list tzresult Lwt.t
+  int list tzresult Lwt.t
 (** [first_mining_priorities ctxt ?max_priority contract_hash level]
     is a list of priorities of max [?max_priority] elements, where the
     delegate of [contract_hash] is allowed to mine for [level]. If
@@ -82,9 +80,9 @@ val first_mining_priorities:
 
 val first_endorsement_slots:
   context ->
-  ?max_priority:int32 ->
+  ?max_priority:int ->
   public_key_hash ->
-  Level.t -> int32 list tzresult Lwt.t
+  Level.t -> int list tzresult Lwt.t
 
 val check_signature:
   context -> Block.header -> public_key_hash -> unit tzresult Lwt.t

src/proto/alpha/nonce_storage.ml

@@ -18,7 +18,7 @@ type error +=
   | Unexpected_nonce
 
 let get_unrevealed c level =
-  Level_storage.current c >>=? fun cur_level ->
+  let cur_level = Level_storage.current c in
   let min_cycle =
     match Cycle_repr.pred cur_level.cycle with
     | None -> Cycle_repr.root
@@ -40,7 +40,7 @@ let get_unrevealed c level =
   (* return nonce_hash *)
 
 let record_hash c delegate_to_reward reward_amount nonce_hash =
-  Level_storage.current c >>=? fun level ->
+  let level = Level_storage.current c in
   Storage.Seed.Nonce.init c level
     (Unrevealed { nonce_hash; delegate_to_reward ; reward_amount })
 
@@ -65,6 +65,3 @@ let get c level = Storage.Seed.Nonce.get c level
 let of_bytes = Seed_repr.make_nonce
 let hash = Seed_repr.hash
 let check_hash = Seed_repr.check_hash
-
-let init c =
-  Storage.Seed.Nonce.init c Level_repr.root (Revealed Seed_repr.initial_nonce_0)

src/proto/alpha/nonce_storage.mli

@@ -41,6 +41,3 @@ val get: Storage.t -> Level_repr.t -> status tzresult Lwt.t
 val of_bytes: MBytes.t -> nonce tzresult
 val hash: nonce -> Nonce_hash.t
 val check_hash: nonce -> Nonce_hash.t -> bool
-
-val init:
-  Storage.t -> Storage.t tzresult Lwt.t

src/proto/alpha/raw_level_repr.ml

@@ -39,3 +39,9 @@ let of_int32_exn l =
   if Compare.Int32.(l >= 0l)
   then l
   else invalid_arg "Level_repr.of_int32"
+
+type error += Unexpected_level of Int32.t
+
+let of_int32 l =
+  try Ok (of_int32_exn l)
+  with _ -> Error [Unexpected_level l]

src/proto/alpha/raw_level_repr.mli

@@ -16,6 +16,7 @@ include Compare.S with type t := raw_level
 
 val to_int32: raw_level -> int32
 val of_int32_exn: int32 -> raw_level
+val of_int32: int32 -> raw_level tzresult
 
 val diff: raw_level -> raw_level -> int32
 

src/proto/alpha/reward_storage.ml

@@ -56,7 +56,7 @@ let pay_rewards_for_cycle c cycle =
                 amount)
 
 let pay_due_rewards c =
-  Storage.get_timestamp c >>= fun timestamp ->
+  let timestamp = Storage.current_timestamp c in
   let rec loop c cycle =
     Storage.Rewards.Date.get_option c cycle >>=? function
     | None ->

src/proto/alpha/roll_storage.ml

@@ -73,7 +73,7 @@ module Random = struct
     let cycle = level.Level_repr.cycle in
     Seed_storage.for_cycle c cycle >>=? fun random_seed ->
     let rd = level_random random_seed kind level in
-    let sequence = Seed_repr.sequence rd offset in
+    let sequence = Seed_repr.sequence rd (Int32.of_int offset) in
     Storage.Roll.Last_for_cycle.get c cycle >>=? fun bound ->
     let roll, _ = Roll_repr.random sequence bound in
     Storage.Roll.Owner_for_cycle.get c (cycle, roll)
@@ -84,7 +84,7 @@ let mining_rights_owner c level ~priority =
   Random.owner c "mining" level priority
 
 let endorsement_rights_owner c level ~slot =
-  Random.owner c "endorsement" level (Int32.of_int slot)
+  Random.owner c "endorsement" level slot
 
 module Contract = struct
 

src/proto/alpha/roll_storage.mli

@@ -35,7 +35,7 @@ val clear_cycle :
   Storage.t -> Cycle_repr.t -> Storage.t tzresult Lwt.t
 
 val mining_rights_owner :
-  Storage.t -> Level_repr.t -> priority:int32 ->
+  Storage.t -> Level_repr.t -> priority:int ->
   Ed25519.Public_key_hash.t tzresult Lwt.t
 
 val endorsement_rights_owner :

src/proto/alpha/script_interpreter.ml

@@ -475,7 +475,7 @@ let rec interp
               Contract.get_balance ctxt source >>=? fun balance ->
               logged_return (Item (balance, rest), qta - 1, ctxt)
           | Now, rest ->
-              Timestamp.get_current ctxt >>= fun now ->
+              let now = Timestamp.current ctxt in
               logged_return (Item (now, rest), qta - 1, ctxt)
           | Check_signature, Item (key, Item ((signature, message), rest)) ->
               Public_key.get ctxt key >>=? fun key ->

src/proto/alpha/seed_storage.ml

@@ -45,7 +45,7 @@ let compute_for_cycle c cycle =
   | c -> Lwt.return c
 
 let for_cycle c cycle =
-  Level_storage.current c >>=? fun current_level ->
+  let current_level = Level_storage.current c in
   let current_cycle = current_level.cycle in
   let next_cycle = (Level_storage.succ c current_level).cycle in
   fail_unless

src/proto/alpha/services.ml

@@ -73,7 +73,7 @@ module Constants = struct
       ~description: "First free mining slot"
       ~input: empty
       ~output: (wrap_tzerror @@
-                describe ~title: "first free mining slot" int32)
+                describe ~title: "first free mining slot" uint16)
       RPC.Path.(custom_root / "constants" / "first_free_mining_slot")
 
   let max_signing_slot custom_root =
@@ -81,7 +81,7 @@ module Constants = struct
       ~description: "Max signing slot"
       ~input: empty
       ~output: (wrap_tzerror @@
-                describe ~title: "max signing slot" int31)
+                describe ~title: "max signing slot" uint16)
       RPC.Path.(custom_root / "constants" / "max_signing_slot")
 
   let instructions_per_transaction custom_root =
@@ -563,7 +563,7 @@ module Helpers = struct
              (req "fitness" Fitness.encoding)
              (req "operations" Operation_list_list_hash.encoding)
              (req "level" Raw_level.encoding)
-             (req "priority" int31)
+             (req "priority" uint16)
              (req "nonce_hash" Nonce_hash.encoding)
              (req "proof_of_work_nonce"
                 (Fixed.bytes Tezos_context.Constants.proof_of_work_nonce_size)))

src/proto/alpha/services_registration.ml

@@ -9,24 +9,27 @@
 
 open Tezos_context
 
-let rpc_services = ref (RPC.empty : Context.t RPC.directory)
+let rpc_init { Updater.context ; level ; timestamp ; fitness } =
+  Tezos_context.init ~level ~timestamp ~fitness context
+
+let rpc_services = ref (RPC.empty : Updater.rpc_context RPC.directory)
 let register0 s f =
   rpc_services :=
     RPC.register !rpc_services (s RPC.Path.root)
       (fun ctxt () ->
-         ( Tezos_context.init ctxt >>=? fun ctxt ->
+         ( rpc_init ctxt >>=? fun ctxt ->
            f ctxt ) >>= RPC.Answer.return)
 let register1 s f =
   rpc_services :=
     RPC.register !rpc_services (s RPC.Path.root)
       (fun ctxt arg ->
-         ( Tezos_context.init ctxt >>=? fun ctxt ->
+         ( rpc_init ctxt >>=? fun ctxt ->
            f ctxt arg ) >>= RPC.Answer.return)
 let register2 s f =
   rpc_services :=
     RPC.register !rpc_services (s RPC.Path.root)
       (fun (ctxt, arg1) arg2 ->
-         ( Tezos_context.init ctxt >>=? fun ctxt ->
+         ( rpc_init ctxt >>=? fun ctxt ->
            f ctxt arg1 arg2 ) >>= RPC.Answer.return)
 let register1_noctxt s f =
   rpc_services :=
@@ -92,7 +95,7 @@ let () =
 type error += Unexpected_level_in_context
 
 let level ctxt =
-  Level.current ctxt >>=? fun level ->
+  let level = Level.current ctxt in
   match Level.pred ctxt level with
   | None -> fail Unexpected_level_in_context
   | Some level -> return level
@@ -100,7 +103,7 @@ let level ctxt =
 let () = register0 Services.Context.level level
 
 let next_level ctxt =
-  Level.current ctxt
+  return (Level.current ctxt)
 
 let () = register0 Services.Context.next_level next_level
 
@@ -143,7 +146,7 @@ let () =
     rpc_services :=
       RPC.register !rpc_services (s RPC.Path.root)
         (fun (ctxt, contract) arg ->
-           ( Tezos_context.init ctxt >>=? fun ctxt ->
+           ( rpc_init ctxt >>=? fun ctxt ->
              Contract.exists ctxt contract >>=? function
              | true -> f ctxt contract arg
              | false -> raise Not_found ) >>= RPC.Answer.return) in
@@ -171,13 +174,13 @@ let () =
 (*-- Helpers -----------------------------------------------------------------*)
 
 let minimal_timestamp ctxt prio =
-  let prio = match prio with None -> 0l | Some p -> Int32.of_int p in
+  let prio = match prio with None -> 0 | Some p -> p in
   Mining.minimal_time ctxt prio
 
 let () = register1
            Services.Helpers.minimal_timestamp
            (fun ctxt slot ->
-             Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
+              let timestamp = Tezos_context.Timestamp.current ctxt in
              minimal_timestamp ctxt slot timestamp)
 
 let () =
@@ -190,10 +193,10 @@ let () =
        | None -> Error_monad.fail Operation.Cannot_parse_operation
        | Some (shell, contents) ->
            let operation = { hash ; shell ; contents ; signature } in
-           Tezos_context.Level.current ctxt >>=? fun level ->
+           let level = Tezos_context.Level.current ctxt in
            Mining.mining_priorities ctxt level >>=? fun (Misc.LCons (miner_pkh, _)) ->
            let miner_contract = Contract.default_contract miner_pkh in
-           let block_prio = 0l in
+           let block_prio = 0 in
            Apply.apply_operation
              ctxt (Some miner_contract) pred_block block_prio operation
            >>=? function
@@ -278,11 +281,11 @@ let () = register2 Services.Helpers.levels levels
 let default_max_mining_priority ctxt arg =
   let default = Constants.first_free_mining_slot ctxt in
   match arg with
-  | None -> Int32.mul 2l default
+  | None -> 2 * default
-  | Some m -> Int32.of_int m
+  | Some m -> m
 
 let mining_rights ctxt level max =
-  let max = Int32.to_int (default_max_mining_priority ctxt max) in
+  let max = default_max_mining_priority ctxt max in
   Mining.mining_priorities ctxt level >>=? fun contract_list ->
   let rec loop l n =
     match n with
@@ -299,15 +302,14 @@ let mining_rights ctxt level max =
 let () =
   register1 Services.Helpers.Rights.mining_rights
     (fun ctxt max ->
-       Level.current ctxt >>=? fun level ->
+       let level = Level.current ctxt in
        mining_rights ctxt level max >>=? fun (raw_level, slots) ->
        begin
          Lwt_list.filter_map_p (fun x -> x) @@
          List.mapi
            (fun prio c ->
-             Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
+             let timestamp = Timestamp.current ctxt in
-              Mining.minimal_time
+              Mining.minimal_time ctxt prio timestamp >>= function
-                ctxt (Int32.of_int prio) timestamp >>= function
               | Error _ -> Lwt.return None
               | Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp)))
            slots
@@ -323,7 +325,7 @@ let () =
 let mining_rights_for_delegate
     ctxt contract (max_priority, min_level, max_level) =
   let max_priority = default_max_mining_priority ctxt max_priority in
-  Level.current ctxt >>=? fun current_level ->
+  let current_level = Level.current ctxt in
   let max_level =
     match max_level with
     | None ->
@@ -343,9 +345,9 @@ let mining_rights_for_delegate
       let raw_level = level.level in
       Error_monad.map_s
         (fun priority ->
-          Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
+           let timestamp = Timestamp.current ctxt in
            Mining.minimal_time ctxt priority timestamp >>=? fun time ->
-           return (raw_level, Int32.to_int priority, time))
+           return (raw_level, priority, time))
         priorities >>=? fun priorities ->
       return (priorities @ t)
   in
@@ -379,7 +381,7 @@ let endorsement_rights ctxt level max =
 let () =
   register1 Services.Helpers.Rights.endorsement_rights
     (fun ctxt max ->
-       Level.current ctxt >>=? fun level ->
+       let level = Level.current ctxt in
        endorsement_rights ctxt (Level.succ ctxt level) max) ;
   register2 Services.Helpers.Rights.endorsement_rights_for_level
     (fun ctxt raw_level max ->
@@ -388,10 +390,8 @@ let () =
 
 let endorsement_rights_for_delegate
     ctxt contract (max_priority, min_level, max_level) =
-  let max_priority =
+  let current_level = Level.current ctxt in
-    Int32.of_int @@
+  let max_priority = default_max_endorsement_priority ctxt max_priority in
-    default_max_endorsement_priority ctxt max_priority in
-  Level.current ctxt >>=? fun current_level ->
   let max_level =
     match max_level with
     | None ->
@@ -409,10 +409,7 @@ let endorsement_rights_for_delegate
       Mining.first_endorsement_slots
         ctxt ~max_priority contract level >>=? fun slots ->
       let raw_level = level.level in
-      let slots =
+      let slots = List.rev_map (fun slot -> (raw_level, slot)) slots in
-        List.rev_map
-          (fun slot -> (raw_level, Int32.to_int slot))
-          slots in
       return (List.rev_append slots t)
   in
   loop min_level
@@ -437,13 +434,13 @@ let forge_operations _ctxt (shell, proto) =
 let () = register1 Services.Helpers.Forge.operations forge_operations
 
 let forge_block _ctxt
-    (net_id, predecessor, timestamp, fitness, operations,
+    (net_id, predecessor, timestamp, fitness, operations_hash,
-     raw_level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t =
+     level, priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t =
-  let priority = Int32.of_int priority in
+  let level = Raw_level.to_int32 level in
-  let mining_slot = { Block.level = raw_level ; priority } in
   return (Block.forge_header
-            { net_id ; predecessor ; timestamp ; fitness ; operations }
+            { net_id ; level ; predecessor ;
-            { mining_slot ; seed_nonce_hash ; proof_of_work_nonce })
+              timestamp ; fitness ; operations_hash }
+            { priority ; seed_nonce_hash ; proof_of_work_nonce })
 
 let () = register1 Services.Helpers.Forge.block forge_block
 

src/proto/alpha/storage.ml

@@ -10,21 +10,54 @@
 open Tezos_hash
 open Storage_functors
 
+(* This key should always be populated for every version of the
+   protocol.  It's absence meaning that the context is empty. *)
+let version_key = ["version"]
+let version_value = "alpha"
+
+type error += Incompatiple_protocol_version
+
+let is_first_block ctxt =
+  Context.get ctxt version_key >>= function
+  | None ->
+      return true
+  | Some bytes ->
+      let s = MBytes.to_string bytes in
+      if Compare.String.(s = version_value) then
+        return false
+      else if Compare.String.(s = "genesis") then
+        return true
+      else
+        fail Incompatiple_protocol_version
+
 let version = "v1"
+let first_level_key = [ version ; "first_level" ]
 let sandboxed_key = [ version ; "sandboxed" ]
-let prevalidation_key = [ version ; "prevalidation" ]
 
 type t = Storage_functors.context
 
 type error += Invalid_sandbox_parameter
 
-let get_fitness (c, _) = Context.get_fitness c
+let current_level { level } = level
-let set_fitness (c, csts) v =
+let current_timestamp { timestamp } = timestamp
-  Context.set_fitness c v >>= fun c -> Lwt.return (c, csts)
+let current_fitness { fitness } = fitness
+let set_current_fitness c fitness = { c with fitness }
 
-let get_timestamp (c, _) = Context.get_timestamp c
+let get_first_level ctxt =
-let set_commit_message (c, csts) msg =
+  Context.get ctxt first_level_key >>= function
-  Context.set_commit_message c msg >>= fun c -> Lwt.return (c, csts)
+  | None -> failwith "Invalid context"
+  | Some bytes ->
+      match
+        Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes
+      with
+      | None -> failwith "Invalid context"
+      | Some level -> return level
+
+let set_first_level ctxt level =
+  let bytes =
+    Data_encoding.Binary.to_bytes Raw_level_repr.encoding level in
+  Context.set ctxt first_level_key bytes >>= fun ctxt ->
+  return ctxt
 
 let get_sandboxed c =
   Context.get c sandboxed_key >>= function
@@ -38,29 +71,41 @@ let set_sandboxed c json =
   Context.set c sandboxed_key
     (Data_encoding.Binary.to_bytes Data_encoding.json json)
 
-let prepare (c : Context.t) : t tzresult Lwt.t =
+let may_tag_first_block ctxt level =
-  get_sandboxed c >>=? fun sandbox ->
+  is_first_block ctxt >>=? function
+  | false ->
+      get_first_level ctxt >>=? fun level ->
+      return (ctxt, false, level)
+  | true ->
+      Context.set ctxt version_key
+        (MBytes.of_string version_value) >>= fun ctxt ->
+      set_first_level ctxt level >>=? fun ctxt ->
+      return (ctxt, true, level)
+
+let prepare ~level ~timestamp ~fitness ctxt =
+  Lwt.return (Raw_level_repr.of_int32 level ) >>=? fun level ->
+  Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
+  may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) ->
+  get_sandboxed ctxt >>=? fun sandbox ->
   Constants_repr.read sandbox >>=? function constants ->
-  return (c, constants)
+  let level =
-let recover (c, _ : t) : Context.t = c
+    Level_repr.from_raw
+      ~first_level
+      ~cycle_length:constants.Constants_repr.cycle_length
+      ~voting_period_length:constants.Constants_repr.voting_period_length
+    level in
+  return ({ context = ctxt ; constants ; level ;
+            timestamp ; fitness ; first_level},
+          first_block)
+let recover { context } : Context.t = context
 
-let get_prevalidation (c, _ : t) =
+let first_level { first_level } = first_level
-  Context.get c prevalidation_key >>= function
+let constants { constants } = constants
-  | None -> Lwt.return false
-  | Some _ -> Lwt.return true
-let set_prevalidation (c, constants : t) =
-  Context.set c prevalidation_key (MBytes.of_string "prevalidation") >>= fun c ->
-  Lwt.return (c, constants)
-
-
-let constants : t -> _ = snd
 
 module Key = struct
 
   let store_root tail = version :: "store" :: tail
 
-  let current_level = store_root ["level"]
-
   let global_counter = store_root ["global_counter"]
 
   let next_cycle_to_be_rewarded = store_root ["next_cycle_to_be_rewarded"]
@@ -132,16 +177,6 @@ module Key = struct
 
 end
 
-(** Global *)
-
-module Current_level =
-  Make_single_data_storage(struct
-    type value = Raw_level_repr.t
-    let name = "level"
-    let key = Key.current_level
-    let encoding = Raw_level_repr.encoding
-  end)
-
 (** Rolls *)
 
 module Roll = struct
@@ -510,13 +545,11 @@ module Rewards = struct
 
 end
 
-let activate (c, constants) h =
+let activate ({ context = c } as s) h =
-  Updater.activate c h >>= fun c -> Lwt.return (c, constants)
+  Updater.activate c h >>= fun c -> Lwt.return { s with context = c }
-let fork_test_network (c, constants) =
+let fork_test_network ({ context = c } as s) protocol expiration =
-  Updater.fork_test_network c >>= fun c -> Lwt.return (c, constants)
+  Updater.fork_test_network c ~protocol ~expiration >>= fun c ->
-let set_test_protocol (c, constants) h =
+  Lwt.return { s with context = c }
-  Updater.set_test_protocol c h >>= fun c -> Lwt.return (c, constants)
-
 
 (** Resolver *)
 

src/proto/alpha/storage.mli

@@ -24,8 +24,17 @@
 (** Abstract view of the database *)
 type t
 
-(** Rerieves the state of the database and gives its abstract view *)
+(** Is first block validated with this version of the protocol ? *)
-val prepare : Context.t -> t tzresult Lwt.t
+val is_first_block: Context.t -> bool tzresult Lwt.t
+
+(** Retrieves the state of the database and gives its abstract view.
+    It also returns wether this is the first block validated
+    with this version of the protocol. *)
+val prepare :
+  level: Int32.t ->
+  timestamp: Time.t ->
+  fitness: Fitness.fitness ->
+  Context.t -> (t * bool) tzresult Lwt.t
 
 (** Returns the state of the database resulting of operations on its
     abstract view *)
@@ -34,27 +43,19 @@ val recover : t -> Context.t
 val get_sandboxed : Context.t -> Data_encoding.json option tzresult Lwt.t
 val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t
 
-val get_fitness : t -> Fitness.fitness Lwt.t
+val current_level : t -> Level_repr.t
-val set_fitness : t -> Fitness.fitness -> t Lwt.t
+val current_timestamp : t -> Time.t
 
-val get_timestamp: t -> Time.t Lwt.t
+val current_fitness : t -> Int64.t
-
+val set_current_fitness : t -> Int64.t -> t
-val set_commit_message: t -> string -> t Lwt.t
-
-val get_prevalidation : t -> bool Lwt.t
-val set_prevalidation : t -> t Lwt.t
 
 val constants : t -> Constants_repr.constants
+val first_level : t -> Raw_level_repr.t
 
 (** {1 Entity Accessors} *****************************************************)
 
 open Storage_sigs
 
-(** The level of the current block *)
-module Current_level : Single_data_storage
-  with type value = Raw_level_repr.t
-   and type context := t
-
 module Roll : sig
 
   (** Storage from this submodule must only be accessed through the
@@ -274,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/storage_functors.ml

@@ -11,7 +11,14 @@
 
 open Misc
 
-type context = Context.t * Constants_repr.constants
+type context = {
+  context: Context.t ;
+  constants: Constants_repr.constants ;
+  first_level: Raw_level_repr.t ;
+  level: Level_repr.t ;
+  timestamp: Time.t ;
+  fitness: Int64.t ;
+}
 
 (*-- Errors ------------------------------------------------------------------*)
 
@@ -52,7 +59,7 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
 
   let key_to_string l = String.concat "/" (key l)
 
-  let get (c, _) k =
+  let get { context = c } k =
     Context.get c (key k) >>= function
     | None ->
         let msg =
@@ -61,16 +68,16 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
     | Some bytes ->
         Lwt.return (P.of_bytes bytes)
 
-  let mem (c, _) k = Context.mem c (key k)
+  let mem { context = c } k = Context.mem c (key k)
 
-  let get_option (c, _) k =
+  let get_option { context = c } k =
     Context.get c (key k) >>= function
     | None -> return None
     | Some bytes ->
         Lwt.return (P.of_bytes bytes >|? fun v -> Some v)
 
   (* Verify that the key is present before modifying *)
-  let set (c, x) k v =
+  let set ({ context = c } as s) k v =
     let key = key k in
     Context.get c key >>= function
     | None ->
@@ -80,13 +87,13 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
     | Some old ->
         let bytes = P.to_bytes v in
         if MBytes.(old = bytes) then
-          return (c, x)
+          return { s with context = c }
         else
           Context.set c key (P.to_bytes v) >>= fun c ->
-          return (c, x)
+          return { s with context = c }
 
   (* Verify that the key is not present before inserting *)
-  let init (c, x) k v =
+  let init ({ context = c } as s) k v =
     let key = key k in
     Context.get c key >>=
       function
@@ -96,27 +103,29 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
           fail (Storage_error msg)
       | None ->
           Context.set c key (P.to_bytes v) >>= fun c ->
-          return (c, x)
+          return { s with context = c }
 
   (* Does not verify that the key is present or not *)
-  let init_set (c, x) k v =
+  let init_set ({ context = c } as s) k v =
-    Context.set c (key k) (P.to_bytes v) >>= fun c -> return (c, x)
+    Context.set c (key k) (P.to_bytes v) >>= fun c ->
+    return { s with context = c }
 
   (* Verify that the key is present before deleting *)
-  let delete (c, x) k =
+  let delete ({ context = c } as s) k =
     let key = key k in
     Context.get c key >>= function
     | Some _ ->
         Context.del c key >>= fun c ->
-        return (c, x)
+        return { s with context = c }
     | None ->
         let msg =
           "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in
         fail (Storage_error msg)
 
   (* Do not verify before deleting *)
-  let remove (c, x) k =
+  let remove ({ context = c } as s) k =
-    Context.del c (key k) >>= fun c -> Lwt.return (c, x)
+    Context.del c (key k) >>= fun c ->
+    Lwt.return { s with context = c }
 
 end
 
@@ -229,28 +238,34 @@ module Make_data_set_storage (P : Single_data_description) = struct
         error (Storage_error msg)
     | Some v -> Ok v
 
-  let add (c, x) v =
+  let add ({ context = c } as s) v =
     let hash, data = serial v in
     HashTbl.mem c hash >>= function
-    | true -> return (c, x)
+    | true ->
-    | false -> HashTbl.set c hash data >>= fun c -> return (c, x)
+        return { s with context = c }
+    | false ->
+        HashTbl.set c hash data >>= fun c ->
+        return { s with context = c }
 
-  let del (c, x) v =
+  let del ({ context = c } as s) v =
     let hash, _ = serial v in
     HashTbl.mem c hash >>= function
-    | false -> return (c, x)
+    | false ->
-    | true -> HashTbl.del c hash >>= fun c -> return (c, x)
+        return { s with context = c }
+    | true ->
+        HashTbl.del c hash >>= fun c ->
+        return { s with context = c }
 
-  let mem (c, _) v =
+  let mem { context = c } v =
     let hash, _ = serial v in
     HashTbl.mem c hash >>= fun v ->
     return v
 
-  let elements (c, _) =
+  let elements { context = c } =
     HashTbl.bindings c >>= fun elts ->
     map_s (fun (_, data) -> Lwt.return (unserial data)) elts
 
-  let fold (c, _) init ~f =
+  let fold { context = c } init ~f =
     HashTbl.fold c (ok init)
       ~f:(fun _ data acc ->
           match acc with
@@ -262,9 +277,9 @@ module Make_data_set_storage (P : Single_data_description) = struct
                   f data acc >>= fun acc ->
                   return acc)
 
-  let clear (c, x) =
+  let clear ({ context = c } as s) =
     HashTbl.fold c c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c ->
-    return (c, x)
+    return { s with context = c }
 
 end
 
@@ -284,7 +299,7 @@ module Raw_make_iterable_data_storage
 
   let key_to_string k = String.concat "/" (K.to_path k)
 
-  let get (c, _) k =
+  let get { context = c } k =
     HashTbl.get c k >>= function
     | None ->
         let msg =
@@ -293,15 +308,15 @@ module Raw_make_iterable_data_storage
     | Some v ->
         return v
 
-  let mem (c, _) k = HashTbl.mem c k
+  let mem { context = c } k = HashTbl.mem c k
 
-  let get_option (c, _) k =
+  let get_option { context = c } k =
     HashTbl.get c k >>= function
     | None -> return None
     | Some v -> return (Some v)
 
   (* Verify that the key is present before modifying *)
-  let set (c, x) k v =
+  let set ({ context = c } as s) k v =
     HashTbl.get c k >>= function
     | None ->
         let msg =
@@ -309,10 +324,10 @@ module Raw_make_iterable_data_storage
         fail (Storage_error msg)
     | Some _ ->
         HashTbl.set c k v >>= fun c ->
-        return (c, x)
+        return { s with context = c }
 
   (* Verify that the key is not present before inserting *)
-  let init (c, x) k v =
+  let init ({ context = c } as s) k v =
     HashTbl.get c k >>=
       function
       | Some _ ->
@@ -321,29 +336,35 @@ module Raw_make_iterable_data_storage
           fail (Storage_error msg)
       | None ->
           HashTbl.set c k v >>= fun c ->
-          return (c, x)
+          return { s with context = c }
 
   (* Does not verify that the key is present or not *)
-  let init_set (c, x) k v = HashTbl.set c k v >>= fun c -> return (c, x)
+  let init_set ({ context = c } as s) k v =
+    HashTbl.set c k v >>= fun c ->
+    return { s with context = c }
 
   (* Verify that the key is present before deleting *)
-  let delete (c, x) k =
+  let delete ({ context = c } as s) k =
     HashTbl.get c k >>= function
     | Some _ ->
         HashTbl.del c k >>= fun c ->
-        return (c, x)
+        return { s with context = c }
     | None ->
         let msg =
           "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in
         fail (Storage_error msg)
 
   (* Do not verify before deleting *)
-  let remove (c, x) k =
+  let remove ({ context = c } as s) k =
-    HashTbl.del c k >>= fun c -> Lwt.return (c, x)
+    HashTbl.del c k >>= fun c ->
+    Lwt.return { s with context = c }
 
-  let clear (c, x) = HashTbl.clear c >>= fun c -> Lwt.return (c, x)
+  let clear ({ context = c } as s) =
-  let fold (c, _) x ~f = HashTbl.fold c x ~f:(fun k v acc -> f k v acc)
+    HashTbl.clear c >>= fun c ->
-  let iter (c, _) ~f = HashTbl.fold c () ~f:(fun k v () -> f k v)
+    Lwt.return { s with context = c }
+
+  let fold { context = c } x ~f = HashTbl.fold c x ~f:(fun k v acc -> f k v acc)
+  let iter { context = c } ~f = HashTbl.fold c () ~f:(fun k v () -> f k v)
 
 end
 

src/proto/alpha/storage_functors.mli

@@ -14,7 +14,14 @@
     indexed data and homgeneous data set). *)
 
 
-type context = Context.t * Constants_repr.constants
+type context = {
+  context: Context.t ;
+  constants: Constants_repr.constants ;
+  first_level: Raw_level_repr.t ;
+  level: Level_repr.t ;
+  timestamp: Time.t ;
+  fitness: Int64.t ;
+}
 
 open Storage_sigs
 

src/proto/alpha/tezos_context.ml

@@ -22,7 +22,7 @@ module Period = Period_repr
 
 module Timestamp = struct
   include Time_repr
-  let get_current = Storage.get_timestamp
+  let current = Storage.current_timestamp
 end
 
 include Operation_repr
@@ -110,18 +110,12 @@ end
 
 let init = Init_storage.may_initialize
 
-let finalize ?commit_message c =
+let finalize ?commit_message:message c =
-  match commit_message with
+  let fitness = Fitness.from_int64 (Fitness.current c) in
-  | None ->
+  let context = Storage.recover c in
-     return (Storage.recover c)
+  { Updater.context ; fitness ; message }
-  | Some msg ->
-     Storage.set_commit_message c msg >>= fun c ->
-     return (Storage.recover c)
 
 let configure_sandbox = Init_storage.configure_sandbox
-let get_prevalidation = Storage.get_prevalidation
-let set_prevalidation = Storage.set_prevalidation
 
 let activate = Storage.activate
 let fork_test_network = Storage.fork_test_network
-let set_test_protocol = Storage.set_test_protocol

src/proto/alpha/tezos_context.mli

@@ -75,10 +75,7 @@ module Timestamp : sig
   val of_seconds: string -> time option
   val to_seconds: time -> string
 
-  val get_current: context -> Time.t Lwt.t
+  val current: context -> Time.t
-  (** [get_current ctxt] returns the current timestamp of [ctxt]. When
-      [ctxt] is the context of a block, the block timestamp is used,
-      otherwise a timestamp is inferred otherwise. *)
 
 end
 
@@ -175,7 +172,7 @@ module Constants : sig
   val voting_period_length: context -> int32
   val time_before_reward: context -> Period.t
   val slot_durations: context -> Period.t list
-  val first_free_mining_slot: context -> int32
+  val first_free_mining_slot: context -> int
   val max_signing_slot: context -> int
   val instructions_per_transaction: context -> int
   val proof_of_work_threshold: context -> int64
@@ -222,6 +219,7 @@ module Level : sig
 
   type t = private {
     level: Raw_level.t ;
+    level_position: int32 ;
     cycle: Cycle.t ;
     cycle_position: int32 ;
     voting_period: Voting_period.t ;
@@ -231,7 +229,7 @@ module Level : sig
   val pp_full: Format.formatter -> t -> unit
   type level = t
 
-  val root: level
+  val root: context -> level
 
   val succ: context -> level -> level
   val pred: context -> level -> level option
@@ -240,8 +238,7 @@ module Level : sig
 
   val diff: level -> level -> int32
 
-  val current: context -> level tzresult Lwt.t
+  val current: context -> level
-  val increment_current: context -> context tzresult Lwt.t
 
   val last_level_in_cycle: context -> Cycle.t -> level
   val levels_in_cycle: context -> Cycle.t -> level list
@@ -253,10 +250,11 @@ module Fitness : sig
   include (module type of Fitness)
   type t = fitness
 
-  val increase: context -> context tzresult Lwt.t
+  val increase: context -> context
 
-  val get: context -> int64 tzresult Lwt.t
+  val current: context -> int64
-  val to_int64: fitness -> int64 tzresult Lwt.t
+
+  val to_int64: fitness -> int64 tzresult
 
 end
 
@@ -525,18 +523,11 @@ module Block : sig
   }
 
   and proto_header = {
-    mining_slot: mining_slot ;
+    priority: int ;
     seed_nonce_hash: Nonce_hash.t ;
     proof_of_work_nonce: MBytes.t ;
   }
 
-  and mining_slot = {
-    level: Raw_level.t ;
-    priority: Int32.t ;
-  }
-
-  val mining_slot_encoding: mining_slot Data_encoding.encoding
-
   val max_header_length: int
 
   val parse_header: Updater.raw_block -> header tzresult
@@ -558,7 +549,7 @@ module Roll : sig
   val clear_cycle: context -> Cycle.t -> context tzresult Lwt.t
 
   val mining_rights_owner:
-    context -> Level.t -> priority:int32 -> public_key_hash tzresult Lwt.t
+    context -> Level.t -> priority:int -> public_key_hash tzresult Lwt.t
 
   val endorsement_rights_owner:
     context -> Level.t -> slot:int -> public_key_hash tzresult Lwt.t
@@ -580,15 +571,16 @@ module Reward : sig
 
 end
 
-val init: Context.t -> context tzresult Lwt.t
+val init:
-val finalize: ?commit_message:string -> context -> Context.t tzresult Lwt.t
+  Context.t ->
+  level:Int32.t ->
+  timestamp:Time.t ->
+  fitness:Fitness.t ->
+  context tzresult Lwt.t
+val finalize: ?commit_message:string -> context -> Updater.validation_result
 
 val configure_sandbox:
   Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
 
-val get_prevalidation: context -> bool Lwt.t
-val set_prevalidation: context -> context Lwt.t
-
 val activate: context -> Protocol_hash.t -> context Lwt.t
-val set_test_protocol: context -> Protocol_hash.t -> context Lwt.t
+val fork_test_network: context -> Protocol_hash.t -> Time.t -> context Lwt.t
-val fork_test_network: context -> context Lwt.t

src/proto/demo/main.ml

@@ -17,9 +17,15 @@ let parse_operation h _ = Ok h
 
 let compare_operations _ _ = 0
 
-module Fitness = struct
+type validation_state = {
+  context : Context.t ;
+  fitness : Int64.t ;
+}
 
-  let version_number = "\000"
+let current_context { context } =
+  return context
+
+module Fitness = struct
 
   type error += Invalid_fitness
   type error += Invalid_fitness2
@@ -36,67 +42,51 @@ module Fitness = struct
       return (MBytes.get_int64 b 0)
 
   let from_int64 fitness =
-    [ MBytes.of_string version_number ;
+    [ int64_to_bytes fitness ]
-      int64_to_bytes fitness ]
 
   let to_int64 = function
-    | [ version ;
+    | [ fitness ] -> int64_of_bytes fitness
-        fitness ]
-      when Compare.String.
-             (MBytes.to_string version = version_number) ->
-        int64_of_bytes fitness
     | [] -> return 0L
     | _ -> fail Invalid_fitness
 
-  let get ctxt =
+  let get { fitness } = fitness
-    Context.get_fitness ctxt >>= fun fitness ->
-    to_int64 fitness
-
-  let set ctxt v =
-    Context.set_fitness ctxt (from_int64 v) >>= fun ctxt ->
-    Lwt.return ctxt
-
-  let increase ctxt =
-    get ctxt >>=? fun v ->
-    set ctxt (Int64.succ v) >>= fun ctxt ->
-    return ctxt
 
 end
 
-type validation_state = Context.t
-
-let current_context ctxt =
-  return ctxt
-
 let precheck_block
     ~ancestor_context:_
     ~ancestor_timestamp:_
-    _raw_block =
+    raw_block =
+  Fitness.to_int64 raw_block.Updater.shell.fitness >>=? fun _ ->
   return ()
 
 let begin_application
-    ~predecessor_context:ctxt
+    ~predecessor_context:context
     ~predecessor_timestamp:_
-    _raw_block =
+    ~predecessor_fitness:_
-  return ctxt
+    raw_block =
+  Fitness.to_int64 raw_block.Updater.shell.fitness >>=? fun fitness ->
+  return { context ; fitness }
 
 let begin_construction
-    ~predecessor_context:ctxt
+    ~predecessor_context:context
     ~predecessor_timestamp:_
+    ~predecessor_level:_
+    ~predecessor_fitness:pred_fitness
     ~predecessor:_
     ~timestamp:_ =
-  return ctxt
+  Fitness.to_int64 pred_fitness >>=? function pred_fitness ->
+  let fitness = Int64.succ pred_fitness in
+  return { context ; fitness }
 
 let apply_operation ctxt _ =
   return ctxt
 
 let finalize_block ctxt =
-  Fitness.increase ctxt >>=? fun ctxt ->
+  let fitness = Fitness.get ctxt in
-  Fitness.get ctxt >>=? fun fitness ->
+  let message = Some (Format.asprintf "fitness <- %Ld" fitness) in
-  let commit_message =
+  let fitness = Fitness.from_int64 fitness in
-    Format.asprintf "fitness <- %Ld" fitness in
+  return { Updater.message ; context = ctxt.context ; fitness }
-  Context.set_commit_message ctxt commit_message >>= fun ctxt ->
-  return ctxt
 
 let rpc_services = Services.rpc_services
 

src/proto/demo/services.ml

@@ -45,7 +45,7 @@ let failing_service custom_root =
     ~output: (wrap_tzerror Data_encoding.empty)
     RPC.Path.(custom_root / "failing")
 
-let rpc_services : Context.t RPC.directory =
+let rpc_services : Updater.rpc_context RPC.directory =
   let dir = RPC.empty in
   let dir =
     RPC.register

src/proto/environment/context.mli

@@ -5,12 +5,6 @@ open Hash
 
 include Persist.STORE
 
-val get_fitness: t -> Fitness.fitness Lwt.t
-val set_fitness: t -> Fitness.fitness -> t Lwt.t
-
-val get_timestamp: t -> Time.t Lwt.t
-val set_commit_message: t -> string -> t Lwt.t
-
 val register_resolver:
   'a Base58.encoding -> (t -> string -> 'a list Lwt.t) -> unit
 

src/proto/environment/data_encoding.mli

@@ -28,7 +28,9 @@ val empty : unit encoding
 val unit : unit encoding
 val constant : string -> unit encoding
 val int8 : int encoding
+val uint8 : int encoding
 val int16 : int encoding
+val uint16 : int encoding
 val int31 : int encoding
 val int32 : int32 encoding
 val int64 : int64 encoding

src/proto/environment/updater.mli

@@ -2,6 +2,7 @@
 
 open Hash
 
+(** The version agnostic toplevel structure of operations. *)
 type shell_operation = {
   net_id: Net_id.t ;
 }
@@ -18,12 +19,14 @@ val raw_operation_encoding: raw_operation Data_encoding.t
 type shell_block = {
   net_id: Net_id.t ;
   (** The genesis of the chain this block belongs to. *)
+  level: Int32.t ;
+  (** The number of predecessing block in the chain. *)
   predecessor: Block_hash.t ;
   (** The preceding block in the chain. *)
   timestamp: Time.t ;
   (** The date at which this block has been forged. *)
-  operations: Operation_list_list_hash.t ;
+  operations_hash: Operation_list_list_hash.t ;
-  (** The sequence of operations. *)
+  (** The hash lf the merkle tree of operations. *)
   fitness: MBytes.t list ;
   (** The announced score of the block. As a sequence of sequences
       of unsigned bytes. Ordered by length and then by contents
@@ -37,6 +40,19 @@ type raw_block = {
 }
 val raw_block_encoding: raw_block Data_encoding.t
 
+type validation_result = {
+  context: Context.t ;
+  fitness: Fitness.fitness ;
+  message: string option ;
+}
+
+type rpc_context = {
+  context: Context.t ;
+  level: Int32.t ;
+  timestamp: Time.t ;
+  fitness: Fitness.fitness ;
+}
+
 (** This is the signature of a Tezos protocol implementation. It has
     access to the standard library and the Environment module. *)
 module type PROTOCOL = sig
@@ -99,6 +115,7 @@ module type PROTOCOL = sig
   val begin_application :
     predecessor_context: Context.t ->
     predecessor_timestamp: Time.t ->
+    predecessor_fitness: Fitness.fitness ->
     raw_block ->
     validation_state tzresult Lwt.t
 
@@ -110,6 +127,8 @@ module type PROTOCOL = sig
   val begin_construction :
     predecessor_context: Context.t ->
     predecessor_timestamp: Time.t ->
+    predecessor_level: Int32.t ->
+    predecessor_fitness: Fitness.fitness ->
     predecessor: Block_hash.t ->
     timestamp: Time.t ->
     validation_state tzresult Lwt.t
@@ -123,10 +142,10 @@ module type PROTOCOL = sig
       context that will be used as input for the validation of its
       successor block candidates. *)
   val finalize_block :
-    validation_state -> Context.t tzresult Lwt.t
+    validation_state -> validation_result tzresult Lwt.t
 
   (** The list of remote procedures exported by this implementation *)
-  val rpc_services : Context.t RPC.directory
+  val rpc_services : rpc_context RPC.directory
 
   val configure_sandbox :
     Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
@@ -155,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
@@ -61,10 +67,10 @@ let check_signature ctxt { shell ; command ; signature } =
     (Ed25519.Signature.check public_key signature bytes)
     Invalid_signature
 
-type validation_state = block * Context.t
+type validation_state = Updater.validation_result
 
-let current_context (_, ctxt) =
+let current_context ({ context } : validation_state) =
-  return ctxt
+  return context
 
 let precheck_block
     ~ancestor_context:_
@@ -76,38 +82,39 @@ let precheck_block
 let begin_application
     ~predecessor_context:ctxt
     ~predecessor_timestamp:_
+    ~predecessor_fitness:_
     raw_block =
+  Data.Init.may_initialize ctxt >>=? fun ctxt ->
   Lwt.return (parse_block raw_block) >>=? fun block ->
-  return (block, ctxt)
+  check_signature ctxt block >>=? fun () ->
+  let fitness = raw_block.shell.fitness in
+  match block.command with
+  | Data.Command.Activate hash ->
+      let message =
+        Some (Format.asprintf "activate %a" Protocol_hash.pp_short hash) in
+      Updater.activate ctxt hash >>= fun ctxt ->
+      return { Updater.message ; context = ctxt ; fitness }
+  | Activate_testnet (hash, delay) ->
+      let message =
+        Some (Format.asprintf "activate testnet %a" Protocol_hash.pp_short hash) in
+      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
-    ~predecessor_context:_
+    ~predecessor_context:context
     ~predecessor_timestamp:_
+    ~predecessor_level:_
+    ~predecessor_fitness:fitness
     ~predecessor:_
     ~timestamp:_ =
-  Lwt.return (Error []) (* absurd *)
+  (* Dummy result. *)
+  return { Updater.message = None ; context ; fitness }
 
 let apply_operation _vctxt _ =
   Lwt.return (Error []) (* absurd *)
 
-let finalize_block (header, ctxt) =
+let finalize_block state = return state
-  check_signature ctxt header >>=? fun () ->
-  Data.Init.may_initialize ctxt >>=? fun ctxt ->
-  Context.set_fitness ctxt header.shell.fitness >>= fun ctxt ->
-  match header.command with
-  | Activate hash ->
-      let commit_message =
-        Format.asprintf "activate %a" Protocol_hash.pp_short hash in
-      Context.set_commit_message ctxt commit_message >>= fun ctxt ->
-      Updater.activate ctxt hash >>= fun ctxt ->
-      return ctxt
-  | Activate_testnet hash ->
-      let commit_message =
-        Format.asprintf "activate testnet %a" Protocol_hash.pp_short hash in
-      Context.set_commit_message ctxt commit_message >>= fun ctxt ->
-      Updater.set_test_protocol ctxt hash >>= fun ctxt ->
-      Updater.fork_test_network ctxt >>= fun ctxt ->
-      return ctxt
 
 let rpc_services = Services.rpc_services
 

src/proto/genesis/services.ml

@@ -38,8 +38,9 @@ module Forge = struct
       ~description: "Forge a block"
       ~input:
         (merge_objs
-           (obj4
+           (obj5
               (req "net_id" Net_id.encoding)
+              (req "level" int32)
               (req "predecessor" Block_hash.encoding)
               (req "timestamp" Time.encoding)
               (req "fitness" Fitness.encoding))
@@ -53,18 +54,18 @@ let int64_to_bytes i =
   MBytes.set_int64 b 0 i;
   b
 
-let operations =
+let operations_hash =
   Operation_list_list_hash.compute [Operation_list_hash.empty]
 
-let rpc_services : Context.t RPC.directory =
+let rpc_services : Updater.rpc_context RPC.directory =
   let dir = RPC.empty in
   let dir =
     RPC.register
       dir
       (Forge.block RPC.Path.root)
-      (fun _ctxt ((net_id, predecessor, timestamp, fitness), command) ->
+      (fun _ctxt ((net_id, level, predecessor, timestamp, fitness), command) ->
-         let shell = { Updater.net_id ; predecessor ; timestamp ; fitness ;
+         let shell = { Updater.net_id ; level ; predecessor ;
-                       operations } in
+                       timestamp ; fitness ; operations_hash } in
          let bytes = Data.Command.forge shell command in
          RPC.Answer.return bytes) in
   dir

test/p2p/test_p2p_connection.ml

@@ -64,7 +64,7 @@ let sync_nodes nodes =
   sync_nodes nodes >>= function
   | Ok () | Error (Exn End_of_file :: _) ->
       return ()
-  | Error e as err ->
+  | Error _ as err ->
       Lwt.return err
 
 let run_nodes client server =
@@ -147,7 +147,7 @@ module Low_level = struct
     return ()
 
   let server _ch sched socket =
-    raw_accept sched socket >>= fun (fd, point) ->
+    raw_accept sched socket >>= fun (fd, _point) ->
     P2p_io_scheduler.write fd simple_msg >>=? fun () ->
     P2p_io_scheduler.close fd >>=? fun _ ->
     return ()
@@ -190,7 +190,7 @@ module Kicked = struct
   let encoding = Data_encoding.bytes
 
   let server _ch sched socket =
-    accept sched socket >>=? fun (info, auth_fd) ->
+    accept sched socket >>=? fun (_info, auth_fd) ->
     P2p_connection.accept auth_fd encoding >>= fun conn ->
     _assert (Kick.is_rejected conn) __LOC__ "" >>=? fun () ->
     return ()
@@ -212,7 +212,7 @@ module Simple_message = struct
   let simple_msg2 = MBytes.create (1 lsl 4)
 
   let server ch sched socket =
-    accept sched socket >>=? fun (info, auth_fd) ->
+    accept sched socket >>=? fun (_info, auth_fd) ->
     P2p_connection.accept auth_fd encoding >>=? fun conn ->
     P2p_connection.write_sync conn simple_msg >>=? fun () ->
     P2p_connection.read conn >>=? fun (_msg_size, msg) ->
@@ -242,7 +242,7 @@ module Close_on_read = struct
   let simple_msg = MBytes.create (1 lsl 4)
 
   let server _ch sched socket =
-    accept sched socket >>=? fun (info, auth_fd) ->
+    accept sched socket >>=? fun (_info, auth_fd) ->
     P2p_connection.accept auth_fd encoding >>=? fun conn ->
     P2p_connection.close conn >>= fun _stat ->
     return ()
@@ -266,7 +266,7 @@ module Close_on_write = struct
   let simple_msg = MBytes.create (1 lsl 4)
 
   let server ch sched socket =
-    accept sched socket >>=? fun (info, auth_fd) ->
+    accept sched socket >>=? fun (_info, auth_fd) ->
     P2p_connection.accept auth_fd encoding >>=? fun conn ->
     P2p_connection.close conn >>= fun _stat ->
     sync ch >>=? fun ()->
@@ -291,8 +291,8 @@ module Garbled_data = struct
 
   let garbled_msg = MBytes.create (1 lsl 4)
 
-  let server ch sched socket =
+  let server _ch sched socket =
-    accept sched socket >>=? fun (info, auth_fd) ->
+    accept sched socket >>=? fun (_info, auth_fd) ->
     P2p_connection.accept auth_fd encoding >>=? fun conn ->
     P2p_connection.raw_write_sync conn garbled_msg >>=? fun () ->
     P2p_connection.read conn >>= fun err ->
@@ -300,7 +300,7 @@ module Garbled_data = struct
     P2p_connection.close conn >>= fun _stat ->
     return ()
 
-  let client ch sched addr port =
+  let client _ch sched addr port =
     connect sched addr port id2 >>=? fun auth_fd ->
     P2p_connection.accept auth_fd encoding >>=? fun conn ->
     P2p_connection.read conn >>= fun err ->
@@ -328,7 +328,7 @@ let spec = Arg.[
 
 let main () =
   let open Utils in
-  let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
+  let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
   let usage_msg = "Usage: %s.\nArguments are:" in
   Arg.parse spec anon_fun usage_msg ;
   Test.run "p2p-connection." [

test/p2p/test_p2p_connection_pool.ml

@@ -54,7 +54,7 @@ let sync_nodes nodes =
   sync_nodes nodes >>= function
   | Ok () | Error (Exn End_of_file :: _) ->
       return ()
-  | Error e as err ->
+  | Error _ as err ->
       Lwt.return err
 
 let detach_node f points n =
@@ -100,7 +100,7 @@ let detach_node f points n =
       return ()
     end
 
-let detach_nodes ?(sync = 0) run_node points =
+let detach_nodes run_node points =
   let open Utils in
   let clients = List.length points in
   Lwt_list.map_p
@@ -196,7 +196,7 @@ module Random_connections = struct
     let rem = ref (n * total) in
     iter_p (fun point -> connect_random pool total rem point n) points
 
-  let node repeat channel pool points =
+  let node repeat _channel pool points =
     lwt_log_info "Begin random connections." >>= fun () ->
     connect_random_all pool points repeat >>=? fun () ->
     lwt_log_info "Random connections OK." >>= fun () ->
@@ -267,7 +267,7 @@ let spec = Arg.[
 
 let main () =
   let open Utils in
-  let anon_fun num_peers = raise (Arg.Bad "No anonymous argument.") in
+  let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
   let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
   Arg.parse spec anon_fun usage_msg ;
   let ports = !port -- (!port + !clients - 1) in

test/proto_alpha/proto_alpha_helpers.ml

@@ -361,7 +361,7 @@ module Mining = struct
       block
       delegate_sk
       shell
-      mining_slot
+      priority
       seed_nonce_hash =
     Client_proto_rpcs.Constants.stamp_threshold
       rpc_config block >>=? fun stamp_threshold ->
@@ -370,7 +370,7 @@ module Mining = struct
         Sodium.Random.Bigbytes.generate Constants.proof_of_work_nonce_size in
       let unsigned_header =
         Block.forge_header
-          shell { mining_slot ; seed_nonce_hash ; proof_of_work_nonce } in
+          shell { priority ; seed_nonce_hash ; proof_of_work_nonce } in
       let signed_header =
         Environment.Ed25519.Signature.append delegate_sk unsigned_header in
       let block_hash = Block_hash.hash_bytes [signed_header] in
@@ -393,24 +393,24 @@ module Mining = struct
     Client_node_rpcs.Blocks.info rpc_config block >>=? fun bi ->
     let seed_nonce_hash = Nonce.hash seed_nonce in
     Client_proto_rpcs.Context.next_level rpc_config block >>=? fun level ->
-    let operations =
+    let operations_hash =
       Operation_list_list_hash.compute
         [Operation_list_hash.compute operation_list] in
     let shell =
-      { Store.Block_header.net_id = bi.net ; predecessor = bi.hash ;
+      { Store.Block_header.net_id = bi.net_id ; predecessor = bi.hash ;
-        timestamp ; fitness ; operations } in
+        timestamp ; fitness ; operations_hash ;
-    let slot = { Block.level = level.level ; priority = Int32.of_int priority } in
+        level = Raw_level.to_int32 level.level } in
     mine_stamp
-      block src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce ->
+      block src_sk shell priority seed_nonce_hash >>=? fun proof_of_work_nonce ->
     Client_proto_rpcs.Helpers.Forge.block rpc_config
       block
-      ~net:bi.net
+      ~net:bi.net_id
       ~predecessor:bi.hash
       ~timestamp
       ~fitness
-      ~operations
+      ~operations_hash
       ~level:level.level
-      ~priority:priority
+      ~priority
       ~seed_nonce_hash
       ~proof_of_work_nonce
       () >>=? fun unsigned_header ->
@@ -422,6 +422,7 @@ module Mining = struct
   let mine
       ?(force = false)
       ?(operations = [])
+      ~fitness_gap
       contract
       block =
   Client_mining_blocks.info rpc_config block >>=? fun bi ->
@@ -434,12 +435,11 @@ module Mining = struct
   Client_proto_rpcs.Context.level rpc_config block >>=? fun level ->
   let level = Raw_level.succ level.level in
   get_first_priority level contract block >>=? fun priority ->
-  (Fitness_repr.to_int64 bi.fitness >|=
+  (Lwt.return (Fitness_repr.to_int64 bi.fitness) >|=
    Register_client_embedded_proto_alpha.wrap_error) >>=? fun fitness ->
   let fitness =
     Fitness_repr.from_int64 @@
-    Int64.add fitness (Int64.of_int @@ List.length operations + 1) in
+    Int64.add fitness (Int64.of_int fitness_gap) in
-  Level.pp_full Format.str_formatter bi.level ;
   inject_block
     ~force
     ~priority
@@ -453,7 +453,7 @@ module Mining = struct
   let endorsement_reward contract block =
     Client_mining_blocks.info rpc_config block >>=? fun bi ->
     get_first_priority bi.level.level contract block >>=? fun prio ->
-    Mining.endorsement_reward ~block_priority:(Int32.of_int prio) >|=
+    Mining.endorsement_reward ~block_priority:prio >|=
     Register_client_embedded_proto_alpha.wrap_error >>|?
     Tez.to_cents
 
@@ -553,3 +553,8 @@ module Endorse = struct
       block delegate ()
 
 end
+
+let display_level block =
+  Client_proto_rpcs.Context.level rpc_config block >>=? fun lvl ->
+  Format.eprintf "Level: %a@." Level.pp_full lvl ;
+  return ()

test/proto_alpha/proto_alpha_helpers.mli

@@ -105,7 +105,7 @@ module Mining : sig
     Client_proto_rpcs.block ->
     secret_key ->
     Updater.shell_block ->
-    Block.mining_slot ->
+    int ->
     Nonce_hash.t ->
     MBytes.t tzresult Lwt.t
 
@@ -122,6 +122,7 @@ module Mining : sig
   val mine :
     ?force:bool ->
     ?operations:Operation_hash.t list ->
+    fitness_gap:int ->
     Account.t ->
     Client_node_rpcs.Blocks.block ->
     Block_hash.t tzresult Lwt.t
@@ -191,3 +192,7 @@ module Assert : sig
   val invalid_endorsement_slot : msg:string -> 'a tzresult -> unit
 
 end
+
+val rpc_config: Client_rpcs.config
+
+val display_level: Client_proto_rpcs.block -> unit tzresult Lwt.t

test/proto_alpha/test_endorsement.ml

@@ -9,6 +9,7 @@
 
 open Client_embedded_proto_alpha
 open Tezos_context
+open Client_alpha
 
 module Helpers = Proto_alpha_helpers
 module Assert = Helpers.Assert
@@ -16,25 +17,25 @@ module Assert = Helpers.Assert
 let test_double_endorsement contract block =
 
   (* Double endorsement for the same level *)
-  Helpers.Mining.mine contract block >>=? fun b1 ->
+  Helpers.Mining.mine ~fitness_gap:1 contract block >>=? fun b1 ->
 
   (* branch root *)
-  Helpers.Mining.mine contract (`Hash b1) >>=? fun b2 ->
+  Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b1) >>=? fun b2 ->
   (* changing branch *)
-  Helpers.Mining.mine contract (`Hash b1) >>=? fun b2' ->
+  Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b1) >>=? fun b2' ->
 
   (* branch root *)
   Helpers.Endorse.endorse ~force:true contract (`Hash b2) >>=? fun ops ->
-  Helpers.Mining.mine ~operations:[ ops ] contract (`Hash b2) >>=? fun _b3 ->
+  Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] contract (`Hash b2) >>=? fun _b3 ->
 
   Helpers.Endorse.endorse ~force:true contract (`Hash b2') >>=? fun ops ->
-  Helpers.Mining.mine ~operations:[ ops ] contract (`Hash b2') >>=? fun b3' ->
+  Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] contract (`Hash b2') >>=? fun b3' ->
 
   Helpers.Endorse.endorse ~force:true contract (`Hash b3') >>=? fun ops ->
-  Helpers.Mining.mine ~operations:[ ops ] contract (`Hash b3') >>=? fun b4' ->
+  Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] contract (`Hash b3') >>=? fun b4' ->
 
   (* TODO: Inject double endorsement op ! *)
-  Helpers.Mining.mine contract (`Hash b4')
+  Helpers.Mining.mine ~fitness_gap:1 contract (`Hash b4')
 
 (* FIXME: Mining.Invalid_signature is unclassified *)
 let test_invalid_signature block =
@@ -47,7 +48,7 @@ let test_invalid_signature block =
        DYfTKhq7rDQujdn5WWzwUMeV3agaZ6J2vPQT58jJAJPi" in
   let account =
     Helpers.Account.create ~keys:(secret_key, public_key) "WRONG SIGNATURE" in
-  Helpers.Mining.mine account block >>= fun res ->
+  Helpers.Mining.mine ~fitness_gap:1 account block >>= fun res ->
   Assert.generic_economic_error ~msg:__LOC__ res ;
   return ()
 
@@ -77,7 +78,7 @@ let test_invalid_endorsement_slot contract block =
   return ()
 
 let test_endorsement_rewards
-    block ({ Helpers.Account.b1 ; _ } as baccounts) =
+    block ({ Helpers.Account.b5 = b1 ; _ } as baccounts) =
   let get_endorser_except_b1 accounts =
     let account, cpt = ref accounts.(0), ref 0 in
     while !account = b1 do
@@ -94,20 +95,24 @@ let test_endorsement_rewards
   get_endorser_except_b1 accounts >>=? fun (account0, slot0) ->
   Helpers.Account.balance account0 >>=? fun balance0 ->
   Helpers.Endorse.endorse ~slot:slot0 ~force:true account0 block >>=? fun ops ->
-  Helpers.Mining.mine ~operations:[ ops ] b1 block >>=? fun head0 ->
+  Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 block >>=? fun head0 ->
+  Helpers.display_level (`Hash head0) >>=? fun () ->
   Assert.balance_equal ~msg:__LOC__ account0
     (Int64.sub (Tez.to_cents balance0) bond) >>=? fun () ->
 
+
   (* #2 endorse & inject in a block  *)
   let block0 = `Hash head0 in
   Helpers.Endorse.endorsers_list block0 baccounts >>=? fun accounts ->
   get_endorser_except_b1 accounts >>=? fun (account1, slot1) ->
   Helpers.Account.balance account1 >>=? fun balance1 ->
   Helpers.Endorse.endorse ~slot:slot1 ~force:true account1 block0 >>=? fun ops ->
-  Helpers.Mining.mine ~operations:[ ops ] b1 block0 >>=? fun head1 ->
+  Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 block0 >>=? fun head1 ->
+  Helpers.display_level (`Hash head1) >>=? fun () ->
   Assert.balance_equal ~msg:__LOC__ account1
     (Int64.sub (Tez.to_cents balance1) bond) >>=? fun () ->
 
+
   (* #3 endorse but the operation is not included in a block, so no reward  *)
   let block1 = `Hash head1 in
   Helpers.Endorse.endorsers_list block1 baccounts >>=? fun accounts ->
@@ -117,8 +122,12 @@ let test_endorsement_rewards
   Assert.balance_equal ~msg:__LOC__ account2
     (Int64.sub (Tez.to_cents balance2) bond) >>=? fun () ->
 
-  Helpers.Mining.mine b1 (`Hash head1) >>=? fun head2 ->
+  Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head1) >>=? fun head2 ->
-  Helpers.Mining.mine b1 (`Hash head2) >>=? fun head3 ->
+  Helpers.display_level (`Hash head2) >>=? fun () ->
+  Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head2) >>=? fun head3 ->
+  Helpers.display_level (`Hash head3) >>=? fun () ->
+  Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head3) >>=? fun head4 ->
+  Helpers.display_level (`Hash head4) >>=? fun () ->
 
   (* Check rewards after one cycle for account0 *)
   Helpers.Mining.endorsement_reward b1 block0 >>=? fun rw0 ->
@@ -135,8 +144,10 @@ let test_endorsement_rewards
     ~msg:__LOC__ account2 (Tez.to_cents balance2) >>=? fun () ->
 
   (* #2 endorse and check reward only on the good chain  *)
-  Helpers.Mining.mine b1 (`Hash head3) >>=? fun head ->
+  Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head4) >>=? fun head ->
-  Helpers.Mining.mine b1 (`Hash head3) >>=? fun fork ->
+  Helpers.display_level (`Hash head) >>=? fun () ->
+  Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head4) >>=? fun fork ->
+  Helpers.display_level (`Hash fork) >>=? fun () ->
 
   (* working on head *)
   Helpers.Endorse.endorsers_list (`Hash head) baccounts >>=? fun accounts ->
@@ -144,18 +155,22 @@ let test_endorsement_rewards
   Helpers.Account.balance account3 >>=? fun balance3 ->
   Helpers.Endorse.endorse
     ~slot:slot3 ~force:true account3 (`Hash head) >>=? fun ops ->
-  Helpers.Mining.mine ~operations:[ ops ] b1 (`Hash head) >>=? fun new_head ->
+  Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash head) >>=? fun new_head ->
+  Helpers.display_level (`Hash new_head) >>=? fun () ->
 
   (* working on fork *)
   Helpers.Endorse.endorsers_list (`Hash fork) baccounts >>=? fun accounts ->
   get_endorser_except_b1 accounts >>=? fun (account4, slot4) ->
   Helpers.Account.balance account4 >>=? fun _balance4 ->
   Helpers.Endorse.endorse ~slot:slot4 ~force:true account4 (`Hash fork) >>=? fun ops ->
-  Helpers.Mining.mine ~operations:[ ops ] b1 (`Hash fork) >>=? fun _new_fork ->
+  Helpers.Mining.mine ~fitness_gap:2 ~operations:[ ops ] b1 (`Hash fork) >>=? fun _new_fork ->
+  Helpers.display_level (`Hash _new_fork) >>=? fun () ->
   Helpers.Account.balance account4 >>=? fun balance4 ->
 
-  Helpers.Mining.mine b1 (`Hash new_head) >>=? fun head ->
+  Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash new_head) >>=? fun head ->
-  Helpers.Mining.mine b1 (`Hash head) >>=? fun head ->
+  Helpers.display_level (`Hash head) >>=? fun () ->
+  Helpers.Mining.mine ~fitness_gap:1 b1 (`Hash head) >>=? fun head ->
+  Helpers.display_level (`Hash head) >>=? fun () ->
 
   (* Check rewards after one cycle *)
   Helpers.Mining.endorsement_reward b1 (`Hash new_head) >>=? fun reward ->
@@ -209,7 +224,7 @@ let run head (({ b1 ; b2 ; b3 ; b4 ; b5 } : Helpers.Account.bootstrap_accounts)
   (* FIXME: cannot inject double endorsement operation yet, but the
      code is still here
      Double endorsement *)
-  test_double_endorsement b5 (`Hash head) >>=? fun new_head ->
+  test_double_endorsement b4 (`Hash head) >>=? fun new_head ->
 
   return new_head
 

test/proto_alpha/test_origination.ml

@@ -15,7 +15,7 @@ module Assert = Helpers.Assert
 
 let run blkid ({ b1 ; b2 ; _ } : Helpers.Account.bootstrap_accounts) =
 
-  Helpers.Mining.mine b1 blkid >>=? fun blkh ->
+  Helpers.Mining.mine ~fitness_gap:1 b1 blkid >>=? fun blkh ->
   let foo = Helpers.Account.create "foo" in
 
   (* Origination with amount = 0 tez *)

test/proto_alpha/test_transaction.ml

@@ -15,7 +15,7 @@ module Assert = Helpers.Assert
 
 let run blkid ({ b1 ; b2 ; b3 ; _ } : Helpers.Account.bootstrap_accounts) =
 
-  Helpers.Mining.mine b1 blkid >>=? fun blkh ->
+  Helpers.Mining.mine ~fitness_gap:1 b1 blkid >>=? fun blkh ->
   let foo = Helpers.Account.create "foo" in
   let bar = Helpers.Account.create "bar" in
 

test/shell/test_context.ml

@@ -37,6 +37,8 @@ let net_id = Net_id.of_block_hash genesis_block
 
 (** Context creation *)
 
+let commit = commit ~time:Time.epoch ~message:""
+
 let block2 =
   Block_hash.of_hex_exn
     "2222222222222222222222222222222222222222222222222222222222222222"
@@ -87,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 () ->

test/shell/test_state.ml

@@ -38,7 +38,7 @@ let net_id = Net_id.of_block_hash genesis_block
 let incr_fitness fitness =
   let new_fitness =
     match fitness with
-    | [ _ ; fitness ] ->
+    | [ fitness ] ->
         Pervasives.(
           Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
           |> Utils.unopt ~default:0L
@@ -47,7 +47,7 @@ let incr_fitness fitness =
         )
     | _ -> Data_encoding.Binary.to_bytes Data_encoding.int64 1L
   in
-  [ MBytes.of_string "\000" ; new_fitness ]
+  [ new_fitness ]
 
 let incr_timestamp timestamp =
   Time.add timestamp (Int64.add 1L (Random.int64 10L))
@@ -62,15 +62,16 @@ let operation op =
   Data_encoding.Binary.to_bytes Store.Operation.encoding op
 
 let block _state ?(operations = []) pred_hash pred name : Store.Block_header.t =
-  let operations =
+  let operations_hash =
     Operation_list_list_hash.compute
       [Operation_list_hash.compute operations] in
   let fitness = incr_fitness pred.Store.Block_header.shell.fitness in
   let timestamp = incr_timestamp pred.shell.timestamp in
   { shell = {
         net_id = pred.shell.net_id ;
+        level = Int32.succ pred.shell.level ;
         predecessor = pred_hash ;
-        timestamp ; operations; fitness } ;
+        timestamp ; operations_hash ; fitness } ;
     proto = MBytes.of_string name ;
   }
 
@@ -133,14 +134,15 @@ let build_chain state tbl otbl pred names =
 
 let block _state ?(operations = []) (pred: State.Valid_block.t) name
   : State.Block_header.t =
-  let operations =
+  let operations_hash =
     Operation_list_list_hash.compute
       [Operation_list_hash.compute operations] in
   let fitness = incr_fitness pred.fitness in
   let timestamp = incr_timestamp pred.timestamp in
   { shell = { net_id = pred.net_id ;
+              level = Int32.succ pred.level ;
               predecessor = pred.hash ;
-              timestamp ; operations; fitness } ;
+              timestamp ; operations_hash ; fitness } ;
     proto = MBytes.of_string name ;
   }
 
@@ -166,6 +168,7 @@ let build_valid_chain state tbl vtbl otbl pred names =
            Proto.begin_application
              ~predecessor_context: pred.context
              ~predecessor_timestamp: pred.timestamp
+             ~predecessor_fitness: pred.fitness
              block >>=? fun vstate ->
            (* no operations *)
            Proto.finalize_block vstate

test/shell/test_store.ml

@@ -89,13 +89,14 @@ let test_operation s =
 (** Block store *)
 
 let lolblock ?(operations = []) header =
-  let operations =
+  let operations_hash =
     Operation_list_list_hash.compute
       [Operation_list_hash.compute operations] in
   { Store.Block_header.shell =
       { timestamp = Time.of_seconds (Random.int64 1500L) ;
+        level = 0l ; (* dummy *)
         net_id ;
-        predecessor = genesis_block ; operations ;
+        predecessor = genesis_block ; operations_hash ;
         fitness = [MBytes.of_string @@ string_of_int @@ String.length header;
                    MBytes.of_string @@ string_of_int @@ 12] } ;
     proto = MBytes.of_string header ;