Shell: Proto.fitness -> Context.set_fitness.

Intead of providing a `fitness` function, an economic protocol should
now call `Context.set_fitness`.

This simplify the shell's code and avoid complexity on protocol
change. Previously the fitness of a context produced by the old protocol
had to be read by the new protocol. Now, the shell read the context
without requesting the help of the economic protocol.

src/Makefile

@@ -40,10 +40,10 @@ $(addprefix proto/environment/, \
   hash.mli \
   ed25519.mli \
   persist.mli \
+  fitness.mli \
   context.mli \
   RPC.mli \
   \
-  fitness.mli \
   updater.mli \
 )
 

src/node/db/context.ml

@@ -62,6 +62,7 @@ let genesis_block_key = ["genesis";"block"]
 let genesis_protocol_key = ["genesis";"protocol"]
 let genesis_time_key = ["genesis";"time"]
 let current_protocol_key = ["protocol"]
+let current_fitness_key = ["fitness"]
 let current_test_protocol_key = ["test_protocol"]
 let current_test_network_key = ["test_network"]
 let current_test_network_expiration_key = ["test_network_expiration"]
@@ -195,6 +196,8 @@ let commit_genesis index ~id:block ~time ~protocol ~test_protocol =
     (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
@@ -211,6 +214,17 @@ let get_protocol v =
 let set_protocol v key =
   raw_set v current_protocol_key (Protocol_hash.to_bytes key)
 
+let get_fitness v =
+  raw_get v 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 v data =
+  raw_set v current_fitness_key
+    (Data_encoding.Binary.to_bytes Fitness.encoding data)
+
 let get_test_protocol v =
   raw_get v current_test_protocol_key >>= function
   | None -> assert false

src/node/db/context.mli

@@ -64,5 +64,8 @@ val fork_test_network: context -> context Lwt.t
 val get_genesis_time: context -> Time.t Lwt.t
 val get_genesis_block: context -> Block_hash.t Lwt.t
 
+val set_fitness: context -> Fitness.fitness -> context Lwt.t
+val get_fitness: context -> Fitness.fitness Lwt.t
+
 val init_test_network:
   context ->  time:Time.t -> genesis:Block_hash.t -> context tzresult Lwt.t

src/node/shell/node.ml

@@ -261,8 +261,7 @@ module RPC = struct
         let net_state = Validator.net_state validator in
         State.Valid_block.Current.head net_state >>= fun head ->
         let ctxt = Prevalidator.context pv in
-        let (module Proto) = Prevalidator.protocol pv in
+        Context.get_fitness ctxt >|= fun fitness ->
-        Proto.fitness ctxt >|= fun fitness ->
         { (convert head) with
           hash = prevalidation_hash ;
           fitness ;
@@ -387,11 +386,11 @@ module RPC = struct
       match protocol with
       | None -> failwith "Unknown protocol version"
       | Some protocol -> return protocol
-    end >>=? function (module Proto) as protocol ->
+    end >>=? fun ((module Proto) as protocol) ->
-      let net_db = Validator.net_db node.global_validator in
+    let net_db = Validator.net_db node.global_validator in
     Prevalidator.preapply
       net_db context protocol hash timestamp sort ops >>=? fun (ctxt, r) ->
-    Proto.fitness ctxt >>= fun fitness ->
+    Context.get_fitness ctxt >>= fun fitness ->
     return (fitness, r)
 
   let complete node ?block str =

src/node/shell/state.ml

@@ -22,7 +22,7 @@ type error +=
 
 let () =
   Error_monad.register_error_kind
-    `Temporary
+    `Permanent
     ~id:"state.invalid_fitness"
     ~title:"Invalid fitness"
     ~description:"The computed fitness differs from the fitness found \
@@ -830,18 +830,8 @@ module Valid_block = struct
         block_header_store hash >>=? fun block ->
       Raw_block_header.Locked.read_discovery_time
         block_header_store hash >>=? fun discovery_time ->
-      begin (* Load the associated version of the economical protocol . *)
-        Context.get_protocol context >>= fun protocol_hash ->
-        match Updater.get protocol_hash with
-        | None ->
-            lwt_log_error
-              "State.Validated_block: unknown protocol (%a)"
-              Protocol_hash.pp_short protocol_hash >>= fun () ->
-            fail (Unknown_protocol protocol_hash)
-        | Some proto -> return proto
-      end >>=? fun (module Proto) ->
       (* Check fitness coherency. *)
-      Proto.fitness context >>= fun fitness ->
+      Context.get_fitness context >>= fun fitness ->
       fail_unless
         (Fitness.equal fitness block.Store.Block_header.shell.fitness)
         (Invalid_fitness

src/node/shell/validator.ml

@@ -187,8 +187,8 @@ module Validation_scheduler = struct
         | Ok new_context ->
             (* The sanity check `set_context` detects differences
                between the computed fitness and the fitness announced
-               in the block header. When distinct `Valid_block.read`
+               in the block header. Then `Valid_block.read` will
-               will return an error. *)
+               return an error. *)
             set_context hash (Ok new_context) >>= fun () ->
             State.Valid_block.read state hash >>= function
             | Error err ->

src/node/updater/protocol.ml

@@ -117,10 +117,6 @@ module type PROTOCOL = sig
     Context.t -> Block_hash.t -> Time.t -> bool -> operation list ->
     (Context.t * error preapply_result) tzresult Lwt.t
 
-  (** The context rating function to determine the winning block chain. *)
-  val fitness :
-    Context.t -> fitness Lwt.t
-
   (** The list of remote procedures exported by this implementation *)
   val rpc_services : Context.t RPC.directory
 

src/proto/alpha/fitness_repr.ml

@@ -9,7 +9,6 @@
 
 type error += Invalid_fitness
 
-
 let int64_to_bytes i =
   let b = MBytes.create 8 in
   MBytes.set_int64 b 0 i;
@@ -22,9 +21,8 @@ let int64_of_bytes b =
     return (MBytes.get_int64 b 0)
 
 let from_int64 fitness =
-  return
+  [ MBytes.of_string Constants_repr.version_number ;
-    [ MBytes.of_string Constants_repr.version_number ;
+    int64_to_bytes fitness ]
-      int64_to_bytes fitness ]
 
 let to_int64 = function
   | [ version ;
@@ -32,4 +30,5 @@ let to_int64 = function
     when Compare.String.
            (MBytes.to_string version = Constants_repr.version_number) ->
       int64_of_bytes fitness
+  | [] -> return 0L
   | _ -> fail Invalid_fitness

src/proto/alpha/fitness_storage.ml

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

src/proto/alpha/init_storage.ml

@@ -21,10 +21,10 @@ let initialize ~from_genesis (ctxt:Context.t) =
   Storage.Current_timestamp.init_set store time >>=? fun store ->
   begin
     if from_genesis then
-      return store
+      Lwt.return store
     else
       Fitness_storage.init store
-  end >>=? fun store ->
+  end >>= fun store ->
   Level_storage.init store >>=? fun store ->
   Roll_storage.init store >>=? fun store ->
   Nonce_storage.init store >>=? fun store ->

src/proto/alpha/main.ml

@@ -30,14 +30,6 @@ let max_block_length =
 
 let rpc_services = Services_registration.rpc_services
 
-let fitness ctxt =
-  begin
-    Tezos_context.init ctxt >>=? fun ctxt ->
-    Tezos_context.Fitness.get ctxt
-  end >|= function
-  | Ok fitness -> fitness
-  | Error _ -> []
-
 let apply ctxt header ops = Apply.apply ctxt true header ops
 
 let preapply = Apply.preapply

src/proto/alpha/mining.ml

@@ -186,8 +186,8 @@ let max_fitness_gap ctxt =
 type error += Invalid_fitness_gap
 
 let check_fitness_gap ctxt (block : Block.header)  =
-  Fitness.raw_get ctxt >>=? fun current_fitness ->
+  Fitness.get ctxt >>=? fun current_fitness ->
-  Fitness.raw_read block.shell.fitness >>=? fun announced_fitness ->
+  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

src/proto/alpha/storage.ml

@@ -18,6 +18,10 @@ type t = Storage_functors.context
 
 type error += Invalid_sandbox_parameter
 
+let get_fitness (c, _) = Context.get_fitness c
+let set_fitness (c, csts) v =
+  Context.set_fitness c v >>= fun c -> Lwt.return (c, csts)
+
 let get_sandboxed c =
   Context.get c sandboxed_key >>= function
   | None -> return None

src/proto/alpha/storage.mli

@@ -34,6 +34,9 @@ val recover : t -> Context.t
 val get_sandboxed : Context.t -> Data_encoding.json option tzresult Lwt.t
 val set_sandboxed : Context.t -> Data_encoding.json -> Context.t Lwt.t
 
+val get_fitness : t -> Fitness.fitness Lwt.t
+val set_fitness : t -> Fitness.fitness -> t Lwt.t
+
 val get_prevalidation : t -> bool Lwt.t
 val set_prevalidation : t -> t Lwt.t
 
@@ -53,12 +56,6 @@ module Current_timestamp : Single_data_storage
   with type value = Time.t
    and type context := t
 
-(** The fitness of the current block, which is the number of ancestor
-    blocks in the chain as an [int64] *)
-module Current_fitness : Single_data_storage
-  with type value = int64
-   and type context := t
-
 module Roll : sig
 
   (** Storage from this submodule must only be accessed through the

src/proto/alpha/tezos_context.mli

@@ -253,11 +253,10 @@ module Fitness : sig
   include (module type of Fitness)
   type t = fitness
 
-  val get: context -> fitness tzresult Lwt.t
   val increase: context -> context tzresult Lwt.t
 
-  val raw_get: context -> int64 tzresult Lwt.t
+  val get: context -> int64 tzresult Lwt.t
-  val raw_read: fitness -> int64 tzresult Lwt.t
+  val to_int64: fitness -> int64 tzresult Lwt.t
 
 end
 

src/proto/demo/main.ml

@@ -18,37 +18,54 @@ let max_number_of_operations = 42
 let parse_block _ = Ok ()
 let parse_operation h _ = Ok h
 
-let fitness_key = ["v1";"store";"fitness"]
+module Fitness = struct
 
-let get_fitness ctxt =
+  let version_number = "\000"
-  Context.get ctxt fitness_key >>= function
-  | None -> Lwt.return 0L
-  | Some b ->
-      match Data_encoding.Binary.of_bytes Data_encoding.int64 b with
-      | None -> Lwt.return 0L
-      | Some v -> Lwt.return v
 
-let set_fitness ctxt v =
+  type error += Invalid_fitness
-  Context.set ctxt fitness_key @@
+  type error += Invalid_fitness2
-  Data_encoding.Binary.to_bytes Data_encoding.int64 v
 
-let int64_to_bytes i =
+  let int64_to_bytes i =
-  let b = MBytes.create 8 in
+    let b = MBytes.create 8 in
-  MBytes.set_int64 b 0 i;
+    MBytes.set_int64 b 0 i;
-  b
+    b
 
-let fitness ctxt =
+  let int64_of_bytes b =
-  get_fitness ctxt >|= fun v ->
+    if Compare.Int.(MBytes.length b <> 8) then
-  [ MBytes.of_string "\000" ;
+      fail Invalid_fitness2
-    int64_to_bytes v ]
+    else
+      return (MBytes.get_int64 b 0)
 
-let increase_fitness ctxt =
+  let from_int64 fitness =
-  get_fitness ctxt >>= fun v ->
+    [ MBytes.of_string version_number ;
-  set_fitness ctxt (Int64.succ v) >>= fun ctxt ->
+      int64_to_bytes fitness ]
-  Lwt.return ctxt
+
+  let to_int64 = function
+    | [ version ;
+        fitness ]
+      when Compare.String.
+             (MBytes.to_string version = version_number) ->
+        int64_of_bytes fitness
+    | [] -> return 0L
+    | _ -> fail Invalid_fitness
+
+  let get ctxt =
+    Context.get_fitness ctxt >>= fun fitness ->
+    to_int64 fitness
+
+  let set ctxt v =
+    Context.set_fitness ctxt (from_int64 v) >>= fun ctxt ->
+    Lwt.return ctxt
+
+  let increase ctxt =
+    get ctxt >>=? fun v ->
+    set ctxt (Int64.succ v) >>= fun ctxt ->
+    return ctxt
+
+end
 
 let apply ctxt () _operations =
-  increase_fitness ctxt >>= fun ctxt ->
+  Fitness.increase ctxt >>=? fun ctxt ->
   return ctxt
 
 let preapply context _block_pred _timestamp _sort operations =

src/proto/environment/context.mli

@@ -5,6 +5,9 @@ open Hash
 
 include Persist.STORE
 
+val get_fitness: t -> Fitness.fitness Lwt.t
+val set_fitness: t -> Fitness.fitness -> t Lwt.t
+
 val get_genesis_time: t -> Time.t Lwt.t
 val get_genesis_block: t -> Block_hash.t Lwt.t
 

src/proto/environment/updater.mli

@@ -110,10 +110,6 @@ module type PROTOCOL = sig
     Context.t -> Block_hash.t -> Time.t -> bool -> operation list ->
     (Context.t * error preapply_result) tzresult Lwt.t
 
-  (** The context rating function to determine the winning block chain. *)
-  val fitness :
-    Context.t -> Fitness.fitness Lwt.t
-
   (** The list of remote procedures exported by this implementation *)
   val rpc_services : Context.t RPC.directory
 

src/proto/genesis/data.ml

@@ -53,51 +53,6 @@ module Command = struct
 
 end
 
-module Fitness = struct
-
-  let fitness_key = ["v1";"store";"fitness"]
-
-  let get ctxt =
-    Context.get ctxt fitness_key >>= function
-    | None -> Lwt.return 0L
-    | Some b ->
-        match Data_encoding.Binary.of_bytes Data_encoding.int64 b with
-        | None -> Lwt.return 0L
-        | Some v -> Lwt.return v
-
-  let set ctxt v =
-    Context.set ctxt fitness_key @@
-    Data_encoding.Binary.to_bytes Data_encoding.int64 v
-
-  type error += Invalid_fitness
-
-  let int64_to_bytes i =
-    let b = MBytes.create 8 in
-    MBytes.set_int64 b 0 i;
-    b
-
-  let int64_of_bytes b =
-    if Compare.Int.(MBytes.length b <> 8) then
-      Error [Invalid_fitness]
-    else
-      Ok (MBytes.get_int64 b 0)
-
-  let version_number = "\000"
-
-  let from_int64 fitness =
-    [ MBytes.of_string version_number ;
-      int64_to_bytes fitness ]
-
-  let to_int64 = function
-    | [ version ;
-        fitness ]
-      when Compare.String.
-             (MBytes.to_string version = version_number) ->
-        int64_of_bytes fitness
-    | _ -> Error [Invalid_fitness]
-
-end
-
 module Pubkey = struct
 
   let pubkey_key = ["genesis_key"]

src/proto/genesis/main.ml

@@ -39,7 +39,6 @@ let max_number_of_operations = 0
 
 type block = {
   shell: Updater.shell_block ;
-  fitness: Int64.t ;
   command: Data.Command.t ;
   signature: Ed25519.signature ;
 }
@@ -52,9 +51,7 @@ let max_block_length =
 let parse_block { Updater.shell ; proto } : block tzresult =
   match Data_encoding.Binary.of_bytes Data.Command.signed_encoding proto with
   | None -> Error [Parsing_error]
-  | Some (command, signature) ->
+  | Some (command, signature) -> Ok { shell ; command ; signature }
-      Data.Fitness.to_int64 shell.fitness >>? fun fitness ->
-      Ok { shell ; fitness ; command ; signature }
 
 let check_signature ctxt { shell ; command ; signature } =
   let bytes = Data.Command.forge shell command in
@@ -63,14 +60,10 @@ let check_signature ctxt { shell ; command ; signature } =
     (Ed25519.check_signature public_key signature bytes)
     Invalid_signature
 
-let fitness ctxt =
-  Data.Fitness.get ctxt >>= fun fitness ->
-  Lwt.return (Data.Fitness.from_int64 fitness)
-
 let apply ctxt header _ops =
   check_signature ctxt header >>=? fun () ->
   Data.Init.may_initialize ctxt >>=? fun ctxt ->
-  Data.Fitness.set ctxt header.fitness >>= fun ctxt ->
+  Context.set_fitness ctxt header.shell.fitness >>= fun ctxt ->
   match header.command with
   | Activate hash ->
       Updater.activate ctxt hash >>= fun ctxt ->

src/proto/genesis/services.ml

@@ -48,6 +48,11 @@ module Forge = struct
       RPC.Path.(custom_root / "helpers" / "forge" / "block")
 end
 
+let int64_to_bytes i =
+  let b = MBytes.create 8 in
+  MBytes.set_int64 b 0 i;
+  b
+
 let rpc_services : Context.t RPC.directory =
   let dir = RPC.empty in
   let dir =
@@ -55,7 +60,7 @@ let rpc_services : Context.t RPC.directory =
       dir
       (Forge.block RPC.Path.root)
       (fun _ctxt ((net_id, predecessor, timestamp, fitness), command) ->
-         let fitness = Data.Fitness.from_int64 fitness in
+         let fitness = [ MBytes.of_string "\000" ; int64_to_bytes fitness ] in
          let shell = { Updater.net_id ; predecessor ; timestamp ;
                        fitness ; operations = [] } in
          let bytes = Data.Command.forge shell command in