From d64776e3a3ceeb8668b23c2a97fbcfaefa247569 Mon Sep 17 00:00:00 2001 From: John Ky Date: Mon, 24 Jul 2023 20:10:26 +1000 Subject: [PATCH] Tighten era bounds to ConwaryEraOnwards --- cardano-api/internal/Cardano/Api/Eras.hs | 1 + cardano-api/internal/Cardano/Api/Feature.hs | 1 + .../Governance/Actions/ProposalProcedure.hs | 108 +++++++++++------- .../Api/Governance/Actions/VotingProcedure.hs | 57 +++++---- 4 files changed, 102 insertions(+), 65 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index a420e4fa4d..4542f35ca6 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} diff --git a/cardano-api/internal/Cardano/Api/Feature.hs b/cardano-api/internal/Cardano/Api/Feature.hs index 85094928e1..0271f0e08d 100644 --- a/cardano-api/internal/Cardano/Api/Feature.hs +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs index 2182f47b2c..fc5027f878 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -9,16 +10,28 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Cardano.Api.Governance.Actions.ProposalProcedure where +module Cardano.Api.Governance.Actions.ProposalProcedure + ( TxGovernanceActions(..) + , TxGovernanceActionSupportedInEra(..) + , governanceActionsSupportedInEra + , AnyGovernanceAction(..) + , GovernanceAction(..) + , toSafeHash + , toGovernanceAction + , fromGovernanceAction + , Proposal(..) + , createProposalProcedure + , fromProposalProcedure + ) where import Cardano.Api.Address import Cardano.Api.Eras +import Cardano.Api.Feature.ConwayEraOnwards import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Shelley import Cardano.Api.ProtocolParameters import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseTextEnvelope -import Cardano.Api.Utils import Cardano.Api.Value import qualified Cardano.Binary as CBOR @@ -92,47 +105,54 @@ toSafeHash = makeHashWithExplicitProxys (Proxy :: Proxy StandardCrypto) (Proxy toGovernanceAction :: EraCrypto ledgerera ~ StandardCrypto => ShelleyLedgerEra era ~ ledgerera - => ShelleyBasedEra era + => ConwayEraOnwards era -> GovernanceAction -> Gov.GovernanceAction ledgerera -toGovernanceAction _ MotionOfNoConfidence = Gov.NoConfidence -toGovernanceAction _ (ProposeNewConstitution bs) = - Gov.NewConstitution $ toSafeHash bs -toGovernanceAction _ (ProposeNewCommittee stakeKeys quor) = - Gov.NewCommittee (Set.fromList $ map (\(StakeKeyHash sk) -> coerceKeyRole sk) stakeKeys) quor -toGovernanceAction _ InfoAct = Gov.InfoAction -toGovernanceAction _ (TreasuryWithdrawal withdrawals) = - let m = Map.fromList [(toShelleyStakeCredential sc, toShelleyLovelace l) | (sc,l) <- withdrawals] - in Gov.TreasuryWithdrawals m -toGovernanceAction _ (InitiateHardfork pVer) = Gov.HardForkInitiation pVer -toGovernanceAction sbe (UpdatePParams ppup) = - case toLedgerPParamsUpdate sbe ppup of - Left e -> error $ "toGovernanceAction: " <> show e - -- TODO: Conway era - remove use of error. Ideally we will use the ledger's PParams type - -- in place of ProtocolParametersUpdate - Right ppup' -> Gov.ParameterChange ppup' +toGovernanceAction w = \case + MotionOfNoConfidence -> + Gov.NoConfidence + ProposeNewConstitution bs -> + Gov.NewConstitution $ toSafeHash bs + ProposeNewCommittee stakeKeys quor -> + Gov.NewCommittee (Set.fromList $ map (\(StakeKeyHash sk) -> coerceKeyRole sk) stakeKeys) quor + InfoAct -> + Gov.InfoAction + TreasuryWithdrawal withdrawals -> + let m = Map.fromList [(toShelleyStakeCredential sc, toShelleyLovelace l) | (sc,l) <- withdrawals] + in Gov.TreasuryWithdrawals m + InitiateHardfork pVer -> + Gov.HardForkInitiation pVer + UpdatePParams ppup -> + case toLedgerPParamsUpdate (conwayEraOnwardsToShelleyBasedEra w) ppup of + Left e -> error $ "toGovernanceAction: " <> show e + -- TODO: Conway era - remove use of error. Ideally we will use the ledger's PParams type + -- in place of ProtocolParametersUpdate + Right ppup' -> Gov.ParameterChange ppup' fromGovernanceAction :: EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => ShelleyBasedEra era + => ConwayEraOnwards era -> Gov.GovernanceAction (ShelleyLedgerEra era) -> GovernanceAction -fromGovernanceAction _ Gov.NoConfidence = MotionOfNoConfidence -fromGovernanceAction sbe (Gov.NewConstitution h) = - ProposeNewConstitution $ obtainSafeToHashConstraint sbe $ originalBytes h -fromGovernanceAction sbe (Gov.ParameterChange pparams) = - UpdatePParams $ fromLedgerPParamsUpdate sbe pparams -fromGovernanceAction _ (Gov.HardForkInitiation pVer) = - InitiateHardfork pVer -fromGovernanceAction _ (Gov.TreasuryWithdrawals withdrawlMap) = - let res = [ (fromShelleyStakeCredential lScred , fromShelleyLovelace coin) - | (lScred, coin) <- Map.toList withdrawlMap - ] - in TreasuryWithdrawal res -fromGovernanceAction _ (Gov.NewCommittee proposedMembers quor) = - let stakeCred = map (StakeKeyHash . coerceKeyRole) $ Set.toList proposedMembers - in ProposeNewCommittee stakeCred quor -fromGovernanceAction _ Gov.InfoAction = InfoAct +fromGovernanceAction w = \case + Gov.NoConfidence -> + MotionOfNoConfidence + Gov.NewConstitution h -> + conwayEraOnwardsConstraints w $ ProposeNewConstitution $ originalBytes h + Gov.ParameterChange pparams -> + UpdatePParams $ fromLedgerPParamsUpdate (conwayEraOnwardsToShelleyBasedEra w) pparams + Gov.HardForkInitiation pVer -> + InitiateHardfork pVer + Gov.TreasuryWithdrawals withdrawlMap -> + let res = [ (fromShelleyStakeCredential lScred , fromShelleyLovelace coin) + | (lScred, coin) <- Map.toList withdrawlMap + ] + in TreasuryWithdrawal res + Gov.NewCommittee proposedMembers quor -> + let stakeCred = map (StakeKeyHash . coerceKeyRole) $ Set.toList proposedMembers + in ProposeNewCommittee stakeCred quor + Gov.InfoAction -> + InfoAct newtype Proposal era = Proposal { unProposal :: Gov.ProposalProcedure (ShelleyLedgerEra era) } @@ -163,26 +183,26 @@ instance HasTypeProxy era => HasTypeProxy (Proposal era) where createProposalProcedure - :: ShelleyBasedEra era + :: ConwayEraOnwards era -> Lovelace -- ^ Deposit -> Hash StakeKey -- ^ Return address -> GovernanceAction -> Proposal era -createProposalProcedure sbe dep (StakeKeyHash retAddrh) govAct = - Proposal $ obtainEraCryptoConstraints sbe $ +createProposalProcedure w dep (StakeKeyHash retAddrh) govAct = + Proposal $ conwayEraOnwardsConstraints w $ Gov.ProposalProcedure { Gov.pProcDeposit = toShelleyLovelace dep , Gov.pProcReturnAddr = retAddrh - , Gov.pProcGovernanceAction = toGovernanceAction sbe govAct + , Gov.pProcGovernanceAction = toGovernanceAction w govAct , Gov.pProcAnchor = SNothing -- TODO: Conway } fromProposalProcedure - :: ShelleyBasedEra era + :: ConwayEraOnwards era -> Proposal era -> (Lovelace, Hash StakeKey, GovernanceAction) -fromProposalProcedure sbe (Proposal pp) = +fromProposalProcedure w (Proposal pp) = ( fromShelleyLovelace $ Gov.pProcDeposit pp - , StakeKeyHash (obtainEraCryptoConstraints sbe (Gov.pProcReturnAddr pp)) - , obtainEraCryptoConstraints sbe $ fromGovernanceAction sbe (Gov.pProcGovernanceAction pp) + , StakeKeyHash (conwayEraOnwardsConstraints w (Gov.pProcReturnAddr pp)) + , conwayEraOnwardsConstraints w $ fromGovernanceAction w (Gov.pProcGovernanceAction pp) ) diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index ac49ac5d79..9acc86e7b3 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -12,10 +12,26 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Cardano.Api.Governance.Actions.VotingProcedure where +module Cardano.Api.Governance.Actions.VotingProcedure + ( TxVotes(..) + , TxVotesSupportedInEra(..) + , votesSupportedInEra + , GovernanceActionId(..) + , makeGoveranceActionId + , Voter(..) + , Vote(..) + , toVoterRole + , toVote + , toVotingCredential + , eraDecodeVotingCredential + , VotingCredential(..) + , createVotingProcedure + , VotingProcedure(..) + ) where import Cardano.Api.Address import Cardano.Api.Eras +import Cardano.Api.Feature.ConwayEraOnwards import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Shelley import Cardano.Api.Script @@ -23,7 +39,6 @@ import Cardano.Api.SerialiseCBOR (FromCBOR (fromCBOR), SerialiseAsCBOR ToCBOR (toCBOR)) import Cardano.Api.SerialiseTextEnvelope import Cardano.Api.TxIn -import Cardano.Api.Utils import qualified Cardano.Binary as CBOR import qualified Cardano.Ledger.BaseTypes as Ledger @@ -69,13 +84,13 @@ deriving instance Eq (TxVotesSupportedInEra era) votesSupportedInEra :: ShelleyBasedEra era -> Maybe (TxVotesSupportedInEra era) -votesSupportedInEra ShelleyBasedEraShelley = Nothing -votesSupportedInEra ShelleyBasedEraAllegra = Nothing -votesSupportedInEra ShelleyBasedEraMary = Nothing -votesSupportedInEra ShelleyBasedEraAlonzo = Nothing -votesSupportedInEra ShelleyBasedEraBabbage = Nothing -votesSupportedInEra ShelleyBasedEraConway = Just VotesSupportedInConwayEra - +votesSupportedInEra = \case + ShelleyBasedEraShelley -> Nothing + ShelleyBasedEraAllegra -> Nothing + ShelleyBasedEraMary -> Nothing + ShelleyBasedEraAlonzo -> Nothing + ShelleyBasedEraBabbage -> Nothing + ShelleyBasedEraConway -> Just VotesSupportedInConwayEra newtype GovernanceActionId ledgerera = GovernanceActionId { unGovernanceActionId :: Ledger.GovernanceActionId (EraCrypto ledgerera) @@ -83,12 +98,12 @@ newtype GovernanceActionId ledgerera = GovernanceActionId deriving (Show, Eq) makeGoveranceActionId - :: ShelleyBasedEra era + :: ConwayEraOnwards era -> TxIn -> GovernanceActionId (ShelleyLedgerEra era) -makeGoveranceActionId sbe txin = +makeGoveranceActionId w txin = let Ledger.TxIn txid (Ledger.TxIx txix) = toShelleyTxIn txin - in obtainEraCryptoConstraints sbe + in conwayEraOnwardsConstraints w $ GovernanceActionId $ Ledger.GovernanceActionId { Ledger.gaidTxId = txid @@ -113,7 +128,7 @@ data Vote toVoterRole :: EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => ShelleyBasedEra era + => ConwayEraOnwards era -> Voter era -> Ledger.Voter (Shelley.EraCrypto (ShelleyLedgerEra era)) toVoterRole _ = \case @@ -131,7 +146,7 @@ toVote = \case Abstain -> Ledger.Abstain toVotingCredential - :: ShelleyBasedEra era + :: ConwayEraOnwards era -> StakeCredential -> Either Plain.DecoderError (VotingCredential era) toVotingCredential sbe (StakeCredentialByKey (StakeKeyHash kh)) = do @@ -148,11 +163,11 @@ toVotingCredential _sbe (StakeCredentialByScript (ScriptHash _sh)) = -- This is a hack. data StakeCredential in cardano-api is not parameterized by era, it defaults to StandardCrypto. -- However VotingProcedure is parameterized on era. We need to also parameterize StakeCredential on era. eraDecodeVotingCredential - :: ShelleyBasedEra era + :: ConwayEraOnwards era -> ByteString -> Either Plain.DecoderError (VotingCredential era) -eraDecodeVotingCredential sbe bs = - obtainCryptoConstraints sbe $ +eraDecodeVotingCredential w bs = + conwayEraOnwardsConstraints w $ case Plain.decodeFull bs of Left e -> Left e Right x -> Right $ VotingCredential x @@ -165,16 +180,16 @@ deriving instance Show (VotingCredential crypto) deriving instance Eq (VotingCredential crypto) createVotingProcedure - :: ShelleyBasedEra era + :: ConwayEraOnwards era -> Vote -> Voter era -> GovernanceActionId (ShelleyLedgerEra era) -> VotingProcedure era -createVotingProcedure sbe vChoice vt (GovernanceActionId govActId) = - obtainEraCryptoConstraints sbe +createVotingProcedure w vChoice vt (GovernanceActionId govActId) = + conwayEraOnwardsConstraints w $ VotingProcedure $ Ledger.VotingProcedure { Ledger.vProcGovActionId = govActId - , Ledger.vProcVoter = toVoterRole sbe vt + , Ledger.vProcVoter = toVoterRole w vt , Ledger.vProcVote = toVote vChoice , Ledger.vProcAnchor = SNothing -- TODO: Conway }