https://gitlab.com/tezos/tezos
Tip revision: 2d5acbfa91dde2e6d2fff91afa1122f310ee1c9e authored by martoon on 28 August 2023, 23:20:02 UTC
Try stack as enum
Try stack as enum
Tip revision: 2d5acbf
baking.ml
(*****************************************************************************)
(* *)
(* 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 Alpha_context
open Misc
type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)
type error +=
| Timestamp_too_early of {
minimal_time : Timestamp.t;
provided_time : Timestamp.t;
priority : int;
endorsing_power_opt : int option;
}
(* `Permanent *)
type error += Unexpected_endorsement (* `Permanent *)
type error += Invalid_endorsement_slot of int (* `Permanent *)
type error += Unexpected_endorsement_slot of int (* `Permanent *)
type error +=
| Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t
(* `Permanent *)
type error += Invalid_signature (* `Permanent *)
type error += Invalid_stamp (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"baking.timestamp_too_early"
~title:"Block forged too early"
~description:"The block timestamp is before the minimal valid one."
~pp:(fun ppf (minimal_time, provided_time, priority, endorsing_power) ->
let message_regarding_endorsements =
match endorsing_power with
| None ->
""
| Some power ->
Format.asprintf " and endorsing power %d" power
in
Format.fprintf
ppf
"Block forged too early: %a is before the minimal time %a for \
priority %d%s)"
Time.pp_hum
provided_time
Time.pp_hum
minimal_time
priority
message_regarding_endorsements)
Data_encoding.(
obj4
(req "minimal_time" Time.encoding)
(req "provided_time" Time.encoding)
(req "priority" int31)
(opt "endorsing_power" int31))
(function
| Timestamp_too_early
{minimal_time; provided_time; priority; endorsing_power_opt} ->
Some (minimal_time, provided_time, priority, endorsing_power_opt)
| _ ->
None)
(fun (minimal_time, provided_time, priority, endorsing_power_opt) ->
Timestamp_too_early
{minimal_time; provided_time; priority; endorsing_power_opt}) ;
register_error_kind
`Permanent
~id:"baking.invalid_fitness_gap"
~title:"Invalid fitness gap"
~description:"The gap of fitness is out of bounds"
~pp:(fun ppf (m, g) ->
Format.fprintf ppf "The gap of fitness %Ld is not between 0 and %Ld" g m)
Data_encoding.(obj2 (req "maximum" int64) (req "provided" int64))
(function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None)
(fun (m, g) -> Invalid_fitness_gap (m, g)) ;
register_error_kind
`Permanent
~id:"baking.invalid_block_signature"
~title:"Invalid block signature"
~description:"A block was not signed with the expected private key."
~pp:(fun ppf (block, pkh) ->
Format.fprintf
ppf
"Invalid signature for block %a. Expected: %a."
Block_hash.pp_short
block
Signature.Public_key_hash.pp_short
pkh)
Data_encoding.(
obj2
(req "block" Block_hash.encoding)
(req "expected" Signature.Public_key_hash.encoding))
(function
| Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None)
(fun (block, pkh) -> Invalid_block_signature (block, pkh)) ;
register_error_kind
`Permanent
~id:"baking.invalid_signature"
~title:"Invalid block signature"
~description:"The block's signature is invalid"
~pp:(fun ppf () -> Format.fprintf ppf "Invalid block signature")
Data_encoding.empty
(function Invalid_signature -> Some () | _ -> None)
(fun () -> Invalid_signature) ;
register_error_kind
`Permanent
~id:"baking.insufficient_proof_of_work"
~title:"Insufficient block proof-of-work stamp"
~description:"The block's proof-of-work stamp is insufficient"
~pp:(fun ppf () -> Format.fprintf ppf "Insufficient proof-of-work stamp")
Data_encoding.empty
(function Invalid_stamp -> Some () | _ -> None)
(fun () -> Invalid_stamp) ;
register_error_kind
`Permanent
~id:"baking.unexpected_endorsement"
~title:"Endorsement from unexpected delegate"
~description:
"The operation is signed by a delegate without endorsement rights."
~pp:(fun ppf () ->
Format.fprintf
ppf
"The endorsement is signed by a delegate without endorsement rights.")
Data_encoding.unit
(function Unexpected_endorsement -> Some () | _ -> None)
(fun () -> Unexpected_endorsement) ;
register_error_kind
`Permanent
~id:"baking.invalid_endorsement_slot"
~title:"Endorsement slot out of range"
~description:"The endorsement slot provided is negative or too high."
~pp:(fun ppf v ->
Format.fprintf
ppf
"Endorsement slot %d provided is negative or too high."
v)
Data_encoding.(obj1 (req "slot" uint16))
(function Invalid_endorsement_slot v -> Some v | _ -> None)
(fun v -> Invalid_endorsement_slot v) ;
register_error_kind
`Permanent
~id:"baking.unexpected_endorsement_slot"
~title:"Endorsement slot not the smallest possible"
~description:"The endorsement slot provided is not the smallest possible."
~pp:(fun ppf v ->
Format.fprintf
ppf
"Endorsement slot %d provided is not the smallest possible."
v)
Data_encoding.(obj1 (req "slot" uint16))
(function Unexpected_endorsement_slot v -> Some v | _ -> None)
(fun v -> Unexpected_endorsement_slot v)
(* The function implements the fast-path case in [minimal_time]. (See
[minimal_valid_time] for the definition of the fast-path.) *)
let minimal_time_fastpath_case minimal_block_delay pred_timestamp =
Timestamp.(pred_timestamp +? minimal_block_delay)
(* The function implements the slow-path case in [minimal_time]. (See
[minimal_valid_time] for the definition of the slow-path.) *)
let minimal_time_slowpath_case time_between_blocks priority pred_timestamp =
let rec cumsum_time_between_blocks acc durations p =
if Compare.Int32.( <= ) p 0l then ok acc
else
match durations with
| [] ->
cumsum_time_between_blocks acc [Period.one_minute] p
| [last] ->
Period.mult p last >>? fun period -> Timestamp.(acc +? period)
| first :: durations ->
Timestamp.(acc +? first)
>>? fun acc ->
let p = Int32.pred p in
cumsum_time_between_blocks acc durations p
in
cumsum_time_between_blocks
pred_timestamp
time_between_blocks
(Int32.succ priority)
let minimal_time constants ~priority pred_timestamp =
let priority = Int32.of_int priority in
if Compare.Int32.(priority = 0l) then
minimal_time_fastpath_case
constants.Constants.minimal_block_delay
pred_timestamp
else
minimal_time_slowpath_case
constants.time_between_blocks
priority
pred_timestamp
let earlier_predecessor_timestamp ctxt level =
let current = Level.current ctxt in
let current_timestamp = Timestamp.current ctxt in
let gap = Level.diff level current in
let step = Constants.minimal_block_delay ctxt in
if Compare.Int32.(gap < 1l) then
failwith "Baking.earlier_block_timestamp: past block."
else
Period.mult (Int32.pred gap) step
>>? fun delay -> Timestamp.(current_timestamp +? delay)
let check_timestamp c ~priority pred_timestamp =
minimal_time (Constants.parametric c) priority pred_timestamp
>>? fun minimal_time ->
let timestamp = Timestamp.current c in
record_trace
(Timestamp_too_early
{
minimal_time;
provided_time = timestamp;
priority;
endorsing_power_opt = None;
})
Timestamp.(timestamp -? minimal_time)
>>? fun _block_delay -> ok ()
type error += Incorrect_priority (* `Permanent *)
type error += Incorrect_number_of_endorsements (* `Permanent *)
let () =
register_error_kind
`Permanent
~id:"incorrect_priority"
~title:"Incorrect priority"
~description:"Block priority must be non-negative."
~pp:(fun ppf () ->
Format.fprintf ppf "The block priority must be non-negative.")
Data_encoding.unit
(function Incorrect_priority -> Some () | _ -> None)
(fun () -> Incorrect_priority)
let () =
let description =
"The number of endorsements must be non-negative and at most the \
endorsers_per_block constant."
in
register_error_kind
`Permanent
~id:"incorrect_number_of_endorsements"
~title:"Incorrect number of endorsements"
~description
~pp:(fun ppf () -> Format.fprintf ppf "%s" description)
Data_encoding.unit
(function Incorrect_number_of_endorsements -> Some () | _ -> None)
(fun () -> Incorrect_number_of_endorsements)
let rec reward_for_priority reward_per_prio prio =
match reward_per_prio with
| [] ->
(* Empty reward list in parameters means no rewards *)
Tez.zero
| [last] ->
last
| first :: rest ->
if Compare.Int.(prio <= 0) then first
else reward_for_priority rest (pred prio)
let baking_reward ctxt ~block_priority ~included_endorsements =
error_unless Compare.Int.(block_priority >= 0) Incorrect_priority
>>? fun () ->
error_unless
Compare.Int.(
included_endorsements >= 0
&& included_endorsements <= Constants.endorsers_per_block ctxt)
Incorrect_number_of_endorsements
>>? fun () ->
let reward_per_endorsement =
reward_for_priority
(Constants.baking_reward_per_endorsement ctxt)
block_priority
in
Tez.(reward_per_endorsement *? Int64.of_int included_endorsements)
let endorsing_reward ctxt ~block_priority num_slots =
error_unless Compare.Int.(block_priority >= 0) Incorrect_priority
>>? fun () ->
let reward_per_endorsement =
reward_for_priority (Constants.endorsement_reward ctxt) block_priority
in
Tez.(reward_per_endorsement *? Int64.of_int num_slots)
let baking_priorities c level =
let rec f priority =
Roll.baking_rights_owner c level ~priority
>|=? fun delegate -> LCons (delegate, fun () -> f (succ priority))
in
f 0
let endorsement_rights ctxt level =
fold_right_s
(fun slot acc ->
Roll.endorsement_rights_owner ctxt level ~slot
>|=? fun pk ->
let pkh = Signature.Public_key.hash pk in
let right =
match Signature.Public_key_hash.Map.find_opt pkh acc with
| None ->
(pk, [slot], false)
| Some (pk, slots, used) ->
(pk, slot :: slots, used)
in
Signature.Public_key_hash.Map.add pkh right acc)
(0 --> (Constants.endorsers_per_block ctxt - 1))
Signature.Public_key_hash.Map.empty
let[@coq_axiom_with_reason "gadt"] check_endorsement_rights ctxt chain_id ~slot
(op : Kind.endorsement Operation.t) =
if
Compare.Int.(slot < 0 (* should not happen because of binary format *))
|| Compare.Int.(slot >= Constants.endorsers_per_block ctxt)
then fail (Invalid_endorsement_slot slot)
else
let current_level = Level.current ctxt in
let (Single (Endorsement {level; _})) = op.protocol_data.contents in
Roll.endorsement_rights_owner ctxt (Level.from_raw ctxt level) ~slot
>>=? fun pk ->
let pkh = Signature.Public_key.hash pk in
match Operation.check_signature pk chain_id op with
| Error _ ->
fail Unexpected_endorsement
| Ok () -> (
( if Raw_level.(succ level = current_level.level) then
return (Alpha_context.allowed_endorsements ctxt)
else endorsement_rights ctxt (Level.from_raw ctxt level) )
>>=? fun endorsements ->
match Signature.Public_key_hash.Map.find_opt pkh endorsements with
| None ->
fail Unexpected_endorsement (* unexpected *)
| Some (_pk, slots, v) ->
error_unless
Compare.Int.(slot = List.hd slots)
(Unexpected_endorsement_slot slot)
>>?= fun () -> return (pkh, slots, v) )
let select_delegate delegate delegate_list max_priority =
let rec loop acc l n =
if Compare.Int.(n >= max_priority) then return (List.rev acc)
else
let (LCons (pk, t)) = l in
let acc =
if
Signature.Public_key_hash.equal
delegate
(Signature.Public_key.hash pk)
then n :: acc
else acc
in
t () >>=? fun t -> loop acc t (succ n)
in
loop [] delegate_list 0
let first_baking_priorities ctxt ?(max_priority = 32) delegate level =
baking_priorities ctxt level
>>=? fun delegate_list -> select_delegate delegate delegate_list max_priority
let check_hash hash stamp_threshold =
let bytes = Block_hash.to_bytes hash in
let word = TzEndian.get_int64 bytes 0 in
Compare.Uint64.(word <= stamp_threshold)
let check_header_proof_of_work_stamp shell contents stamp_threshold =
let hash =
Block_header.hash
{shell; protocol_data = {contents; signature = Signature.zero}}
in
check_hash hash stamp_threshold
let check_proof_of_work_stamp ctxt block =
let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in
if
check_header_proof_of_work_stamp
block.Block_header.shell
block.protocol_data.contents
proof_of_work_threshold
then ok_unit
else error Invalid_stamp
let check_signature block chain_id key =
let check_signature key
{Block_header.shell; protocol_data = {contents; signature}} =
let unsigned_header =
Data_encoding.Binary.to_bytes_exn
Block_header.unsigned_encoding
(shell, contents)
in
Signature.check
~watermark:(Block_header chain_id)
key
signature
unsigned_header
in
if check_signature key block then return_unit
else
fail
(Invalid_block_signature
(Block_header.hash block, Signature.Public_key.hash key))
let max_fitness_gap _ctxt = 1L
let check_fitness_gap ctxt (block : Block_header.t) =
let current_fitness = Fitness.current ctxt in
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
error (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
else ok_unit
(* The minimal threshold on the endorsing power for the fast-path case
is 60% of the maximal endorsing power. *)
let fastpath_endorsing_power_threshold maximal_endorsing_power =
3 * maximal_endorsing_power / 5
(* This function computes the minimal time at which a block is
valid. It distinguishes between the "fast-path" case, when the
priority is 0 and the endorsing power is at least 60% of the
maximal endorsing power, and the "slow-path" case, when this
condition is not satisfied. *)
let minimal_valid_time constants ~priority ~endorsing_power
~predecessor_timestamp =
if
Compare.Int.(priority = 0)
&& Compare.Int.(
endorsing_power
>= fastpath_endorsing_power_threshold
constants.Constants.endorsers_per_block)
then
minimal_time_fastpath_case
constants.minimal_block_delay
predecessor_timestamp
else
minimal_time_slowpath_case
constants.time_between_blocks
(Int32.of_int priority)
predecessor_timestamp
>>? fun minimal_time ->
let delay_per_missing_endorsement =
constants.Constants.delay_per_missing_endorsement
in
let missing_endorsements =
let minimal_required_endorsements =
constants.Constants.initial_endorsers
in
Compare.Int.max 0 (minimal_required_endorsements - endorsing_power)
in
Period.mult
(Int32.of_int missing_endorsements)
delay_per_missing_endorsement
>|? fun delay -> Time.add minimal_time (Period.to_seconds delay)