diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 81c09323f9..ada7e46dcd 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -169,6 +169,7 @@ library internal , deepseq , directory , either + , errors , filepath , formatting , iproute diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index f753e1a0ff..579b769822 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -252,76 +252,29 @@ data StakeAddressRequirements era where -> StakeCredential -> StakeAddressRequirements era - makeStakeAddressRegistrationCertificate :: StakeAddressRequirements era -> Certificate era -makeStakeAddressRegistrationCertificate req = - case req of - StakeAddrRegistrationPreConway atMostEra scred -> - shelleyToBabbageEraConstraints atMostEra - $ makeStakeAddressRegistrationCertificatePreConway atMostEra scred - StakeAddrRegistrationConway cOnwards ll scred -> - conwayEraOnwardsConstraints cOnwards - $ makeStakeAddressRegistrationCertificatePostConway cOnwards scred ll - where - makeStakeAddressRegistrationCertificatePreConway :: () - => EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => Ledger.ShelleyEraTxCert (ShelleyLedgerEra era) - => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ShelleyTxCert (ShelleyLedgerEra era) - => ShelleyToBabbageEra era - -> StakeCredential - -> Certificate era - makeStakeAddressRegistrationCertificatePreConway atMostBabbage scred = - ShelleyRelatedCertificate atMostBabbage $ Ledger.mkRegTxCert $ toShelleyStakeCredential scred - - makeStakeAddressRegistrationCertificatePostConway :: () - => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ConwayTxCert (ShelleyLedgerEra era) - => Ledger.ConwayEraTxCert (ShelleyLedgerEra era) - => EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => ConwayEraOnwards era - -> StakeCredential - -> Lovelace - -> Certificate era - makeStakeAddressRegistrationCertificatePostConway cWayEraOn scred deposit = - ConwayCertificate cWayEraOn - $ Ledger.mkRegDepositTxCert - (toShelleyStakeCredential scred) - (toShelleyLovelace deposit) +makeStakeAddressRegistrationCertificate = \case + StakeAddrRegistrationPreConway w scred -> + shelleyToBabbageEraConstraints w + $ ShelleyRelatedCertificate w + $ Ledger.mkRegTxCert $ toShelleyStakeCredential scred + StakeAddrRegistrationConway cOnwards deposit scred -> + conwayEraOnwardsConstraints cOnwards + $ ConwayCertificate cOnwards + $ Ledger.mkRegDepositTxCert (toShelleyStakeCredential scred) (toShelleyLovelace deposit) makeStakeAddressUnregistrationCertificate :: StakeAddressRequirements era -> Certificate era makeStakeAddressUnregistrationCertificate req = case req of - StakeAddrRegistrationConway cOnwards ll scred -> + StakeAddrRegistrationConway cOnwards deposit scred -> conwayEraOnwardsConstraints cOnwards - $ makeStakeAddressDeregistrationCertificatePostConway cOnwards scred ll + $ ConwayCertificate cOnwards + $ Ledger.mkUnRegDepositTxCert (toShelleyStakeCredential scred) (toShelleyLovelace deposit) StakeAddrRegistrationPreConway atMostEra scred -> shelleyToBabbageEraConstraints atMostEra - $ makeStakeAddressDeregistrationCertificatePreConway atMostEra scred - where - makeStakeAddressDeregistrationCertificatePreConway - :: Ledger.ShelleyEraTxCert (ShelleyLedgerEra era) - => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ShelleyTxCert (ShelleyLedgerEra era) - => EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => ShelleyToBabbageEra era - -> StakeCredential - -> Certificate era - makeStakeAddressDeregistrationCertificatePreConway aMostBab scred = - ShelleyRelatedCertificate aMostBab - $ Ledger.mkUnRegTxCert $ toShelleyStakeCredential scred - - makeStakeAddressDeregistrationCertificatePostConway - :: EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ConwayTxCert (ShelleyLedgerEra era) - => Ledger.ConwayEraTxCert (ShelleyLedgerEra era) - => ConwayEraOnwards era - -> StakeCredential - -> Lovelace - -> Certificate era - makeStakeAddressDeregistrationCertificatePostConway cOn scred deposit = - ConwayCertificate cOn - $ Ledger.mkUnRegDepositTxCert - (toShelleyStakeCredential scred) - (toShelleyLovelace deposit) + $ ShelleyRelatedCertificate atMostEra + $ Ledger.mkUnRegTxCert $ toShelleyStakeCredential scred data StakeDelegationRequirements era where StakeDelegationRequirementsConwayOnwards @@ -336,19 +289,17 @@ data StakeDelegationRequirements era where -> PoolId -> StakeDelegationRequirements era - makeStakeAddressDelegationCertificate :: StakeDelegationRequirements era -> Certificate era -makeStakeAddressDelegationCertificate req = - case req of - StakeDelegationRequirementsConwayOnwards cOnwards scred delegatee -> - conwayEraOnwardsConstraints cOnwards - $ ConwayCertificate cOnwards - $ Ledger.mkDelegTxCert (toShelleyStakeCredential scred) delegatee +makeStakeAddressDelegationCertificate = \case + StakeDelegationRequirementsConwayOnwards cOnwards scred delegatee -> + conwayEraOnwardsConstraints cOnwards + $ ConwayCertificate cOnwards + $ Ledger.mkDelegTxCert (toShelleyStakeCredential scred) delegatee - StakeDelegationRequirementsPreConway atMostBabbage scred pid -> - shelleyToBabbageEraConstraints atMostBabbage - $ ShelleyRelatedCertificate atMostBabbage - $ Ledger.mkDelegStakeTxCert (toShelleyStakeCredential scred) (unStakePoolKeyHash pid) + StakeDelegationRequirementsPreConway atMostBabbage scred pid -> + shelleyToBabbageEraConstraints atMostBabbage + $ ShelleyRelatedCertificate atMostBabbage + $ Ledger.mkDelegStakeTxCert (toShelleyStakeCredential scred) (unStakePoolKeyHash pid) data StakePoolRegistrationRequirements era where StakePoolRegistrationRequirementsConwayOnwards @@ -364,16 +315,15 @@ data StakePoolRegistrationRequirements era where makeStakePoolRegistrationCertificate :: () => StakePoolRegistrationRequirements era -> Certificate era -makeStakePoolRegistrationCertificate req = - case req of - StakePoolRegistrationRequirementsConwayOnwards cOnwards poolParams -> - conwayEraOnwardsConstraints cOnwards - $ ConwayCertificate cOnwards - $ Ledger.mkRegPoolTxCert poolParams - StakePoolRegistrationRequirementsPreConway atMostBab poolParams -> - shelleyToBabbageEraConstraints atMostBab - $ ShelleyRelatedCertificate atMostBab - $ Ledger.mkRegPoolTxCert poolParams +makeStakePoolRegistrationCertificate = \case + StakePoolRegistrationRequirementsConwayOnwards cOnwards poolParams -> + conwayEraOnwardsConstraints cOnwards + $ ConwayCertificate cOnwards + $ Ledger.mkRegPoolTxCert poolParams + StakePoolRegistrationRequirementsPreConway atMostBab poolParams -> + shelleyToBabbageEraConstraints atMostBab + $ ShelleyRelatedCertificate atMostBab + $ Ledger.mkRegPoolTxCert poolParams data StakePoolRetirementRequirements era where StakePoolRetirementRequirementsConwayOnwards diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 59311d96ba..d19af134be 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -223,19 +223,10 @@ evaluateTransactionFee pp txbody keywitcount _byronwitcount = ByronTx{} -> case shelleyBasedEra :: ShelleyBasedEra era of {} --TODO: we could actually support Byron here, it'd be different but simpler - ShelleyTx sbe tx -> shelleyBasedEraConstraints sbe (evalShelleyBasedEra tx) - where - evalShelleyBasedEra :: forall ledgerera. - ShelleyLedgerEra era ~ ledgerera - => L.EraTx ledgerera - => Ledger.Tx ledgerera - -> Lovelace - evalShelleyBasedEra tx = - fromShelleyLovelace $ - Ledger.evaluateTransactionFee - pp - tx - keywitcount + ShelleyTx sbe tx -> + shelleyBasedEraConstraints sbe + $ fromShelleyLovelace + $ Ledger.evaluateTransactionFee pp tx keywitcount -- | Give an approximate count of the number of key witnesses (i.e. signatures) -- a transaction will need. @@ -1208,9 +1199,5 @@ calculateMinimumUTxO -> Lovelace calculateMinimumUTxO sbe txout pp = shelleyBasedEraConstraints sbe - $ calcMinUTxO pp (toShelleyTxOutAny sbe txout) - where - calcMinUTxO :: L.EraTxOut ledgerera => L.PParams ledgerera -> L.TxOut ledgerera -> Lovelace - calcMinUTxO pp' txOut = - let txOutWithMinCoin = L.setMinCoinTxOut pp' txOut + $ let txOutWithMinCoin = L.setMinCoinTxOut pp (toShelleyTxOutAny sbe txout) in fromShelleyLovelace (txOutWithMinCoin ^. L.coinTxOutL) diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs index e643c1780c..1c6ef023e9 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs @@ -67,38 +67,40 @@ data GovernanceAction deriving (Eq, Show) -toGovernanceAction - :: EraCrypto ledgerera ~ StandardCrypto - => ShelleyLedgerEra era ~ ledgerera +toGovernanceAction :: () => ShelleyBasedEra era -> GovernanceAction - -> Gov.GovAction ledgerera -toGovernanceAction _ (MotionOfNoConfidence prevGovId) = Gov.NoConfidence prevGovId -toGovernanceAction _ (ProposeNewConstitution prevGovAction anchor) = - Gov.NewConstitution prevGovAction Gov.Constitution - { Gov.constitutionAnchor = anchor - , Gov.constitutionScript = SNothing -- TODO: Conway era - } -toGovernanceAction _ (ProposeNewCommittee prevGovId oldCommitteeMembers newCommitteeMembers quor) = - Gov.UpdateCommittee - prevGovId -- previous governance action id - (Set.fromList $ map toCommitteeMember oldCommitteeMembers) -- members to remove - (Map.mapKeys toCommitteeMember newCommitteeMembers) -- members to add - (fromMaybe (error $ mconcat ["toGovernanceAction: the given quorum " - , show quor - , " was outside of the unit interval!" - ]) - $ boundRational @UnitInterval quor) -toGovernanceAction _ InfoAct = Gov.InfoAction -toGovernanceAction _ (TreasuryWithdrawal withdrawals) = - let m = Map.fromList [(L.mkRwdAcnt nw (toShelleyStakeCredential sc), toShelleyLovelace l) | (nw,sc,l) <- withdrawals] - in Gov.TreasuryWithdrawals m -toGovernanceAction _ (InitiateHardfork prevGovId pVer) = - Gov.HardForkInitiation prevGovId pVer -toGovernanceAction sbe (UpdatePParams preGovId ppup) = - case toLedgerPParamsUpdate sbe ppup of - Left e -> error $ "toGovernanceAction: " <> show e - Right ppup' -> Gov.ParameterChange preGovId ppup' + -> Gov.GovAction (ShelleyLedgerEra era) +toGovernanceAction sbe = + shelleyBasedEraConstraints sbe $ \case + MotionOfNoConfidence prevGovId -> + Gov.NoConfidence prevGovId + ProposeNewConstitution prevGovAction anchor -> + Gov.NewConstitution prevGovAction Gov.Constitution + { Gov.constitutionAnchor = anchor + , Gov.constitutionScript = SNothing -- TODO: Conway era + } + ProposeNewCommittee prevGovId oldCommitteeMembers newCommitteeMembers quor -> + Gov.UpdateCommittee + prevGovId -- previous governance action id + (Set.fromList $ map toCommitteeMember oldCommitteeMembers) -- members to remove + (Map.mapKeys toCommitteeMember newCommitteeMembers) -- members to add + (fromMaybe (error $ mconcat ["toGovernanceAction: the given quorum " + , show quor + , " was outside of the unit interval!" + ]) + $ boundRational @UnitInterval quor) + InfoAct -> + Gov.InfoAction + TreasuryWithdrawal withdrawals -> + let m = Map.fromList [(L.mkRwdAcnt nw (toShelleyStakeCredential sc), toShelleyLovelace l) | (nw,sc,l) <- withdrawals] + in Gov.TreasuryWithdrawals m + InitiateHardfork prevGovId pVer -> + Gov.HardForkInitiation prevGovId pVer + UpdatePParams preGovId ppup -> + case toLedgerPParamsUpdate sbe ppup of + Left e -> error $ "toGovernanceAction: " <> show e + Right ppup' -> Gov.ParameterChange preGovId ppup' fromGovernanceAction :: EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 663fff7045..21c52589f9 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -121,7 +121,7 @@ import qualified Cardano.Ledger.Api.Transition as Ledger import Cardano.Ledger.BaseTypes (Globals (..), Nonce, ProtVer (..), natVersion, (⭒)) import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.BHeaderView as Ledger -import Cardano.Ledger.Binary (DecoderError, FromCBOR) +import Cardano.Ledger.Binary (DecoderError) import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.PoolDistr as SL @@ -154,7 +154,6 @@ import qualified Ouroboros.Consensus.Ledger.Extended as Ledger import qualified Ouroboros.Consensus.Mempool.Capacity as TxLimits import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ConsensusProtocol (..)) -import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import Ouroboros.Consensus.Protocol.Praos.VRF (mkInputVRF, vrfLeaderValue) import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos @@ -167,11 +166,12 @@ import qualified Ouroboros.Network.Protocol.ChainSync.Client as CS import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as CSP import Ouroboros.Network.Protocol.ChainSync.PipelineDecision +import Control.Error.Util (note) import Control.Exception import Control.Monad (when) import Control.Monad.Trans.Class import Control.Monad.Trans.Except -import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, left) +import Control.Monad.Trans.Except.Extra import Data.Aeson as Aeson import Data.Aeson.Types (Parser) import Data.Bifunctor @@ -1428,10 +1428,7 @@ instance Error LeadershipError where "Error while calculating the slot range: " <> Text.unpack e displayError LeaderErrCandidateNonceStillEvolving = "Candidate nonce is still evolving" -nextEpochEligibleLeadershipSlots - :: forall era. () - => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) - => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) +nextEpochEligibleLeadershipSlots :: forall era. () => ShelleyBasedEra era -> ShelleyGenesis Shelley.StandardCrypto -> SerialisedCurrentEpochState era @@ -1446,81 +1443,82 @@ nextEpochEligibleLeadershipSlots -> EpochInfo (Either Text) -> (ChainTip, EpochNo) -> Either LeadershipError (Set SlotNo) -nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (VrfSigningKey vrfSkey) pp eInfo (cTip, currentEpoch) = do - (_, currentEpochLastSlot) <- first LeaderErrSlotRangeCalculationFailure - $ Slot.epochInfoRange eInfo currentEpoch - - (firstSlotOfEpoch, lastSlotofEpoch) <- first LeaderErrSlotRangeCalculationFailure - $ Slot.epochInfoRange eInfo (currentEpoch + 1) - - - -- First we check if we are within 3k/f slots of the end of the current epoch. - -- Why? Because the stake distribution is stable at this point. - -- k is the security parameter - -- f is the active slot coefficient - let stabilityWindowR :: Rational - stabilityWindowR = fromIntegral (3 * sgSecurityParam sGen) / Ledger.unboundRational (sgActiveSlotsCoeff sGen) - stabilityWindowSlots :: SlotNo - stabilityWindowSlots = fromIntegral @Word64 $ floor $ fromRational @Double stabilityWindowR - stableStakeDistribSlot = currentEpochLastSlot - stabilityWindowSlots - - - case cTip of - ChainTipAtGenesis -> Left LeaderErrGenesisSlot - ChainTip tip _ _ -> - if tip > stableStakeDistribSlot - then return () - else Left $ LeaderErrStakeDistribUnstable tip stableStakeDistribSlot stabilityWindowSlots currentEpochLastSlot - - chainDepState <- first LeaderErrDecodeProtocolStateFailure - $ decodeProtocolState ptclState - - -- We need the candidate nonce, the previous epoch's last block header hash - -- and the extra entropy from the protocol parameters. We then need to combine them - -- with the (⭒) operator. - let Consensus.PraosNonces { Consensus.candidateNonce, Consensus.evolvingNonce } = - Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState - - -- Let's do a nonce check. The candidate nonce and the evolving nonce should not be equal. - when (evolvingNonce == candidateNonce) - $ Left LeaderErrCandidateNonceStillEvolving - - -- Get the previous epoch's last block header hash nonce - let previousLabNonce = Consensus.previousLabNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) - extraEntropy :: Nonce - extraEntropy = - caseShelleyToAlonzoOrBabbageEraOnwards - (const (pp ^. Core.ppExtraEntropyL)) - (const Ledger.NeutralNonce) - sbe - - nextEpochsNonce = candidateNonce ⭒ previousLabNonce ⭒ extraEntropy - - -- Then we get the "mark" snapshot. This snapshot will be used for the next - -- epoch's leadership schedule. - CurrentEpochState cEstate <- first LeaderErrDecodeProtocolEpochStateFailure $ - decodeCurrentEpochState sbe serCurrEpochState - - let snapshot :: ShelleyAPI.SnapShot Shelley.StandardCrypto - snapshot = ShelleyAPI.ssStakeMark $ shelleyBasedEraConstraints sbe $ ShelleyAPI.esSnapshots cEstate - markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) - markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot - - let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo - slotRangeOfInterest pp' = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp' ^. Core.ppDG)) - $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] - - caseShelleyToAlonzoOrBabbageEraOnwards - (const (isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f)) - (const (isLeadingSlotsPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f)) - sbe - where - globals = shelleyBasedEraConstraints sbe - $ constructGlobals sGen eInfo $ pp ^. Core.ppProtocolVersionL - - f :: Ledger.ActiveSlotCoeff - f = activeSlotCoeff globals +nextEpochEligibleLeadershipSlots sbe sGen serCurrEpochState ptclState poolid (VrfSigningKey vrfSkey) pp eInfo (cTip, currentEpoch) = + shelleyBasedEraConstraints sbe $ do + (_, currentEpochLastSlot) <- first LeaderErrSlotRangeCalculationFailure + $ Slot.epochInfoRange eInfo currentEpoch + + (firstSlotOfEpoch, lastSlotofEpoch) <- first LeaderErrSlotRangeCalculationFailure + $ Slot.epochInfoRange eInfo (currentEpoch + 1) + + + -- First we check if we are within 3k/f slots of the end of the current epoch. + -- Why? Because the stake distribution is stable at this point. + -- k is the security parameter + -- f is the active slot coefficient + let stabilityWindowR :: Rational + stabilityWindowR = fromIntegral (3 * sgSecurityParam sGen) / Ledger.unboundRational (sgActiveSlotsCoeff sGen) + stabilityWindowSlots :: SlotNo + stabilityWindowSlots = fromIntegral @Word64 $ floor $ fromRational @Double stabilityWindowR + stableStakeDistribSlot = currentEpochLastSlot - stabilityWindowSlots + + + case cTip of + ChainTipAtGenesis -> Left LeaderErrGenesisSlot + ChainTip tip _ _ -> + if tip > stableStakeDistribSlot + then return () + else Left $ LeaderErrStakeDistribUnstable tip stableStakeDistribSlot stabilityWindowSlots currentEpochLastSlot + + chainDepState <- first LeaderErrDecodeProtocolStateFailure + $ decodeProtocolState ptclState + + -- We need the candidate nonce, the previous epoch's last block header hash + -- and the extra entropy from the protocol parameters. We then need to combine them + -- with the (⭒) operator. + let Consensus.PraosNonces { Consensus.candidateNonce, Consensus.evolvingNonce } = + Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState + + -- Let's do a nonce check. The candidate nonce and the evolving nonce should not be equal. + when (evolvingNonce == candidateNonce) $ + Left LeaderErrCandidateNonceStillEvolving + + -- Get the previous epoch's last block header hash nonce + let previousLabNonce = Consensus.previousLabNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) + extraEntropy :: Nonce + extraEntropy = + caseShelleyToAlonzoOrBabbageEraOnwards + (const (pp ^. Core.ppExtraEntropyL)) + (const Ledger.NeutralNonce) + sbe + + nextEpochsNonce = candidateNonce ⭒ previousLabNonce ⭒ extraEntropy + + -- Then we get the "mark" snapshot. This snapshot will be used for the next + -- epoch's leadership schedule. + CurrentEpochState cEstate <- + first LeaderErrDecodeProtocolEpochStateFailure $ + decodeCurrentEpochState sbe serCurrEpochState + + let snapshot :: ShelleyAPI.SnapShot Shelley.StandardCrypto + snapshot = ShelleyAPI.ssStakeMark $ ShelleyAPI.esSnapshots cEstate + markSnapshotPoolDistr :: Map (SL.KeyHash 'SL.StakePool Shelley.StandardCrypto) (SL.IndividualPoolStake Shelley.StandardCrypto) + markSnapshotPoolDistr = ShelleyAPI.unPoolDistr . ShelleyAPI.calculatePoolDistr $ snapshot + + let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo + slotRangeOfInterest pp' = Set.filter + (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp' ^. Core.ppDG)) + $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] + + caseShelleyToAlonzoOrBabbageEraOnwards + (const (isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f)) + (const (isLeadingSlotsPraos (slotRangeOfInterest pp) poolid markSnapshotPoolDistr nextEpochsNonce vrfSkey f)) + sbe + where + globals = shelleyBasedEraConstraints sbe $ constructGlobals sGen eInfo $ pp ^. Core.ppProtocolVersionL + + f :: Ledger.ActiveSlotCoeff + f = activeSlotCoeff globals -- | Return slots a given stake pool operator is leading. @@ -1543,8 +1541,9 @@ isLeadingSlotsTPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey let certifiedVrf s = Crypto.evalCertified () (TPraos.mkSeed TPraos.seedL s eNonce) vrfSkey - stakePoolStake <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid) Right $ + stakePoolStake <- ShelleyAPI.individualPoolStake <$> Map.lookup poolHash snapshotPoolDistr + & note (LeaderErrStakePoolHasNoStake poolid) let isLeader s = TPraos.checkLeaderValue (Crypto.certifiedOutput (certifiedVrf s)) stakePoolStake activeSlotCoeff' @@ -1561,7 +1560,7 @@ isLeadingSlotsPraos :: () isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey activeSlotCoeff' = do let StakePoolKeyHash poolHash = poolid - stakePoolStake <- maybe (Left $ LeaderErrStakePoolHasNoStake poolid) Right $ + stakePoolStake <- note (LeaderErrStakePoolHasNoStake poolid) $ ShelleyAPI.individualPoolStake <$> Map.lookup poolHash snapshotPoolDistr let isLeader slotNo = checkLeaderNatValue certifiedNatValue stakePoolStake activeSlotCoeff' @@ -1573,9 +1572,6 @@ isLeadingSlotsPraos slotRangeOfInterest poolid snapshotPoolDistr eNonce vrfSkey -- | Return the slots at which a particular stake pool operator is -- expected to mint a block. currentEpochEligibleLeadershipSlots :: forall era. () - => Consensus.PraosProtocolSupportsNode (Api.ConsensusProtocol era) - => FromCBOR (Consensus.ChainDepState (Api.ConsensusProtocol era)) - => Shelley.EraCrypto (ShelleyLedgerEra era) ~ Shelley.StandardCrypto => ShelleyBasedEra era -> ShelleyGenesis Shelley.StandardCrypto -> EpochInfo (Either Text) @@ -1586,39 +1582,38 @@ currentEpochEligibleLeadershipSlots :: forall era. () -> SerialisedPoolDistribution era -> EpochNo -- ^ Current EpochInfo -> Either LeadershipError (Set SlotNo) -currentEpochEligibleLeadershipSlots sbe sGen eInfo pp ptclState poolid (VrfSigningKey vrkSkey) serPoolDistr currentEpoch = do +currentEpochEligibleLeadershipSlots sbe sGen eInfo pp ptclState poolid (VrfSigningKey vrkSkey) serPoolDistr currentEpoch = + shelleyBasedEraConstraints sbe $ do + chainDepState :: ChainDepState (Api.ConsensusProtocol era) <- + first LeaderErrDecodeProtocolStateFailure $ decodeProtocolState ptclState - chainDepState :: ChainDepState (Api.ConsensusProtocol era) <- - first LeaderErrDecodeProtocolStateFailure $ decodeProtocolState ptclState + -- We use the current epoch's nonce for the current leadership schedule + -- calculation because the TICKN transition updates the epoch nonce + -- at the start of the epoch. + let epochNonce :: Nonce = Consensus.epochNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) - -- We use the current epoch's nonce for the current leadership schedule - -- calculation because the TICKN transition updates the epoch nonce - -- at the start of the epoch. - let epochNonce :: Nonce = Consensus.epochNonce (Consensus.getPraosNonces (Proxy @(Api.ConsensusProtocol era)) chainDepState) + (firstSlotOfEpoch, lastSlotofEpoch) :: (SlotNo, SlotNo) <- first LeaderErrSlotRangeCalculationFailure + $ Slot.epochInfoRange eInfo currentEpoch - (firstSlotOfEpoch, lastSlotofEpoch) :: (SlotNo, SlotNo) <- first LeaderErrSlotRangeCalculationFailure - $ Slot.epochInfoRange eInfo currentEpoch + setSnapshotPoolDistr <- + first LeaderErrDecodeProtocolEpochStateFailure . fmap (SL.unPoolDistr . unPoolDistr) + $ decodePoolDistribution sbe serPoolDistr - setSnapshotPoolDistr <- - first LeaderErrDecodeProtocolEpochStateFailure . fmap (SL.unPoolDistr . unPoolDistr) - $ decodePoolDistribution sbe serPoolDistr + let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo + slotRangeOfInterest pp' = Set.filter + (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp' ^. Core.ppDG)) + $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] - let slotRangeOfInterest :: Core.EraPParams ledgerera => Core.PParams ledgerera -> Set SlotNo - slotRangeOfInterest pp' = Set.filter - (not . Ledger.isOverlaySlot firstSlotOfEpoch (pp' ^. Core.ppDG)) - $ Set.fromList [firstSlotOfEpoch .. lastSlotofEpoch] + caseShelleyToAlonzoOrBabbageEraOnwards + (const (isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f)) + (const (isLeadingSlotsPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f)) + sbe - caseShelleyToAlonzoOrBabbageEraOnwards - (const (isLeadingSlotsTPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f)) - (const (isLeadingSlotsPraos (slotRangeOfInterest pp) poolid setSnapshotPoolDistr epochNonce vrkSkey f)) - sbe - - where - globals = shelleyBasedEraConstraints sbe - $ constructGlobals sGen eInfo $ pp ^. Core.ppProtocolVersionL + where + globals = shelleyBasedEraConstraints sbe $ constructGlobals sGen eInfo $ pp ^. Core.ppProtocolVersionL - f :: Ledger.ActiveSlotCoeff - f = activeSlotCoeff globals + f :: Ledger.ActiveSlotCoeff + f = activeSlotCoeff globals constructGlobals :: ShelleyGenesis Shelley.StandardCrypto diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index 0bc1a2a71c..bc68e62601 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -97,6 +97,8 @@ module Cardano.Api.ProtocolParameters ( ) where import Cardano.Api.Address +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras import Cardano.Api.Eras.Constraints @@ -178,13 +180,13 @@ convertToLedgerProtocolParameters sbe pp = LedgerProtocolParameters <$> toLedgerPParams sbe pp createPParams - :: EraPParams (ShelleyLedgerEra era) - => ShelleyBasedEra era + :: ShelleyBasedEra era -> EraBasedProtocolParametersUpdate era -> Ledger.PParams (ShelleyLedgerEra era) createPParams sbe ebPParamsUpdate = - let ppUp = createEraBasedProtocolParamUpdate sbe ebPParamsUpdate - in Ledger.applyPPUpdates emptyPParams ppUp + shelleyBasedEraConstraints sbe $ + let ppUp = createEraBasedProtocolParamUpdate sbe ebPParamsUpdate + in Ledger.applyPPUpdates emptyPParams ppUp -- ----------------------------------------------------------------------------- -- Era based Ledger protocol parameters update @@ -289,21 +291,21 @@ createEraBasedProtocolParamUpdate sbe eraPParamsUpdate = AlonzoEraBasedProtocolParametersUpdate c depAfterAlonzoA introInAlon depAfterAlonzoB -> let Ledger.PParamsUpdate common = createCommonPParamsUpdate c - Ledger.PParamsUpdate preAl' = createPParamsUpdateIntroducedInAlonzo sbe introInAlon + Ledger.PParamsUpdate preAl' = createPParamsUpdateIntroducedInAlonzo AlonzoEraOnwardsAlonzo introInAlon Ledger.PParamsUpdate depAfterAlonzoA' = createDeprecatedAfterAlonzoPParams' sbe depAfterAlonzoA Ledger.PParamsUpdate depAfterAlonzoB' = createDeprecatedAfterAlonzoPParams sbe depAfterAlonzoB in Ledger.PParamsUpdate $ common <> preAl' <> depAfterAlonzoA' <> depAfterAlonzoB' BabbageEraBasedProtocolParametersUpdate c introInAlonzo introInBabbage -> let Ledger.PParamsUpdate common = createCommonPParamsUpdate c - Ledger.PParamsUpdate inAlonzoPParams = createPParamsUpdateIntroducedInAlonzo sbe introInAlonzo - Ledger.PParamsUpdate inBAb = createIntroducedInBabbagePParams sbe introInBabbage + Ledger.PParamsUpdate inAlonzoPParams = createPParamsUpdateIntroducedInAlonzo AlonzoEraOnwardsBabbage introInAlonzo + Ledger.PParamsUpdate inBAb = createIntroducedInBabbagePParams BabbageEraOnwardsBabbage introInBabbage in Ledger.PParamsUpdate $ common <> inAlonzoPParams <> inBAb ConwayEraBasedProtocolParametersUpdate c introInAlonzo introInBabbage introInConway -> let Ledger.PParamsUpdate common = createCommonPParamsUpdate c - Ledger.PParamsUpdate inAlonzoPParams = createPParamsUpdateIntroducedInAlonzo sbe introInAlonzo - Ledger.PParamsUpdate inBab = createIntroducedInBabbagePParams sbe introInBabbage + Ledger.PParamsUpdate inAlonzoPParams = createPParamsUpdateIntroducedInAlonzo AlonzoEraOnwardsConway introInAlonzo + Ledger.PParamsUpdate inBab = createIntroducedInBabbagePParams BabbageEraOnwardsConway introInBabbage Ledger.PParamsUpdate inCon = createIntroducedInConwayPParams introInConway in Ledger.PParamsUpdate $ common <> inAlonzoPParams <> inBab <> inCon @@ -409,13 +411,13 @@ data AlonzoOnwardsPParams ledgerera } deriving Show -createPParamsUpdateIntroducedInAlonzo - :: AlonzoEraPParams (ShelleyLedgerEra era) - => ShelleyBasedEra era +createPParamsUpdateIntroducedInAlonzo :: () + => AlonzoEraOnwards era -> AlonzoOnwardsPParams era -> Ledger.PParamsUpdate (ShelleyLedgerEra era) -createPParamsUpdateIntroducedInAlonzo _ (AlonzoOnwardsPParams {..})= - Ledger.emptyPParamsUpdate +createPParamsUpdateIntroducedInAlonzo w (AlonzoOnwardsPParams {..})= + alonzoEraOnwardsConstraints w $ + Ledger.emptyPParamsUpdate & Ledger.ppuCostModelsL .~ alCostModels & Ledger.ppuPricesL .~ alPrices & Ledger.ppuMaxTxExUnitsL .~ alMaxTxExUnits @@ -429,14 +431,13 @@ newtype IntroducedInBabbagePParams era (StrictMaybe CoinPerByte) -- ^ Coins per UTxO byte deriving Show -createIntroducedInBabbagePParams - :: Ledger.BabbageEraPParams (ShelleyLedgerEra era) - => ShelleyBasedEra era +createIntroducedInBabbagePParams :: () + => BabbageEraOnwards era -> IntroducedInBabbagePParams era -> Ledger.PParamsUpdate (ShelleyLedgerEra era) -createIntroducedInBabbagePParams _ (IntroducedInBabbagePParams coinsPerUTxOByte) = - Ledger.emptyPParamsUpdate - & Ledger.ppuCoinsPerUTxOByteL .~ coinsPerUTxOByte +createIntroducedInBabbagePParams w (IntroducedInBabbagePParams coinsPerUTxOByte) = + babbageEraOnwardsConstraints w $ + Ledger.emptyPParamsUpdate & Ledger.ppuCoinsPerUTxOByteL .~ coinsPerUTxOByte -- | The values of the set of /updatable/ protocol parameters. At any -- particular point on the chain there is a current set of parameters in use. @@ -1240,24 +1241,20 @@ makeShelleyUpdateProposal params genesisKeyHashes = -- Conversion functions: updates to ledger types -- -toLedgerUpdate :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => Ledger.EraCrypto ledgerera ~ StandardCrypto - => ShelleyBasedEra era - -> UpdateProposal - -> Either ProtocolParametersConversionError (Ledger.Update ledgerera) +toLedgerUpdate :: () + => ShelleyBasedEra era + -> UpdateProposal + -> Either ProtocolParametersConversionError (Ledger.Update (ShelleyLedgerEra era)) toLedgerUpdate sbe (UpdateProposal ppup epochno) = (`Ledger.Update` epochno) <$> toLedgerProposedPPUpdates sbe ppup - -toLedgerProposedPPUpdates :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => Ledger.EraCrypto ledgerera ~ StandardCrypto - => ShelleyBasedEra era - -> Map (Hash GenesisKey) ProtocolParametersUpdate - -> Either ProtocolParametersConversionError (Ledger.ProposedPPUpdates ledgerera) +toLedgerProposedPPUpdates :: () + => ShelleyBasedEra era + -> Map (Hash GenesisKey) ProtocolParametersUpdate + -> Either ProtocolParametersConversionError (Ledger.ProposedPPUpdates (ShelleyLedgerEra era)) toLedgerProposedPPUpdates sbe m = - Ledger.ProposedPPUpdates . Map.mapKeysMonotonic (\(GenesisKeyHash kh) -> kh) <$> traverse (toLedgerPParamsUpdate sbe) m + shelleyBasedEraConstraints sbe $ + Ledger.ProposedPPUpdates . Map.mapKeysMonotonic (\(GenesisKeyHash kh) -> kh) <$> traverse (toLedgerPParamsUpdate sbe) m toLedgerPParamsUpdate :: ShelleyBasedEra era -> ProtocolParametersUpdate diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 23ac25c014..11527ebd54 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -489,29 +489,29 @@ toShelleyAddrSet era = . Set.toList -toLedgerUTxO :: ShelleyLedgerEra era ~ ledgerera - => Core.EraCrypto ledgerera ~ StandardCrypto - => ShelleyBasedEra era - -> UTxO era - -> Shelley.UTxO ledgerera +toLedgerUTxO :: () + => ShelleyBasedEra era + -> UTxO era + -> Shelley.UTxO (ShelleyLedgerEra era) toLedgerUTxO sbe (UTxO utxo) = - Shelley.UTxO - . Map.fromList - . map (bimap toShelleyTxIn (toShelleyTxOut sbe)) - . Map.toList - $ utxo - -fromLedgerUTxO :: ShelleyLedgerEra era ~ ledgerera - => Core.EraCrypto ledgerera ~ StandardCrypto - => ShelleyBasedEra era - -> Shelley.UTxO ledgerera - -> UTxO era + shelleyBasedEraConstraints sbe + $ Shelley.UTxO + . Map.fromList + . map (bimap toShelleyTxIn (toShelleyTxOut sbe)) + . Map.toList + $ utxo + +fromLedgerUTxO :: () + => ShelleyBasedEra era + -> Shelley.UTxO (ShelleyLedgerEra era) + -> UTxO era fromLedgerUTxO sbe (Shelley.UTxO utxo) = - UTxO - . Map.fromList - . map (bimap fromShelleyTxIn (fromShelleyTxOut sbe)) - . Map.toList - $ utxo + shelleyBasedEraConstraints sbe + $ UTxO + . Map.fromList + . map (bimap fromShelleyTxIn (fromShelleyTxOut sbe)) + . Map.toList + $ utxo fromShelleyPoolDistr :: Shelley.PoolDistr StandardCrypto -> Map (Hash StakePoolKey) Rational diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index d176f9ef91..da06416aff 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -2714,12 +2714,10 @@ convValidityInterval (lowerBound, upperBound) = } -- | Convert transaction update proposal into ledger update proposal -convTxUpdateProposal - :: forall era ledgerera. ShelleyLedgerEra era ~ ledgerera - => Ledger.EraCrypto ledgerera ~ StandardCrypto +convTxUpdateProposal :: () => ShelleyBasedEra era -> TxUpdateProposal era - -> Either TxBodyError (StrictMaybe (Ledger.Update ledgerera)) + -> Either TxBodyError (StrictMaybe (Ledger.Update (ShelleyLedgerEra era))) -- ^ 'Left' when there's protocol params conversion error, 'Right' otherwise, 'Right SNothing' means that -- there's no update proposal convTxUpdateProposal sbe = \case