Proto: explicit fitness/timestamp in the signature

This remove the data fomr the context where they "duplicate" the
block header.

src/node/db/context.ml

@@ -84,15 +84,11 @@ type t = context
 (*-- Version Access and Update -----------------------------------------------*)
 
 let current_protocol_key = ["protocol"]
-let current_fitness_key = ["fitness"]
-let current_timestamp_key = ["timestamp"]
 let current_test_protocol_key = ["test_protocol"]
 let current_test_network_key = ["test_network"]
 let current_test_network_expiration_key = ["test_network_expiration"]
 let current_fork_test_network_key = ["fork_test_network"]
 
-let transient_commit_message_key = ["message"]
-
 let exists { repo } key =
   GitStore.of_branch_id
     Irmin.Task.none (Block_hash.to_b58check key) repo >>= fun t ->
@@ -134,59 +130,17 @@ let exists index key =
     Block_hash.pp_short key exists >>= fun () ->
   Lwt.return exists
 
-let get_and_erase_commit_message ctxt =
-  GitStore.FunView.get ctxt.view transient_commit_message_key >>= function
-  | None -> Lwt.return (None, ctxt)
-  | Some bytes ->
-     GitStore.FunView.del ctxt.view transient_commit_message_key >>= fun view ->
-     Lwt.return (Some (MBytes.to_string bytes), { ctxt with view })
-let set_commit_message ctxt msg =
-  GitStore.FunView.set ctxt.view
-    transient_commit_message_key
-    (MBytes.of_string msg) >>= fun view ->
-  Lwt.return { ctxt with view }
-
-let get_fitness { view } =
-  GitStore.FunView.get view current_fitness_key >>= function
-  | None -> assert false
-  | Some data ->
-      match Data_encoding.Binary.of_bytes Fitness.encoding data with
-      | None -> assert false
-      | Some data -> Lwt.return data
-let set_fitness ctxt data =
-  GitStore.FunView.set ctxt.view current_fitness_key
-    (Data_encoding.Binary.to_bytes Fitness.encoding data) >>= fun view ->
-  Lwt.return { ctxt with view }
-
-let get_timestamp { view } =
-  GitStore.FunView.get view current_timestamp_key >>= function
-  | None -> assert false
-  | Some time ->
-     Lwt.return (Time.of_notation_exn (MBytes.to_string time))
-let set_timestamp ctxt time =
-  GitStore.FunView.set ctxt.view current_timestamp_key
-    (MBytes.of_string (Time.to_notation time)) >>= fun view ->
-  Lwt.return { ctxt with view }
-
 exception Preexistent_context of Block_hash.t
 exception Empty_head of Block_hash.t
 
-let commit key context =
+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
@@ -267,18 +221,15 @@ let init ?patch_context ~root =
   }
 
 let commit_genesis index ~id:block ~time ~protocol ~test_protocol =
+  let task = Irmin.Task.create ~date:(Time.to_seconds time) ~owner:"Tezos" in
   GitStore.of_branch_id
-    Irmin.Task.none (Block_hash.to_b58check block)
+    task (Block_hash.to_b58check block)
     index.repo >>= fun t ->
-  let store = t () in
+  let store = t "Genesis" in
   GitStore.FunView.of_path store [] >>= fun view ->
   let view = (view, index.repack_scheduler) in
-  GitStore.FunView.set view current_timestamp_key
-    (MBytes.of_string (Time.to_notation time)) >>= fun view ->
   GitStore.FunView.set view current_protocol_key
     (Protocol_hash.to_bytes protocol) >>= fun view ->
-  GitStore.FunView.set view current_fitness_key
-    (Data_encoding.Binary.to_bytes Fitness.encoding []) >>= fun view ->
   GitStore.FunView.set view current_test_protocol_key
     (Protocol_hash.to_bytes test_protocol) >>= fun view ->
   let ctxt = { index ; store ; view } in
@@ -334,7 +285,6 @@ let init_test_network v ~time ~genesis =
   get_test_protocol v >>= fun test_protocol ->
   del_test_network_expiration v >>= fun v ->
   set_protocol v test_protocol >>= fun v ->
-  set_timestamp v time >>= fun v ->
   let task =
     Irmin.Task.create
       ~date:(Time.to_seconds time)

src/node/db/context.mli

@@ -40,7 +40,11 @@ exception Preexistent_context of Block_hash.t
 val exists: index -> Block_hash.t -> bool Lwt.t
 val checkout: index -> Block_hash.t -> context option Lwt.t
 val checkout_exn: index -> Block_hash.t -> context Lwt.t
-val commit: Block_hash.t -> context -> unit Lwt.t
+val commit:
+  Block_hash.t ->
+  time:Time.t ->
+  message:string ->
+  context -> unit Lwt.t
 
 (** {2 Predefined Fields} ****************************************************)
 
@@ -58,16 +62,9 @@ val get_test_network_expiration: context -> Time.t option Lwt.t
 val set_test_network_expiration: context -> Time.t -> context Lwt.t
 val del_test_network_expiration: context -> context Lwt.t
 
+(* FIXME split in two (reset after commit *)
 val read_and_reset_fork_test_network: context -> (bool * context) Lwt.t
 val fork_test_network: context -> context Lwt.t
 
-val set_fitness: context -> Fitness.fitness -> context Lwt.t
-val get_fitness: context -> Fitness.fitness Lwt.t
-
-val set_timestamp: context -> Time.t -> context Lwt.t
-val get_timestamp: context -> Time.t Lwt.t
-
-val set_commit_message: context -> string -> context Lwt.t
-
 val init_test_network:
   context ->  time:Time.t -> genesis:Block_hash.t -> context tzresult Lwt.t

src/node/shell/node.ml

@@ -278,9 +278,8 @@ module RPC = struct
         State.Valid_block.Current.head net_state >>= fun head ->
         Prevalidator.context pv >>= function
         | Error _ -> Lwt.fail Not_found
-        | Ok ctxt ->
+        | Ok { context ; fitness } ->
-            Context.get_fitness ctxt >>= fun fitness ->
+            Context.get_protocol context >>= fun protocol ->
-            Context.get_protocol ctxt >>= fun protocol ->
             let operations =
               let pv_result, _ = Prevalidator.operations pv in
               Some [ pv_result.applied ] in
@@ -291,29 +290,36 @@ module RPC = struct
                 protocol = Some protocol ;
                 fitness ; operations ; timestamp }
 
-  let get_context node block =
+  let rpc_context block : Updater.rpc_context =
+    { context = block.State.Valid_block.context ;
+      fitness = block.fitness ;
+      timestamp = block. timestamp }
+
+  let get_rpc_context node block =
     match block with
     | `Genesis ->
         State.Valid_block.Current.genesis node.mainnet_net >>= fun block ->
-        Lwt.return (Some block.context)
+        Lwt.return (Some (rpc_context block))
     | ( `Head n | `Test_head n ) as block ->
         let validator = get_validator node block in
         let net_state = Validator.net_state validator in
         let net_db = Validator.net_db validator in
         State.Valid_block.Current.head net_state >>= fun head ->
-        get_pred net_db n head >>= fun { context } ->
+        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 pv = Validator.prevalidator validator in
         Prevalidator.context pv >>= function
         | Error _ -> Lwt.fail Not_found
-        | Ok ctxt -> Lwt.return (Some ctxt)
+        | Ok { context ; fitness } ->
+            let timestamp = Prevalidator.timestamp pv in
+            Lwt.return (Some { Updater.context ; fitness ; timestamp })
 
   let operations node block =
     match block with
@@ -417,8 +423,7 @@ module RPC = struct
       ~predecessor ~timestamp >>=? fun validation_state ->
     Prevalidation.prevalidate
       validation_state ~sort rops >>=? fun (validation_state, r) ->
-    Prevalidation.end_prevalidation validation_state >>=? fun ctxt ->
+    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 +431,9 @@ module RPC = struct
     | None ->
         Base58.complete str
     | Some block ->
-        get_context node block >>= function
+        get_rpc_context node block >>= function
         | None -> Lwt.fail Not_found
-        | Some ctxt ->
+        | Some { context = ctxt } ->
             Context.get_protocol ctxt >>= fun protocol_hash ->
             let (module Proto) = Updater.get_exn protocol_hash in
             Base58.complete str >>= fun l1 ->
@@ -436,12 +441,12 @@ module RPC = struct
             Lwt.return (l1 @ l2)
 
   let context_dir node block =
-    get_context node block >>= function
+    get_rpc_context node block >>= function
     | None -> Lwt.return None
-    | Some ctxt ->
+    | 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 =

src/node/shell/prevalidation.ml

@@ -135,7 +135,8 @@ let start_prevalidation
     { State.Valid_block.protocol ;
       hash = predecessor ;
       context = predecessor_context ;
-      timestamp = predecessor_timestamp }
+      timestamp = predecessor_timestamp ;
+      fitness = predecessor_fitness }
     ~timestamp =
   let (module Proto) =
     match protocol with
@@ -144,8 +145,10 @@ let start_prevalidation
   Proto.begin_construction
     ~predecessor_context
     ~predecessor_timestamp
+    ~predecessor_fitness
     ~predecessor
-    ~timestamp >>=? fun state ->
+    ~timestamp
+  >>=? fun state ->
   return (State { proto = (module Proto) ; state })
 
 let prevalidate

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

@@ -996,14 +996,13 @@ module Valid_block = struct
         block_header_store
         (net_state: net_state)
         valid_block_watcher
-        hash context ttl =
+        hash { Updater.context ; fitness ; message } ttl =
       (* Read the block header. *)
       Raw_block_header.Locked.read
         block_header_store hash >>=? fun block ->
       Raw_block_header.Locked.read_discovery_time
         block_header_store hash >>=? fun discovery_time ->
       (* Check fitness coherency. *)
-      Context.get_fitness context >>= fun fitness ->
       fail_unless
         (Fitness.equal fitness block.Store.Block_header.shell.fitness)
         (Invalid_fitness
@@ -1041,7 +1040,15 @@ module Valid_block = struct
       Operation_list.Locked.read_all
         block_header_store hash >>=? fun operations ->
       (* Let's commit the context. *)
-      Context.commit hash context >>= fun () ->
+      let message =
+        match message with
+        | Some message -> message
+        | None ->
+            Format.asprintf "%a: %a"
+              Block_hash.pp_short hash
+              Fitness.pp fitness in
+      Context.commit
+        hash ~time:block.shell.timestamp ~message context >>= fun () ->
       (* Update the chain state. *)
       let store = net_state.chain_store in
       let predecessor = block.shell.predecessor in

src/node/shell/state.mli

@@ -284,7 +284,8 @@ module Valid_block : sig
   val read_opt: Net.t -> Block_hash.t -> valid_block option Lwt.t
   val read_exn: Net.t -> Block_hash.t -> valid_block Lwt.t
   val store:
-    Net.t -> Block_hash.t -> Context.t -> valid_block option tzresult Lwt.t
+    Net.t -> Block_hash.t -> Updater.validation_result ->
+    valid_block option tzresult Lwt.t
 
   val watcher: Net.t -> valid_block Lwt_stream.t * Watcher.stopper
 

src/node/shell/validator.ml

@@ -181,10 +181,8 @@ let apply_block net db
   begin
     match pred.protocol with
     | None -> fail (State.Unknown_protocol pred.protocol_hash)
-    | Some p ->
+    | 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 () ->
@@ -201,8 +199,9 @@ let apply_block net db
   lwt_debug "validation of %a: applying block..."
     Block_hash.pp_short hash >>= fun () ->
   Proto.begin_application
-    ~predecessor_context:patched_context
+    ~predecessor_context:pred.context
     ~predecessor_timestamp:pred.timestamp
+    ~predecessor_fitness:pred.fitness
     block >>=? fun state ->
   fold_left_s (fun state op ->
       Proto.apply_operation state op >>=? fun state ->

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,12 @@ type raw_operation = Store.Operation.t = {
   proto: MBytes.t ;
 }
 
-(** The version agnostic toplevel structure of blocks. *)
 type shell_block = Store.Block_header.shell_header =
   { net_id: Net_id.t ;
-    (** The genesis of the chain this block belongs to. *)
     predecessor: Block_hash.t ;
-    (** The preceding block in the chain. *)
     timestamp: Time.t ;
-    (** The date at which this block has been forged. *)
     operations: Operation_list_list_hash.t ;
-    (** The sequence of operations. *)
     fitness: MBytes.t list ;
-    (** The announced score of the block. As a sequence of sequences
-        of unsigned bytes. Ordered by length and then by contents
-        lexicographically. *)
   }
 
 type raw_block = Store.Block_header.t = {
@@ -44,96 +35,59 @@ type raw_block = Store.Block_header.t = {
   proto: MBytes.t ;
 }
 
-(** This is the signature of a Tezos protocol implementation. It has
+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 ;
+  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_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_fitness
         ~predecessor ~timestamp =
       begin_construction
         ~predecessor_context ~predecessor_timestamp
+        ~predecessor_fitness
         ~predecessor ~timestamp >|= wrap_error
     let current_context c =
       current_context c >|= wrap_error

src/node/updater/updater.ml

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

src/node/updater/updater.mli

@@ -18,20 +18,12 @@ type raw_operation = Store.Operation.t = {
 }
 val raw_operation_encoding: raw_operation Data_encoding.t
 
-(** The version agnostic toplevel structure of blocks. *)
 type shell_block = Store.Block_header.shell_header = {
   net_id: Net_id.t ;
-  (** The genesis of the chain this block belongs to. *)
   predecessor: Block_hash.t ;
-  (** The preceding block in the chain. *)
   timestamp: Time.t ;
-  (** The date at which this block has been forged. *)
   operations: Operation_list_list_hash.t ;
-  (** The sequence of operations. *)
   fitness: MBytes.t list ;
-  (** The announced score of the block. As a sequence of sequences
-      of unsigned bytes. Ordered by length and then by contents
-      lexicographically. *)
 }
 val shell_block_encoding: shell_block Data_encoding.t
 
@@ -41,6 +33,18 @@ type raw_block = Store.Block_header.t = {
 }
 val raw_block_encoding: raw_block Data_encoding.t
 
+type validation_result = Protocol.validation_result = {
+  context: Context.t ;
+  fitness: Fitness.fitness ;
+  message: string option ;
+}
+
+type rpc_context = Protocol.rpc_context = {
+  context: Context.t ;
+  timestamp: Time.t ;
+  fitness: Fitness.fitness ;
+}
+
 module type PROTOCOL = Protocol.PROTOCOL
 module type REGISTRED_PROTOCOL = sig
   val hash: Protocol_hash.t

src/proto/alpha/apply.ml

@@ -51,7 +51,7 @@ let apply_delegate_operation_content
         (Block_hash.equal block pred_block)
         (Wrong_endorsement_predecessor (pred_block, block)) >>=? fun () ->
       Mining.check_signing_rights ctxt slot delegate >>=? fun () ->
-      Fitness.increase ctxt >>=? fun ctxt ->
+      let ctxt = Fitness.increase ctxt in
       Mining.pay_endorsement_bond ctxt delegate >>=? fun (ctxt, bond) ->
       Mining.endorsement_reward ~block_priority >>=? fun reward ->
       Level.current ctxt >>=? fun { cycle = current_cycle } ->
@@ -238,7 +238,7 @@ let may_start_new_cycle ctxt =
       Seed.compute_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt ->
       Roll.clear_cycle ctxt last_cycle >>=? fun ctxt ->
       Roll.freeze_rolls_for_cycle ctxt (Cycle.succ new_cycle) >>=? fun ctxt ->
-      Timestamp.get_current ctxt >>= fun timestamp ->
+      let timestamp = Timestamp.current ctxt in
       Lwt.return (Timestamp.(timestamp +? (Constants.time_before_reward ctxt)))
       >>=? fun reward_date ->
       Reward.set_reward_time_for_cycle
@@ -254,10 +254,10 @@ let begin_application ctxt block pred_timestamp =
   Mining.check_mining_rights ctxt block pred_timestamp >>=? fun miner ->
   Mining.check_signature ctxt block miner >>=? fun () ->
   Mining.pay_mining_bond ctxt block miner >>=? fun ctxt ->
-  Fitness.increase ctxt >>=? fun ctxt ->
+  let ctxt = Fitness.increase ctxt in
   return (ctxt, miner)
 
-let finalize_application ctxt block miner op_count =
+let finalize_application ctxt block miner =
   (* end of level (from this point nothing should fail) *)
   let priority = block.Block.proto.mining_slot.priority in
   let reward = Mining.base_mining_reward ctxt ~priority in
@@ -268,14 +268,7 @@ let finalize_application ctxt block miner op_count =
   (* end of cycle *)
   may_start_new_cycle ctxt >>=? fun ctxt ->
   Amendment.may_start_new_voting_cycle ctxt >>=? fun ctxt ->
-  Level.current ctxt >>=? fun { level } ->
+  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/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

@@ -14,15 +14,9 @@ let version_key = ["version"]
 let version_value = "alpha"
 
 (* This is the genesis protocol: initialise the state *)
-let initialize ~from_genesis (ctxt:Context.t) =
+let initialize ~timestamp ~fitness (ctxt: Context.t) =
   Context.set ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
-  Storage.prepare ctxt >>=? fun store ->
+  Storage.prepare ~timestamp ~fitness 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 ->
@@ -41,19 +35,20 @@ type error +=
   | Incompatiple_protocol_version
   | Unimplemented_sandbox_migration
 
-let may_initialize ctxt =
+let may_initialize ctxt ~timestamp ~fitness =
   Context.get ctxt version_key >>= function
   | None ->
       (* This is the genesis protocol: The only acceptable preceding
          version is an empty context *)
-      initialize ~from_genesis:false ctxt
+      initialize ~timestamp ~fitness ctxt
   | Some bytes ->
       let s = MBytes.to_string bytes in
-      if Compare.String.(s = version_value)
+      if Compare.String.(s = version_value) then
-      then Storage.prepare ctxt
+        Storage.prepare ~timestamp ~fitness ctxt
       else if Compare.String.(s = "genesis") then
-        initialize ~from_genesis:true ctxt
+        initialize ~timestamp ~fitness ctxt
-      else fail Incompatiple_protocol_version
+      else
+        fail Incompatiple_protocol_version
 
 let configure_sandbox ctxt json =
   let json =
@@ -63,8 +58,7 @@ let configure_sandbox ctxt json =
   Context.get ctxt version_key >>= function
   | None ->
       Storage.set_sandboxed ctxt json >>= fun ctxt ->
-      initialize ~from_genesis:false ctxt >>=? fun ctxt ->
+      return ctxt
-      return (Storage.recover ctxt)
   | Some _ ->
       Storage.get_sandboxed ctxt >>=? function
       | None ->

src/proto/alpha/main.ml

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

src/proto/alpha/mining.ml

@@ -128,7 +128,7 @@ let minimal_time c priority pred_timestamp =
 
 let check_timestamp c priority pred_timestamp =
   minimal_time c priority pred_timestamp >>=? fun minimal_time ->
-  Tezos_context.Timestamp.get_current c >>= fun timestamp ->
+  let timestamp = Tezos_context.Timestamp.current c in
   fail_unless Timestamp.(minimal_time <= timestamp)
     (Timestamp_too_early (minimal_time, timestamp))
 
@@ -273,8 +273,8 @@ let max_fitness_gap ctxt =
   Int64.add slots 1L
 
 let check_fitness_gap ctxt (block : Block.header) =
-  Fitness.get ctxt >>=? fun current_fitness ->
+  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))

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

@@ -9,24 +9,27 @@
 
 open Tezos_context
 
-let rpc_services = ref (RPC.empty : Context.t RPC.directory)
+let rpc_init { Updater.context ; timestamp ; fitness } =
+  Tezos_context.init ~timestamp ~fitness context
+
+let rpc_services = ref (RPC.empty : Updater.rpc_context RPC.directory)
 let register0 s f =
   rpc_services :=
     RPC.register !rpc_services (s RPC.Path.root)
       (fun ctxt () ->
-         ( Tezos_context.init ctxt >>=? fun ctxt ->
+         ( rpc_init ctxt >>=? fun ctxt ->
            f ctxt ) >>= RPC.Answer.return)
 let register1 s f =
   rpc_services :=
     RPC.register !rpc_services (s RPC.Path.root)
       (fun ctxt arg ->
-         ( Tezos_context.init ctxt >>=? fun ctxt ->
+         ( rpc_init ctxt >>=? fun ctxt ->
            f ctxt arg ) >>= RPC.Answer.return)
 let register2 s f =
   rpc_services :=
     RPC.register !rpc_services (s RPC.Path.root)
       (fun (ctxt, arg1) arg2 ->
-         ( Tezos_context.init ctxt >>=? fun ctxt ->
+         ( rpc_init ctxt >>=? fun ctxt ->
            f ctxt arg1 arg2 ) >>= RPC.Answer.return)
 let register1_noctxt s f =
   rpc_services :=
@@ -143,7 +146,7 @@ let () =
     rpc_services :=
       RPC.register !rpc_services (s RPC.Path.root)
         (fun (ctxt, contract) arg ->
-           ( Tezos_context.init ctxt >>=? fun ctxt ->
+           ( rpc_init ctxt >>=? fun ctxt ->
              Contract.exists ctxt contract >>=? function
              | true -> f ctxt contract arg
              | false -> raise Not_found ) >>= RPC.Answer.return) in
@@ -177,7 +180,7 @@ let minimal_timestamp ctxt prio =
 let () = register1
            Services.Helpers.minimal_timestamp
            (fun ctxt slot ->
-             Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
+              let timestamp = Tezos_context.Timestamp.current ctxt in
              minimal_timestamp ctxt slot timestamp)
 
 let () =
@@ -305,7 +308,7 @@ let () =
          Lwt_list.filter_map_p (fun x -> x) @@
          List.mapi
            (fun prio c ->
-             Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
+             let timestamp = Timestamp.current ctxt in
               Mining.minimal_time
                 ctxt (Int32.of_int prio) timestamp >>= function
               | Error _ -> Lwt.return None
@@ -343,7 +346,7 @@ let mining_rights_for_delegate
       let raw_level = level.level in
       Error_monad.map_s
         (fun priority ->
-          Tezos_context.Timestamp.get_current ctxt >>= fun timestamp ->
+           let timestamp = Timestamp.current ctxt in
            Mining.minimal_time ctxt priority timestamp >>=? fun time ->
            return (raw_level, Int32.to_int priority, time))
         priorities >>=? fun priorities ->

src/proto/alpha/storage.ml

@@ -12,19 +12,14 @@ open Storage_functors
 
 let version = "v1"
 let sandboxed_key = [ version ; "sandboxed" ]
-let prevalidation_key = [ version ; "prevalidation" ]
 
 type t = Storage_functors.context
 
 type error += Invalid_sandbox_parameter
 
-let get_fitness (c, _) = Context.get_fitness c
+let current_timestamp { timestamp } = timestamp
-let set_fitness (c, csts) v =
+let current_fitness { fitness } = fitness
-  Context.set_fitness c v >>= fun c -> Lwt.return (c, csts)
+let set_current_fitness c fitness = { c with fitness }
-
-let get_timestamp (c, _) = Context.get_timestamp c
-let set_commit_message (c, csts) msg =
-  Context.set_commit_message c msg >>= fun c -> Lwt.return (c, csts)
 
 let get_sandboxed c =
   Context.get c sandboxed_key >>= function
@@ -38,22 +33,14 @@ let set_sandboxed c json =
   Context.set c sandboxed_key
     (Data_encoding.Binary.to_bytes Data_encoding.json json)
 
-let prepare (c : Context.t) : t tzresult Lwt.t =
+let prepare ~timestamp ~fitness (c : Context.t) : t tzresult Lwt.t =
+  Lwt.return (Fitness_repr.to_int64 fitness) >>=? fun fitness ->
   get_sandboxed c >>=? fun sandbox ->
   Constants_repr.read sandbox >>=? function constants ->
-  return (c, constants)
+  return { context = c ; constants ; timestamp ; fitness }
-let recover (c, _ : t) : Context.t = c
+let recover { context } : Context.t = context
 
-let get_prevalidation (c, _ : t) =
+let constants { constants } = constants
-  Context.get c prevalidation_key >>= function
-  | None -> Lwt.return false
-  | Some _ -> Lwt.return true
-let set_prevalidation (c, constants : t) =
-  Context.set c prevalidation_key (MBytes.of_string "prevalidation") >>= fun c ->
-  Lwt.return (c, constants)
-
-
-let constants : t -> _ = snd
 
 module Key = struct
 
@@ -510,12 +497,12 @@ 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) =
-  Updater.fork_test_network c >>= fun c -> Lwt.return (c, constants)
+  Updater.fork_test_network c >>= fun c -> Lwt.return { s with context = c }
-let set_test_protocol (c, constants) h =
+let set_test_protocol ({ context = c } as s) h =
-  Updater.set_test_protocol c h >>= fun c -> Lwt.return (c, constants)
+  Updater.set_test_protocol c h >>= fun c -> Lwt.return { s with context = c }
 
 
 (** Resolver *)

src/proto/alpha/storage.mli

@@ -25,7 +25,10 @@
 type t
 
 (** Rerieves the state of the database and gives its abstract view *)
-val prepare : Context.t -> t tzresult Lwt.t
+val prepare :
+  timestamp: Time.t ->
+  fitness: Fitness.fitness ->
+  Context.t -> t tzresult Lwt.t
 
 (** Returns the state of the database resulting of operations on its
     abstract view *)
@@ -34,15 +37,10 @@ val recover : t -> Context.t
 val get_sandboxed : Context.t -> Data_encoding.json option tzresult Lwt.t
 val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t
 
-val get_fitness : t -> Fitness.fitness Lwt.t
+val current_timestamp : t -> Time.t
-val set_fitness : t -> Fitness.fitness -> t Lwt.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
 

src/proto/alpha/storage_functors.ml

@@ -11,7 +11,12 @@
 
 open Misc
 
-type context = Context.t * Constants_repr.constants
+type context = {
+  context: Context.t ;
+  constants: Constants_repr.constants ;
+  timestamp: Time.t ;
+  fitness: Int64.t ;
+}
 
 (*-- Errors ------------------------------------------------------------------*)
 
@@ -52,7 +57,7 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
 
   let key_to_string l = String.concat "/" (key l)
 
-  let get (c, _) k =
+  let get { context = c } k =
     Context.get c (key k) >>= function
     | None ->
         let msg =
@@ -61,16 +66,16 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
     | Some bytes ->
         Lwt.return (P.of_bytes bytes)
 
-  let mem (c, _) k = Context.mem c (key k)
+  let mem { context = c } k = Context.mem c (key k)
 
-  let get_option (c, _) k =
+  let get_option { context = c } k =
     Context.get c (key k) >>= function
     | None -> return None
     | Some bytes ->
         Lwt.return (P.of_bytes bytes >|? fun v -> Some v)
 
   (* Verify that the key is present before modifying *)
-  let set (c, x) k v =
+  let set ({ context = c } as s) k v =
     let key = key k in
     Context.get c key >>= function
     | None ->
@@ -80,13 +85,13 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
     | Some old ->
         let bytes = P.to_bytes v in
         if MBytes.(old = bytes) then
-          return (c, x)
+          return { s with context = c }
         else
           Context.set c key (P.to_bytes v) >>= fun c ->
-          return (c, x)
+          return { s with context = c }
 
   (* Verify that the key is not present before inserting *)
-  let init (c, x) k v =
+  let init ({ context = c } as s) k v =
     let key = key k in
     Context.get c key >>=
       function
@@ -96,27 +101,29 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
           fail (Storage_error msg)
       | None ->
           Context.set c key (P.to_bytes v) >>= fun c ->
-          return (c, x)
+          return { s with context = c }
 
   (* Does not verify that the key is present or not *)
-  let init_set (c, x) k v =
+  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 +236,34 @@ module Make_data_set_storage (P : Single_data_description) = struct
         error (Storage_error msg)
     | Some v -> Ok v
 
-  let add (c, x) v =
+  let add ({ context = c } as s) v =
     let hash, data = serial v in
     HashTbl.mem c hash >>= function
-    | true -> return (c, x)
+    | 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 +275,9 @@ module Make_data_set_storage (P : Single_data_description) = struct
                   f data acc >>= fun acc ->
                   return acc)
 
-  let clear (c, x) =
+  let clear ({ context = c } as s) =
     HashTbl.fold c c ~f:(fun hash _ c -> HashTbl.del c hash) >>= fun c ->
-    return (c, x)
+    return { s with context = c }
 
 end
 
@@ -284,7 +297,7 @@ module Raw_make_iterable_data_storage
 
   let key_to_string k = String.concat "/" (K.to_path k)
 
-  let get (c, _) k =
+  let get { context = c } k =
     HashTbl.get c k >>= function
     | None ->
         let msg =
@@ -293,15 +306,15 @@ module Raw_make_iterable_data_storage
     | Some v ->
         return v
 
-  let mem (c, _) k = HashTbl.mem c k
+  let mem { context = c } k = HashTbl.mem c k
 
-  let get_option (c, _) k =
+  let get_option { context = c } k =
     HashTbl.get c k >>= function
     | None -> return None
     | Some v -> return (Some v)
 
   (* Verify that the key is present before modifying *)
-  let set (c, x) k v =
+  let set ({ context = c } as s) k v =
     HashTbl.get c k >>= function
     | None ->
         let msg =
@@ -309,10 +322,10 @@ module Raw_make_iterable_data_storage
         fail (Storage_error msg)
     | Some _ ->
         HashTbl.set c k v >>= fun c ->
-        return (c, x)
+        return { s with context = c }
 
   (* Verify that the key is not present before inserting *)
-  let init (c, x) k v =
+  let init ({ context = c } as s) k v =
     HashTbl.get c k >>=
       function
       | Some _ ->
@@ -321,29 +334,35 @@ module Raw_make_iterable_data_storage
           fail (Storage_error msg)
       | None ->
           HashTbl.set c k v >>= fun c ->
-          return (c, x)
+          return { s with context = c }
 
   (* Does not verify that the key is present or not *)
-  let init_set (c, x) k v = HashTbl.set c k v >>= fun c -> return (c, x)
+  let init_set ({ context = c } as s) k v =
+    HashTbl.set c k v >>= fun c ->
+    return { s with context = c }
 
   (* Verify that the key is present before deleting *)
-  let delete (c, x) k =
+  let delete ({ context = c } as s) k =
     HashTbl.get c k >>= function
     | Some _ ->
         HashTbl.del c k >>= fun c ->
-        return (c, x)
+        return { s with context = c }
     | None ->
         let msg =
           "cannot delete undefined " ^ P.name ^ " key " ^ key_to_string k in
         fail (Storage_error msg)
 
   (* Do not verify before deleting *)
-  let remove (c, x) k =
+  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,12 @@
     indexed data and homgeneous data set). *)
 
 
-type context = Context.t * Constants_repr.constants
+type context = {
+  context: Context.t ;
+  constants: Constants_repr.constants ;
+  timestamp: Time.t ;
+  fitness: Int64.t ;
+}
 
 open Storage_sigs
 

src/proto/alpha/tezos_context.ml

@@ -22,7 +22,7 @@ module Period = Period_repr
 
 module Timestamp = struct
   include Time_repr
-  let get_current = Storage.get_timestamp
+  let current = Storage.current_timestamp
 end
 
 include Operation_repr
@@ -110,17 +110,12 @@ end
 
 let init = Init_storage.may_initialize
 
-let finalize ?commit_message c =
+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

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
 
@@ -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
 
@@ -580,15 +578,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 ->
+  timestamp:Time.t ->
+  fitness:Fitness.t ->
+  context tzresult Lwt.t
+val finalize: ?commit_message:string -> context -> Updater.validation_result
 
 val configure_sandbox:
   Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t
 
-val get_prevalidation: context -> bool Lwt.t
-val set_prevalidation: context -> context Lwt.t
-
 val activate: context -> Protocol_hash.t -> context Lwt.t
 val set_test_protocol: context -> Protocol_hash.t -> context Lwt.t
 val fork_test_network: context -> context Lwt.t

src/proto/demo/main.ml

@@ -17,9 +17,15 @@ let parse_operation h _ = Ok h
 
 let compare_operations _ _ = 0
 
-module Fitness = struct
+type validation_state = {
+  context : Context.t ;
+  fitness : Int64.t ;
+}
 
-  let version_number = "\000"
+let current_context { context } =
+  return context
+
+module Fitness = struct
 
   type error += Invalid_fitness
   type error += Invalid_fitness2
@@ -36,67 +42,50 @@ module Fitness = struct
       return (MBytes.get_int64 b 0)
 
   let from_int64 fitness =
-    [ MBytes.of_string version_number ;
+    [ int64_to_bytes fitness ]
-      int64_to_bytes fitness ]
 
   let to_int64 = function
-    | [ version ;
+    | [ fitness ] -> 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_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/updater.mli

@@ -2,6 +2,7 @@
 
 open Hash
 
+(** The version agnostic toplevel structure of operations. *)
 type shell_operation = {
   net_id: Net_id.t ;
 }
@@ -37,6 +38,18 @@ type raw_block = {
 }
 val raw_block_encoding: raw_block Data_encoding.t
 
+type validation_result = {
+  context: Context.t ;
+  fitness: Fitness.fitness ;
+  message: string option ;
+}
+
+type rpc_context = {
+  context: Context.t ;
+  timestamp: Time.t ;
+  fitness: Fitness.fitness ;
+}
+
 (** This is the signature of a Tezos protocol implementation. It has
     access to the standard library and the Environment module. *)
 module type PROTOCOL = sig
@@ -99,6 +112,7 @@ module type PROTOCOL = sig
   val begin_application :
     predecessor_context: Context.t ->
     predecessor_timestamp: Time.t ->
+    predecessor_fitness: Fitness.fitness ->
     raw_block ->
     validation_state tzresult Lwt.t
 
@@ -110,6 +124,7 @@ module type PROTOCOL = sig
   val begin_construction :
     predecessor_context: Context.t ->
     predecessor_timestamp: Time.t ->
+    predecessor_fitness: Fitness.fitness ->
     predecessor: Block_hash.t ->
     timestamp: Time.t ->
     validation_state tzresult Lwt.t
@@ -123,10 +138,10 @@ module type PROTOCOL = sig
       context that will be used as input for the validation of its
       successor block candidates. *)
   val finalize_block :
-    validation_state -> Context.t tzresult Lwt.t
+    validation_state -> validation_result tzresult Lwt.t
 
   (** The list of remote procedures exported by this implementation *)
-  val rpc_services : Context.t RPC.directory
+  val rpc_services : rpc_context RPC.directory
 
   val configure_sandbox :
     Context.t -> Data_encoding.json option -> Context.t tzresult Lwt.t

src/proto/genesis/main.ml

@@ -61,10 +61,10 @@ let check_signature ctxt { shell ; command ; signature } =
     (Ed25519.Signature.check public_key signature bytes)
     Invalid_signature
 
-type validation_state = block * Context.t
+type validation_state = Updater.validation_result
 
-let current_context (_, ctxt) =
+let current_context ({ context } : validation_state) =
-  return ctxt
+  return context
 
 let precheck_block
     ~ancestor_context:_
@@ -76,38 +76,38 @@ let precheck_block
 let begin_application
     ~predecessor_context:ctxt
     ~predecessor_timestamp:_
+    ~predecessor_fitness:_
     raw_block =
+  Data.Init.may_initialize ctxt >>=? fun ctxt ->
   Lwt.return (parse_block raw_block) >>=? fun block ->
-  return (block, ctxt)
+  check_signature ctxt block >>=? fun () ->
+  let fitness = raw_block.shell.fitness in
+  match block.command with
+  | Data.Command.Activate hash ->
+      let message =
+        Some (Format.asprintf "activate %a" Protocol_hash.pp_short hash) in
+      Updater.activate ctxt hash >>= fun ctxt ->
+      return { Updater.message ; context = ctxt ; fitness }
+  | Activate_testnet hash ->
+      let message =
+        Some (Format.asprintf "activate testnet %a" Protocol_hash.pp_short hash) in
+      Updater.set_test_protocol ctxt hash >>= fun ctxt ->
+      Updater.fork_test_network ctxt >>= fun ctxt ->
+      return { Updater.message ; context = ctxt ; fitness }
 
 let begin_construction
-    ~predecessor_context:_
+    ~predecessor_context:context
     ~predecessor_timestamp:_
+    ~predecessor_fitness:fitness
     ~predecessor:_
     ~timestamp:_ =
-  Lwt.return (Error []) (* absurd *)
+  (* Dummy result. *)
+  return { Updater.message = None ; context ; fitness }
 
 let apply_operation _vctxt _ =
   Lwt.return (Error []) (* absurd *)
 
-let finalize_block (header, ctxt) =
+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

@@ -56,7 +56,7 @@ let int64_to_bytes i =
 let operations =
   Operation_list_list_hash.compute [Operation_list_hash.empty]
 
-let rpc_services : Context.t RPC.directory =
+let rpc_services : Updater.rpc_context RPC.directory =
   let dir = RPC.empty in
   let dir =
     RPC.register

test/proto_alpha/proto_alpha_helpers.ml

@@ -434,7 +434,7 @@ module Mining = struct
   Client_proto_rpcs.Context.level rpc_config block >>=? fun level ->
   let level = Raw_level.succ level.level in
   get_first_priority level contract block >>=? fun priority ->
-  (Fitness_repr.to_int64 bi.fitness >|=
+  (Lwt.return (Fitness_repr.to_int64 bi.fitness) >|=
    Register_client_embedded_proto_alpha.wrap_error) >>=? fun fitness ->
   let fitness =
     Fitness_repr.from_int64 @@

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"

test/shell/test_state.ml

@@ -38,7 +38,7 @@ let net_id = Net_id.of_block_hash genesis_block
 let incr_fitness fitness =
   let new_fitness =
     match fitness with
-    | [ _ ; fitness ] ->
+    | [ fitness ] ->
         Pervasives.(
           Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
           |> Utils.unopt ~default:0L
@@ -47,7 +47,7 @@ let incr_fitness fitness =
         )
     | _ -> Data_encoding.Binary.to_bytes Data_encoding.int64 1L
   in
-  [ MBytes.of_string "\000" ; new_fitness ]
+  [ new_fitness ]
 
 let incr_timestamp timestamp =
   Time.add timestamp (Int64.add 1L (Random.int64 10L))
@@ -166,6 +166,7 @@ let build_valid_chain state tbl vtbl otbl pred names =
            Proto.begin_application
              ~predecessor_context: pred.context
              ~predecessor_timestamp: pred.timestamp
+             ~predecessor_fitness: pred.fitness
              block >>=? fun vstate ->
            (* no operations *)
            Proto.finalize_block vstate