From 2bded2df7cd09881018f43e137c33917fb1dcf97 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Wed, 6 Jan 2021 12:58:26 +0000 Subject: [PATCH 1/5] Reorder the code in ProtocolParameters for improved clarity Before we add more things into that module. --- .../src/Cardano/Api/ProtocolParameters.hs | 116 ++++++++++-------- 1 file changed, 68 insertions(+), 48 deletions(-) diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index 73fb37814d2..0bc9b51e970 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -4,24 +4,32 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} --- | Protocol parameters. +-- | The various Cardano protocol parameters, including: -- --- This covers Protocol parameter updates that can be embedded in transactions. --- --- TODO: add protocol parameters in ledger state queries. +-- * updates to protocol parameters: 'ProtocolParametersUpdate' +-- * update proposals that can be embedded in transactions: 'UpdateProposal' -- module Cardano.Api.ProtocolParameters ( - UpdateProposal(..), + + -- * Updates to the protocol paramaters ProtocolParametersUpdate(..), EpochNo, - makeShelleyUpdateProposal, -- * PraosNonce PraosNonce, makePraosNonce, + -- * Update proposals to change the protocol paramaters + UpdateProposal(..), + makeShelleyUpdateProposal, + -- * Internal conversion functions + toShelleyPParamsUpdate, + toShelleyProposedPPUpdates, toShelleyUpdate, + fromShelleyPParamsUpdate, + fromShelleyProposedPPUpdates, + fromShelleyUpdate, -- * Data family instances AsType(..) @@ -62,31 +70,11 @@ import Cardano.Api.Value -- ---------------------------------------------------------------------------- --- Protocol updates embedded in transactions +-- Updates to the protocol paramaters -- -data UpdateProposal = - UpdateProposal - !(Map (Hash GenesisKey) ProtocolParametersUpdate) - !EpochNo - deriving stock (Eq, Show) - deriving anyclass SerialiseAsCBOR - -instance HasTypeProxy UpdateProposal where - data AsType UpdateProposal = AsUpdateProposal - proxyToAsType _ = AsUpdateProposal - -instance HasTextEnvelope UpdateProposal where - textEnvelopeType _ = "UpdateProposalShelley" - -instance ToCBOR UpdateProposal where - toCBOR = toCBOR . toShelleyUpdate @StandardShelley - -- We have to pick a monomorphic era type for the serialisation. We use the - -- Shelley era. This makes no difference since era type is phantom. - -instance FromCBOR UpdateProposal where - fromCBOR = fromShelleyUpdate @StandardShelley <$> fromCBOR - +-- | The representation of a change in the 'ProtocolParameters'. +-- data ProtocolParametersUpdate = ProtocolParametersUpdate { @@ -250,6 +238,53 @@ instance Monoid ProtocolParametersUpdate where , protocolUpdateTreasuryCut = Nothing } + +-- ---------------------------------------------------------------------------- +-- Praos nonce +-- + +newtype PraosNonce = PraosNonce (Shelley.Hash StandardCrypto ByteString) + deriving (Eq, Ord, Show) + +makePraosNonce :: ByteString -> PraosNonce +makePraosNonce = PraosNonce . Crypto.hashWith id + +toShelleyNonce :: Maybe PraosNonce -> Shelley.Nonce +toShelleyNonce Nothing = Shelley.NeutralNonce +toShelleyNonce (Just (PraosNonce h)) = Shelley.Nonce (Crypto.castHash h) + +fromPraosNonce :: Shelley.Nonce -> Maybe PraosNonce +fromPraosNonce Shelley.NeutralNonce = Nothing +fromPraosNonce (Shelley.Nonce h) = Just (PraosNonce (Crypto.castHash h)) + + +-- ---------------------------------------------------------------------------- +-- Proposals embedded in transactions to update protocol parameters +-- + +data UpdateProposal = + UpdateProposal + !(Map (Hash GenesisKey) ProtocolParametersUpdate) + !EpochNo + deriving stock (Eq, Show) + deriving anyclass SerialiseAsCBOR + +instance HasTypeProxy UpdateProposal where + data AsType UpdateProposal = AsUpdateProposal + proxyToAsType _ = AsUpdateProposal + +instance HasTextEnvelope UpdateProposal where + textEnvelopeType _ = "UpdateProposalShelley" + +instance ToCBOR UpdateProposal where + toCBOR = toCBOR . toShelleyUpdate @StandardShelley + -- We have to pick a monomorphic era type for the serialisation. We use the + -- Shelley era. This makes no difference since era type is phantom. + +instance FromCBOR UpdateProposal where + fromCBOR = fromShelleyUpdate @StandardShelley <$> fromCBOR + + makeShelleyUpdateProposal :: ProtocolParametersUpdate -> [Hash GenesisKey] -> EpochNo @@ -259,6 +294,10 @@ makeShelleyUpdateProposal params genesisKeyHashes = UpdateProposal (Map.fromList [ (kh, params) | kh <- genesisKeyHashes ]) +-- ---------------------------------------------------------------------------- +-- Conversion functions +-- + toShelleyUpdate :: Ledger.Crypto ledgerera ~ StandardCrypto => UpdateProposal -> Shelley.Update ledgerera toShelleyUpdate (UpdateProposal ppup epochno) = @@ -390,22 +429,3 @@ fromShelleyPParamsUpdate , protocolUpdateTreasuryCut = Shelley.unitIntervalToRational <$> strictMaybeToMaybe _tau } - - --- ---------------------------------------------------------------------------- --- Praos nonce --- - -newtype PraosNonce = PraosNonce (Shelley.Hash StandardCrypto ByteString) - deriving (Eq, Ord, Show) - -makePraosNonce :: ByteString -> PraosNonce -makePraosNonce = PraosNonce . Crypto.hashWith id - -toShelleyNonce :: Maybe PraosNonce -> Shelley.Nonce -toShelleyNonce Nothing = Shelley.NeutralNonce -toShelleyNonce (Just (PraosNonce h)) = Shelley.Nonce (Crypto.castHash h) - -fromPraosNonce :: Shelley.Nonce -> Maybe PraosNonce -fromPraosNonce Shelley.NeutralNonce = Nothing -fromPraosNonce (Shelley.Nonce h) = Just (PraosNonce (Crypto.castHash h)) From 316839a9887704383ce8258ed7fa3e978d6fc535 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Wed, 6 Jan 2021 13:32:19 +0000 Subject: [PATCH 2/5] Add a ProtocolParameters type for the current values To go along with the existing ProtocolParametersUpdate type. This new one will be used for the query that returns the current param values. --- .../src/Cardano/Api/ProtocolParameters.hs | 173 ++++++++++++++++++ 1 file changed, 173 insertions(+) diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index 0bc9b51e970..df5f9698865 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -6,10 +6,13 @@ -- | The various Cardano protocol parameters, including: -- +-- * the current values of updateable protocol parameters: 'ProtocolParameters' -- * updates to protocol parameters: 'ProtocolParametersUpdate' -- * update proposals that can be embedded in transactions: 'UpdateProposal' -- module Cardano.Api.ProtocolParameters ( + -- * The updateable protocol paramaters + ProtocolParameters(..), -- * Updates to the protocol paramaters ProtocolParametersUpdate(..), @@ -27,6 +30,7 @@ module Cardano.Api.ProtocolParameters ( toShelleyPParamsUpdate, toShelleyProposedPPUpdates, toShelleyUpdate, + fromShelleyPParams, fromShelleyPParamsUpdate, fromShelleyProposedPPUpdates, fromShelleyUpdate, @@ -69,6 +73,131 @@ import Cardano.Api.TxMetadata import Cardano.Api.Value +-- | The values of the set of /updateable/ protocol paramaters. At any +-- particular point on the chain there is a current set of paramaters in use. +-- +-- These paramaters can be updated (at epoch boundaries) via an +-- 'UpdateProposal', which contains a 'ProtocolParametersUpdate'. +-- +-- The 'ProtocolParametersUpdate' is essentially a diff for the +-- 'ProtocolParameters'. +-- +data ProtocolParameters = + ProtocolParameters { + + -- | Protocol version, major and minor. Updating the major version is + -- used to trigger hard forks. + -- + protocolParamProtocolVersion :: (Natural, Natural), + + -- | The decentralization parameter. This is fraction of slots that + -- belong to the BFT overlay schedule, rather than the Praos schedule. + -- So 1 means fully centralised, while 0 means fully decentralised. + -- + -- This is the \"d\" parameter from the design document. + -- + protocolParamDecentralization :: Rational, + + -- | Extra entropy for the Praos per-epoch nonce. + -- + -- This can be used to add extra entropy during the decentralisation + -- process. If the extra entropy can be demonstrated to be generated + -- randomly then this method can be used to show that the initial + -- federated operators did not subtly bias the initial schedule so that + -- they retain undue influence after decentralisation. + -- + protocolParamExtraPraosEntropy :: Maybe PraosNonce, + + -- | The maximum permitted size of a block header. + -- + -- This must be at least as big as the largest legitimate block headers + -- but should not be too much larger, to help prevent DoS attacks. + -- + -- Caution: setting this to be smaller than legitimate block headers is + -- a sure way to brick the system! + -- + protocolParamMaxBlockHeaderSize :: Natural, + + -- | The maximum permitted size of the block body (that is, the block + -- payload, without the block header). + -- + -- This should be picked with the Praos network delta security parameter + -- in mind. Making this too large can severely weaken the Praos + -- consensus properties. + -- + -- Caution: setting this to be smaller than a transaction that can + -- change the protocol parameters is a sure way to brick the system! + -- + protocolParamMaxBlockBodySize :: Natural, + + -- | The maximum permitted size of a transaction. + -- + -- Typically this should not be too high a fraction of the block size, + -- otherwise wastage from block fragmentation becomes a problem, and + -- the current implementation does not use any sophisticated box packing + -- algorithm. + -- + protocolParamMaxTxSize :: Natural, + + -- | The constant factor for the minimum fee calculation. + -- + protocolParamTxFeeFixed :: Natural, + + -- | The linear factor for the minimum fee calculation. + -- + protocolParamTxFeePerByte :: Natural, + + -- | The minimum permitted value for new UTxO entries, ie for + -- transaction outputs. + -- + protocolParamMinUTxOValue :: Lovelace, + + -- | The deposit required to register a stake address. + -- + protocolParamStakeAddressDeposit :: Lovelace, + + -- | The deposit required to register a stake pool. + -- + protocolParamStakePoolDeposit :: Lovelace, + + -- | The minimum value that stake pools are permitted to declare for + -- their cost parameter. + -- + protocolParamMinPoolCost :: Lovelace, + + -- | The maximum number of epochs into the future that stake pools + -- are permitted to schedule a retirement. + -- + protocolParamPoolRetireMaxEpoch :: EpochNo, + + -- | The equilibrium target number of stake pools. + -- + -- This is the \"k\" incentives parameter from the design document. + -- + protocolParamStakePoolTargetNum :: Natural, + + -- | The influence of the pledge in stake pool rewards. + -- + -- This is the \"a_0\" incentives parameter from the design document. + -- + protocolParamPoolPledgeInfluence :: Rational, + + -- | The monetary expansion rate. This determines the fraction of the + -- reserves that are added to the fee pot each epoch. + -- + -- This is the \"rho\" incentives parameter from the design document. + -- + protocolParamMonetaryExpansion :: Rational, + + -- | The fraction of the fee pot each epoch that goes to the treasury. + -- + -- This is the \"tau\" incentives parameter from the design document. + -- + protocolParamTreasuryCut :: Rational + } + deriving (Eq, Show) + + -- ---------------------------------------------------------------------------- -- Updates to the protocol paramaters -- @@ -429,3 +558,47 @@ fromShelleyPParamsUpdate , protocolUpdateTreasuryCut = Shelley.unitIntervalToRational <$> strictMaybeToMaybe _tau } + + +fromShelleyPParams :: Shelley.PParams ledgerera + -> ProtocolParameters +fromShelleyPParams + Shelley.PParams { + Shelley._minfeeA + , Shelley._minfeeB + , Shelley._maxBBSize + , Shelley._maxTxSize + , Shelley._maxBHSize + , Shelley._keyDeposit + , Shelley._poolDeposit + , Shelley._eMax + , Shelley._nOpt + , Shelley._a0 + , Shelley._rho + , Shelley._tau + , Shelley._d + , Shelley._extraEntropy + , Shelley._protocolVersion + , Shelley._minUTxOValue + , Shelley._minPoolCost + } = + ProtocolParameters { + protocolParamProtocolVersion = (\(Shelley.ProtVer a b) -> (a,b)) + _protocolVersion + , protocolParamDecentralization = Shelley.unitIntervalToRational _d + , protocolParamExtraPraosEntropy = fromPraosNonce _extraEntropy + , protocolParamMaxBlockHeaderSize = _maxBHSize + , protocolParamMaxBlockBodySize = _maxBBSize + , protocolParamMaxTxSize = _maxTxSize + , protocolParamTxFeeFixed = _minfeeB + , protocolParamTxFeePerByte = _minfeeA + , protocolParamMinUTxOValue = fromShelleyLovelace _minUTxOValue + , protocolParamStakeAddressDeposit = fromShelleyLovelace _keyDeposit + , protocolParamStakePoolDeposit = fromShelleyLovelace _poolDeposit + , protocolParamMinPoolCost = fromShelleyLovelace _minPoolCost + , protocolParamPoolRetireMaxEpoch = _eMax + , protocolParamStakePoolTargetNum = _nOpt + , protocolParamPoolPledgeInfluence = _a0 + , protocolParamMonetaryExpansion = Shelley.unitIntervalToRational _rho + , protocolParamTreasuryCut = Shelley.unitIntervalToRational _tau + } From d192f0bf447f28bae3e78f991a4ca0a584cc0d35 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 7 Jan 2021 00:30:14 +0000 Subject: [PATCH 3/5] Add a GenesisParameters type for initial params from the genesis The node keeps the values of the params that are fixed in the genesis file. -- Please enter the commit message for your changes. Lines starting --- .../src/Cardano/Api/ProtocolParameters.hs | 120 +++++++++++++++++- 1 file changed, 118 insertions(+), 2 deletions(-) diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index df5f9698865..bed60c395d5 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -9,14 +9,15 @@ -- * the current values of updateable protocol parameters: 'ProtocolParameters' -- * updates to protocol parameters: 'ProtocolParametersUpdate' -- * update proposals that can be embedded in transactions: 'UpdateProposal' +-- * parameters fixed in the genesis file: 'GenesisParameters' -- module Cardano.Api.ProtocolParameters ( -- * The updateable protocol paramaters ProtocolParameters(..), + EpochNo, -- * Updates to the protocol paramaters ProtocolParametersUpdate(..), - EpochNo, -- * PraosNonce PraosNonce, @@ -26,6 +27,10 @@ module Cardano.Api.ProtocolParameters ( UpdateProposal(..), makeShelleyUpdateProposal, + -- * Protocol paramaters fixed in the genesis file + GenesisParameters(..), + EpochSize(..), + -- * Internal conversion functions toShelleyPParamsUpdate, toShelleyProposedPPUpdates, @@ -34,6 +39,7 @@ module Cardano.Api.ProtocolParameters ( fromShelleyPParamsUpdate, fromShelleyProposedPPUpdates, fromShelleyUpdate, + fromShelleyGenesis, -- * Data family instances AsType(..) @@ -45,10 +51,11 @@ import Numeric.Natural import Data.ByteString (ByteString) import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) +import Data.Time (UTCTime, NominalDiffTime) import Control.Monad -import Cardano.Slotting.Slot (EpochNo) +import Cardano.Slotting.Slot (EpochNo, EpochSize (..)) import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Ledger.Era as Ledger @@ -60,12 +67,14 @@ import Shelley.Spec.Ledger.BaseTypes import qualified Shelley.Spec.Ledger.BaseTypes as Shelley import qualified Shelley.Spec.Ledger.Keys as Shelley import qualified Shelley.Spec.Ledger.PParams as Shelley +import qualified Shelley.Spec.Ledger.Genesis as Shelley import Cardano.Api.Address import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.KeysByron import Cardano.Api.KeysShelley +import Cardano.Api.NetworkId import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseTextEnvelope import Cardano.Api.StakePoolMetadata @@ -82,6 +91,8 @@ import Cardano.Api.Value -- The 'ProtocolParametersUpdate' is essentially a diff for the -- 'ProtocolParameters'. -- +-- There are also paramaters fixed in the Genesis file. See 'GenesisParameters'. +-- data ProtocolParameters = ProtocolParameters { @@ -423,6 +434,73 @@ makeShelleyUpdateProposal params genesisKeyHashes = UpdateProposal (Map.fromList [ (kh, params) | kh <- genesisKeyHashes ]) +-- ---------------------------------------------------------------------------- +-- Genesis paramaters +-- + +data GenesisParameters = + GenesisParameters { + + -- | The reference time the system started. The time of slot zero. + -- The time epoch against which all Ouroboros time slots are measured. + -- + protocolParamSystemStart :: UTCTime, + + -- | The network identifier for this blockchain instance. This + -- distinguishes the mainnet from testnets, and different testnets from + -- each other. + -- + protocolParamNetworkId :: NetworkId, + + -- | The Ouroboros Praos active slot coefficient, aka @f@. + -- + protocolParamActiveSlotsCoefficient :: Rational, + + -- | The Ouroboros security paramaters, aka @k@. This is the maximum + -- number of blocks the node would ever be prepared to roll back by. + -- + -- Clients of the node following the chain should be prepared to handle + -- the node switching forks up to this long. + -- + protocolParamSecurity :: Int, + + -- | The number of Ouroboros time slots in an Ouroboros epoch. + -- + protocolParamEpochLength :: EpochSize, + + -- | The time duration of a slot. + -- + protocolParamSlotLength :: NominalDiffTime, + + -- | For Ouroboros Praos, the length of a KES period as a number of time + -- slots. The KES keys get evolved once per KES period. + -- + protocolParamSlotsPerKESPeriod :: Int, + + -- | The maximum number of times a KES key can be evolved before it is + -- no longer considered valid. This can be less than the maximum number + -- of times given the KES key size. For example the mainnet KES key size + -- would allow 64 evolutions, but the max KES evolutions param is 62. + -- + protocolParamMaxKESEvolutions :: Int, + + -- | In the Shelley era, prior to decentralised governance, this is the + -- number of genesis key delegates that need to agree for an update + -- proposal to be enacted. + -- + protocolParamUpdateQuorum :: Int, + + -- | The maximum supply for Lovelace. This determines the initial value + -- of the reserves. + -- + protocolParamMaxLovelaceSupply :: Lovelace, + + -- | The initial values of the updateable 'ProtocolParameters'. + -- + protocolInitialUpdateableProtocolParameters :: ProtocolParameters + } + + -- ---------------------------------------------------------------------------- -- Conversion functions -- @@ -602,3 +680,41 @@ fromShelleyPParams , protocolParamMonetaryExpansion = Shelley.unitIntervalToRational _rho , protocolParamTreasuryCut = Shelley.unitIntervalToRational _tau } + + +fromShelleyGenesis :: Shelley.ShelleyGenesis era -> GenesisParameters +fromShelleyGenesis + Shelley.ShelleyGenesis { + Shelley.sgSystemStart + , Shelley.sgNetworkMagic + , Shelley.sgNetworkId + , Shelley.sgActiveSlotsCoeff + , Shelley.sgSecurityParam + , Shelley.sgEpochLength + , Shelley.sgSlotsPerKESPeriod + , Shelley.sgMaxKESEvolutions + , Shelley.sgSlotLength + , Shelley.sgUpdateQuorum + , Shelley.sgMaxLovelaceSupply + , Shelley.sgProtocolParams + , Shelley.sgGenDelegs = _ -- unused, might be of interest + , Shelley.sgInitialFunds = _ -- unused, not retained by the node + , Shelley.sgStaking = _ -- unused, not retained by the node + } = + GenesisParameters { + protocolParamSystemStart = sgSystemStart + , protocolParamNetworkId = fromShelleyNetwork sgNetworkId + (NetworkMagic sgNetworkMagic) + , protocolParamActiveSlotsCoefficient = sgActiveSlotsCoeff + , protocolParamSecurity = fromIntegral sgSecurityParam + , protocolParamEpochLength = sgEpochLength + , protocolParamSlotLength = sgSlotLength + , protocolParamSlotsPerKESPeriod = fromIntegral sgSlotsPerKESPeriod + , protocolParamMaxKESEvolutions = fromIntegral sgMaxKESEvolutions + , protocolParamUpdateQuorum = fromIntegral sgUpdateQuorum + , protocolParamMaxLovelaceSupply = Lovelace + (fromIntegral sgMaxLovelaceSupply) + , protocolInitialUpdateableProtocolParameters = fromShelleyPParams + sgProtocolParams + } + From dee245d649aa38db0ea6c624b66f3a5742b5468f Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 7 Jan 2021 00:31:24 +0000 Subject: [PATCH 4/5] Add API support for queries for protocol params. Several kinds of params: 1. current values of updateable protocol params 2. any pending proposed param updates 3. the non-updateable params fixed in the (Shelley) genesis file --- cardano-api/src/Cardano/Api/NetworkId.hs | 17 ++++++++-- cardano-api/src/Cardano/Api/Query.hs | 42 ++++++++++++++++++++---- cardano-api/src/Cardano/Api/Typed.hs | 2 +- 3 files changed, 50 insertions(+), 11 deletions(-) diff --git a/cardano-api/src/Cardano/Api/NetworkId.hs b/cardano-api/src/Cardano/Api/NetworkId.hs index 4b2f182589d..91f28b89f89 100644 --- a/cardano-api/src/Cardano/Api/NetworkId.hs +++ b/cardano-api/src/Cardano/Api/NetworkId.hs @@ -5,12 +5,14 @@ module Cardano.Api.NetworkId ( NetworkId(..), NetworkMagic(..), toNetworkMagic, + mainnetNetworkMagic, -- * Internal conversion functions toByronProtocolMagicId, toByronNetworkMagic, toByronRequiresNetworkMagic, toShelleyNetwork, + fromShelleyNetwork, ) where import Prelude @@ -35,9 +37,12 @@ data NetworkId = Mainnet toNetworkMagic :: NetworkId -> NetworkMagic toNetworkMagic (Testnet nm) = nm -toNetworkMagic Mainnet = NetworkMagic - . Byron.unProtocolMagicId - $ Byron.mainnetProtocolMagicId +toNetworkMagic Mainnet = mainnetNetworkMagic + +mainnetNetworkMagic :: NetworkMagic +mainnetNetworkMagic = NetworkMagic + . Byron.unProtocolMagicId + $ Byron.mainnetProtocolMagicId -- ---------------------------------------------------------------------------- @@ -65,3 +70,9 @@ toShelleyNetwork :: NetworkId -> Shelley.Network toShelleyNetwork Mainnet = Shelley.Mainnet toShelleyNetwork (Testnet _) = Shelley.Testnet +fromShelleyNetwork :: Shelley.Network -> NetworkMagic -> NetworkId +fromShelleyNetwork Shelley.Testnet nm = Testnet nm +fromShelleyNetwork Shelley.Mainnet nm + | nm == mainnetNetworkMagic = Mainnet + | otherwise = error "fromShelleyNetwork Mainnet: wrong mainnet network magic" + diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index 4ad78dcdc4a..b25ef1acd94 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -49,7 +49,9 @@ import qualified Shelley.Spec.Ledger.API as Shelley import Cardano.Api.Address import Cardano.Api.Block import Cardano.Api.Eras +import Cardano.Api.KeysShelley import Cardano.Api.Modes +import Cardano.Api.ProtocolParameters import Cardano.Api.TxBody @@ -93,16 +95,17 @@ data QueryInShelleyBasedEra era result where QueryEpoch :: QueryInShelleyBasedEra era EpochNo ---TODO: add support for these --- QueryGenesisParameters --- :: QueryInShelleyBasedEra GenesisParameters + QueryGenesisParameters + :: QueryInShelleyBasedEra era GenesisParameters --- QueryProtocolParameters --- :: QueryInShelleyBasedEra ProtocolParameters + QueryProtocolParameters + :: QueryInShelleyBasedEra era ProtocolParameters --- QueryProtocolParametersUpdate --- :: QueryInShelleyBasedEra ProtocolParametersUpdate + QueryProtocolParametersUpdate + :: QueryInShelleyBasedEra era + (Map (Hash GenesisKey) ProtocolParametersUpdate) +--TODO: add support for these -- QueryStakeDistribution -- :: QueryInShelleyBasedEra StakeDistribution @@ -208,6 +211,15 @@ toConsensusQueryShelleyBased erainmode QueryChainPoint = toConsensusQueryShelleyBased erainmode QueryEpoch = Some (consensusQueryInEraInMode erainmode Consensus.GetEpochNo) +toConsensusQueryShelleyBased erainmode QueryGenesisParameters = + Some (consensusQueryInEraInMode erainmode Consensus.GetGenesisConfig) + +toConsensusQueryShelleyBased erainmode QueryProtocolParameters = + Some (consensusQueryInEraInMode erainmode Consensus.GetCurrentPParams) + +toConsensusQueryShelleyBased erainmode QueryProtocolParametersUpdate = + Some (consensusQueryInEraInMode erainmode Consensus.GetProposedPParamsUpdates) + toConsensusQueryShelleyBased erainmode (QueryUTxO Nothing) = Some (consensusQueryInEraInMode erainmode Consensus.GetUTxO) @@ -327,6 +339,22 @@ fromConsensusQueryResultShelleyBased QueryEpoch q' epoch = Consensus.GetEpochNo -> epoch _ -> fromConsensusQueryResultMismatch +fromConsensusQueryResultShelleyBased QueryGenesisParameters q' r' = + case q' of + Consensus.GetGenesisConfig -> fromShelleyGenesis + (Consensus.getCompactGenesis r') + _ -> fromConsensusQueryResultMismatch + +fromConsensusQueryResultShelleyBased QueryProtocolParameters q' r' = + case q' of + Consensus.GetCurrentPParams -> fromShelleyPParams r' + _ -> fromConsensusQueryResultMismatch + +fromConsensusQueryResultShelleyBased QueryProtocolParametersUpdate q' r' = + case q' of + Consensus.GetProposedPParamsUpdates -> fromShelleyProposedPPUpdates r' + _ -> fromConsensusQueryResultMismatch + fromConsensusQueryResultShelleyBased (QueryUTxO Nothing) q' utxo' = case q' of Consensus.GetUTxO -> fromShelleyUTxO utxo' diff --git a/cardano-api/src/Cardano/Api/Typed.hs b/cardano-api/src/Cardano/Api/Typed.hs index 874c57b1938..ee953552099 100644 --- a/cardano-api/src/Cardano/Api/Typed.hs +++ b/cardano-api/src/Cardano/Api/Typed.hs @@ -515,7 +515,7 @@ import Control.Tracer (nullTracer) -- -- Common types, consensus, network -- -import Cardano.Slotting.Slot (EpochNo (..), EpochSize (..), SlotNo (..)) +import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) -- TODO: it'd be nice if the network imports needed were a bit more coherent import Ouroboros.Network.Block (Point, Tip) From b5abac043945c810cf2408b2442702530f561825 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 7 Jan 2021 02:01:41 +0000 Subject: [PATCH 5/5] Add API support for queries for stake distribution and stake addrs --- cardano-api/src/Cardano/Api/Address.hs | 4 +- cardano-api/src/Cardano/Api/Query.hs | 81 +++++++++++++++++++++++--- 2 files changed, 75 insertions(+), 10 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Address.hs b/cardano-api/src/Cardano/Api/Address.hs index 662fe9c8d80..73e003dacf5 100644 --- a/cardano-api/src/Cardano/Api/Address.hs +++ b/cardano-api/src/Cardano/Api/Address.hs @@ -424,12 +424,12 @@ data StakeAddress where data PaymentCredential = PaymentCredentialByKey (Hash PaymentKey) | PaymentCredentialByScript ScriptHash - deriving (Eq, Show) + deriving (Eq, Ord, Show) data StakeCredential = StakeCredentialByKey (Hash StakeKey) | StakeCredentialByScript ScriptHash - deriving (Eq, Show) + deriving (Eq, Ord, Show) data StakeAddressReference = StakeAddressByValue StakeCredential diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index b25ef1acd94..9ec680569db 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -4,6 +4,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +-- The Shelley ledger uses promoted data kinds which we have to use, but we do +-- not export any from this API. We also use them unticked as nature intended. +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + + -- | Queries from local clients to the node. -- module Cardano.Api.Query ( @@ -38,21 +44,25 @@ import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (EraMismatch import qualified Ouroboros.Consensus.Byron.Ledger as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.Cardano.Block as Consensus +import Ouroboros.Consensus.Cardano.Block (StandardCrypto) import qualified Cardano.Chain.Update.Validation.Interface as Byron.Update import qualified Cardano.Ledger.Era as Ledger import qualified Cardano.Ledger.Shelley.Constraints as Ledger -import qualified Shelley.Spec.Ledger.API as Shelley +import qualified Shelley.Spec.Ledger.API as Shelley +import qualified Shelley.Spec.Ledger.LedgerState as Shelley import Cardano.Api.Address import Cardano.Api.Block +import Cardano.Api.Certificate import Cardano.Api.Eras import Cardano.Api.KeysShelley import Cardano.Api.Modes import Cardano.Api.ProtocolParameters import Cardano.Api.TxBody +import Cardano.Api.Value -- ---------------------------------------------------------------------------- @@ -105,18 +115,17 @@ data QueryInShelleyBasedEra era result where :: QueryInShelleyBasedEra era (Map (Hash GenesisKey) ProtocolParametersUpdate) ---TODO: add support for these --- QueryStakeDistribution --- :: QueryInShelleyBasedEra StakeDistribution + QueryStakeDistribution + :: QueryInShelleyBasedEra era (Map (Hash StakePoolKey) Rational) QueryUTxO :: Maybe (Set AddressAny) -> QueryInShelleyBasedEra era (UTxO era) --- QueryStakeAddresses --- :: Set StakeAddress --- -> QueryInShelleyBasedEra (Map StakeAddress Lovelace, --- Map StakeAddress PoolId) + QueryStakeAddresses + :: Set StakeCredential + -> QueryInShelleyBasedEra era (Map StakeCredential Lovelace, + Map StakeCredential PoolId) -- QueryPoolRanking -- :: @@ -127,6 +136,7 @@ data QueryInShelleyBasedEra era result where -- QueryProtocolState -- :: QueryInShelleyBasedEra ProtocolState +--TODO: add support for these deriving instance Show (QueryInShelleyBasedEra era result) @@ -169,6 +179,38 @@ fromShelleyUTxO = . Shelley.unUTxO +fromShelleyPoolDistr :: Shelley.PoolDistr StandardCrypto + -> Map (Hash StakePoolKey) Rational +fromShelleyPoolDistr = + --TODO: write an appropriate property to show it is safe to use + -- Map.fromListAsc or to use Map.mapKeysMonotonic + Map.fromList + . map (bimap StakePoolKeyHash Shelley.individualPoolStake) + . Map.toList + . Shelley.unPoolDistr + +fromShelleyDelegations :: Map (Shelley.Credential Shelley.Staking StandardCrypto) + (Shelley.KeyHash Shelley.StakePool StandardCrypto) + -> Map StakeCredential PoolId +fromShelleyDelegations = + --TODO: write an appropriate property to show it is safe to use + -- Map.fromListAsc or to use Map.mapKeysMonotonic + -- In this case it may not be: the Ord instances for Shelley.Credential + -- do not match the one for StakeCredential + Map.fromList + . map (bimap fromShelleyStakeCredential StakePoolKeyHash) + . Map.toList + +fromShelleyRewardAccounts :: Shelley.RewardAccounts Consensus.StandardCrypto + -> Map StakeCredential Lovelace +fromShelleyRewardAccounts = + --TODO: write an appropriate property to show it is safe to use + -- Map.fromListAsc or to use Map.mapKeysMonotonic + Map.fromList + . map (bimap fromShelleyStakeCredential fromShelleyLovelace) + . Map.toList + + -- ---------------------------------------------------------------------------- -- Conversions of queries into the consensus types. -- @@ -220,6 +262,9 @@ toConsensusQueryShelleyBased erainmode QueryProtocolParameters = toConsensusQueryShelleyBased erainmode QueryProtocolParametersUpdate = Some (consensusQueryInEraInMode erainmode Consensus.GetProposedPParamsUpdates) +toConsensusQueryShelleyBased erainmode QueryStakeDistribution = + Some (consensusQueryInEraInMode erainmode Consensus.GetStakeDistribution) + toConsensusQueryShelleyBased erainmode (QueryUTxO Nothing) = Some (consensusQueryInEraInMode erainmode Consensus.GetUTxO) @@ -229,6 +274,13 @@ toConsensusQueryShelleyBased erainmode (QueryUTxO (Just addrs)) = addrs' :: Set (Shelley.Addr Consensus.StandardCrypto) addrs' = toShelleyAddrSet (eraInModeToEra erainmode) addrs +toConsensusQueryShelleyBased erainmode (QueryStakeAddresses creds) = + Some (consensusQueryInEraInMode erainmode + (Consensus.GetFilteredDelegationsAndRewardAccounts creds')) + where + creds' :: Set (Shelley.Credential Shelley.Staking StandardCrypto) + creds' = Set.map toShelleyStakeCredential creds + consensusQueryInEraInMode :: forall era mode erablock modeblock result result' xs. @@ -355,6 +407,11 @@ fromConsensusQueryResultShelleyBased QueryProtocolParametersUpdate q' r' = Consensus.GetProposedPParamsUpdates -> fromShelleyProposedPPUpdates r' _ -> fromConsensusQueryResultMismatch +fromConsensusQueryResultShelleyBased QueryStakeDistribution q' r' = + case q' of + Consensus.GetStakeDistribution -> fromShelleyPoolDistr r' + _ -> fromConsensusQueryResultMismatch + fromConsensusQueryResultShelleyBased (QueryUTxO Nothing) q' utxo' = case q' of Consensus.GetUTxO -> fromShelleyUTxO utxo' @@ -365,6 +422,14 @@ fromConsensusQueryResultShelleyBased (QueryUTxO Just{}) q' utxo' = Consensus.GetFilteredUTxO{} -> fromShelleyUTxO utxo' _ -> fromConsensusQueryResultMismatch +fromConsensusQueryResultShelleyBased QueryStakeAddresses{} q' r' = + case q' of + Consensus.GetFilteredDelegationsAndRewardAccounts{} + -> let (delegs, rwaccs) = r' + in (fromShelleyRewardAccounts rwaccs, + fromShelleyDelegations delegs) + _ -> fromConsensusQueryResultMismatch + -- | This should /only/ happen if we messed up the mapping in 'toConsensusQuery' -- and 'fromConsensusQueryResult' so they are inconsistent with each other.