diff --git a/CHANGES.rst b/CHANGES.rst index e6e78c893e608bcdfd1a07e017e31dbf411206eb..366671b30584b6f13f72ce03dc7abd1b7446f9aa 100644 --- a/CHANGES.rst +++ b/CHANGES.rst @@ -37,6 +37,12 @@ Node - Added RPC ``POST /bls/check_proof`` to check a BLS proof. (MR :gl:`!17461`) +- Added RPC ``GET + /chains//delegators_contribution//``, which + provides a breakdown of all the contributions to the delegation + portion of the baking power of the baker for the given cycle. (MR + :gl:`!17406`) + Client ------ @@ -135,7 +141,7 @@ Smart Rollup node - Add a CLI argument ``--config-file`` to allow specifying a configuration file outside the data directory. (MR :gl:`!17225`) - + - Allow to provide a remote URL for downloading snapshots in commands ``snapshot info`` and ``snapshot import``. (MR :gl:`!17407`) diff --git a/src/lib_shell/chain_directory.ml b/src/lib_shell/chain_directory.ml index 5b6590d286f5f3fbffb0e60a5819bab6567ec6a2..5c8eee87d7560a18a29ed4606b689e2adb04c38a 100644 --- a/src/lib_shell/chain_directory.ml +++ b/src/lib_shell/chain_directory.ml @@ -110,6 +110,94 @@ let list_blocks chain_store ?(length = 1) ?min_date blocks = in return (List.rev blocks) +module Delegators_contribution_implem = struct + open Chain_services.Delegators_contribution_errors + + let context_and_plugin chain_store block_id = + let open Lwt_result_syntax in + let* block = + let*! block_opt = + Store.Chain.block_of_identifier_opt chain_store block_id + in + match block_opt with + | Some v -> return v + | None -> tzfail Cycle_too_far_in_past + in + let* (context : Context.t) = + let*! context_opt = Store.Block.context_opt chain_store block in + match context_opt with + | Some v -> return v + | None -> tzfail Cycle_too_far_in_past + in + let context_for_plugin = (Store.Block.shell_header block, context) in + let*! protocol_hash = Store.Block.protocol_hash_exn chain_store block in + let* delegators_contribution_plugin = + match Protocol_plugin.find_delegators_contribution protocol_hash with + | Some x -> return x + | None -> tzfail (Protocol_not_supported {protocol_hash}) + in + return (context_for_plugin, delegators_contribution_plugin) + + let rec delegated_breakdown_at_sampling chain_store ~cycle ~delegate_pkh block + = + let open Lwt_result_syntax in + let* context, (module Delegators_contribution_plugin) = + context_and_plugin chain_store block + in + let* output = + Delegators_contribution_plugin.delegated_breakdown_at_sampling + context + ~cycle + ~delegate_pkh + in + match output with + | `Ok v -> return v + | `Retry_at_level level -> + delegated_breakdown_at_sampling + chain_store + ~cycle + ~delegate_pkh + (`Level level) + | `Cycle_too_far_in_future -> tzfail Cycle_too_far_in_future + + let delegators_contribution chain_store cycle delegate_pkh () () = + let open Lwt_result_syntax in + let* { + min_delegated_amount; + min_delegated_level; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + } = + delegated_breakdown_at_sampling chain_store ~cycle ~delegate_pkh (`Head 0) + in + let* context, (module Delegators_contribution_plugin) = + context_and_plugin chain_store (`Level min_delegated_level) + in + let* { + total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } = + Delegators_contribution_plugin.min_delegated_breakdown + context + ~delegate_pkh + in + assert (Int64.equal min_delegated_amount total_delegated) ; + return + { + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + } +end + let register0 dir s f = dir := Tezos_rpc.Directory.register @@ -117,6 +205,13 @@ let register0 dir s f = (Tezos_rpc.Service.subst0 s) (fun chain p q -> f chain p q) +let register2 dir s f = + dir := + Tezos_rpc.Directory.register + !dir + (Tezos_rpc.Service.subst2 s) + (fun ((chain, x1), x2) p q -> f chain x1 x2 p q) + (* This RPC directory must be instantiated by the node itself. Indeed, only the node has access to some particular resources, such as the validator or some store internal values computed at runtime, that @@ -149,6 +244,10 @@ let rpc_directory_with_validator dir validator = | Ok chain_validator -> let*! ap = Chain_validator.active_peers_heads chain_validator in return ap) ; + register2 + dir + S.delegators_contribution + Delegators_contribution_implem.delegators_contribution ; (* invalid_blocks *) register0 dir S.Invalid_blocks.list (fun chain_store () () -> let convert (hash, {Store_types.level; errors}) = {hash; level; errors} in diff --git a/src/lib_shell_services/chain_services.ml b/src/lib_shell_services/chain_services.ml index bd7fa0747793e6561fb2fd29ff1531913c3cb6a2..3653556f1689314744a1f0275cc9d98b3a22a49d 100644 --- a/src/lib_shell_services/chain_services.ml +++ b/src/lib_shell_services/chain_services.ml @@ -103,6 +103,116 @@ let active_peers_info_encoding = let active_peers_heads_encoding = obj1 (req "active_peers_heads" (list active_peers_info_encoding)) +type delegators_contribution = { + own_delegated : int64; + delegators_contributions : (string * int64) list; + former_delegators_unstake_requests : int64; + overstaked : int64; + total_delegated_including_overdelegated : int64; + total_delegated_after_limits : int64; + overdelegated : int64; +} + +let delegators_contribution_encoding = + conv + (fun { + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + } -> + ( own_delegated, + delegators_contributions, + former_delegators_unstake_requests, + overstaked, + total_delegated_including_overdelegated, + total_delegated_after_limits, + overdelegated )) + (fun ( own_delegated, + delegators_contributions, + former_delegators_unstake_requests, + overstaked, + total_delegated_including_overdelegated, + total_delegated_after_limits, + overdelegated ) -> + { + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + }) + @@ obj7 + (req "own_delegated" int64) + (req + "external_delegators" + (list + (obj2 + (req "delegator_contract_hash" string) + (req "contribution" int64)))) + (req "former_delegators_unstake_requests" int64) + (req "overstaked" int64) + (req "total_delegated_including_overdelegated" int64) + (req "total_delegated_after_limits" int64) + (req "overdelegated" int64) + +module Delegators_contribution_errors = struct + type error += + | Cycle_too_far_in_future + | Cycle_too_far_in_past + | Protocol_not_supported of {protocol_hash : Protocol_hash.t} + + let () = + let open Data_encoding in + register_error_kind + `Temporary + ~id:"delegators_contribution.cycle_too_far_in_future" + ~title:"Cycle too far in future" + ~description: + "Requested cycle is too far in the future: its baking rights have not \ + been determined yet." + unit + (function Cycle_too_far_in_future -> Some () | _ -> None) + (function () -> Cycle_too_far_in_future) ; + register_error_kind + `Temporary + ~id:"delegators_contribution.cycle_too_far_in_past" + ~title:"Cycle too far in past" + ~description: + "The data needed for the computation is too far in the past: the node \ + no longer has the data (block or context) required to compute the \ + delegators' contribution. Either you are in rolling mode and didn't \ + keep enough cycles, or you recently imported a fresh snapshot, which \ + is missing the relevant contexts" + unit + (function Cycle_too_far_in_past -> Some () | _ -> None) + (function () -> Cycle_too_far_in_past) ; + register_error_kind + `Temporary + ~id:"delegators_contribution.protocol_not_supported" + ~title:"Protocol not supported by delegators_contribution" + ~description: + "This RPC call involves a protocol that does not support \ + delegators_contribution." + ~pp:(fun fmt protocol_hash -> + Format.fprintf + fmt + "This RPC call involves protocol %a which does not support \ + delegators_contribution." + Protocol_hash.pp + protocol_hash) + (obj1 (req "protocol_hash" Protocol_hash.encoding)) + (function + | Protocol_not_supported {protocol_hash} -> Some protocol_hash + | _ -> None) + (function protocol_hash -> Protocol_not_supported {protocol_hash}) +end + module S = struct let path : prefix Tezos_rpc.Path.context = Tezos_rpc.Path.open_root @@ -139,6 +249,17 @@ module S = struct ~output:active_peers_heads_encoding Tezos_rpc.Path.(path / "active_peers_heads") + let delegators_contribution = + Tezos_rpc.Service.get_service + ~description: + "A breakdown of all the contributions to the delegation portion of the \ + baking power of the given delegate for the given cycle." + ~query:Tezos_rpc.Query.empty + ~output:delegators_contribution_encoding + Tezos_rpc.Path.( + path / "delegators_contribution" /: Tezos_rpc.Arg.int32 + /: Signature.Public_key_hash.rpc_arg) + module Levels = struct let path = Tezos_rpc.Path.(path / "levels") diff --git a/src/lib_shell_services/chain_services.mli b/src/lib_shell_services/chain_services.mli index e369c33be276c0d7ef2909bdbf726d194fd99c87..a80fcec0e91d831543fbf600bd048a3a6ccfc8da 100644 --- a/src/lib_shell_services/chain_services.mli +++ b/src/lib_shell_services/chain_services.mli @@ -52,6 +52,23 @@ type active_peers_info = { block_level : Int32.t; } +type delegators_contribution = { + own_delegated : int64; + delegators_contributions : (string * int64) list; + former_delegators_unstake_requests : int64; + overstaked : int64; + total_delegated_including_overdelegated : int64; + total_delegated_after_limits : int64; + overdelegated : int64; +} + +module Delegators_contribution_errors : sig + type error += + | Cycle_too_far_in_future + | Cycle_too_far_in_past + | Protocol_not_supported of {protocol_hash : Protocol_hash.t} +end + val path : (unit, prefix) Tezos_rpc.Path.path open Tezos_rpc.Context @@ -139,6 +156,15 @@ module S : sig active_peers_info list ) Tezos_rpc.Service.t + val delegators_contribution : + ( [`GET], + prefix, + (prefix * int32) * Signature.public_key_hash, + unit, + unit, + delegators_contribution ) + Tezos_rpc.Service.t + module Levels : sig val checkpoint : ( [`GET], diff --git a/src/lib_validation/protocol_plugin.ml b/src/lib_validation/protocol_plugin.ml index b2f842aff4e3b8cd08df120ab4ec80698f2aba69..0cfb23c11a50d05301cde49d0e8ef472c7145fe1 100644 --- a/src/lib_validation/protocol_plugin.ml +++ b/src/lib_validation/protocol_plugin.ml @@ -297,3 +297,49 @@ let proto_with_validation_plugin ~block_hash protocol_hash = return (module No_plugin (Proto) : T)) in return (module Patch_T (Proto_with_plugin) : T) + +type delegated_breakdown_at_sampling = { + min_delegated_amount : int64; + min_delegated_level : int32; + overstaked : int64; + total_delegated_including_overdelegated : int64; + total_delegated_after_limits : int64; + overdelegated : int64; +} + +type min_delegated_breakdown = { + total_delegated : int64; + own_delegated : int64; + delegators_contributions : (string * int64) list; + former_delegators_unstake_requests : int64; +} + +module type DELEGATORS_CONTRIBUTION = sig + val hash : Protocol_hash.t + + val delegated_breakdown_at_sampling : + Tezos_base.Block_header.shell_header * Tezos_protocol_environment.Context.t -> + cycle:int32 -> + delegate_pkh:Signature.public_key_hash -> + [ `Ok of delegated_breakdown_at_sampling + | `Retry_at_level of int32 + | `Cycle_too_far_in_future ] + Error_monad.tzresult + Lwt.t + + val min_delegated_breakdown : + Block_header.shell_header * Tezos_protocol_environment.Context.t -> + delegate_pkh:Signature.public_key_hash -> + min_delegated_breakdown Error_monad.tzresult Lwt.t +end + +let delegators_contribution_table : + (module DELEGATORS_CONTRIBUTION) Protocol_hash.Table.t = + Protocol_hash.Table.create 5 + +let register_delegators_contribution (module M : DELEGATORS_CONTRIBUTION) = + assert (not (Protocol_hash.Table.mem delegators_contribution_table M.hash)) ; + Protocol_hash.Table.add delegators_contribution_table M.hash (module M) + +let find_delegators_contribution = + Protocol_hash.Table.find delegators_contribution_table diff --git a/src/lib_validation/protocol_plugin.mli b/src/lib_validation/protocol_plugin.mli index 8b28e18ada03ff34d518813dd05971575e65413e..2789495a0ed3efc46b4dfe2f6b4e84b25a7841e9 100644 --- a/src/lib_validation/protocol_plugin.mli +++ b/src/lib_validation/protocol_plugin.mli @@ -258,3 +258,132 @@ val find_http_cache_headers : (** Looks for a shell helpers plugin module for a specific protocol *) val find_shell_helpers : Protocol_hash.t -> (module SHELL_HELPERS) option + +(** The types below are used to implement the + {!Shell_services.Chain.S.delegators_contribution} RPC in + [src/lib_shell/chain_directory.ml]. *) + +(** Partial breakdown of delegated tez contribution to baking rights. + + Contains the data available from the context at the level when the + baking rights for the cycle of interest were sampled. In + particular, only the total sum [min_delegated_amount] is available + for the contributions from delegated balances of both the delegate + and its delegators; breaking it down further requires access to + the context at [min_delegated_level]. + + All int64 values are mutez amount. *) +type delegated_breakdown_at_sampling = { + min_delegated_amount : int64; + (** Sum of the contribution to the delegate's baking rights from + the delegated balances of the delegate and its (current and + former) delegators. Includes the delegate and current + delegators' spendable balances, frozen bonds, and unstake + requests associated with this delegate. Also includes + unstaked requests that belong to former delegators but are + still associated with this delegate. Excludes delegators' + lingering unstake requests associated with an older + delegate. *) + min_delegated_level : int32; + (** Level of min-delegated-in-current-cycle, whose context + contains the information needed to break down + [min_delegated_amount]. *) + overstaked : int64; + (** Tez that are part of external stakers' staked balances, but + contribute to the delegated portion of baking power because + of overstaking. *) + total_delegated_including_overdelegated : int64; + (** Total contribution to the delegated portion of baking power, + before computing overdelegation. + + Invariant: [total_delegated_including_overdelegated = + min_delegated_amount + overstaked] *) + total_delegated_after_limits : int64; + (** Actual total contribution to the delegated portion of baking + power, constrained by overdelegation. + + Invariant: [total_delegated_after_limits <= + total_delegated_including_overdelegated] *) + overdelegated : int64; + (** Amount that is delegated to the delegate but contributes + nothing to its baking power because of overdelegation. + + Invariant: [total_delegated_including_overdelegated = + total_delegated_after_limits + overdelegated] *) +} + +(** Breakdown of {!field-min_delegated_amount}. + + Invariant: + [total_delegated = own_delegated + + sum_amounts(delegators_contributions) + + former_delegators_unstake_requests] +*) +type min_delegated_breakdown = { + total_delegated : int64; + (** Sum of all contributions to the delegate's baking power from + delegated balances. Same as {!field-min_delegated_amount}. *) + own_delegated : int64; + (** Contribution from the delegate's own delegated + balance. Includes the delegate's spendable balance, frozen + bonds, and unstake requests associated with itself. Exclude + any unstake requests associated with an older delegate. *) + delegators_contributions : (string * int64) list; + (** Contract hash (pkh or KT) and contribution for each current + external delegator. Includes the delegator's spendable + balance, frozen bonds, and unstake requests associated with + the delegate. Exclude any unstake requests associated with + an older delegate. *) + former_delegators_unstake_requests : int64; + (** Sum of the unstake requests that belong to the delegate's + former delegators but are still associated with the + delegate. *) +} + +module type DELEGATORS_CONTRIBUTION = sig + val hash : Protocol_hash.t + + (** - Returns [`Ok delegated_breakdown_at_sampling] if the provided + context's current level is the level at which the baking rights + for [cycle] have been sampled. See + {!type-delegated_breakdown_at_sampling}. + + - Returns [`Cycle_too_far_in_future] if the sampling level for + [cycle] is higher than the context's current level. + + - Returns [`Retry_at_level retry_level] if the sampling level + for [cycle] is lower than the context's current level, + guaranteing that: + + [actual_sampling_level_for_cycle <= retry_level < current_level] + + This function should be called initially on the context of the + current head of the chain, then again on the context of + [retry_level] in the [`Retry_at_level] case. The inequality on + [retry_level] ensures that this will eventually return another + result than [`Retry_at_level], and that this will only return + [`Cycle_too_far_in_future] if the sampling level is higher than + the level of current head of the chain. *) + val delegated_breakdown_at_sampling : + Block_header.shell_header * Tezos_protocol_environment.Context.t -> + cycle:int32 -> + delegate_pkh:Signature.public_key_hash -> + [ `Ok of delegated_breakdown_at_sampling + | `Retry_at_level of int32 + | `Cycle_too_far_in_future ] + Error_monad.tzresult + Lwt.t + + (** When called on the context of {!field-min_delegated_level}, + returns the breakdown of {!field-min_delegated_amount}. See + {!type-min_delegated_breakdown}. *) + val min_delegated_breakdown : + Block_header.shell_header * Tezos_protocol_environment.Context.t -> + delegate_pkh:Signature.public_key_hash -> + min_delegated_breakdown Error_monad.tzresult Lwt.t +end + +val register_delegators_contribution : (module DELEGATORS_CONTRIBUTION) -> unit + +val find_delegators_contribution : + Protocol_hash.t -> (module DELEGATORS_CONTRIBUTION) option diff --git a/src/proto_021_PsQuebec/lib_plugin/contract_services.ml b/src/proto_021_PsQuebec/lib_plugin/contract_services.ml index 216c72be6ec23c41d76d83d0b20f09d6f9919157..6b9b7fe09c69e8c4e9109e56b6453bb65d24bc37 100644 --- a/src/proto_021_PsQuebec/lib_plugin/contract_services.ml +++ b/src/proto_021_PsQuebec/lib_plugin/contract_services.ml @@ -382,6 +382,27 @@ module S = struct end end +module Implem = struct + let unstake_requests ctxt contract = + let open Lwt_result_syntax in + let open Unstake_requests in + let open Unstake_requests.For_RPC in + let* result = + (* This function applies slashing to finalizable requests. *) + prepare_finalize_unstake ctxt contract + in + match result with + | None -> return_none + | Some {finalizable; unfinalizable} -> + let* unfinalizable = + (* Apply slashing to unfinalizable requests too. *) + apply_slash_to_unstaked_unfinalizable_stored_requests + ctxt + unfinalizable + in + return_some {finalizable; unfinalizable} +end + let register () = let open Lwt_result_syntax in register0 ~chunked:true S.list (fun ctxt () () -> diff --git a/src/proto_021_PsQuebec/lib_plugin/contract_services.mli b/src/proto_021_PsQuebec/lib_plugin/contract_services.mli index 70a5d42332a6256f8caa0a192caed94cd94ce538..a95787b3ed8056f65693a691745f69e2879d58f4 100644 --- a/src/proto_021_PsQuebec/lib_plugin/contract_services.mli +++ b/src/proto_021_PsQuebec/lib_plugin/contract_services.mli @@ -188,3 +188,16 @@ val single_sapling_get_diff : (Sapling.root * Sapling.diff) shell_tzresult Lwt.t val register : unit -> unit + +(** Functions used in the implementation of this file's RPCs, but also + useful elsewhere (as opposed to the functions above, which call + the RPCs). These functions are gathered in a separate module to + avoid naming conflicts. *) +module Implem : sig + val unstake_requests : + Alpha_context.t -> + Contract.t -> + Unstake_requests.prepared_finalize_unstake option + Environment.Error_monad.tzresult + Lwt.t +end diff --git a/src/proto_021_PsQuebec/lib_plugin/delegate_services.ml b/src/proto_021_PsQuebec/lib_plugin/delegate_services.ml index 7df778d3efb49e5a33cdbee1e9287883ba3739aa..f1dd8f01d634bdc16e9b3dbd8427b489853109e0 100644 --- a/src/proto_021_PsQuebec/lib_plugin/delegate_services.ml +++ b/src/proto_021_PsQuebec/lib_plugin/delegate_services.ml @@ -948,9 +948,11 @@ let contract_stake ctxt ~delegator_contract ~delegate = return @@ Some (delegator_pkh, staked_balance) else return_none +let delegators ctxt pkh = Delegate.delegated_contracts ctxt pkh + let stakers ctxt pkh = let open Lwt_result_syntax in - let*! delegators = Delegate.delegated_contracts ctxt pkh in + let*! delegators = delegators ctxt pkh in List.filter_map_es (fun delegator_contract -> contract_stake ctxt ~delegator_contract ~delegate:pkh) @@ -1105,7 +1107,7 @@ let f_baking_power ctxt pkh () () = let f_delegators ctxt pkh () () = let open Lwt_result_syntax in let* () = check_delegate_registered ctxt pkh in - let*! contracts = Delegate.delegated_contracts ctxt pkh in + let*! contracts = delegators ctxt pkh in return contracts let f_total_currently_staked ctxt = @@ -1188,7 +1190,7 @@ let info ctxt pkh = let* consensus_key = consensus_key ctxt pkh in (* Chunked RPCs *) let* stakers = stakers ctxt pkh in - let*! delegators = Delegate.delegated_contracts ctxt pkh in + let*! delegators = delegators ctxt pkh in return { (* General baking information *) @@ -1229,6 +1231,16 @@ let wrap_check_registered ~chunked s f = let* () = check_delegate_registered ctxt pkh in f ctxt pkh) +module Implem = struct + let check_delegate_registered = check_delegate_registered + + let total_delegated = total_delegated + + let own_delegated = own_delegated + + let delegators = delegators +end + let register () = let open Lwt_result_syntax in register0 ~chunked:true S.list_delegate (fun ctxt q () -> diff --git a/src/proto_021_PsQuebec/lib_plugin/delegate_services.mli b/src/proto_021_PsQuebec/lib_plugin/delegate_services.mli index dde556a498debb1cf97719d2bbda135c814706d5..1cf3bb64dea50a8073c6e943792887ef1f779528 100644 --- a/src/proto_021_PsQuebec/lib_plugin/delegate_services.mli +++ b/src/proto_021_PsQuebec/lib_plugin/delegate_services.mli @@ -198,9 +198,25 @@ val info : val register : unit -> unit -(** For RPC.ml *) - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/7369 *) - -val external_staked_and_delegated : - t -> public_key_hash -> Tez.t Environment.Error_monad.tzresult Lwt.t +(** Functions used in the implementation of this file's RPCs, but also + useful elsewhere (as opposed to the functions above, which call + the RPCs). These functions are gathered in a separate module to + avoid naming conflicts. *) +module Implem : sig + val check_delegate_registered : + Alpha_context.t -> + public_key_hash -> + unit Environment.Error_monad.tzresult Lwt.t + + val total_delegated : + Alpha_context.t -> + public_key_hash -> + Tez.t Environment.Error_monad.tzresult Lwt.t + + val own_delegated : + Alpha_context.t -> + public_key_hash -> + Tez.t Environment.Error_monad.tzresult Lwt.t + + val delegators : Alpha_context.t -> public_key_hash -> Contract.t list Lwt.t +end diff --git a/src/proto_021_PsQuebec/lib_plugin/delegators_contribution.ml b/src/proto_021_PsQuebec/lib_plugin/delegators_contribution.ml new file mode 100644 index 0000000000000000000000000000000000000000..75d2547c30dbd74c1c30182e3b89f22e45c98ebd --- /dev/null +++ b/src/proto_021_PsQuebec/lib_plugin/delegators_contribution.ml @@ -0,0 +1,316 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2025 Nomadic Labs *) +(* *) +(*****************************************************************************) + +open Protocol + +(* Cf {!Services_registration.rpc_init}. *) +let init_ctxt + ( (block_header : Block_header.shell_header), + (context : Environment.Context.t) ) = + let open Lwt_result_syntax in + let timestamp = block_header.timestamp in + let level = block_header.level in + let* ctxt, _, _ = + Alpha_context.prepare + ~level + ~predecessor_timestamp:timestamp + ~timestamp + context + in + return ctxt + +(* Checks whether [ctxt]'s current level is the level at which the + baking rights for [cycle] have been sampled, and if not, returns + information needed to find it. + + - Returns [`Already_at_sampling_level] if [ctxt]'s current level is + the sampling level for [cycle]. + + - Returns [`Cycle_too_far_in_future] if the sampling level for + [cycle] is higher than [ctxt]'s current level. + + - Returns [`Retry_at_level retry_level] if the sampling level for + [cycle] is lower than [ctxt]'s current level. [retry_level] is the + sampling level for [cycle] if it belongs to the current protocol; + otherwise it is the highest level of the previous protocol: indeed, + in that case we cannot determine the actual sampling level here, + since [blocks_per_cycle] may be different for ealier protocols. In + both cases, the following holds: + + [actual_sampling_level_for_cycle <= retry_level < current_level] + + (Here, the protocol that a level "belongs" to is the protocol + associated with its resulting context.) +*) +let find_sampling_level ctxt cycle = + let open Lwt_result_syntax in + let open Alpha_context in + let consensus_rights_delay = Constants.consensus_rights_delay ctxt in + let blocks_per_cycle = Constants.blocks_per_cycle ctxt in + let current_level = Level.current ctxt in + let current_cycle = Cycle.to_int32 current_level.cycle in + let current_raw = Raw_level.to_int32 current_level.level in + let sampling_level = + if Compare.Int32.(cycle <= Int32.of_int consensus_rights_delay) then + (* This means that rights for [cycle] have been initialized during migration from Genesis *) + 1l + else + let open Int32 in + let sampling_cycle = sub cycle (of_int (consensus_rights_delay + 1)) in + assert (Compare.Int32.(sampling_cycle >= 0l)) ; + let last_level_of_current_cycle = + add + (sub current_raw current_level.cycle_position) + (pred blocks_per_cycle) + in + add + last_level_of_current_cycle + (mul blocks_per_cycle (sub sampling_cycle current_cycle)) + in + if Compare.Int32.(current_raw = sampling_level) then + return `Already_at_sampling_level + else if Compare.Int32.(current_raw < sampling_level) then + return `Cycle_too_far_in_future + else + let* first_level = First_level_of_protocol.get ctxt in + let first_level = Raw_level.to_int32 first_level in + if Compare.Int32.(first_level <= sampling_level) then + return (`Retry_at_level sampling_level) + else ( + assert (Compare.Int32.(first_level >= 1l)) ; + return (`Retry_at_level (Int32.pred first_level))) + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +type delegated_breakdown_at_sampling = { + min_delegated_amount : int64; + min_delegated_level : int32; + overstaked : int64; + total_delegated_including_overdelegated : int64; + total_delegated_after_limits : int64; + overdelegated : int64; +} + +(* Returns the overstaking- and overdelegation-related breakdown of + delegated contribution to baking rights as of [ctxt]. + + Intended to be called on the [ctxt] that corresponds to the level + at which the protocol sampled the baking rights for the queried + cycle. + + Contributions from delegated balances of both the delegate and + delegators are totaled in [min_delegated_amount]; breaking them + down further requires accessing the context at + [min_delegated_level]. + + Mostly based on the implementation of + {!Stake_context.apply_limits}. *) +let delegated_breakdown_from_sampling_level_ctxt ctxt pkh = + let open Lwt_result_syntax in + let* () = Delegate_services.Implem.check_delegate_registered ctxt pkh in + let raw_ctxt = Alpha_context.Internal_for_tests.to_raw ctxt in + let* staking_balance = Stake_storage.get_full_staking_balance raw_ctxt pkh in + let* staking_parameters = + Delegate_staking_parameters.of_delegate raw_ctxt pkh + in + let current_level = Raw_context.current_level raw_ctxt in + let cycle_eras = Raw_context.cycle_eras raw_ctxt in + let own_frozen = Full_staking_balance_repr.own_frozen staking_balance in + let staked_frozen = Full_staking_balance_repr.staked_frozen staking_balance in + let allowed_staked_frozen = + Full_staking_balance_repr.allowed_staked_frozen + ~adaptive_issuance_global_limit_of_staking_over_baking: + (Constants_storage.adaptive_issuance_global_limit_of_staking_over_baking + raw_ctxt) + ~delegate_limit_of_staking_over_baking_millionth: + staking_parameters + .Staking_parameters_repr.limit_of_staking_over_baking_millionth + staking_balance + in + let min_delegated_amount, min_delegated_level = + Full_staking_balance_repr.Internal_for_tests_and_RPCs + .min_delegated_and_level + ~cycle_eras + ~current_level + staking_balance + in + let limit_of_delegation_over_baking = + Int64.of_int (Constants_storage.limit_of_delegation_over_baking raw_ctxt) + in + let*? overstaked = Tez_repr.(staked_frozen -? allowed_staked_frozen) in + let*? total_delegated_including_overdelegated = + Tez_repr.(min_delegated_amount +? overstaked) + in + let total_delegated_after_limits = + match Tez_repr.(own_frozen *? limit_of_delegation_over_baking) with + | Ok max_allowed_delegated -> + Tez_repr.min + max_allowed_delegated + total_delegated_including_overdelegated + | Error _max_allowed_delegated_overflows -> + total_delegated_including_overdelegated + in + let total_delegated_including_overdelegated = + Tez_repr.to_mutez total_delegated_including_overdelegated + in + let total_delegated_after_limits = + Tez_repr.to_mutez total_delegated_after_limits + in + let overdelegated = + Int64.sub + total_delegated_including_overdelegated + total_delegated_after_limits + in + return + { + min_delegated_amount = Tez_repr.to_mutez min_delegated_amount; + min_delegated_level = Raw_level_repr.to_int32 min_delegated_level.level; + overstaked = Tez_repr.to_mutez overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + } + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +let delegated_breakdown_at_sampling context ~cycle ~delegate_pkh = + let open Lwt_result_syntax in + let* ctxt = init_ctxt context in + let* sampling_level = find_sampling_level ctxt cycle in + match sampling_level with + | `Already_at_sampling_level -> + let* breakdown = + delegated_breakdown_from_sampling_level_ctxt ctxt delegate_pkh + in + return (`Ok breakdown) + | (`Retry_at_level _ | `Cycle_too_far_in_future) as x -> return x + +(* Computes [delegator]'s delegated contribution to its current + delegate. + + It is equal to [delegator]'s delegated_balance (that is, its full + balance minus its staked balance) minus the amounts in any unstaked + requests that [delegator] might still have associated with older + delegates. + + Precondition: [delegate_pkh] is [delegator]'s current delegate + (checked by the function). *) +let delegator_contribution ctxt ~delegate_pkh delegator = + let open Lwt_result_syntax in + let* current_delegate = Alpha_context.Contract.Delegate.find ctxt delegator in + assert ( + match current_delegate with + | None -> false + | Some current_delegate -> + Signature.Public_key_hash.(current_delegate = delegate_pkh)) ; + let* full_balance = + Alpha_context.Contract.For_RPC.get_full_balance ctxt delegator + in + let* staked_balance_opt = + Alpha_context.Contract.For_RPC.get_staked_balance ctxt delegator + in + let staked_balance = + Option.value staked_balance_opt ~default:Alpha_context.Tez.zero + in + let* unstake_requests = + Contract_services.Implem.unstake_requests ctxt delegator + in + let*? unstaked_counting_for_former_delegates = + let open Result_syntax in + match unstake_requests with + | None -> return Alpha_context.Tez.zero + | Some {finalizable; unfinalizable} -> + let* finalizable_sum = + List.fold_left_e + (fun acc (request_delegate, _cycle, (amount : Alpha_context.Tez.t)) -> + if Signature.Public_key_hash.(request_delegate <> delegate_pkh) + then Alpha_context.Tez.(acc +? amount) + else return acc) + Alpha_context.Tez.zero + finalizable + in + let* unfinalizable_sum = + if Signature.Public_key_hash.(unfinalizable.delegate <> delegate_pkh) + then + List.fold_left_e + (fun acc (_cycle, amount) -> Alpha_context.Tez.(acc +? amount)) + Alpha_context.Tez.zero + unfinalizable.requests + else return Alpha_context.Tez.zero + in + Alpha_context.Tez.(finalizable_sum +? unfinalizable_sum) + in + let*? delegated_balance = + Alpha_context.Tez.(full_balance -? staked_balance) + in + let*? delegated_contribution_to_delegate_pkh = + Alpha_context.Tez.( + delegated_balance -? unstaked_counting_for_former_delegates) + in + return + ( Format.asprintf "%a" Alpha_context.Contract.pp delegator, + Alpha_context.Tez.to_mutez delegated_contribution_to_delegate_pkh ) + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +type min_delegated_breakdown = { + total_delegated : int64; + own_delegated : int64; + delegators_contributions : (string * int64) list; + former_delegators_unstake_requests : int64; +} + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +let min_delegated_breakdown context ~delegate_pkh = + let open Lwt_result_syntax in + let open Alpha_context in + let* ctxt = init_ctxt context in + let* total_delegated = + Delegate_services.Implem.total_delegated ctxt delegate_pkh + in + let total_delegated = Tez.to_mutez total_delegated in + let* own_delegated = + Delegate_services.Implem.own_delegated ctxt delegate_pkh + in + let own_delegated = Tez.to_mutez own_delegated in + let*! delegators = Delegate_services.Implem.delegators ctxt delegate_pkh in + let external_delegators = + List.filter + (function + | Contract.Implicit pkh -> + Signature.Public_key_hash.(pkh <> delegate_pkh) + | Originated _ -> true) + delegators + in + let* delegators_contributions = + List.map_es (delegator_contribution ctxt ~delegate_pkh) external_delegators + in + let total_external_delegators = + List.fold_left + (fun acc (_delegator_str, amount) -> Int64.add acc amount) + 0L + delegators_contributions + in + let former_delegators_unstake_requests = + Int64.(sub (sub total_delegated own_delegated) total_external_delegators) + in + return + { + total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } + +let wrap_tzresult_lwt x = + let open Lwt_syntax in + let* result = x in + return (Environment.wrap_tzresult result) + +let delegated_breakdown_at_sampling context ~cycle ~delegate_pkh = + delegated_breakdown_at_sampling context ~cycle ~delegate_pkh + |> wrap_tzresult_lwt + +let min_delegated_breakdown context ~delegate_pkh = + min_delegated_breakdown context ~delegate_pkh |> wrap_tzresult_lwt diff --git a/src/proto_021_PsQuebec/lib_plugin/delegators_contribution.mli b/src/proto_021_PsQuebec/lib_plugin/delegators_contribution.mli new file mode 100644 index 0000000000000000000000000000000000000000..3b2a363008b273d5677e97d06e9db9601463624a --- /dev/null +++ b/src/proto_021_PsQuebec/lib_plugin/delegators_contribution.mli @@ -0,0 +1,45 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2025 Nomadic Labs *) +(* *) +(*****************************************************************************) + +(** Protocol-dependent helpers for the delegators_contribution RPC, + which is defined in [src/lib_shell_services/chain_services.ml] and + implemented in [src/lib_shell/chain_directory.ml]. + + See [src/lib_validation/protocol_plugin.mli] for the descriptions of + the types and functions below. +*) + +type delegated_breakdown_at_sampling = { + min_delegated_amount : int64; + min_delegated_level : int32; + overstaked : int64; + total_delegated_including_overdelegated : int64; + total_delegated_after_limits : int64; + overdelegated : int64; +} + +val delegated_breakdown_at_sampling : + Block_header.shell_header * Environment.Context.t -> + cycle:int32 -> + delegate_pkh:Environment.Signature.public_key_hash -> + [ `Ok of delegated_breakdown_at_sampling + | `Retry_at_level of int32 + | `Cycle_too_far_in_future ] + Environment.Error_monad.shell_tzresult + Lwt.t + +type min_delegated_breakdown = { + total_delegated : int64; + own_delegated : int64; + delegators_contributions : (string * int64) list; + former_delegators_unstake_requests : int64; +} + +val min_delegated_breakdown : + Block_header.shell_header * Environment.Context.t -> + delegate_pkh:Environment.Signature.public_key_hash -> + min_delegated_breakdown Environment.Error_monad.shell_tzresult Lwt.t diff --git a/src/proto_021_PsQuebec/lib_plugin/plugin_registerer.ml b/src/proto_021_PsQuebec/lib_plugin/plugin_registerer.ml index 366c85d6c1a8f1e39d73c492876d0b8f0207bf60..0a85726a692ca4637eedacd7c64b12d90d08ac13 100644 --- a/src/proto_021_PsQuebec/lib_plugin/plugin_registerer.ml +++ b/src/proto_021_PsQuebec/lib_plugin/plugin_registerer.ml @@ -53,3 +53,69 @@ let () = Protocol_plugin.register_http_cache_headers_plugin (module Http_cache_headers) let () = Protocol_plugin.register_shell_helpers (module Shell_helpers) + +module Delegators_contribution_plugin = struct + let hash = Registerer.Registered.hash + + let convert_pkh : + Tezos_crypto.Signature.public_key_hash -> + Tezos_crypto__.Signature_v1.public_key_hash = function + | Ed25519 x -> Ed25519 x + | Secp256k1 x -> Secp256k1 x + | P256 x -> P256 x + | Bls x -> Bls x + + let delegated_breakdown_at_sampling context ~cycle ~delegate_pkh = + let open Lwt_result_syntax in + let* output = + Delegators_contribution.delegated_breakdown_at_sampling + context + ~cycle + ~delegate_pkh:(convert_pkh delegate_pkh) + in + match output with + | `Ok + { + min_delegated_amount; + min_delegated_level; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + } -> + return + (`Ok + { + Protocol_plugin.min_delegated_amount; + min_delegated_level; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + }) + | (`Retry_at_level _ | `Cycle_too_far_in_future) as x -> return x + + let min_delegated_breakdown context ~delegate_pkh = + let open Lwt_result_syntax in + let* { + total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } = + Delegators_contribution.min_delegated_breakdown + context + ~delegate_pkh:(convert_pkh delegate_pkh) + in + return + { + Protocol_plugin.total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } +end + +let () = + Protocol_plugin.register_delegators_contribution + (module Delegators_contribution_plugin) diff --git a/src/proto_022_PsRiotum/lib_plugin/contract_services.ml b/src/proto_022_PsRiotum/lib_plugin/contract_services.ml index 6970215343b2159e9c45671bb0060561ee80e9f3..44b37e911a0681136f4c55eae94bae8b29513015 100644 --- a/src/proto_022_PsRiotum/lib_plugin/contract_services.ml +++ b/src/proto_022_PsRiotum/lib_plugin/contract_services.ml @@ -383,6 +383,26 @@ module S = struct end end +module Implem = struct + let unstake_requests ctxt contract = + let open Lwt_result_syntax in + let open Unstake_requests.For_RPC in + let* result = + (* This function applies slashing to finalizable requests. *) + prepare_finalize_unstake ctxt contract + in + match result with + | None -> return_none + | Some {finalizable; unfinalizable} -> + let* unfinalizable = + (* Apply slashing to unfinalizable requests too. *) + apply_slash_to_unstaked_unfinalizable_stored_requests + ctxt + unfinalizable + in + return_some {finalizable; unfinalizable} +end + let register () = let open Lwt_result_syntax in register0 ~chunked:true S.list (fun ctxt () () -> @@ -521,17 +541,7 @@ let register () = Contract.For_RPC.get_unstaked_finalizable_balance ; register_field ~chunked:false S.full_balance Contract.For_RPC.get_full_balance ; register1 ~chunked:false S.unstake_requests (fun ctxt contract () () -> - let open Unstake_requests.For_RPC in - let* result = prepare_finalize_unstake ctxt contract in - match result with - | None -> return_none - | Some {finalizable; unfinalizable} -> - let* unfinalizable = - apply_slash_to_unstaked_unfinalizable_stored_requests - ctxt - unfinalizable - in - return_some {finalizable; unfinalizable}) ; + Implem.unstake_requests ctxt contract) ; opt_register1 ~chunked:false S.manager_key (fun ctxt contract () () -> match contract with | Originated _ -> return_none diff --git a/src/proto_022_PsRiotum/lib_plugin/contract_services.mli b/src/proto_022_PsRiotum/lib_plugin/contract_services.mli index caaccc2aac59937db5c6cf3a09e8ccb072914a5d..f454a4e8604dadfffa03ddef3c5dc041c9a6e9d8 100644 --- a/src/proto_022_PsRiotum/lib_plugin/contract_services.mli +++ b/src/proto_022_PsRiotum/lib_plugin/contract_services.mli @@ -188,3 +188,16 @@ val single_sapling_get_diff : (Sapling.root * Sapling.diff) shell_tzresult Lwt.t val register : unit -> unit + +(** Functions used in the implementation of this file's RPCs, but also + useful elsewhere (as opposed to the functions above, which call + the RPCs). These functions are gathered in a separate module to + avoid naming conflicts. *) +module Implem : sig + val unstake_requests : + Alpha_context.t -> + Contract.t -> + Unstake_requests.For_RPC.prepared_finalize_unstake option + Environment.Error_monad.tzresult + Lwt.t +end diff --git a/src/proto_022_PsRiotum/lib_plugin/delegate_services.ml b/src/proto_022_PsRiotum/lib_plugin/delegate_services.ml index f44a88bd99114b0cf9b23c770277db469263b5a9..32da65c616d305112753e6afba200f83470051c1 100644 --- a/src/proto_022_PsRiotum/lib_plugin/delegate_services.ml +++ b/src/proto_022_PsRiotum/lib_plugin/delegate_services.ml @@ -1026,9 +1026,11 @@ let contract_stake ctxt ~delegator_contract ~delegate = return @@ Some (delegator_pkh, staked_balance) else return_none +let delegators ctxt pkh = Delegate.delegated_contracts ctxt pkh + let stakers ctxt pkh = let open Lwt_result_syntax in - let*! delegators = Delegate.delegated_contracts ctxt pkh in + let*! delegators = delegators ctxt pkh in List.filter_map_es (fun delegator_contract -> contract_stake ctxt ~delegator_contract ~delegate:pkh) @@ -1070,26 +1072,12 @@ let own_staked ctxt pkh = in return (Option.value own_staked_opt ~default:Tez.zero) -let unstake_requests ctxt pkh = - let open Lwt_result_syntax in - let open Unstake_requests.For_RPC in - let* result = - (* This function applies slashing to finalizable requests. *) - prepare_finalize_unstake ctxt pkh - in - match result with - | None -> return_none - | Some {finalizable; unfinalizable} -> - let* unfinalizable = - (* Apply slashing to unfinalizable requests too. *) - apply_slash_to_unstaked_unfinalizable_stored_requests ctxt unfinalizable - in - return_some {finalizable; unfinalizable} - let own_staked_and_delegated ctxt pkh = let open Lwt_result_syntax in let* own_full_balance = Delegate.For_RPC.full_balance ctxt pkh in - let* own_unstake_requests = unstake_requests ctxt (Implicit pkh) in + let* own_unstake_requests = + Contract_services.Implem.unstake_requests ctxt (Implicit pkh) + in let* own_unstaked_from_other_delegates = match own_unstake_requests with | None -> return Tez.zero @@ -1178,7 +1166,7 @@ let f_baking_power ctxt pkh () () = let f_delegators ctxt pkh () () = let open Lwt_result_syntax in let* () = check_delegate_registered ctxt pkh in - let*! contracts = Delegate.delegated_contracts ctxt pkh in + let*! contracts = delegators ctxt pkh in return contracts let f_total_currently_staked ctxt = @@ -1272,7 +1260,7 @@ let info ctxt pkh = let* consensus_key = consensus_key ctxt pkh in (* Chunked RPCs *) let* stakers = stakers ctxt pkh in - let*! delegators = Delegate.delegated_contracts ctxt pkh in + let*! delegators = delegators ctxt pkh in return { (* General baking information *) @@ -1314,6 +1302,16 @@ let wrap_check_registered ~chunked s f = let* () = check_delegate_registered ctxt pkh in f ctxt pkh) +module Implem = struct + let check_delegate_registered = check_delegate_registered + + let total_delegated = total_delegated + + let own_delegated = own_delegated + + let delegators = delegators +end + let register () = let open Lwt_result_syntax in register0 ~chunked:true S.list_delegate (fun ctxt q () -> diff --git a/src/proto_022_PsRiotum/lib_plugin/delegate_services.mli b/src/proto_022_PsRiotum/lib_plugin/delegate_services.mli index 2967d93fbfc6ee55e56a603d295dc1254e34ea63..50c033d51d05784d5c88c6f259a95f068dfa1bd6 100644 --- a/src/proto_022_PsRiotum/lib_plugin/delegate_services.mli +++ b/src/proto_022_PsRiotum/lib_plugin/delegate_services.mli @@ -204,9 +204,25 @@ val info : val register : unit -> unit -(** For RPC.ml *) - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/7369 *) - -val external_staked_and_delegated : - t -> public_key_hash -> Tez.t Environment.Error_monad.tzresult Lwt.t +(** Functions used in the implementation of this file's RPCs, but also + useful elsewhere (as opposed to the functions above, which call + the RPCs). These functions are gathered in a separate module to + avoid naming conflicts. *) +module Implem : sig + val check_delegate_registered : + Alpha_context.t -> + public_key_hash -> + unit Environment.Error_monad.tzresult Lwt.t + + val total_delegated : + Alpha_context.t -> + public_key_hash -> + Tez.t Environment.Error_monad.tzresult Lwt.t + + val own_delegated : + Alpha_context.t -> + public_key_hash -> + Tez.t Environment.Error_monad.tzresult Lwt.t + + val delegators : Alpha_context.t -> public_key_hash -> Contract.t list Lwt.t +end diff --git a/src/proto_022_PsRiotum/lib_plugin/delegators_contribution.ml b/src/proto_022_PsRiotum/lib_plugin/delegators_contribution.ml new file mode 100644 index 0000000000000000000000000000000000000000..75d2547c30dbd74c1c30182e3b89f22e45c98ebd --- /dev/null +++ b/src/proto_022_PsRiotum/lib_plugin/delegators_contribution.ml @@ -0,0 +1,316 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2025 Nomadic Labs *) +(* *) +(*****************************************************************************) + +open Protocol + +(* Cf {!Services_registration.rpc_init}. *) +let init_ctxt + ( (block_header : Block_header.shell_header), + (context : Environment.Context.t) ) = + let open Lwt_result_syntax in + let timestamp = block_header.timestamp in + let level = block_header.level in + let* ctxt, _, _ = + Alpha_context.prepare + ~level + ~predecessor_timestamp:timestamp + ~timestamp + context + in + return ctxt + +(* Checks whether [ctxt]'s current level is the level at which the + baking rights for [cycle] have been sampled, and if not, returns + information needed to find it. + + - Returns [`Already_at_sampling_level] if [ctxt]'s current level is + the sampling level for [cycle]. + + - Returns [`Cycle_too_far_in_future] if the sampling level for + [cycle] is higher than [ctxt]'s current level. + + - Returns [`Retry_at_level retry_level] if the sampling level for + [cycle] is lower than [ctxt]'s current level. [retry_level] is the + sampling level for [cycle] if it belongs to the current protocol; + otherwise it is the highest level of the previous protocol: indeed, + in that case we cannot determine the actual sampling level here, + since [blocks_per_cycle] may be different for ealier protocols. In + both cases, the following holds: + + [actual_sampling_level_for_cycle <= retry_level < current_level] + + (Here, the protocol that a level "belongs" to is the protocol + associated with its resulting context.) +*) +let find_sampling_level ctxt cycle = + let open Lwt_result_syntax in + let open Alpha_context in + let consensus_rights_delay = Constants.consensus_rights_delay ctxt in + let blocks_per_cycle = Constants.blocks_per_cycle ctxt in + let current_level = Level.current ctxt in + let current_cycle = Cycle.to_int32 current_level.cycle in + let current_raw = Raw_level.to_int32 current_level.level in + let sampling_level = + if Compare.Int32.(cycle <= Int32.of_int consensus_rights_delay) then + (* This means that rights for [cycle] have been initialized during migration from Genesis *) + 1l + else + let open Int32 in + let sampling_cycle = sub cycle (of_int (consensus_rights_delay + 1)) in + assert (Compare.Int32.(sampling_cycle >= 0l)) ; + let last_level_of_current_cycle = + add + (sub current_raw current_level.cycle_position) + (pred blocks_per_cycle) + in + add + last_level_of_current_cycle + (mul blocks_per_cycle (sub sampling_cycle current_cycle)) + in + if Compare.Int32.(current_raw = sampling_level) then + return `Already_at_sampling_level + else if Compare.Int32.(current_raw < sampling_level) then + return `Cycle_too_far_in_future + else + let* first_level = First_level_of_protocol.get ctxt in + let first_level = Raw_level.to_int32 first_level in + if Compare.Int32.(first_level <= sampling_level) then + return (`Retry_at_level sampling_level) + else ( + assert (Compare.Int32.(first_level >= 1l)) ; + return (`Retry_at_level (Int32.pred first_level))) + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +type delegated_breakdown_at_sampling = { + min_delegated_amount : int64; + min_delegated_level : int32; + overstaked : int64; + total_delegated_including_overdelegated : int64; + total_delegated_after_limits : int64; + overdelegated : int64; +} + +(* Returns the overstaking- and overdelegation-related breakdown of + delegated contribution to baking rights as of [ctxt]. + + Intended to be called on the [ctxt] that corresponds to the level + at which the protocol sampled the baking rights for the queried + cycle. + + Contributions from delegated balances of both the delegate and + delegators are totaled in [min_delegated_amount]; breaking them + down further requires accessing the context at + [min_delegated_level]. + + Mostly based on the implementation of + {!Stake_context.apply_limits}. *) +let delegated_breakdown_from_sampling_level_ctxt ctxt pkh = + let open Lwt_result_syntax in + let* () = Delegate_services.Implem.check_delegate_registered ctxt pkh in + let raw_ctxt = Alpha_context.Internal_for_tests.to_raw ctxt in + let* staking_balance = Stake_storage.get_full_staking_balance raw_ctxt pkh in + let* staking_parameters = + Delegate_staking_parameters.of_delegate raw_ctxt pkh + in + let current_level = Raw_context.current_level raw_ctxt in + let cycle_eras = Raw_context.cycle_eras raw_ctxt in + let own_frozen = Full_staking_balance_repr.own_frozen staking_balance in + let staked_frozen = Full_staking_balance_repr.staked_frozen staking_balance in + let allowed_staked_frozen = + Full_staking_balance_repr.allowed_staked_frozen + ~adaptive_issuance_global_limit_of_staking_over_baking: + (Constants_storage.adaptive_issuance_global_limit_of_staking_over_baking + raw_ctxt) + ~delegate_limit_of_staking_over_baking_millionth: + staking_parameters + .Staking_parameters_repr.limit_of_staking_over_baking_millionth + staking_balance + in + let min_delegated_amount, min_delegated_level = + Full_staking_balance_repr.Internal_for_tests_and_RPCs + .min_delegated_and_level + ~cycle_eras + ~current_level + staking_balance + in + let limit_of_delegation_over_baking = + Int64.of_int (Constants_storage.limit_of_delegation_over_baking raw_ctxt) + in + let*? overstaked = Tez_repr.(staked_frozen -? allowed_staked_frozen) in + let*? total_delegated_including_overdelegated = + Tez_repr.(min_delegated_amount +? overstaked) + in + let total_delegated_after_limits = + match Tez_repr.(own_frozen *? limit_of_delegation_over_baking) with + | Ok max_allowed_delegated -> + Tez_repr.min + max_allowed_delegated + total_delegated_including_overdelegated + | Error _max_allowed_delegated_overflows -> + total_delegated_including_overdelegated + in + let total_delegated_including_overdelegated = + Tez_repr.to_mutez total_delegated_including_overdelegated + in + let total_delegated_after_limits = + Tez_repr.to_mutez total_delegated_after_limits + in + let overdelegated = + Int64.sub + total_delegated_including_overdelegated + total_delegated_after_limits + in + return + { + min_delegated_amount = Tez_repr.to_mutez min_delegated_amount; + min_delegated_level = Raw_level_repr.to_int32 min_delegated_level.level; + overstaked = Tez_repr.to_mutez overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + } + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +let delegated_breakdown_at_sampling context ~cycle ~delegate_pkh = + let open Lwt_result_syntax in + let* ctxt = init_ctxt context in + let* sampling_level = find_sampling_level ctxt cycle in + match sampling_level with + | `Already_at_sampling_level -> + let* breakdown = + delegated_breakdown_from_sampling_level_ctxt ctxt delegate_pkh + in + return (`Ok breakdown) + | (`Retry_at_level _ | `Cycle_too_far_in_future) as x -> return x + +(* Computes [delegator]'s delegated contribution to its current + delegate. + + It is equal to [delegator]'s delegated_balance (that is, its full + balance minus its staked balance) minus the amounts in any unstaked + requests that [delegator] might still have associated with older + delegates. + + Precondition: [delegate_pkh] is [delegator]'s current delegate + (checked by the function). *) +let delegator_contribution ctxt ~delegate_pkh delegator = + let open Lwt_result_syntax in + let* current_delegate = Alpha_context.Contract.Delegate.find ctxt delegator in + assert ( + match current_delegate with + | None -> false + | Some current_delegate -> + Signature.Public_key_hash.(current_delegate = delegate_pkh)) ; + let* full_balance = + Alpha_context.Contract.For_RPC.get_full_balance ctxt delegator + in + let* staked_balance_opt = + Alpha_context.Contract.For_RPC.get_staked_balance ctxt delegator + in + let staked_balance = + Option.value staked_balance_opt ~default:Alpha_context.Tez.zero + in + let* unstake_requests = + Contract_services.Implem.unstake_requests ctxt delegator + in + let*? unstaked_counting_for_former_delegates = + let open Result_syntax in + match unstake_requests with + | None -> return Alpha_context.Tez.zero + | Some {finalizable; unfinalizable} -> + let* finalizable_sum = + List.fold_left_e + (fun acc (request_delegate, _cycle, (amount : Alpha_context.Tez.t)) -> + if Signature.Public_key_hash.(request_delegate <> delegate_pkh) + then Alpha_context.Tez.(acc +? amount) + else return acc) + Alpha_context.Tez.zero + finalizable + in + let* unfinalizable_sum = + if Signature.Public_key_hash.(unfinalizable.delegate <> delegate_pkh) + then + List.fold_left_e + (fun acc (_cycle, amount) -> Alpha_context.Tez.(acc +? amount)) + Alpha_context.Tez.zero + unfinalizable.requests + else return Alpha_context.Tez.zero + in + Alpha_context.Tez.(finalizable_sum +? unfinalizable_sum) + in + let*? delegated_balance = + Alpha_context.Tez.(full_balance -? staked_balance) + in + let*? delegated_contribution_to_delegate_pkh = + Alpha_context.Tez.( + delegated_balance -? unstaked_counting_for_former_delegates) + in + return + ( Format.asprintf "%a" Alpha_context.Contract.pp delegator, + Alpha_context.Tez.to_mutez delegated_contribution_to_delegate_pkh ) + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +type min_delegated_breakdown = { + total_delegated : int64; + own_delegated : int64; + delegators_contributions : (string * int64) list; + former_delegators_unstake_requests : int64; +} + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +let min_delegated_breakdown context ~delegate_pkh = + let open Lwt_result_syntax in + let open Alpha_context in + let* ctxt = init_ctxt context in + let* total_delegated = + Delegate_services.Implem.total_delegated ctxt delegate_pkh + in + let total_delegated = Tez.to_mutez total_delegated in + let* own_delegated = + Delegate_services.Implem.own_delegated ctxt delegate_pkh + in + let own_delegated = Tez.to_mutez own_delegated in + let*! delegators = Delegate_services.Implem.delegators ctxt delegate_pkh in + let external_delegators = + List.filter + (function + | Contract.Implicit pkh -> + Signature.Public_key_hash.(pkh <> delegate_pkh) + | Originated _ -> true) + delegators + in + let* delegators_contributions = + List.map_es (delegator_contribution ctxt ~delegate_pkh) external_delegators + in + let total_external_delegators = + List.fold_left + (fun acc (_delegator_str, amount) -> Int64.add acc amount) + 0L + delegators_contributions + in + let former_delegators_unstake_requests = + Int64.(sub (sub total_delegated own_delegated) total_external_delegators) + in + return + { + total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } + +let wrap_tzresult_lwt x = + let open Lwt_syntax in + let* result = x in + return (Environment.wrap_tzresult result) + +let delegated_breakdown_at_sampling context ~cycle ~delegate_pkh = + delegated_breakdown_at_sampling context ~cycle ~delegate_pkh + |> wrap_tzresult_lwt + +let min_delegated_breakdown context ~delegate_pkh = + min_delegated_breakdown context ~delegate_pkh |> wrap_tzresult_lwt diff --git a/src/proto_022_PsRiotum/lib_plugin/delegators_contribution.mli b/src/proto_022_PsRiotum/lib_plugin/delegators_contribution.mli new file mode 100644 index 0000000000000000000000000000000000000000..3b2a363008b273d5677e97d06e9db9601463624a --- /dev/null +++ b/src/proto_022_PsRiotum/lib_plugin/delegators_contribution.mli @@ -0,0 +1,45 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2025 Nomadic Labs *) +(* *) +(*****************************************************************************) + +(** Protocol-dependent helpers for the delegators_contribution RPC, + which is defined in [src/lib_shell_services/chain_services.ml] and + implemented in [src/lib_shell/chain_directory.ml]. + + See [src/lib_validation/protocol_plugin.mli] for the descriptions of + the types and functions below. +*) + +type delegated_breakdown_at_sampling = { + min_delegated_amount : int64; + min_delegated_level : int32; + overstaked : int64; + total_delegated_including_overdelegated : int64; + total_delegated_after_limits : int64; + overdelegated : int64; +} + +val delegated_breakdown_at_sampling : + Block_header.shell_header * Environment.Context.t -> + cycle:int32 -> + delegate_pkh:Environment.Signature.public_key_hash -> + [ `Ok of delegated_breakdown_at_sampling + | `Retry_at_level of int32 + | `Cycle_too_far_in_future ] + Environment.Error_monad.shell_tzresult + Lwt.t + +type min_delegated_breakdown = { + total_delegated : int64; + own_delegated : int64; + delegators_contributions : (string * int64) list; + former_delegators_unstake_requests : int64; +} + +val min_delegated_breakdown : + Block_header.shell_header * Environment.Context.t -> + delegate_pkh:Environment.Signature.public_key_hash -> + min_delegated_breakdown Environment.Error_monad.shell_tzresult Lwt.t diff --git a/src/proto_022_PsRiotum/lib_plugin/plugin_registerer.ml b/src/proto_022_PsRiotum/lib_plugin/plugin_registerer.ml index 096a5f55d284741e6acc783b191388dc5782f565..167c7eeaf0d5eef8aea09e33e79a903ee9fa49c3 100644 --- a/src/proto_022_PsRiotum/lib_plugin/plugin_registerer.ml +++ b/src/proto_022_PsRiotum/lib_plugin/plugin_registerer.ml @@ -44,3 +44,70 @@ let () = Protocol_plugin.register_http_cache_headers_plugin (module Http_cache_headers) let () = Protocol_plugin.register_shell_helpers (module Shell_helpers) + +module Delegators_contribution_plugin = struct + let hash = Registerer.Registered.hash + + let convert_pkh : + Tezos_crypto.Signature.public_key_hash -> + Tezos_crypto__.Signature_v1.public_key_hash = function + | Ed25519 x -> Ed25519 x + | Secp256k1 x -> Secp256k1 x + | P256 x -> P256 x + | Bls x -> Bls x + + let delegated_breakdown_at_sampling context ~cycle ~delegate_pkh = + let open Lwt_result_syntax in + let* output = + Delegators_contribution.delegated_breakdown_at_sampling + context + ~cycle + ~delegate_pkh:(convert_pkh delegate_pkh) + in + match output with + | `Ok + { + min_delegated_amount; + min_delegated_level; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + } -> + return + (`Ok + { + Protocol_plugin.min_delegated_amount; + min_delegated_level; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + }) + | (`Retry_at_level _ | `Cycle_too_far_in_future) as x -> return x + + let min_delegated_breakdown context ~delegate_pkh = + let open Lwt_result_syntax in + let* { + total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } = + Delegators_contribution.min_delegated_breakdown + context + ~delegate_pkh:(convert_pkh delegate_pkh) + in + + return + { + Protocol_plugin.total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } +end + +let () = + Protocol_plugin.register_delegators_contribution + (module Delegators_contribution_plugin) diff --git a/src/proto_alpha/lib_plugin/contract_services.ml b/src/proto_alpha/lib_plugin/contract_services.ml index 6970215343b2159e9c45671bb0060561ee80e9f3..44b37e911a0681136f4c55eae94bae8b29513015 100644 --- a/src/proto_alpha/lib_plugin/contract_services.ml +++ b/src/proto_alpha/lib_plugin/contract_services.ml @@ -383,6 +383,26 @@ module S = struct end end +module Implem = struct + let unstake_requests ctxt contract = + let open Lwt_result_syntax in + let open Unstake_requests.For_RPC in + let* result = + (* This function applies slashing to finalizable requests. *) + prepare_finalize_unstake ctxt contract + in + match result with + | None -> return_none + | Some {finalizable; unfinalizable} -> + let* unfinalizable = + (* Apply slashing to unfinalizable requests too. *) + apply_slash_to_unstaked_unfinalizable_stored_requests + ctxt + unfinalizable + in + return_some {finalizable; unfinalizable} +end + let register () = let open Lwt_result_syntax in register0 ~chunked:true S.list (fun ctxt () () -> @@ -521,17 +541,7 @@ let register () = Contract.For_RPC.get_unstaked_finalizable_balance ; register_field ~chunked:false S.full_balance Contract.For_RPC.get_full_balance ; register1 ~chunked:false S.unstake_requests (fun ctxt contract () () -> - let open Unstake_requests.For_RPC in - let* result = prepare_finalize_unstake ctxt contract in - match result with - | None -> return_none - | Some {finalizable; unfinalizable} -> - let* unfinalizable = - apply_slash_to_unstaked_unfinalizable_stored_requests - ctxt - unfinalizable - in - return_some {finalizable; unfinalizable}) ; + Implem.unstake_requests ctxt contract) ; opt_register1 ~chunked:false S.manager_key (fun ctxt contract () () -> match contract with | Originated _ -> return_none diff --git a/src/proto_alpha/lib_plugin/contract_services.mli b/src/proto_alpha/lib_plugin/contract_services.mli index caaccc2aac59937db5c6cf3a09e8ccb072914a5d..f454a4e8604dadfffa03ddef3c5dc041c9a6e9d8 100644 --- a/src/proto_alpha/lib_plugin/contract_services.mli +++ b/src/proto_alpha/lib_plugin/contract_services.mli @@ -188,3 +188,16 @@ val single_sapling_get_diff : (Sapling.root * Sapling.diff) shell_tzresult Lwt.t val register : unit -> unit + +(** Functions used in the implementation of this file's RPCs, but also + useful elsewhere (as opposed to the functions above, which call + the RPCs). These functions are gathered in a separate module to + avoid naming conflicts. *) +module Implem : sig + val unstake_requests : + Alpha_context.t -> + Contract.t -> + Unstake_requests.For_RPC.prepared_finalize_unstake option + Environment.Error_monad.tzresult + Lwt.t +end diff --git a/src/proto_alpha/lib_plugin/delegate_services.ml b/src/proto_alpha/lib_plugin/delegate_services.ml index 4cf1206ebcadf6898dfca40d6f6d8492884b3e35..58de3d56479a4bc43cde01c3210d1d0f3a24501e 100644 --- a/src/proto_alpha/lib_plugin/delegate_services.ml +++ b/src/proto_alpha/lib_plugin/delegate_services.ml @@ -1109,9 +1109,11 @@ let contract_stake ctxt ~delegator_contract ~delegate = return @@ Some (delegator_pkh, staked_balance) else return_none +let delegators ctxt pkh = Delegate.delegated_contracts ctxt pkh + let stakers ctxt pkh = let open Lwt_result_syntax in - let*! delegators = Delegate.delegated_contracts ctxt pkh in + let*! delegators = delegators ctxt pkh in List.filter_map_es (fun delegator_contract -> contract_stake ctxt ~delegator_contract ~delegate:pkh) @@ -1153,26 +1155,12 @@ let own_staked ctxt pkh = in return (Option.value own_staked_opt ~default:Tez.zero) -let unstake_requests ctxt pkh = - let open Lwt_result_syntax in - let open Unstake_requests.For_RPC in - let* result = - (* This function applies slashing to finalizable requests. *) - prepare_finalize_unstake ctxt pkh - in - match result with - | None -> return_none - | Some {finalizable; unfinalizable} -> - let* unfinalizable = - (* Apply slashing to unfinalizable requests too. *) - apply_slash_to_unstaked_unfinalizable_stored_requests ctxt unfinalizable - in - return_some {finalizable; unfinalizable} - let own_staked_and_delegated ctxt pkh = let open Lwt_result_syntax in let* own_full_balance = Delegate.For_RPC.full_balance ctxt pkh in - let* own_unstake_requests = unstake_requests ctxt (Implicit pkh) in + let* own_unstake_requests = + Contract_services.Implem.unstake_requests ctxt (Implicit pkh) + in let* own_unstaked_from_other_delegates = match own_unstake_requests with | None -> return Tez.zero @@ -1261,7 +1249,7 @@ let f_baking_power ctxt pkh () () = let f_delegators ctxt pkh () () = let open Lwt_result_syntax in let* () = check_delegate_registered ctxt pkh in - let*! contracts = Delegate.delegated_contracts ctxt pkh in + let*! contracts = delegators ctxt pkh in return contracts let f_total_currently_staked ctxt = @@ -1356,7 +1344,7 @@ let info ctxt pkh = let* companion_key = companion_key ctxt pkh in (* Chunked RPCs *) let* stakers = stakers ctxt pkh in - let*! delegators = Delegate.delegated_contracts ctxt pkh in + let*! delegators = delegators ctxt pkh in return { (* General baking information *) @@ -1399,6 +1387,16 @@ let wrap_check_registered ~chunked s f = let* () = check_delegate_registered ctxt pkh in f ctxt pkh) +module Implem = struct + let check_delegate_registered = check_delegate_registered + + let total_delegated = total_delegated + + let own_delegated = own_delegated + + let delegators = delegators +end + let register () = let open Lwt_result_syntax in register0 ~chunked:true S.list_delegate (fun ctxt q () -> diff --git a/src/proto_alpha/lib_plugin/delegate_services.mli b/src/proto_alpha/lib_plugin/delegate_services.mli index 2f5e7d9dc8fbca05a982e33aa3da846c3f9f3e59..e5fb34a317371d25a87b83e05b672c9e7b4e8030 100644 --- a/src/proto_alpha/lib_plugin/delegate_services.mli +++ b/src/proto_alpha/lib_plugin/delegate_services.mli @@ -222,9 +222,25 @@ val info : val register : unit -> unit -(** For RPC.ml *) - -(* TODO: https://gitlab.com/tezos/tezos/-/issues/7369 *) - -val external_staked_and_delegated : - t -> public_key_hash -> Tez.t Environment.Error_monad.tzresult Lwt.t +(** Functions used in the implementation of this file's RPCs, but also + useful elsewhere (as opposed to the functions above, which call + the RPCs). These functions are gathered in a separate module to + avoid naming conflicts. *) +module Implem : sig + val check_delegate_registered : + Alpha_context.t -> + public_key_hash -> + unit Environment.Error_monad.tzresult Lwt.t + + val total_delegated : + Alpha_context.t -> + public_key_hash -> + Tez.t Environment.Error_monad.tzresult Lwt.t + + val own_delegated : + Alpha_context.t -> + public_key_hash -> + Tez.t Environment.Error_monad.tzresult Lwt.t + + val delegators : Alpha_context.t -> public_key_hash -> Contract.t list Lwt.t +end diff --git a/src/proto_alpha/lib_plugin/delegators_contribution.ml b/src/proto_alpha/lib_plugin/delegators_contribution.ml new file mode 100644 index 0000000000000000000000000000000000000000..75d2547c30dbd74c1c30182e3b89f22e45c98ebd --- /dev/null +++ b/src/proto_alpha/lib_plugin/delegators_contribution.ml @@ -0,0 +1,316 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2025 Nomadic Labs *) +(* *) +(*****************************************************************************) + +open Protocol + +(* Cf {!Services_registration.rpc_init}. *) +let init_ctxt + ( (block_header : Block_header.shell_header), + (context : Environment.Context.t) ) = + let open Lwt_result_syntax in + let timestamp = block_header.timestamp in + let level = block_header.level in + let* ctxt, _, _ = + Alpha_context.prepare + ~level + ~predecessor_timestamp:timestamp + ~timestamp + context + in + return ctxt + +(* Checks whether [ctxt]'s current level is the level at which the + baking rights for [cycle] have been sampled, and if not, returns + information needed to find it. + + - Returns [`Already_at_sampling_level] if [ctxt]'s current level is + the sampling level for [cycle]. + + - Returns [`Cycle_too_far_in_future] if the sampling level for + [cycle] is higher than [ctxt]'s current level. + + - Returns [`Retry_at_level retry_level] if the sampling level for + [cycle] is lower than [ctxt]'s current level. [retry_level] is the + sampling level for [cycle] if it belongs to the current protocol; + otherwise it is the highest level of the previous protocol: indeed, + in that case we cannot determine the actual sampling level here, + since [blocks_per_cycle] may be different for ealier protocols. In + both cases, the following holds: + + [actual_sampling_level_for_cycle <= retry_level < current_level] + + (Here, the protocol that a level "belongs" to is the protocol + associated with its resulting context.) +*) +let find_sampling_level ctxt cycle = + let open Lwt_result_syntax in + let open Alpha_context in + let consensus_rights_delay = Constants.consensus_rights_delay ctxt in + let blocks_per_cycle = Constants.blocks_per_cycle ctxt in + let current_level = Level.current ctxt in + let current_cycle = Cycle.to_int32 current_level.cycle in + let current_raw = Raw_level.to_int32 current_level.level in + let sampling_level = + if Compare.Int32.(cycle <= Int32.of_int consensus_rights_delay) then + (* This means that rights for [cycle] have been initialized during migration from Genesis *) + 1l + else + let open Int32 in + let sampling_cycle = sub cycle (of_int (consensus_rights_delay + 1)) in + assert (Compare.Int32.(sampling_cycle >= 0l)) ; + let last_level_of_current_cycle = + add + (sub current_raw current_level.cycle_position) + (pred blocks_per_cycle) + in + add + last_level_of_current_cycle + (mul blocks_per_cycle (sub sampling_cycle current_cycle)) + in + if Compare.Int32.(current_raw = sampling_level) then + return `Already_at_sampling_level + else if Compare.Int32.(current_raw < sampling_level) then + return `Cycle_too_far_in_future + else + let* first_level = First_level_of_protocol.get ctxt in + let first_level = Raw_level.to_int32 first_level in + if Compare.Int32.(first_level <= sampling_level) then + return (`Retry_at_level sampling_level) + else ( + assert (Compare.Int32.(first_level >= 1l)) ; + return (`Retry_at_level (Int32.pred first_level))) + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +type delegated_breakdown_at_sampling = { + min_delegated_amount : int64; + min_delegated_level : int32; + overstaked : int64; + total_delegated_including_overdelegated : int64; + total_delegated_after_limits : int64; + overdelegated : int64; +} + +(* Returns the overstaking- and overdelegation-related breakdown of + delegated contribution to baking rights as of [ctxt]. + + Intended to be called on the [ctxt] that corresponds to the level + at which the protocol sampled the baking rights for the queried + cycle. + + Contributions from delegated balances of both the delegate and + delegators are totaled in [min_delegated_amount]; breaking them + down further requires accessing the context at + [min_delegated_level]. + + Mostly based on the implementation of + {!Stake_context.apply_limits}. *) +let delegated_breakdown_from_sampling_level_ctxt ctxt pkh = + let open Lwt_result_syntax in + let* () = Delegate_services.Implem.check_delegate_registered ctxt pkh in + let raw_ctxt = Alpha_context.Internal_for_tests.to_raw ctxt in + let* staking_balance = Stake_storage.get_full_staking_balance raw_ctxt pkh in + let* staking_parameters = + Delegate_staking_parameters.of_delegate raw_ctxt pkh + in + let current_level = Raw_context.current_level raw_ctxt in + let cycle_eras = Raw_context.cycle_eras raw_ctxt in + let own_frozen = Full_staking_balance_repr.own_frozen staking_balance in + let staked_frozen = Full_staking_balance_repr.staked_frozen staking_balance in + let allowed_staked_frozen = + Full_staking_balance_repr.allowed_staked_frozen + ~adaptive_issuance_global_limit_of_staking_over_baking: + (Constants_storage.adaptive_issuance_global_limit_of_staking_over_baking + raw_ctxt) + ~delegate_limit_of_staking_over_baking_millionth: + staking_parameters + .Staking_parameters_repr.limit_of_staking_over_baking_millionth + staking_balance + in + let min_delegated_amount, min_delegated_level = + Full_staking_balance_repr.Internal_for_tests_and_RPCs + .min_delegated_and_level + ~cycle_eras + ~current_level + staking_balance + in + let limit_of_delegation_over_baking = + Int64.of_int (Constants_storage.limit_of_delegation_over_baking raw_ctxt) + in + let*? overstaked = Tez_repr.(staked_frozen -? allowed_staked_frozen) in + let*? total_delegated_including_overdelegated = + Tez_repr.(min_delegated_amount +? overstaked) + in + let total_delegated_after_limits = + match Tez_repr.(own_frozen *? limit_of_delegation_over_baking) with + | Ok max_allowed_delegated -> + Tez_repr.min + max_allowed_delegated + total_delegated_including_overdelegated + | Error _max_allowed_delegated_overflows -> + total_delegated_including_overdelegated + in + let total_delegated_including_overdelegated = + Tez_repr.to_mutez total_delegated_including_overdelegated + in + let total_delegated_after_limits = + Tez_repr.to_mutez total_delegated_after_limits + in + let overdelegated = + Int64.sub + total_delegated_including_overdelegated + total_delegated_after_limits + in + return + { + min_delegated_amount = Tez_repr.to_mutez min_delegated_amount; + min_delegated_level = Raw_level_repr.to_int32 min_delegated_level.level; + overstaked = Tez_repr.to_mutez overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + } + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +let delegated_breakdown_at_sampling context ~cycle ~delegate_pkh = + let open Lwt_result_syntax in + let* ctxt = init_ctxt context in + let* sampling_level = find_sampling_level ctxt cycle in + match sampling_level with + | `Already_at_sampling_level -> + let* breakdown = + delegated_breakdown_from_sampling_level_ctxt ctxt delegate_pkh + in + return (`Ok breakdown) + | (`Retry_at_level _ | `Cycle_too_far_in_future) as x -> return x + +(* Computes [delegator]'s delegated contribution to its current + delegate. + + It is equal to [delegator]'s delegated_balance (that is, its full + balance minus its staked balance) minus the amounts in any unstaked + requests that [delegator] might still have associated with older + delegates. + + Precondition: [delegate_pkh] is [delegator]'s current delegate + (checked by the function). *) +let delegator_contribution ctxt ~delegate_pkh delegator = + let open Lwt_result_syntax in + let* current_delegate = Alpha_context.Contract.Delegate.find ctxt delegator in + assert ( + match current_delegate with + | None -> false + | Some current_delegate -> + Signature.Public_key_hash.(current_delegate = delegate_pkh)) ; + let* full_balance = + Alpha_context.Contract.For_RPC.get_full_balance ctxt delegator + in + let* staked_balance_opt = + Alpha_context.Contract.For_RPC.get_staked_balance ctxt delegator + in + let staked_balance = + Option.value staked_balance_opt ~default:Alpha_context.Tez.zero + in + let* unstake_requests = + Contract_services.Implem.unstake_requests ctxt delegator + in + let*? unstaked_counting_for_former_delegates = + let open Result_syntax in + match unstake_requests with + | None -> return Alpha_context.Tez.zero + | Some {finalizable; unfinalizable} -> + let* finalizable_sum = + List.fold_left_e + (fun acc (request_delegate, _cycle, (amount : Alpha_context.Tez.t)) -> + if Signature.Public_key_hash.(request_delegate <> delegate_pkh) + then Alpha_context.Tez.(acc +? amount) + else return acc) + Alpha_context.Tez.zero + finalizable + in + let* unfinalizable_sum = + if Signature.Public_key_hash.(unfinalizable.delegate <> delegate_pkh) + then + List.fold_left_e + (fun acc (_cycle, amount) -> Alpha_context.Tez.(acc +? amount)) + Alpha_context.Tez.zero + unfinalizable.requests + else return Alpha_context.Tez.zero + in + Alpha_context.Tez.(finalizable_sum +? unfinalizable_sum) + in + let*? delegated_balance = + Alpha_context.Tez.(full_balance -? staked_balance) + in + let*? delegated_contribution_to_delegate_pkh = + Alpha_context.Tez.( + delegated_balance -? unstaked_counting_for_former_delegates) + in + return + ( Format.asprintf "%a" Alpha_context.Contract.pp delegator, + Alpha_context.Tez.to_mutez delegated_contribution_to_delegate_pkh ) + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +type min_delegated_breakdown = { + total_delegated : int64; + own_delegated : int64; + delegators_contributions : (string * int64) list; + former_delegators_unstake_requests : int64; +} + +(* See description in [src/lib_validation/protocol_plugin.mli]. *) +let min_delegated_breakdown context ~delegate_pkh = + let open Lwt_result_syntax in + let open Alpha_context in + let* ctxt = init_ctxt context in + let* total_delegated = + Delegate_services.Implem.total_delegated ctxt delegate_pkh + in + let total_delegated = Tez.to_mutez total_delegated in + let* own_delegated = + Delegate_services.Implem.own_delegated ctxt delegate_pkh + in + let own_delegated = Tez.to_mutez own_delegated in + let*! delegators = Delegate_services.Implem.delegators ctxt delegate_pkh in + let external_delegators = + List.filter + (function + | Contract.Implicit pkh -> + Signature.Public_key_hash.(pkh <> delegate_pkh) + | Originated _ -> true) + delegators + in + let* delegators_contributions = + List.map_es (delegator_contribution ctxt ~delegate_pkh) external_delegators + in + let total_external_delegators = + List.fold_left + (fun acc (_delegator_str, amount) -> Int64.add acc amount) + 0L + delegators_contributions + in + let former_delegators_unstake_requests = + Int64.(sub (sub total_delegated own_delegated) total_external_delegators) + in + return + { + total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } + +let wrap_tzresult_lwt x = + let open Lwt_syntax in + let* result = x in + return (Environment.wrap_tzresult result) + +let delegated_breakdown_at_sampling context ~cycle ~delegate_pkh = + delegated_breakdown_at_sampling context ~cycle ~delegate_pkh + |> wrap_tzresult_lwt + +let min_delegated_breakdown context ~delegate_pkh = + min_delegated_breakdown context ~delegate_pkh |> wrap_tzresult_lwt diff --git a/src/proto_alpha/lib_plugin/delegators_contribution.mli b/src/proto_alpha/lib_plugin/delegators_contribution.mli new file mode 100644 index 0000000000000000000000000000000000000000..3b2a363008b273d5677e97d06e9db9601463624a --- /dev/null +++ b/src/proto_alpha/lib_plugin/delegators_contribution.mli @@ -0,0 +1,45 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2025 Nomadic Labs *) +(* *) +(*****************************************************************************) + +(** Protocol-dependent helpers for the delegators_contribution RPC, + which is defined in [src/lib_shell_services/chain_services.ml] and + implemented in [src/lib_shell/chain_directory.ml]. + + See [src/lib_validation/protocol_plugin.mli] for the descriptions of + the types and functions below. +*) + +type delegated_breakdown_at_sampling = { + min_delegated_amount : int64; + min_delegated_level : int32; + overstaked : int64; + total_delegated_including_overdelegated : int64; + total_delegated_after_limits : int64; + overdelegated : int64; +} + +val delegated_breakdown_at_sampling : + Block_header.shell_header * Environment.Context.t -> + cycle:int32 -> + delegate_pkh:Environment.Signature.public_key_hash -> + [ `Ok of delegated_breakdown_at_sampling + | `Retry_at_level of int32 + | `Cycle_too_far_in_future ] + Environment.Error_monad.shell_tzresult + Lwt.t + +type min_delegated_breakdown = { + total_delegated : int64; + own_delegated : int64; + delegators_contributions : (string * int64) list; + former_delegators_unstake_requests : int64; +} + +val min_delegated_breakdown : + Block_header.shell_header * Environment.Context.t -> + delegate_pkh:Environment.Signature.public_key_hash -> + min_delegated_breakdown Environment.Error_monad.shell_tzresult Lwt.t diff --git a/src/proto_alpha/lib_plugin/plugin_registerer.ml b/src/proto_alpha/lib_plugin/plugin_registerer.ml index 096a5f55d284741e6acc783b191388dc5782f565..9c34111880af3d39f211a28f4bad787810834252 100644 --- a/src/proto_alpha/lib_plugin/plugin_registerer.ml +++ b/src/proto_alpha/lib_plugin/plugin_registerer.ml @@ -44,3 +44,59 @@ let () = Protocol_plugin.register_http_cache_headers_plugin (module Http_cache_headers) let () = Protocol_plugin.register_shell_helpers (module Shell_helpers) + +module Delegators_contribution_plugin = struct + let hash = Registerer.Registered.hash + + let delegated_breakdown_at_sampling context ~cycle ~delegate_pkh = + let open Lwt_result_syntax in + let* output = + Delegators_contribution.delegated_breakdown_at_sampling + context + ~cycle + ~delegate_pkh + in + match output with + | `Ok + { + min_delegated_amount; + min_delegated_level; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + } -> + return + (`Ok + { + Protocol_plugin.min_delegated_amount; + min_delegated_level; + overstaked; + total_delegated_including_overdelegated; + total_delegated_after_limits; + overdelegated; + }) + | (`Retry_at_level _ | `Cycle_too_far_in_future) as x -> return x + + let min_delegated_breakdown context ~delegate_pkh = + let open Lwt_result_syntax in + let* { + total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } = + Delegators_contribution.min_delegated_breakdown context ~delegate_pkh + in + return + { + Protocol_plugin.total_delegated; + own_delegated; + delegators_contributions; + former_delegators_unstake_requests; + } +end + +let () = + Protocol_plugin.register_delegators_contribution + (module Delegators_contribution_plugin)