938 lines
36 KiB
OCaml
938 lines
36 KiB
OCaml
(*****************************************************************************)
|
|
(* *)
|
|
(* Open Source License *)
|
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
(* *)
|
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
|
(* copy of this software and associated documentation files (the "Software"),*)
|
|
(* to deal in the Software without restriction, including without limitation *)
|
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
|
(* Software is furnished to do so, subject to the following conditions: *)
|
|
(* *)
|
|
(* The above copyright notice and this permission notice shall be included *)
|
|
(* in all copies or substantial portions of the Software. *)
|
|
(* *)
|
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
|
(* DEALINGS IN THE SOFTWARE. *)
|
|
(* *)
|
|
(*****************************************************************************)
|
|
|
|
open Proto_alpha
|
|
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 *)
|
|
let endorsements_index = 0
|
|
let votes_index = 1
|
|
let anonymous_index = 2
|
|
let managers_index = 3
|
|
|
|
type state = {
|
|
genesis: Block_hash.t ;
|
|
context_path: string ;
|
|
mutable index : Context.index ;
|
|
|
|
(* see [get_delegates] below to find delegates when the list is empty *)
|
|
delegates: public_key_hash list ;
|
|
|
|
(* lazy-initialisation with retry-on-error *)
|
|
constants: Constants.t tzlazy ;
|
|
|
|
(* truly mutable *)
|
|
mutable best: Client_baking_blocks.block_info ;
|
|
mutable future_slots:
|
|
(Time.t * (Client_baking_blocks.block_info * int * public_key_hash)) list ;
|
|
}
|
|
|
|
let create_state genesis context_path index delegates constants best =
|
|
{ genesis ;
|
|
context_path ;
|
|
index ;
|
|
delegates ;
|
|
constants ;
|
|
best ;
|
|
future_slots = [] ;
|
|
}
|
|
|
|
let get_delegates cctxt state = match state.delegates with
|
|
| [] ->
|
|
Client_keys.get_keys cctxt >>=? fun keys ->
|
|
let delegates = List.map (fun (_,pkh,_,_) -> pkh) keys in
|
|
return delegates
|
|
| (_ :: _) as delegates -> return delegates
|
|
|
|
let generate_seed_nonce () =
|
|
match Nonce.of_bytes @@
|
|
Rand.generate Constants.nonce_length with
|
|
| Error _errs -> assert false
|
|
| Ok nonce -> nonce
|
|
|
|
let forge_block_header
|
|
(cctxt : #Proto_alpha.full)
|
|
?(chain = `Main) block delegate_sk shell priority seed_nonce_hash =
|
|
Client_baking_pow.mine
|
|
cctxt chain block shell
|
|
(fun proof_of_work_nonce ->
|
|
{ Block_header.priority ;
|
|
seed_nonce_hash ;
|
|
proof_of_work_nonce ;
|
|
}) >>=? fun contents ->
|
|
let unsigned_header =
|
|
Data_encoding.Binary.to_bytes_exn
|
|
Alpha_context.Block_header.unsigned_encoding
|
|
(shell, contents) in
|
|
Shell_services.Chain.chain_id cctxt ~chain () >>=? fun chain_id ->
|
|
Client_keys.append cctxt delegate_sk ~watermark:(Block_header chain_id) unsigned_header
|
|
|
|
let forge_faked_protocol_data ~priority ~seed_nonce_hash =
|
|
Alpha_context.Block_header.{
|
|
contents = { priority ; seed_nonce_hash ;
|
|
proof_of_work_nonce = Client_baking_pow.empty_proof_of_work_nonce } ;
|
|
signature = Signature.zero
|
|
}
|
|
|
|
let assert_valid_operations_hash shell_header operations =
|
|
let operations_hash =
|
|
Operation_list_list_hash.compute
|
|
(List.map Operation_list_hash.compute
|
|
(List.map
|
|
(List.map Tezos_base.Operation.hash) operations)) in
|
|
fail_unless
|
|
(Operation_list_list_hash.equal
|
|
operations_hash shell_header.Tezos_base.Block_header.operations_hash)
|
|
(failure "Client_baking_forge.inject_block: inconsistent header.")
|
|
|
|
|
|
let inject_block cctxt
|
|
?force ?(chain = `Main)
|
|
~shell_header ~priority ?seed_nonce_hash ~src_sk operations =
|
|
assert_valid_operations_hash shell_header operations >>=? fun () ->
|
|
let block = `Hash (shell_header.Tezos_base.Block_header.predecessor, 0) in
|
|
forge_block_header cctxt ~chain block
|
|
src_sk shell_header priority seed_nonce_hash >>=? fun signed_header ->
|
|
Shell_services.Injection.block cctxt
|
|
?force ~chain signed_header operations >>=? fun block_hash ->
|
|
return block_hash
|
|
|
|
type error +=
|
|
| Failed_to_preapply of Tezos_base.Operation.t * error list
|
|
|
|
let () =
|
|
register_error_kind
|
|
`Permanent
|
|
~id:"Client_baking_forge.failed_to_preapply"
|
|
~title: "Fail to preapply an operation"
|
|
~description: ""
|
|
~pp:(fun ppf (op, err) ->
|
|
let h = Tezos_base.Operation.hash op in
|
|
Format.fprintf ppf "@[Failed to preapply %a:@ %a@]"
|
|
Operation_hash.pp_short h
|
|
pp_print_error err)
|
|
Data_encoding.
|
|
(obj2
|
|
(req "operation" (dynamic_size Tezos_base.Operation.encoding))
|
|
(req "error" RPC_error.encoding))
|
|
(function
|
|
| Failed_to_preapply (hash, err) -> Some (hash, err)
|
|
| _ -> None)
|
|
(fun (hash, err) -> Failed_to_preapply (hash, err))
|
|
|
|
let get_manager_operation_gas_and_fee op =
|
|
let { protocol_data = Operation_data { contents } ; _ } = op in
|
|
let open Operation in
|
|
let l = to_list (Contents_list contents) in
|
|
fold_left_s (fun ((total_fee, total_gas) as acc) -> function
|
|
| Contents (Manager_operation { fee ; gas_limit ; _ }) ->
|
|
Lwt.return @@ Alpha_environment.wrap_error @@
|
|
Tez.(total_fee +? fee) >>=? fun total_fee ->
|
|
return (total_fee, (Z.add total_gas gas_limit))
|
|
| _ -> return acc) (Tez.zero, Z.zero) l
|
|
|
|
(* Sort operation consisdering potential gas and storage usage.
|
|
Weight = fee / (max ( (size/size_total), (gas/gas_total))) *)
|
|
let sort_manager_operations
|
|
~max_size
|
|
~hard_gas_limit_per_block
|
|
?(threshold = Tez.zero)
|
|
(operations : Proto_alpha.operation list)
|
|
=
|
|
let compute_weight op (fee, gas) =
|
|
let size = Data_encoding.Binary.length Operation.encoding op in
|
|
let size_f = Q.of_int size in
|
|
let gas_f = Q.of_bigint gas in
|
|
let fee_f = Q.of_int64 (Tez.to_mutez fee) in
|
|
let size_ratio = Q.(size_f / (Q.of_int max_size)) in
|
|
let gas_ratio = Q.(gas_f / (Q.of_bigint hard_gas_limit_per_block)) in
|
|
(size, gas, Q.(fee_f / (max size_ratio gas_ratio)))
|
|
in
|
|
filter_map_s
|
|
(fun op ->
|
|
get_manager_operation_gas_and_fee op >>=? fun (fee, gas) ->
|
|
if Tez.(<) fee threshold then
|
|
return_none
|
|
else
|
|
return (Some (op, (compute_weight op (fee, gas))))
|
|
) operations >>=? fun operations ->
|
|
(* We sort by the biggest weight *)
|
|
return
|
|
(List.sort (fun (_, (_, _, w)) (_, (_, _, w')) -> Q.compare w' w) operations)
|
|
|
|
let retain_operations_up_to_quota operations quota =
|
|
let { T.max_op ; max_size } = quota in
|
|
let operations = match max_op with
|
|
| Some n -> List.sub operations n
|
|
| None -> operations
|
|
in
|
|
let exception Full of packed_operation list in
|
|
let operations = try
|
|
List.fold_left (fun (ops, size) op ->
|
|
let operation_size =
|
|
Data_encoding.Binary.length Alpha_context.Operation.encoding op
|
|
in
|
|
let new_size = size + operation_size in
|
|
if new_size > max_size then
|
|
raise (Full ops)
|
|
else
|
|
(op :: ops, new_size)
|
|
) ([], 0) operations |> fst
|
|
with
|
|
| Full ops -> ops in
|
|
List.rev operations
|
|
|
|
let trim_manager_operations ~max_size ~hard_gas_limit_per_block manager_operations =
|
|
map_s (fun op ->
|
|
get_manager_operation_gas_and_fee op >>=? fun (_fee, gas) ->
|
|
let size = Data_encoding.Binary.length Operation.encoding op in
|
|
return (op, (size, gas))) manager_operations >>=? fun manager_operations ->
|
|
List.fold_left
|
|
(fun (total_size, total_gas, (good_ops, bad_ops)) (op, (size, gas)) ->
|
|
let new_size = total_size + size in
|
|
let new_gas = Z.(total_gas + gas) in
|
|
if new_size > max_size || (Z.gt new_gas hard_gas_limit_per_block) then
|
|
(new_size, new_gas, (good_ops, op :: bad_ops))
|
|
else
|
|
(new_size, new_gas, (op :: good_ops, bad_ops))
|
|
) (0, Z.zero, ([], [])) manager_operations |> fun (_, _, (good_ops, bad_ops)) ->
|
|
(* We keep the overflowing operations, it may be used for client-side validation *)
|
|
return ((List.rev good_ops), (List.rev bad_ops))
|
|
|
|
(* We classify operations, sort managers operation by interest and add bad ones at the end *)
|
|
(* Hypothesis : we suppose that the received manager operations have a valid gas_limit *)
|
|
let classify_operations
|
|
(cctxt : #Proto_alpha.full)
|
|
?threshold
|
|
~block
|
|
~hard_gas_limit_per_block
|
|
(ops: Proto_alpha.operation list) =
|
|
Alpha_block_services.live_blocks cctxt ~chain:`Main ~block ()
|
|
>>=? fun live_blocks ->
|
|
(* Remove operations that are too old for the mempool *)
|
|
let ops =
|
|
List.filter (fun { shell = { branch } } ->
|
|
Block_hash.Set.mem branch live_blocks
|
|
) ops
|
|
in
|
|
let t = Array.make (List.length Proto_alpha.Main.validation_passes) [] in
|
|
List.iter
|
|
(fun (op: Proto_alpha.operation) ->
|
|
List.iter
|
|
(fun pass -> t.(pass) <- op :: t.(pass))
|
|
(Main.acceptable_passes op))
|
|
ops ;
|
|
let t = Array.map List.rev t in
|
|
|
|
(* Retrieve the optimist 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
|
|
sort_manager_operations ~max_size ~hard_gas_limit_per_block ?threshold manager_operations
|
|
>>=? fun ordered_operations ->
|
|
(* Greedy heuristic *)
|
|
trim_manager_operations ~max_size ~hard_gas_limit_per_block (List.map fst ordered_operations)
|
|
>>=? fun (desired_manager_operations, overflowing_manager_operations) ->
|
|
t.(managers_index) <- desired_manager_operations ;
|
|
return @@ (Array.fold_right (fun ops acc -> ops :: acc) t [ overflowing_manager_operations ])
|
|
|
|
let parse (op : Operation.raw) : Operation.packed =
|
|
let protocol_data =
|
|
Data_encoding.Binary.of_bytes_exn
|
|
Alpha_context.Operation.protocol_data_encoding
|
|
op.proto in
|
|
{ shell = op.shell ;
|
|
protocol_data ;
|
|
}
|
|
|
|
let forge (op : Operation.packed) : Operation.raw =
|
|
{ shell = op.shell ;
|
|
proto = Data_encoding.Binary.to_bytes_exn
|
|
Alpha_context.Operation.protocol_data_encoding
|
|
op.protocol_data
|
|
}
|
|
|
|
let ops_of_mempool (ops : Alpha_block_services.Mempool.t) =
|
|
(* We only retain the applied, unprocessed and delayed operations *)
|
|
List.rev (
|
|
Operation_hash.Map.fold (fun _ op acc -> op :: acc) ops.unprocessed @@
|
|
Operation_hash.Map.fold (fun _ (op, _) acc -> op :: acc) ops.branch_delayed @@
|
|
List.rev_map (fun (_, op) -> op) ops.applied
|
|
)
|
|
|
|
let unopt_operations cctxt chain = function
|
|
| None ->
|
|
Alpha_block_services.Mempool.pending_operations cctxt ~chain () >>=? fun mpool ->
|
|
let ops = ops_of_mempool mpool in
|
|
return ops
|
|
| Some operations ->
|
|
return operations
|
|
|
|
let all_ops_valid (results: error Preapply_result.t list) =
|
|
let open Operation_hash.Map in
|
|
List.for_all (fun (result: error Preapply_result.t) ->
|
|
is_empty result.refused
|
|
&& is_empty result.branch_refused
|
|
&& is_empty result.branch_delayed)
|
|
results
|
|
|
|
let decode_priority cctxt chain block = function
|
|
| `Set priority -> begin
|
|
Alpha_services.Delegate.Baking_rights.get cctxt
|
|
~all:true ~max_priority:(priority+1) (chain, block) >>=? fun rights ->
|
|
let time =
|
|
Option.apply
|
|
~f:(fun r -> r.Alpha_services.Delegate.Baking_rights.timestamp)
|
|
(List.nth_opt rights priority) in
|
|
return (priority, time)
|
|
end
|
|
| `Auto (src_pkh, max_priority) ->
|
|
Alpha_services.Helpers.current_level
|
|
cctxt ~offset:1l (chain, block)>>=? fun { level } ->
|
|
Alpha_services.Delegate.Baking_rights.get cctxt
|
|
?max_priority
|
|
~levels:[level]
|
|
~delegates:[src_pkh]
|
|
(chain, block) >>=? fun possibilities ->
|
|
try
|
|
let { Alpha_services.Delegate.Baking_rights.priority = prio ;
|
|
timestamp = time } =
|
|
List.find
|
|
(fun p -> p.Alpha_services.Delegate.Baking_rights.level = level)
|
|
possibilities in
|
|
return (prio, time)
|
|
with Not_found ->
|
|
failwith "No slot found at level %a" Raw_level.pp level
|
|
|
|
let unopt_timestamp timestamp minimal_timestamp =
|
|
match timestamp, minimal_timestamp with
|
|
| None, None -> return (Time.now ())
|
|
| None, Some timestamp -> return timestamp
|
|
| Some timestamp, None -> return timestamp
|
|
| Some timestamp, Some minimal_timestamp ->
|
|
if timestamp < minimal_timestamp then
|
|
failwith
|
|
"Proposed timestamp %a is earlier than minimal timestamp %a"
|
|
Time.pp_hum timestamp
|
|
Time.pp_hum minimal_timestamp
|
|
else
|
|
return timestamp
|
|
|
|
let merge_preapps (old: error Preapply_result.t) (neu: error Preapply_result.t) =
|
|
let merge _ a b = (* merge ops *)
|
|
match a, b with
|
|
| None, None -> None
|
|
| Some x, None -> Some x
|
|
| _, Some y -> Some y in
|
|
let merge = Operation_hash.Map.merge merge in (* merge op maps *)
|
|
(* merge preapplies *)
|
|
{ Preapply_result.applied = [] ;
|
|
refused = merge old.refused neu.refused ;
|
|
branch_refused = merge old.branch_refused neu.branch_refused ;
|
|
branch_delayed = merge old.branch_delayed neu.branch_delayed }
|
|
|
|
let error_of_op (result: error Preapply_result.t) op =
|
|
let op = forge op in
|
|
let h = Tezos_base.Operation.hash op in
|
|
try Some (Failed_to_preapply (op, snd @@ Operation_hash.Map.find h result.refused))
|
|
with Not_found ->
|
|
try Some (Failed_to_preapply (op, snd @@ Operation_hash.Map.find h result.branch_refused))
|
|
with Not_found ->
|
|
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
|
|
?operations ?(best_effort = operations = None) ?(sort = best_effort)
|
|
?timestamp
|
|
~priority
|
|
?seed_nonce_hash ~src_sk () =
|
|
|
|
(* making the arguments usable *)
|
|
unopt_operations cctxt chain operations >>=? fun operations_arg ->
|
|
decode_priority cctxt chain block priority >>=? fun (priority, minimal_timestamp) ->
|
|
unopt_timestamp timestamp minimal_timestamp >>=? fun timestamp ->
|
|
|
|
(* get basic building blocks *)
|
|
let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
|
|
Alpha_services.Constants.all cctxt (`Main, block) >>=?
|
|
fun Constants.{ parametric = { hard_gas_limit_per_block ; endorsers_per_block } } ->
|
|
classify_operations cctxt ~hard_gas_limit_per_block ~block:block ?threshold operations_arg >>=? fun operations ->
|
|
(* Ensure that we retain operations up to the quota *)
|
|
let quota : Alpha_environment.Updater.quota list = Main.validation_passes in
|
|
let endorsements = List.sub
|
|
(List.nth operations endorsements_index)
|
|
endorsers_per_block in
|
|
let votes = retain_operations_up_to_quota
|
|
(List.nth operations votes_index)
|
|
(List.nth quota votes_index) in
|
|
let anonymous =
|
|
retain_operations_up_to_quota
|
|
(List.nth operations anonymous_index)
|
|
(List.nth quota anonymous_index) in
|
|
(* Size/Gas check already occured in classify operations *)
|
|
let managers = List.nth operations managers_index in
|
|
let operations = [ endorsements ; votes ; anonymous ; managers ] in
|
|
Alpha_block_services.Helpers.Preapply.block
|
|
cctxt ~block ~timestamp ~sort ~protocol_data operations >>=? fun (shell_header, result) ->
|
|
|
|
(* Now for some logging *)
|
|
let total_op_count = List.length operations_arg in
|
|
let valid_op_count =
|
|
List.fold_left
|
|
(fun acc r -> acc + List.length r.Preapply_result.applied)
|
|
0 result in
|
|
lwt_log_info Tag.DSL.(fun f ->
|
|
f "Found %d valid operations (%d refused) for timestamp %a@.Computed fitness %a"
|
|
-% t event "found_valid_operations"
|
|
-% s valid_ops valid_op_count
|
|
-% s refused_ops (total_op_count - valid_op_count)
|
|
-% a timestamp_tag timestamp
|
|
-% a fitness_tag shell_header.fitness) >>= fun () ->
|
|
|
|
(* everything went well (or we don't care about errors): GO! *)
|
|
if best_effort || all_ops_valid result then
|
|
let operations =
|
|
if best_effort then
|
|
List.map (fun l -> List.map snd l.Preapply_result.applied) result
|
|
else
|
|
List.map (List.map forge) operations in
|
|
inject_block cctxt
|
|
?force ~chain ~shell_header ~priority ?seed_nonce_hash ~src_sk
|
|
operations
|
|
|
|
(* some errors (and we care about them) *)
|
|
else
|
|
let result = List.fold_left merge_preapps Preapply_result.empty result in
|
|
Lwt.return_error @@
|
|
List.filter_map (error_of_op result) (List.concat operations)
|
|
|
|
(** Worker *)
|
|
|
|
module State = Daemon_state.Make(struct let name = "block" end)
|
|
|
|
let previously_baked_level cctxt pkh new_lvl =
|
|
State.get cctxt pkh >>=? function
|
|
| None -> return_false
|
|
| Some last_lvl ->
|
|
return (Raw_level.(last_lvl >= new_lvl))
|
|
|
|
|
|
let get_baking_slot cctxt
|
|
?max_priority (bi: Client_baking_blocks.block_info) delegates =
|
|
let chain = `Hash bi.chain_id in
|
|
let block = `Hash (bi.hash, 0) in
|
|
let level = Raw_level.succ bi.level in
|
|
Alpha_services.Delegate.Baking_rights.get cctxt
|
|
?max_priority
|
|
~levels:[level]
|
|
~delegates
|
|
(chain, block) >>= function
|
|
| Error errs ->
|
|
lwt_log_error Tag.DSL.(fun f ->
|
|
f "Error while fetching baking possibilities:\n%a"
|
|
-% t event "baking_slot_fetch_errors"
|
|
-% a errs_tag errs) >>= fun () ->
|
|
Lwt.return_nil
|
|
| Ok [] ->
|
|
lwt_log_info Tag.DSL.(fun f ->
|
|
f "Found no baking rights for level %a"
|
|
-% t event "no_baking_rights"
|
|
-% a level_tag level) >>= fun () ->
|
|
Lwt.return_nil
|
|
| Ok slots ->
|
|
let slots =
|
|
List.filter_map
|
|
(function
|
|
| { Alpha_services.Delegate.Baking_rights.timestamp = None } -> None
|
|
| { timestamp = Some timestamp ; priority ; delegate } ->
|
|
Some (timestamp, (bi, priority, delegate))
|
|
)
|
|
slots
|
|
in
|
|
Lwt.return slots
|
|
|
|
let rec insert_baking_slot slot = function
|
|
(* This is just a sorted-insert *)
|
|
| [] -> [slot]
|
|
| ((timestamp,_) :: _) as slots when Time.(fst slot < timestamp) ->
|
|
slot :: slots
|
|
| slot' :: slots -> slot' :: insert_baking_slot slot slots
|
|
|
|
let drop_old_slots ~before state =
|
|
state.future_slots <-
|
|
List.filter
|
|
(fun (t, _slot) -> Time.compare before t <= 0)
|
|
state.future_slots
|
|
|
|
let compute_timeout { future_slots } =
|
|
match future_slots with
|
|
| [] ->
|
|
(* No slots, just wait for new blocks which will give more info *)
|
|
Lwt_utils.never_ending ()
|
|
| (timestamp, _) :: _ ->
|
|
match Client_baking_scheduling.sleep_until timestamp with
|
|
| None ->
|
|
Lwt.return_unit
|
|
| Some timeout ->
|
|
timeout
|
|
|
|
let get_unrevealed_nonces
|
|
(cctxt : #Proto_alpha.full) ?(force = false) ?(chain = `Main) block =
|
|
Client_baking_blocks.blocks_from_current_cycle
|
|
cctxt block ~offset:(-1l) () >>=? fun blocks ->
|
|
filter_map_s (fun hash ->
|
|
Client_baking_nonces.find cctxt hash >>=? function
|
|
| None -> return_none
|
|
| Some nonce ->
|
|
Alpha_block_services.metadata
|
|
cctxt ~chain ~block:(`Hash (hash, 0)) () >>=? fun { protocol_data = { level } } ->
|
|
if force then
|
|
return_some (hash, (level.level, nonce))
|
|
else
|
|
Alpha_services.Nonce.get
|
|
cctxt (chain, block) level.level >>=? function
|
|
| Missing nonce_hash
|
|
when Nonce.check_hash nonce nonce_hash ->
|
|
cctxt#warning "Found nonce for %a (level: %a)@."
|
|
Block_hash.pp_short hash
|
|
Level.pp level >>= fun () ->
|
|
return_some (hash, (level.level, nonce))
|
|
| Missing _nonce_hash ->
|
|
cctxt#error "Incoherent nonce for level %a"
|
|
Raw_level.pp level.level >>= fun () ->
|
|
return_none
|
|
| Forgotten -> return_none
|
|
| Revealed _ -> return_none)
|
|
blocks
|
|
|
|
let safe_get_unrevealed_nonces cctxt block =
|
|
get_unrevealed_nonces cctxt block >>= function
|
|
| Ok r -> Lwt.return r
|
|
| Error err ->
|
|
lwt_warn Tag.DSL.(fun f ->
|
|
f "Cannot read nonces: %a@."
|
|
-% t event "read_nonce_fail"
|
|
-% a errs_tag err)
|
|
>>= fun () ->
|
|
Lwt.return_nil
|
|
|
|
let insert_block
|
|
?max_priority
|
|
()
|
|
(cctxt: #Proto_alpha.full)
|
|
state
|
|
(bi: Client_baking_blocks.block_info) =
|
|
begin
|
|
safe_get_unrevealed_nonces cctxt (`Hash (bi.hash, 0)) >>= fun nonces ->
|
|
Client_baking_revelation.forge_seed_nonce_revelation
|
|
cctxt (`Hash (bi.hash, 0)) (List.map snd nonces)
|
|
end >>= fun _ignore_error ->
|
|
if Fitness.compare state.best.fitness bi.fitness < 0 then begin
|
|
state.best <- bi ;
|
|
drop_old_slots
|
|
~before:(Time.add state.best.timestamp (-1800L)) state ;
|
|
end ;
|
|
get_delegates cctxt state >>=? fun delegates ->
|
|
get_baking_slot cctxt ?max_priority bi delegates >>= function
|
|
| [] ->
|
|
lwt_debug
|
|
Tag.DSL.(fun f ->
|
|
f "Can't compute slots for %a"
|
|
-% t event "cannot_compute_slot"
|
|
-% a Block_hash.Logging.tag bi.hash) >>= fun () ->
|
|
return_unit
|
|
| (_ :: _) as slots ->
|
|
iter_p
|
|
(fun ((timestamp, (_, _, delegate)) as slot) ->
|
|
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
|
|
lwt_log_info Tag.DSL.(fun f ->
|
|
f "New baking slot at %a for %s after %a"
|
|
-% t event "have_baking_slot"
|
|
-% a timestamp_tag timestamp
|
|
-% s Client_keys.Logging.tag name
|
|
-% a Block_hash.Logging.tag bi.hash
|
|
-% t Signature.Public_key_hash.Logging.tag delegate) >>= fun () ->
|
|
state.future_slots <- insert_baking_slot slot state.future_slots ;
|
|
return_unit
|
|
)
|
|
slots
|
|
|
|
let pop_baking_slots state =
|
|
let now = Time.now () in
|
|
let rec pop acc = function
|
|
| [] -> List.rev acc, []
|
|
| ((timestamp,_) :: _) as slots when Time.compare now timestamp < 0 ->
|
|
List.rev acc, slots
|
|
| slot :: slots -> pop (slot :: acc) slots in
|
|
let slots, future_slots = pop [] state.future_slots in
|
|
state.future_slots <- future_slots ;
|
|
slots
|
|
|
|
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 ~timestamp ?protocol_data state.index block_info >>= function
|
|
| Ok inc -> return inc
|
|
| Error errs ->
|
|
lwt_log_error Tag.DSL.(fun f ->
|
|
f "Error while fetching current context : %a"
|
|
-% t event "context_fetch_error"
|
|
-% 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 ~timestamp ?protocol_data index block_info >>=? fun inc ->
|
|
state.index <- index ;
|
|
return inc
|
|
end >>=? fun initial_inc ->
|
|
let endorsements = List.nth operations endorsements_index in
|
|
let votes = List.nth operations votes_index in
|
|
let anonymous = List.nth operations anonymous_index in
|
|
let managers = List.nth operations managers_index in
|
|
let bad_managers =
|
|
if List.length operations > managers_index + 1 then
|
|
List.nth operations (managers_index + 1)
|
|
else []
|
|
in
|
|
let validate_operation inc op =
|
|
add_operation inc op >>= function
|
|
| Error errs ->
|
|
lwt_log_info Tag.DSL.(fun f ->
|
|
f "Client-side validation: invalid operation filtered %a\n%a"
|
|
-% t event "baking_rejected_invalid_operation"
|
|
-% a Operation_hash.Logging.tag (Operation.hash_packed op)
|
|
-% a errs_tag errs)
|
|
>>= fun () ->
|
|
return_none
|
|
| Ok inc -> return_some inc
|
|
in
|
|
let filter_valid_operations inc ops =
|
|
fold_left_s (fun (inc, acc) op ->
|
|
validate_operation inc op >>=? function
|
|
| None -> return (inc, acc)
|
|
| Some inc' -> return (inc', op :: acc)
|
|
) (inc, []) ops
|
|
in
|
|
(* Invalid endorsements are detected during block finalization *)
|
|
let is_valid_endorsement inc endorsement =
|
|
validate_operation inc endorsement >>=? function
|
|
| None -> return_none
|
|
| Some inc' -> finalize_construction inc' >>= begin function
|
|
| Ok _ -> return_some endorsement
|
|
| Error _ -> return_none
|
|
end
|
|
in
|
|
filter_valid_operations initial_inc votes >>=? fun (inc, votes) ->
|
|
filter_valid_operations inc anonymous >>=? fun (inc, anonymous) ->
|
|
(* Retrieve the correct index order *)
|
|
let managers = List.sort Proto_alpha.compare_operations managers in
|
|
let bad_managers = List.sort Proto_alpha.compare_operations bad_managers in
|
|
filter_valid_operations inc (managers @ bad_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 >>=? fun _ ->
|
|
let quota : Alpha_environment.Updater.quota list = Main.validation_passes in
|
|
tzforce state.constants >>=? fun
|
|
{ Constants.parametric = { endorsers_per_block ; hard_gas_limit_per_block ; } } ->
|
|
let endorsements =
|
|
List.sub (List.rev endorsements) endorsers_per_block
|
|
in
|
|
let votes =
|
|
retain_operations_up_to_quota
|
|
(List.rev votes)
|
|
(List.nth quota votes_index) in
|
|
let anonymous =
|
|
retain_operations_up_to_quota
|
|
(List.rev anonymous)
|
|
(List.nth quota anonymous_index) in
|
|
trim_manager_operations ~max_size:(List.nth quota managers_index).max_size
|
|
~hard_gas_limit_per_block managers >>=? fun (accepted_managers, _overflowing_managers) ->
|
|
(* Retrieve the correct index order *)
|
|
let accepted_managers = List.sort Proto_alpha.compare_operations accepted_managers in
|
|
(* Make sure we only keep valid operations *)
|
|
filter_valid_operations initial_inc votes >>=? fun (inc, votes) ->
|
|
filter_valid_operations inc anonymous >>=? fun (inc, anonymous) ->
|
|
filter_valid_operations inc accepted_managers >>=? fun (inc, accepted_managers) ->
|
|
filter_map_s (is_valid_endorsement inc) endorsements >>=? fun endorsements ->
|
|
(* Endorsements won't fail now *)
|
|
fold_left_s add_operation inc endorsements >>=? fun final_inc ->
|
|
let operations = List.map List.rev [ endorsements ; votes ; anonymous ; accepted_managers ] in
|
|
finalize_construction final_inc >>=? fun (validation_result, metadata) ->
|
|
return @@ (final_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)) as slot)
|
|
=
|
|
let chain = `Hash bi.Client_baking_blocks.chain_id in
|
|
let block = `Hash (bi.hash, 0) in
|
|
Alpha_services.Helpers.current_level cctxt
|
|
~offset:1l (chain, block) >>=? fun next_level ->
|
|
let timestamp =
|
|
if Block_hash.equal bi.Client_baking_blocks.hash state.genesis then
|
|
Time.now ()
|
|
else
|
|
timestamp in
|
|
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
|
|
lwt_debug Tag.DSL.(fun f ->
|
|
f "Try baking after %a (slot %d) for %s (%a)"
|
|
-% t event "try_baking"
|
|
-% a Block_hash.Logging.tag bi.hash
|
|
-% s bake_priorty_tag priority
|
|
-% s Client_keys.Logging.tag name
|
|
-% a timestamp_tag timestamp) >>= fun () ->
|
|
(* Retrieve pending operations *)
|
|
Alpha_block_services.Mempool.pending_operations cctxt ~chain () >>=? fun mpool ->
|
|
let operations = ops_of_mempool mpool in
|
|
let seed_nonce_hash =
|
|
if next_level.expected_commitment then
|
|
Some seed_nonce_hash
|
|
else
|
|
None in
|
|
tzforce state.constants >>=? fun Constants.{ parametric = { hard_gas_limit_per_block } } ->
|
|
classify_operations cctxt ?threshold ~hard_gas_limit_per_block ~block operations >>=? fun operations ->
|
|
(* Don't load an alpha context if the chain is still in genesis *)
|
|
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
|
|
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 () ->
|
|
lwt_log_notice Tag.DSL.(fun f ->
|
|
f "Building an empty block using shell validation"
|
|
-% t event "shell_prevalidation_notice") >>= fun () ->
|
|
shell_prevalidation cctxt ~chain ~block seed_nonce_hash operations slot
|
|
| Ok (final_context, validation_result, operations) ->
|
|
lwt_debug Tag.DSL.(fun f ->
|
|
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
|
|
-% 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), _, _, _)
|
|
(_, _, (h2: Block_header.shell_header), _, _, _) =
|
|
match Fitness.compare h1.fitness h2.fitness with
|
|
| 0 -> Time.compare h1.timestamp h2.timestamp
|
|
| cmp -> ~- cmp
|
|
|
|
let fit_enough (state: state) (shell_header: Block_header.shell_header) =
|
|
Fitness.compare state.best.fitness shell_header.fitness < 0
|
|
|| (Fitness.compare state.best.fitness shell_header.fitness = 0
|
|
&& Time.compare shell_header.timestamp state.best.timestamp < 0)
|
|
|
|
let record_nonce_hash cctxt block_hash seed_nonce seed_nonce_hash =
|
|
if seed_nonce_hash <> None then
|
|
Client_baking_nonces.add cctxt block_hash seed_nonce
|
|
|> trace_exn (Failure "Error while recording block")
|
|
else
|
|
return_unit
|
|
|
|
let pp_operation_list_list =
|
|
Format.pp_print_list
|
|
~pp_sep:(fun ppf () -> Format.fprintf ppf "+")
|
|
(fun ppf operations -> Format.fprintf ppf "%d" (List.length operations))
|
|
|
|
(* [bake] create a single block when woken up to do so. All the necessary
|
|
information (e.g., slot) is available in the [state]. *)
|
|
let bake
|
|
?threshold
|
|
()
|
|
(cctxt : #Proto_alpha.full)
|
|
state
|
|
() =
|
|
let slots = pop_baking_slots state in
|
|
lwt_log_info Tag.DSL.(fun f ->
|
|
f "Found %d current slots and %d future slots."
|
|
-% t event "pop_baking_slots"
|
|
-% s current_slots_tag (List.length slots)
|
|
-% s future_slots_tag (List.length state.future_slots)) >>= fun () ->
|
|
let seed_nonce = generate_seed_nonce () in
|
|
let seed_nonce_hash = Nonce.hash seed_nonce in
|
|
|
|
(* baking for each slot *)
|
|
filter_map_s
|
|
(bake_slot cctxt ?threshold state seed_nonce_hash)
|
|
slots >>=? fun candidates ->
|
|
|
|
(* FIXME: pick one block per-delegate *)
|
|
(* selecting the candidate baked block *)
|
|
let candidates = List.sort fittest candidates in
|
|
match candidates with
|
|
| (bi, priority, shell_header, operations, delegate, seed_nonce_hash) :: _
|
|
when fit_enough state shell_header -> begin
|
|
let level = Raw_level.succ bi.level in
|
|
cctxt#message
|
|
"Select candidate block after %a (slot %d) fitness: %a"
|
|
Block_hash.pp_short bi.hash priority
|
|
Fitness.pp shell_header.fitness >>= fun () ->
|
|
|
|
(* core function *)
|
|
Client_keys.get_key cctxt delegate >>=? fun (_,src_pk,src_sk) ->
|
|
let src_pkh = Signature.Public_key.hash src_pk in
|
|
let chain = `Hash bi.Client_baking_blocks.chain_id in
|
|
|
|
(* avoid double baking *)
|
|
previously_baked_level cctxt src_pkh level >>=? function
|
|
| true -> lwt_log_error Tag.DSL.(fun f ->
|
|
f "Level %a : previously baked"
|
|
-% t event "double_bake_near_miss"
|
|
-% a level_tag level) >>= return
|
|
| false ->
|
|
inject_block cctxt
|
|
~force:true ~chain
|
|
~shell_header ~priority ?seed_nonce_hash ~src_sk
|
|
operations
|
|
(* /core function; back to logging and info *)
|
|
|
|
|> trace_exn (Failure "Error while injecting block") >>=? fun block_hash ->
|
|
State.record cctxt src_pkh level >>=? fun () ->
|
|
record_nonce_hash cctxt block_hash seed_nonce seed_nonce_hash >>=? fun () ->
|
|
Client_keys.Public_key_hash.name cctxt delegate >>=? fun name ->
|
|
cctxt#message
|
|
"Injected block %a for %s after %a (level %a, slot %d, fitness %a, operations %a)"
|
|
Block_hash.pp_short block_hash
|
|
name
|
|
Block_hash.pp_short bi.hash
|
|
Raw_level.pp level priority
|
|
Fitness.pp shell_header.fitness
|
|
pp_operation_list_list operations >>= fun () ->
|
|
return_unit
|
|
end
|
|
| _ -> (* no candidates, or none fit-enough *)
|
|
lwt_debug Tag.DSL.(fun f ->
|
|
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] *)
|
|
let create
|
|
(cctxt : #Proto_alpha.full)
|
|
?threshold
|
|
?max_priority
|
|
~(context_path: string)
|
|
(delegates: public_key_hash list)
|
|
(block_stream: Client_baking_blocks.block_info tzresult Lwt_stream.t)
|
|
=
|
|
|
|
let state_maker genesis_hash bi =
|
|
let constants =
|
|
tzlazy (fun () -> Alpha_services.Constants.all cctxt (`Main, `Head 0)) in
|
|
Client_baking_simulator.load_context ~context_path >>= fun index ->
|
|
let state = create_state genesis_hash context_path index delegates constants bi in
|
|
return state
|
|
in
|
|
|
|
Client_baking_scheduling.main
|
|
~name:"baker"
|
|
~cctxt
|
|
~stream:block_stream
|
|
~state_maker
|
|
~pre_loop:(insert_block ?max_priority ())
|
|
~compute_timeout
|
|
~timeout_k:(bake ?threshold ())
|
|
~event_k:(insert_block ?max_priority ())
|