Alpha/Baker: forge a block locally

src/proto_alpha/lib_client/proto_alpha.ml

@@ -15,6 +15,7 @@ module Proto = Tezos_protocol_alpha.Functor.Make(Alpha_environment)
 module Alpha_block_services = Block_services.Make(Proto)(Proto)
 
 include Proto
+module LiftedMain = Alpha_environment.Lift(Proto)
 
 class type rpc_context = object
   inherit RPC_context.json

src/proto_alpha/lib_delegate/client_baking_blocks.ml

@@ -18,6 +18,7 @@ type block_info = {
   timestamp: Time.t ;
   protocol: Protocol_hash.t ;
   next_protocol: Protocol_hash.t ;
+  proto_level: int ;
   level: Raw_level.t ;
   context : Context_hash.t ;
 }
@@ -29,12 +30,12 @@ let raw_info cctxt ?(chain = `Main) hash shell_header =
     cctxt ~chain ~block () >>=? fun { current_protocol = protocol ;
                                       next_protocol } ->
   let { Tezos_base.Block_header.predecessor ; fitness ;
-        timestamp ; level ; context ; _ } =
+        timestamp ; level ; context ; proto_level ; _ } =
     shell_header in
   match Raw_level.of_int32 level with
   | Ok level ->
       return { hash ; chain_id ; predecessor ; fitness ;
-               timestamp ; protocol ; next_protocol ; level ; context }
+               timestamp ; protocol ; next_protocol ; proto_level ; level ; context }
   | Error _ ->
       failwith "Cannot convert level into int32"
 

src/proto_alpha/lib_delegate/client_baking_blocks.mli

@@ -18,6 +18,7 @@ type block_info = {
   timestamp: Time.t ;
   protocol: Protocol_hash.t ;
   next_protocol: Protocol_hash.t ;
+  proto_level: int ;
   level: Raw_level.t ;
   context : Context_hash.t ;
 }

src/proto_alpha/lib_delegate/client_baking_forge.ml

@@ -13,7 +13,6 @@ open Alpha_context
 include Tezos_stdlib.Logging.Make_semantic(struct let name = "client.baking" end)
 open Logging
 
-
 (* The index of the different components of the protocol's validation passes *)
 (* TODO: ideally, we would like this to be more abstract and possibly part of
    the protocol, while retaining the generality of lists *)
@@ -175,18 +174,18 @@ let retain_operations_up_to_quota operations max_quota =
   List.rev operations
 
 let classify_operations ?threshold (ops: Proto_alpha.operation list) =
-  let t = Array.make (List.length Proto_alpha.Main.validation_passes) [] in
+  let t = Array.make (List.length LiftedMain.validation_passes) [] in
   List.iter
     (fun (op: Proto_alpha.operation) ->
        List.iter
          (fun pass -> t.(pass) <- op :: t.(pass))
-         (Proto_alpha.Main.acceptable_passes op))
+         (Main.acceptable_passes op))
     ops ;
   let t = Array.map List.rev t in
   (* Retrieve the maximum paying manager operations *)
   let manager_operations = t.(managers_index) in
   let { Alpha_environment.Updater.max_size } =
-    List.nth Proto_alpha.Main.validation_passes managers_index in
+    List.nth LiftedMain.validation_passes managers_index in
   sort_operations_by_fee ?threshold manager_operations >>=? fun ordered_operations ->
   let max_operations =
     retain_operations_up_to_quota ordered_operations max_size
@@ -301,7 +300,6 @@ let error_of_op (result: error Preapply_result.t) op =
   try Some (Failed_to_preapply (op, snd @@ Operation_hash.Map.find h result.branch_delayed))
   with Not_found -> None
 
-
 let forge_block cctxt ?(chain = `Main) block
     ?threshold
     ?force
@@ -514,13 +512,18 @@ let pop_baking_slots state =
   state.future_slots <- future_slots ;
   slots
 
-let filter_invalid_operations (cctxt : #full) state block_info (operations : packed_operation list list) =
+let filter_and_apply_operations
+    state
+    block_info
+    ~timestamp
+    ?protocol_data
+    (operations : packed_operation list list) =
   let open Client_baking_simulator in
   lwt_debug Tag.DSL.(fun f ->
       f "Starting client-side validation %a"
       -% t event "baking_local_validation_start"
       -% a Block_hash.Logging.tag block_info.Client_baking_blocks.hash) >>= fun () ->
-  begin begin_construction cctxt state.index block_info >>= function
+  begin begin_construction ~timestamp ?protocol_data state.index block_info >>= function
     | Ok inc -> return inc
     | Error errs ->
         lwt_log_error Tag.DSL.(fun f ->
@@ -529,7 +532,7 @@ let filter_invalid_operations (cctxt : #full) state block_info (operations : pac
             -% a errs_tag errs) >>= fun () ->
         lwt_log_notice Tag.DSL.(fun f -> f "Retrying to open the context" -% t event "reopen_context") >>= fun () ->
         Client_baking_simulator.load_context ~context_path:state.context_path >>= fun index ->
-        begin_construction cctxt index block_info >>=? fun inc ->
+        begin_construction ~timestamp ?protocol_data index block_info >>=? fun inc ->
         state.index <- index ;
         return inc
   end  >>=? fun initial_inc ->
@@ -570,20 +573,13 @@ let filter_invalid_operations (cctxt : #full) state block_info (operations : pac
   filter_valid_operations inc managers >>=? fun (inc, managers) ->
   (* Gives a chance to the endorser to fund their deposit in the current block *)
   filter_map_s (is_valid_endorsement inc) endorsements >>=? fun endorsements ->
-  finalize_construction inc >>= function
-  | Error errs ->
-      lwt_log_error Tag.DSL.(fun f ->
-          f "Client-side validation: invalid block built. Building an empty block...\n%a"
-          -% t event "built_invalid_block_error"
-          -% a errs_tag errs) >>= fun () ->
-      return [ [] ; [] ; [] ; [] ]
-  | Ok () ->
-      let quota : Alpha_environment.Updater.quota list = Main.validation_passes in
+  finalize_construction inc >>=? fun _ ->
+  let quota : Alpha_environment.Updater.quota list = LiftedMain.validation_passes in
   (* This shouldn't happen *)
   tzforce state.constants >>=? fun constants ->
   let endorsements =
-        List.sub (List.rev endorsements) constants.Constants.parametric.endorsers_per_block
-      in
+    List.sub (List.rev endorsements)
+      constants.Constants.parametric.endorsers_per_block in
   let votes =
     retain_operations_up_to_quota
       (List.rev votes)
@@ -593,14 +589,73 @@ let filter_invalid_operations (cctxt : #full) state block_info (operations : pac
       (List.rev anonymous)
       (List.nth quota anonymous_index).max_size in
   (* manager operations size check already occured in classify operations *)
-      return @@ List.map List.rev [ endorsements ; votes ; anonymous ; managers ]
+  let operations = List.map List.rev [ endorsements ; votes ; anonymous ; managers ] in
+  (* Re-run with the final operations  *)
+  fold_left_s
+    add_operation
+    initial_inc (List.flatten operations) >>=? fun inc ->
+  finalize_construction inc >>=? fun (validation_result, metadata) ->
+  return @@ (inc, (validation_result, metadata), operations)
+
+(* Build the block header : mimics node prevalidation *)
+let finalize_block_header
+    (inc : Client_baking_simulator.incremental)
+    ~timestamp
+    (validation_result, _metadata)
+    operations =
+  let { T.context ; fitness ; message ; _ } = validation_result in
+  let validation_passes = List.length LiftedMain.validation_passes in
+  let operations_hash : Operation_list_list_hash.t = 
+    Operation_list_list_hash.compute
+      (List.map
+         (fun sl ->
+            Operation_list_hash.compute
+              (List.map Operation.hash_packed sl)
+         ) operations
+      ) in
+  Context.hash ~time:timestamp ?message context >>= fun context ->
+  let header =
+    { inc.header with
+      level = Raw_level.to_int32 (Raw_level.succ inc.predecessor.level) ;
+      validation_passes ;
+      operations_hash ;
+      fitness ;
+      context ;
+    } in
+  return header
+
+let shell_prevalidation
+    (cctxt : #Proto_alpha.full)
+    ~chain
+    ~block
+    seed_nonce_hash
+    operations 
+    (timestamp, (bi, priority, delegate)) =
+  let protocol_data =
+    forge_faked_protocol_data ~priority ~seed_nonce_hash in
+  Alpha_block_services.Helpers.Preapply.block
+    cctxt ~chain ~block
+    ~timestamp ~sort:true ~protocol_data operations
+  >>= function
+  | Error errs ->
+      lwt_log_error Tag.DSL.(fun f ->
+          f "Shell-side validation: error while prevalidating operations:@\n%a"
+          -% t event "built_invalid_block_error"
+          -% a errs_tag errs) >>= fun () ->
+      return None
+  | Ok (shell_header, operations) ->
+      let raw_ops =
+        List.map (fun l ->
+            List.map snd l.Preapply_result.applied) operations in
+      return
+        (Some (bi, priority, shell_header, raw_ops, delegate, seed_nonce_hash))
 
 let bake_slot
     cctxt
     state
     ?threshold
     seed_nonce_hash
-    (timestamp, (bi, priority, delegate)) (* baking slot *)
+    ((timestamp, (bi, priority, delegate)) as slot)
   =
   let chain = `Hash bi.Client_baking_blocks.chain_id in
   let block = `Hash (bi.hash, 0) in
@@ -619,55 +674,39 @@ let bake_slot
       -% s bake_priorty_tag priority
       -% s Client_keys.Logging.tag name
       -% a timestamp_tag timestamp) >>= fun () ->
-  (* get and process operations *)
+  (* Retrieve pending operations *)
   Alpha_block_services.Mempool.pending_operations cctxt ~chain () >>=? fun mpool ->
   let operations = ops_of_mempool mpool in
-  let total_op_count = List.length operations in
   let seed_nonce_hash =
     if next_level.expected_commitment then
       Some seed_nonce_hash
     else
       None in
-  let protocol_data =
-    forge_faked_protocol_data ~priority ~seed_nonce_hash in
   classify_operations ?threshold operations >>=? fun operations ->
-  begin
   (* Don't load an alpha context if the chain is still in genesis *)
-    if Protocol_hash.(bi.protocol = bi.next_protocol) then
-      filter_invalid_operations cctxt state bi operations
+  if Protocol_hash.(Proto_alpha.hash <> bi.next_protocol) then
+    (* Delegate validation to shell *)
+    shell_prevalidation cctxt ~chain ~block seed_nonce_hash operations slot
   else
-      return operations
-  end >>= function
+    let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
+    filter_and_apply_operations ~timestamp ~protocol_data state bi operations >>= function
     | Error errs ->
         lwt_log_error Tag.DSL.(fun f ->
             f "Client-side validation: error while filtering invalid operations :@\n%a"
             -% t event "client_side_validation_error"
             -% a errs_tag errs) >>= fun () ->
-      return_none
-  | Ok operations ->
-      Alpha_block_services.Helpers.Preapply.block
-        cctxt ~chain ~block
-        ~timestamp ~sort:true ~protocol_data operations
-      >>= function
-      | Error errs ->
-          lwt_log_error Tag.DSL.(fun f ->
-              f "Error while prevalidating operations:@\n%a"
-              -% t event "prevalidate_operations_error"
-              -% a errs_tag errs) >>= fun () ->
-          return_none
-      | Ok (shell_header, operations) ->
+        shell_prevalidation cctxt ~chain ~block seed_nonce_hash [] slot
+    | Ok (final_context, validation_result, operations) ->
         lwt_debug Tag.DSL.(fun f ->
-              f "Computed candidate block after %a (slot %d): %a/%d fitness: %a"
-              -% t event "candidate_block"
+            f "Try forging locally the block header for %a (slot %d) for %s (%a)"
+            -% t event "try_forging"
             -% a Block_hash.Logging.tag bi.hash
             -% s bake_priorty_tag priority
-              -% a operations_tag operations
-              -% s bake_op_count_tag total_op_count
-              -% a fitness_tag shell_header.fitness) >>= fun () ->
-          let operations =
-            List.map (fun l -> List.map snd l.Preapply_result.applied) operations in
-          return
-            (Some (bi, priority, shell_header, operations, delegate, seed_nonce_hash))
+            -% s Client_keys.Logging.tag name
+            -% a timestamp_tag timestamp) >>= fun () ->
+        finalize_block_header final_context ~timestamp validation_result operations >>=? fun shell_header ->
+        let raw_ops = List.map (List.map forge) operations in
+        return (Some (bi, priority, shell_header, raw_ops, delegate, seed_nonce_hash))
 
 let fittest
     (_, _, (h1: Block_header.shell_header), _, _, _)
@@ -764,8 +803,6 @@ let bake
           f "No valid candidates." -% t event "no_baking_candidates") >>= fun () ->
       return_unit
 
-
-
 (* [create] starts the main loop of the baker. The loop monitors new blocks and
    starts individual baking operations when baking-slots are available to any of
    the [delegates] *)

src/proto_alpha/lib_delegate/client_baking_simulator.ml

@@ -10,8 +10,6 @@
 open Proto_alpha
 open Alpha_context
 
-module Main = Alpha_environment.Lift(Main)
-
 type error +=
   | Failed_to_checkout_context
 
@@ -31,7 +29,7 @@ let () =
 type incremental = {
   predecessor: Client_baking_blocks.block_info ;
   context : Context.t ;
-  state: Main.validation_state ;
+  state: LiftedMain.validation_state ;
   rev_operations: Operation.packed list ;
   header: Tezos_base.Block_header.shell_header ;
 }
@@ -39,16 +37,14 @@ type incremental = {
 let load_context ~context_path =
   Context.init ~readonly:true context_path
 
-let begin_construction (_cctxt : #Proto_alpha.full) index predecessor =
+let begin_construction ~timestamp ?protocol_data index predecessor =
   let { Client_baking_blocks.context } = predecessor in
   Context.checkout index context >>= function
   | None -> fail Failed_to_checkout_context
   | Some context ->
-      let timestamp = Time.now () in
-      let predecessor_hash = predecessor.hash in
       let header : Tezos_base.Block_header.shell_header = Tezos_base.Block_header.{
-          predecessor = predecessor_hash ;
-          proto_level = 0 ;
+          predecessor = predecessor.hash  ;
+          proto_level = predecessor.proto_level ;
           validation_passes = 0 ;
           fitness = predecessor.fitness ;
           timestamp ;
@@ -56,13 +52,14 @@ let begin_construction (_cctxt : #Proto_alpha.full) index predecessor =
           context = Context_hash.zero ;
           operations_hash = Operation_list_list_hash.zero ;
         } in
-      Main.begin_construction
+      LiftedMain.begin_construction
         ~chain_id:predecessor.chain_id
         ~predecessor_context: context
-        ~predecessor_timestamp: header.timestamp
-        ~predecessor_fitness: header.fitness
-        ~predecessor_level: header.level
-        ~predecessor:predecessor_hash
+        ~predecessor_timestamp: predecessor.timestamp
+        ~predecessor_fitness: predecessor.fitness
+        ~predecessor_level: (Raw_level.to_int32 predecessor.level)
+        ~predecessor: predecessor.hash
+        ?protocol_data
         ~timestamp
         () >>=? fun state ->
       return {
@@ -74,8 +71,8 @@ let begin_construction (_cctxt : #Proto_alpha.full) index predecessor =
       }
 
 let add_operation st ( op : Operation.packed ) =
-  Main.apply_operation st.state op >>=? fun (state, _) ->
+  LiftedMain.apply_operation st.state op >>=? fun (state, _) ->
   return { st with state ; rev_operations = op :: st.rev_operations }
 
 let finalize_construction inc =
-  Main.finalize_block inc.state >>=? fun _ -> return_unit
+  LiftedMain.finalize_block inc.state

src/proto_alpha/lib_delegate/client_baking_simulator.mli

@@ -20,8 +20,8 @@ type incremental = {
 
 val load_context : context_path:string -> Context.index Lwt.t
 
-val begin_construction : #Proto_alpha.full -> Context.index -> Client_baking_blocks.block_info -> incremental tzresult Lwt.t
+val begin_construction : timestamp:Time.t -> ?protocol_data: block_header_data -> Context.index -> Client_baking_blocks.block_info -> incremental tzresult Lwt.t
 
 val add_operation : incremental -> Operation.packed -> incremental tzresult Lwt.t
 
-val finalize_construction : incremental -> unit tzresult Lwt.t
+val finalize_construction : incremental -> (T.validation_result * LiftedMain.block_header_metadata) tzresult Lwt.t