Shell/Proto: more complete "begin_construction".

The `begin_construction` function now accepts an optional argument
`proto_header`. This is to be used by a new RPC that ease forging the
shell header of a block (i.e. it will compute the fitness and, in a
near future, the hash of the resulting context).

src/node/shell/prevalidation.ml

@@ -155,6 +155,7 @@ let start_prevalidation
     ~predecessor_level
     ~predecessor
     ~timestamp
+    ()
   >>=? fun state ->
   return (State { proto = (module Proto) ; state })
 

src/node/updater/protocol_sigs.mli

@@ -62,7 +62,8 @@ module type PROTOCOL = sig
     predecessor_fitness: Fitness.t ->
     predecessor: Block_hash.t ->
     timestamp: Time.t ->
-    validation_state tzresult Lwt.t
+    ?proto_header: MBytes.t ->
+    unit -> validation_state tzresult Lwt.t
   val apply_operation :
     validation_state -> operation -> validation_state tzresult Lwt.t
   val finalize_block :

src/node/updater/register.ml

@@ -50,11 +50,11 @@ let register (module Proto : Protocol_sigs.PACKED_PROTOCOL) =
     let begin_construction
         ~predecessor_context ~predecessor_timestamp
         ~predecessor_level ~predecessor_fitness
-        ~predecessor ~timestamp =
+        ~predecessor ~timestamp ?proto_header () =
       begin_construction
         ~predecessor_context ~predecessor_timestamp
         ~predecessor_level ~predecessor_fitness
-        ~predecessor ~timestamp >|= wrap_error
+        ~predecessor ~timestamp ?proto_header () >|= wrap_error
     let current_context c =
       current_context c >|= wrap_error
     let apply_operation c o =

src/proto/alpha/apply.ml

@@ -247,24 +247,36 @@ let may_start_new_cycle ctxt =
         ctxt last_cycle reward_date >>=? fun ctxt ->
       return ctxt
 
-let begin_construction ctxt =
-  Fitness.increase ctxt
+let begin_full_construction ctxt pred_timestamp proto_header =
+  Lwt.return
+    (Block_header.parse_unsigned_proto_header
+       proto_header) >>=? fun proto_header ->
+  Mining.check_mining_rights
+    ctxt proto_header pred_timestamp >>=? fun miner ->
+  Mining.pay_mining_bond ctxt proto_header miner >>=? fun ctxt ->
+  let ctxt = Fitness.increase ctxt in
+  return (ctxt, proto_header, miner)
 
-let begin_application ctxt block pred_timestamp =
-  Mining.check_proof_of_work_stamp ctxt block >>=? fun () ->
-  Mining.check_fitness_gap ctxt block >>=? fun () ->
-  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 ->
+let begin_partial_construction ctxt =
+  let ctxt = Fitness.increase ctxt in
+  return ctxt
+
+let begin_application ctxt block_header pred_timestamp =
+  Mining.check_proof_of_work_stamp ctxt block_header >>=? fun () ->
+  Mining.check_fitness_gap ctxt block_header >>=? fun () ->
+  Mining.check_mining_rights
+    ctxt block_header.proto pred_timestamp >>=? fun miner ->
+  Mining.check_signature ctxt block_header miner >>=? fun () ->
+  Mining.pay_mining_bond ctxt block_header.proto miner >>=? fun ctxt ->
   let ctxt = Fitness.increase ctxt in
   return (ctxt, miner)
 
-let finalize_application ctxt block miner =
+let finalize_application ctxt block_proto_header miner =
   (* end of level (from this point nothing should fail) *)
-  let priority = block.Block_header.proto.priority in
+  let priority = block_proto_header.Block_header.priority in
   let reward = Mining.base_mining_reward ctxt ~priority in
   Nonce.record_hash ctxt
-    miner reward block.proto.seed_nonce_hash >>=? fun ctxt ->
+    miner reward block_proto_header.seed_nonce_hash >>=? fun ctxt ->
   Reward.pay_due_rewards ctxt >>=? fun ctxt ->
   (* end of cycle *)
   may_start_new_cycle ctxt >>=? fun ctxt ->

src/proto/alpha/block_header_repr.ml

@@ -92,9 +92,17 @@ let parse
           timestamp ; fitness ; operations_hash } in
       Ok { shell ; proto ; signature }
 
+let parse_unsigned_proto_header bytes =
+  match Data_encoding.Binary.of_bytes proto_header_encoding bytes with
+  | None -> Error [Cant_parse_proto_header]
+  | Some proto -> Ok proto
+
 let forge_unsigned shell proto =
   Data_encoding.Binary.to_bytes unsigned_header_encoding (shell, proto)
 
+let forge_unsigned_proto_header proto =
+  Data_encoding.Binary.to_bytes proto_header_encoding proto
+
 let hash_raw = Block_header.hash
 let hash { shell ; proto ; signature } =
   Block_header.hash

src/proto/alpha/block_header_repr.mli

@@ -36,7 +36,15 @@ val max_header_length: int
 (** The maximum size of block headers in bytes *)
 
 val parse: Block_header.t -> block_header tzresult
-(** Parse the protocol-specific part of a block header. *)
+(** Parse the (signed) protocol-specific part of a block header. *)
+
+val parse_unsigned_proto_header: MBytes.t -> proto_header tzresult
+(** Parse the (unsigned) protocol-specific part of a block header. *)
+
+val forge_unsigned_proto_header: proto_header -> MBytes.t
+(** [forge_header proto_hdr] is the binary serialization
+    (using [proto_header_encoding]) of the protocol-specific part
+    of a block header, without the signature. *)
 
 val forge_unsigned:
   Block_header.shell_header -> proto_header -> MBytes.t

src/proto/alpha/main.ml

@@ -25,8 +25,18 @@ let max_block_length =
 let rpc_services = Services_registration.rpc_services
 
 type validation_mode =
-  | Application of Tezos_context.Block_header.t * Tezos_context.public_key_hash
-  | Construction of { pred_block : Block_hash.t ; timestamp : Time.t }
+  | Application of {
+      block_header : Tezos_context.Block_header.t ;
+      miner : Tezos_context.public_key_hash ;
+    }
+  | Partial_construction of {
+      predecessor : Block_hash.t ;
+    }
+  | Full_construction of {
+      predecessor : Block_hash.t ;
+      block_proto_header : Tezos_context.Block_header.proto_header ;
+      miner : Tezos_context.public_key_hash ;
+    }
 
 type validation_state =
   { mode : validation_mode ;
@@ -49,38 +59,56 @@ let begin_application
     ~predecessor_timestamp:pred_timestamp
     ~predecessor_fitness:pred_fitness
     raw_block =
-  Lwt.return (Tezos_context.Block_header.parse raw_block) >>=? fun header ->
-  let level = header.shell.level in
+  Lwt.return (Tezos_context.Block_header.parse raw_block) >>=? fun block_header ->
+  let level = block_header.shell.level in
   let fitness = pred_fitness in
-  let timestamp = header.shell.timestamp in
+  let timestamp = block_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
+  Apply.begin_application
+    ctxt block_header pred_timestamp >>=? fun (ctxt, miner) ->
+  let mode = Application { block_header ; miner } in
   return { mode ; ctxt ; op_count = 0 }
 
 let begin_construction
     ~predecessor_context:ctxt
-    ~predecessor_timestamp:_
+    ~predecessor_timestamp:pred_timestamp
     ~predecessor_level:pred_level
     ~predecessor_fitness:pred_fitness
-    ~predecessor:pred_block
-    ~timestamp =
-  let mode = Construction { pred_block ; timestamp } in
-  let level = Int32.succ pred_level in
+    ~predecessor
+    ~timestamp
+    ?proto_header
+    () =
+ let level = Int32.succ pred_level in
   let fitness = pred_fitness in
   Tezos_context.init ~timestamp ~level ~fitness ctxt >>=? fun ctxt ->
-  let ctxt = Apply.begin_construction ctxt in
+  begin
+    match proto_header with
+    | None ->
+        Apply.begin_partial_construction ctxt >>=? fun ctxt ->
+        let mode = Partial_construction { predecessor } in
+        return (mode, ctxt)
+    | Some proto_header ->
+        Apply.begin_full_construction
+          ctxt pred_timestamp
+          proto_header >>=? fun (ctxt, block_proto_header, miner) ->
+        let mode =
+          Full_construction { predecessor ; miner ; block_proto_header } in
+        return (mode, ctxt)
+  end >>=? fun (mode, ctxt) ->
   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, 0, None
-    | Application (block, delegate) ->
-        block.shell.predecessor,
-        block.proto.priority,
-        Some (Tezos_context.Contract.default_contract delegate) in
+    | Partial_construction { predecessor } ->
+        predecessor, 0, None
+    | Application
+        { miner ;  block_header = { shell = { predecessor } ;
+                                    proto = block_proto_header } }
+    | Full_construction { predecessor ; block_proto_header ; miner } ->
+        predecessor,
+        block_proto_header.priority,
+        Some (Tezos_context.Contract.default_contract miner) in
   Apply.apply_operation
     ctxt miner_contract pred_block block_prio operation
   >>=? fun (ctxt, _contracts, _ignored_script_error) ->
@@ -88,14 +116,16 @@ let apply_operation ({ mode ; ctxt ; op_count } as data) operation =
   return { data with ctxt ; op_count }
 
 let finalize_block { mode ; ctxt ; op_count } = match mode with
-  | Construction _ ->
+  | Partial_construction _ ->
       let ctxt = Tezos_context.finalize ctxt in
       return ctxt
-  | Application (block, miner) ->
-      Apply.finalize_application ctxt block miner >>=? fun ctxt ->
+  | Application
+      { miner ;  block_header = { proto = block_proto_header } }
+  | Full_construction { block_proto_header ; miner } ->
+      Apply.finalize_application ctxt block_proto_header miner >>=? fun ctxt ->
       let { level } : Tezos_context.Level.t =
         Tezos_context. Level.current ctxt in
-      let priority = block.proto.priority in
+      let priority = block_proto_header.priority in
       let level = Tezos_context.Raw_level.to_int32 level in
       let fitness = Tezos_context.Fitness.current ctxt in
       let commit_message =

src/proto/alpha/mining.ml

@@ -118,14 +118,14 @@ let check_timestamp c priority pred_timestamp =
   fail_unless Timestamp.(minimal_time <= timestamp)
     (Timestamp_too_early (minimal_time, timestamp))
 
-let check_mining_rights c { Block_header.proto = { priority } }
+let check_mining_rights c { Block_header.priority }
     pred_timestamp =
   let level = Level.current c in
   Roll.mining_rights_owner c level ~priority >>=? fun delegate ->
   check_timestamp c priority pred_timestamp >>=? fun () ->
   return delegate
 
-let pay_mining_bond c { Block_header.proto = { priority } } id =
+let pay_mining_bond c { Block_header.priority } id =
   if Compare.Int.(priority >= Constants.first_free_mining_slot c)
   then return c
   else

src/proto/alpha/mining.mli

@@ -29,7 +29,7 @@ val minimal_time: context -> int -> Time.t -> Time.t tzresult Lwt.t
 
 val pay_mining_bond:
   context ->
-  Block_header.t ->
+  Block_header.proto_header ->
   public_key_hash ->
   context tzresult Lwt.t
 
@@ -42,7 +42,8 @@ val pay_endorsement_bond:
     * the bond have been payed if the slot is below [Constants.first_free_mining_slot].
 *)
 val check_mining_rights:
-  context -> Block_header.t -> Time.t -> public_key_hash tzresult Lwt.t
+  context -> Block_header.proto_header -> Time.t ->
+  public_key_hash tzresult Lwt.t
 
 (** [check_signing_rights c slot contract] verifies that:
     * the slot is valid;

src/proto/alpha/services.ml

@@ -604,6 +604,24 @@ module Helpers = struct
                describe ~title: "hex encoded operation" bytes)))
         RPC.Path.(custom_root / "helpers" / "forge" / "operations" )
 
+    let empty_proof_of_work_nonce =
+      MBytes.of_string
+        (String.make Constants_repr.proof_of_work_nonce_size  '\000')
+
+    let block_proto_header custom_root =
+      RPC.service
+        ~description: "Forge the protocol-specific part of a block header"
+        ~input:
+          (obj3
+             (req "priority" uint16)
+             (req "nonce_hash" Nonce_hash.encoding)
+             (dft "proof_of_work_nonce"
+                (Fixed.bytes
+                   Tezos_context.Constants.proof_of_work_nonce_size)
+                empty_proof_of_work_nonce))
+        ~output: (wrap_tzerror bytes)
+        RPC.Path.(custom_root / "helpers" / "forge" / "block_proto_header")
+
     let block custom_root =
       RPC.service
         ~description: "Forge a block header"

src/proto/alpha/services_registration.ml

@@ -488,6 +488,14 @@ let forge_operations _ctxt (shell, proto) =
 
 let () = register1 Services.Helpers.Forge.operations forge_operations
 
+let forge_block_proto_header _ctxt
+    (priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t =
+  return (Block_header.forge_unsigned_proto_header
+            { priority ; seed_nonce_hash ; proof_of_work_nonce })
+
+let () =
+  register1 Services.Helpers.Forge.block_proto_header forge_block_proto_header
+
 let forge_block _ctxt
     ((net_id, predecessor, timestamp, fitness, operations_hash),
      (level, priority, proto_level, seed_nonce_hash, proof_of_work_nonce)) : MBytes.t tzresult Lwt.t =

src/proto/alpha/tezos_context.mli

@@ -562,6 +562,14 @@ module Block_header : sig
   val parse: Block_header.t -> block_header tzresult
   (** Parse the protocol-specific part of a block header. *)
 
+  val parse_unsigned_proto_header: MBytes.t -> proto_header tzresult
+  (** Parse the (unsigned) protocol-specific part of a block header. *)
+
+  val forge_unsigned_proto_header: proto_header -> MBytes.t
+  (** [forge_header proto_hdr] is the binary serialization
+      (using [proto_header_encoding]) of the protocol-specific part
+      of a block header, without the signature. *)
+
   val forge_unsigned:
     Block_header.shell_header -> proto_header -> MBytes.t
   (** [forge_header shell_hdr proto_hdr] is the binary serialization

src/proto/demo/main.ml

@@ -74,7 +74,8 @@ let begin_construction
     ~predecessor_level:_
     ~predecessor_fitness:pred_fitness
     ~predecessor:_
-    ~timestamp:_ =
+    ~timestamp:_
+    ?proto_header:_ () =
   Fitness.to_int64 pred_fitness >>=? function pred_fitness ->
   let fitness = Int64.succ pred_fitness in
   return { context ; fitness }

src/proto/environment/updater.mli

@@ -95,7 +95,8 @@ module type PROTOCOL = sig
     predecessor_fitness: Fitness.t ->
     predecessor: Block_hash.t ->
     timestamp: Time.t ->
-    validation_state tzresult Lwt.t
+    ?proto_header: MBytes.t ->
+    unit -> validation_state tzresult Lwt.t
 
   (** Called after {!begin_application} (or {!begin_construction}) and
       before {!finalize_block}, with each operation in the block. *)

src/proto/genesis/main.ml

@@ -107,7 +107,9 @@ let begin_construction
     ~predecessor_level:_
     ~predecessor_fitness:fitness
     ~predecessor:_
-    ~timestamp:_ =
+    ~timestamp:_
+    ?proto_header:_
+    () =
   (* Dummy result. *)
   return { Updater.message = None ; context ; fitness }