From 58d7f3ee4d92475b8f4447b7a6828addc7bbd33c Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 14 Jul 2023 15:13:32 -0400 Subject: [PATCH 01/10] Introduce internal module Cardano.Api.ReexposeLedger. This module imports cardano-ledger's Cardano.Ledger.Api module and other necessary modules from cardano-ledger Introduce external module Cardano.Api.Ledger. This module reexports Cardano.Api.ReexposeLedger with the aim of transitioning cardano-api (and cardano-cli) to be fully reliant on cardano-ledger-api --- cardano-api/cardano-api.cabal | 6 ++ .../internal/Cardano/Api/ReexposeLedger.hs | 66 +++++++++++++++++++ cardano-api/src/Cardano/Api/Ledger.hs | 6 ++ 3 files changed, 78 insertions(+) create mode 100644 cardano-api/internal/Cardano/Api/ReexposeLedger.hs create mode 100644 cardano-api/src/Cardano/Api/Ledger.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index d88c2a1ab9..efddcc37a5 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -91,6 +91,7 @@ library internal Cardano.Api.ProtocolParameters Cardano.Api.Query Cardano.Api.Query.Expr + Cardano.Api.ReexposeLedger Cardano.Api.Script Cardano.Api.ScriptData Cardano.Api.SerialiseBech32 @@ -193,6 +194,11 @@ library Cardano.Api.ChainSync.ClientPipelined Cardano.Api.Crypto.Ed25519Bip32 Cardano.Api.Shelley + -- TODO: Eliminate Cardano.Api.Ledger when + -- cardano-api only depends on modules + -- exposed by cardano-api-ledger + Cardano.Api.Ledger + build-depends: bytestring , cardano-api:internal diff --git a/cardano-api/internal/Cardano/Api/ReexposeLedger.hs b/cardano-api/internal/Cardano/Api/ReexposeLedger.hs new file mode 100644 index 0000000000..369d4ff546 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/ReexposeLedger.hs @@ -0,0 +1,66 @@ +module Cardano.Api.ReexposeLedger + ( module Cardano.Ledger.Api + , Credential (..) + , KeyHash(..) + , KeyRole(..) + , ShelleyTxCert(..) + , ShelleyDelegCert(..) + , ShelleyEraTxCert(..) + , GenesisDelegCert(..) + , PoolParams (..) + , HasKeyRole(..) + , MIRPot(..) + , MIRTarget(..) + , MIRCert(..) + , StakePoolRelay(..) + , PoolMetadata(..) + , EraTxCert(..) + + -- Core + , PoolCert(..) + , toEraCBOR + , fromEraCBOR + + -- Conway + , ConwayTxCert(..) + , ConwayCommitteeCert(..) + , ConwayDelegCert(..) + , ConwayEraTxCert(..) + + -- Base + , boundRational + , unboundRational + , DnsName + , dnsToText + , textToDns + , Url + , urlToText + , textToUrl + , portToWord16 + , strictMaybeToMaybe + , maybeToStrictMaybe + + -- Crypto + , hashToBytes + , hashFromBytes + + -- Slotting + , EpochNo(..) + ) where + +import Cardano.Crypto.Hash.Class (hashFromBytes, hashToBytes) +import Cardano.Ledger.Api +import Cardano.Ledger.BaseTypes (DnsName, Url, boundRational, dnsToText, + maybeToStrictMaybe, portToWord16, strictMaybeToMaybe, textToDns, textToUrl, + unboundRational, urlToText) +import Cardano.Ledger.Conway.TxCert (ConwayCommitteeCert (..), ConwayDelegCert (..), + ConwayEraTxCert (..), ConwayTxCert (..)) +import Cardano.Ledger.Core (PoolCert (..), fromEraCBOR, toEraCBOR) +import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.Keys (HasKeyRole (..), KeyHash (..), KeyRole (..)) +import Cardano.Ledger.PoolParams (PoolMetadata (..), PoolParams (..), StakePoolRelay (..)) +import Cardano.Ledger.Shelley.TxCert (EraTxCert (..), GenesisDelegCert (..), MIRCert (..), + MIRPot (..), MIRTarget (..), ShelleyDelegCert (..), ShelleyEraTxCert (..), + ShelleyTxCert (..)) +import Cardano.Slotting.Slot (EpochNo (..)) + diff --git a/cardano-api/src/Cardano/Api/Ledger.hs b/cardano-api/src/Cardano/Api/Ledger.hs new file mode 100644 index 0000000000..7d8caba1e4 --- /dev/null +++ b/cardano-api/src/Cardano/Api/Ledger.hs @@ -0,0 +1,6 @@ +module Cardano.Api.Ledger + ( module Cardano.Api.ReexposeLedger + ) + where + +import Cardano.Api.ReexposeLedger From 8a042a9aafca23044861ab3241c9276b8c95b469 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 14 Jul 2023 15:19:11 -0400 Subject: [PATCH 02/10] Redefine Certificate era to be a sum type of two data constructors: ShelleyRelatedCertificate and ConwayCertificate. These wrap the data types exposed by cardano-ledger that correspond to the certificates of the aforementioned eras. Certificate era is also a GADT now. --- .../internal/Cardano/Api/Certificate.hs | 49 +++++++++---------- 1 file changed, 23 insertions(+), 26 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 5e0fd5ccb3..8255e6a701 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -92,35 +92,32 @@ import Network.Socket (PortNumber) -- Certificates embedded in transactions -- -data Certificate era = +data Certificate era where + -- Pre-Conway + -- 1. Stake registration + -- 2. Stake unregistration + -- 3. Stake delegation + -- 4. Pool retirement + -- 5. Pool registration + -- 6. Genesis delegation + -- 7. MIR certificates + ShelleyRelatedCertificate + :: AtMostBabbageEra era + -> Ledger.ShelleyTxCert (ShelleyLedgerEra era) + -> Certificate era + + -- Conway onwards + -- TODO: Add comments about the new types of certificates + ConwayCertificate + :: ConwayEraOnwards era + -> Ledger.ConwayTxCert (ShelleyLedgerEra era) + -> Certificate era - -- Stake address certificates - StakeAddressRegistrationCertificate StakeCredential - | StakeAddressDeregistrationCertificate StakeCredential - | StakeAddressPoolDelegationCertificate StakeCredential PoolId - - -- Stake pool certificates - | StakePoolRegistrationCertificate StakePoolParameters - | StakePoolRetirementCertificate PoolId EpochNo - - -- Special certificates - | GenesisKeyDelegationCertificate - (Hash GenesisKey) - (Hash GenesisDelegateKey) - (Hash VrfKey) - - | CommitteeDelegationCertificate - (Hash CommitteeColdKey) - (Hash CommitteeHotKey) - - | CommitteeHotKeyDeregistrationCertificate - (Hash CommitteeColdKey) - - | MIRCertificate MIRPot MIRTarget - - deriving stock (Eq, Show) deriving anyclass SerialiseAsCBOR +deriving instance Eq (Certificate era) +deriving instance Show (Certificate era) + instance Typeable era => HasTypeProxy (Certificate era) where data AsType (Certificate era) = AsCertificate proxyToAsType _ = AsCertificate From 517a6c6eac08855013aaff9d1208ff8a5a8474fa Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 14 Jul 2023 15:25:24 -0400 Subject: [PATCH 03/10] Introduce ConwayEraOnwards and AtMostBabbageEra GADTs in order to resolve cardano-ledger's certificate related type families to the correct type given an era. --- .../internal/Cardano/Api/Certificate.hs | 114 +++++++++++++++--- 1 file changed, 100 insertions(+), 14 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 8255e6a701..1d63035eb0 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -277,20 +277,106 @@ data DRepMetadataReference = -- Constructor functions -- -makeStakeAddressRegistrationCertificate :: () - => ShelleyBasedEra era - -> StakeCredential - -> Certificate era -makeStakeAddressRegistrationCertificate _ = - StakeAddressRegistrationCertificate - -makeStakeAddressDeregistrationCertificate :: () - => ShelleyBasedEra era - -> StakeCredential - -> Certificate era -makeStakeAddressDeregistrationCertificate _ = - StakeAddressDeregistrationCertificate - +data ConwayEraOnwards era where + ConwayEraOnwardsConway :: ConwayEraOnwards ConwayEra + +deriving instance Show (ConwayEraOnwards era) +deriving instance Eq (ConwayEraOnwards era) + +data AtMostBabbageEra era where + AtMostBabbageEraBabbage :: AtMostBabbageEra BabbageEra + AtMostBabbageEraAlonzo :: AtMostBabbageEra AlonzoEra + AtMostBabbageEraMary :: AtMostBabbageEra MaryEra + AtMostBabbageEraAllegra :: AtMostBabbageEra AllegraEra + AtMostBabbageEraShelley :: AtMostBabbageEra ShelleyEra + +deriving instance Show (AtMostBabbageEra era) +deriving instance Eq (AtMostBabbageEra era) + +data StakeAddressRequirements era where + StakeAddrRegistrationConway + :: ConwayEraOnwards era + -> Lovelace + -> StakeCredential + -> StakeAddressRequirements era + + StakeAddrRegistrationPreConway + :: AtMostBabbageEra era + -> StakeCredential + -> StakeAddressRequirements era + + +makeStakeAddressRegistrationCertificate :: StakeAddressRequirements era -> Certificate era +makeStakeAddressRegistrationCertificate req = + case req of + StakeAddrRegistrationPreConway atMostEra scred -> + shelleyCertificateConstraints atMostEra + $ makeStakeAddressRegistrationCertificatePreConway atMostEra scred + StakeAddrRegistrationConway cOnwards ll scred -> + conwayCertificateConstraints cOnwards + $ makeStakeAddressRegistrationCertificatePostConway cOnwards scred ll + where + makeStakeAddressRegistrationCertificatePreConway :: () + => EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto + => Ledger.ShelleyEraTxCert (ShelleyLedgerEra era) + => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ShelleyTxCert (ShelleyLedgerEra era) + => AtMostBabbageEra 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) + +makeStakeAddressUnregistrationCertificate :: StakeAddressRequirements era -> Certificate era +makeStakeAddressUnregistrationCertificate req = + case req of + StakeAddrRegistrationConway cOnwards ll scred -> + conwayCertificateConstraints cOnwards + $ makeStakeAddressDeregistrationCertificatePostConway cOnwards scred ll + + StakeAddrRegistrationPreConway atMostEra scred -> + shelleyCertificateConstraints atMostEra + $ makeStakeAddressDeregistrationCertificatePreConway atMostEra scred + where + makeStakeAddressDeregistrationCertificatePreConway + :: Ledger.ShelleyEraTxCert (ShelleyLedgerEra era) + => Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ShelleyTxCert (ShelleyLedgerEra era) + => EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto + => AtMostBabbageEra 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) + +{-# DEPRECATED makeStakeAddressPoolDelegationCertificate "This function is deprecated, please use 'makeStakeAddressDelegationCertificate' instead." #-} makeStakeAddressPoolDelegationCertificate :: () => ShelleyBasedEra era -> StakeCredential From e13f833b88663a6876d0d8bffb66c4276da94361 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 17 Jul 2023 11:30:55 -0400 Subject: [PATCH 04/10] Implement the following GADTs to be more explicit about the different requirements of certificates across changing eras: StakeDelegationRequirements era StakePoolRegistrationRequirements era StakePoolRetirementRequirements era GenesisKeyDelegationRequirements era MirCertificateRequirements era DRepRegistrationRequirements era CommitteeHotKeyAuthorizationRequirements era CommitteeColdkeyResignationRequirements era DRepUnregistrationRequirements era In combination with the following GADTs: ConwayEraOnwards era and AtMostBabbageEra era. We inherit the type safety of the ledger's type families via the ConwayEraOnwards and AtMostBabbageEra GADTs. --- .../internal/Cardano/Api/Certificate.hs | 216 +++++++++++++++--- 1 file changed, 181 insertions(+), 35 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 1d63035eb0..76941bda95 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -382,55 +382,201 @@ makeStakeAddressPoolDelegationCertificate :: () -> StakeCredential -> PoolId -> Certificate era -makeStakeAddressPoolDelegationCertificate _ = - StakeAddressPoolDelegationCertificate +makeStakeAddressPoolDelegationCertificate sbe scred poolId = + case sbe of + ShelleyBasedEraShelley -> + makeStakeAddressDelegationCertificate + (StakeDelegationRequirementsPreConway AtMostBabbageEraShelley scred poolId) + ShelleyBasedEraAllegra -> + makeStakeAddressDelegationCertificate + (StakeDelegationRequirementsPreConway AtMostBabbageEraAllegra scred poolId) + ShelleyBasedEraMary -> + makeStakeAddressDelegationCertificate + (StakeDelegationRequirementsPreConway AtMostBabbageEraMary scred poolId) + ShelleyBasedEraAlonzo -> + makeStakeAddressDelegationCertificate + (StakeDelegationRequirementsPreConway AtMostBabbageEraAlonzo scred poolId) + ShelleyBasedEraBabbage -> + makeStakeAddressDelegationCertificate + (StakeDelegationRequirementsPreConway AtMostBabbageEraBabbage scred poolId) + ShelleyBasedEraConway -> + makeStakeAddressDelegationCertificate + (StakeDelegationRequirementsConwayOnwards ConwayEraOnwardsConway scred (Ledger.DelegStake $ unStakePoolKeyHash poolId)) + +data StakeDelegationRequirements era where + StakeDelegationRequirementsConwayOnwards + :: ConwayEraOnwards era + -> StakeCredential + -> Ledger.Delegatee (EraCrypto (ShelleyLedgerEra era)) + -> StakeDelegationRequirements era + + StakeDelegationRequirementsPreConway + :: AtMostBabbageEra era + -> StakeCredential + -> PoolId + -> StakeDelegationRequirements era + + +makeStakeAddressDelegationCertificate :: StakeDelegationRequirements era -> Certificate era +makeStakeAddressDelegationCertificate req = + case req of + StakeDelegationRequirementsConwayOnwards cOnwards scred delegatee -> + conwayCertificateConstraints cOnwards + $ ConwayCertificate cOnwards + $ Ledger.mkDelegTxCert (toShelleyStakeCredential scred) delegatee + + StakeDelegationRequirementsPreConway atMostBabbage scred pid -> + shelleyCertificateConstraints atMostBabbage + $ ShelleyRelatedCertificate atMostBabbage + $ Ledger.mkDelegStakeTxCert (toShelleyStakeCredential scred) (unStakePoolKeyHash pid) + +data StakePoolRegistrationRequirements era where + StakePoolRegistrationRequirementsConwayOnwards + :: ConwayEraOnwards era + -> Ledger.PoolParams (EraCrypto (ShelleyLedgerEra era)) + -> StakePoolRegistrationRequirements era + + StakePoolRegistrationRequirementsPreConway + :: AtMostBabbageEra era + -> Ledger.PoolParams (EraCrypto (ShelleyLedgerEra era)) + -> StakePoolRegistrationRequirements era makeStakePoolRegistrationCertificate :: () - => ShelleyBasedEra era - -> StakePoolParameters + => StakePoolRegistrationRequirements era -> Certificate era -makeStakePoolRegistrationCertificate _ = - StakePoolRegistrationCertificate +makeStakePoolRegistrationCertificate req = + case req of + StakePoolRegistrationRequirementsConwayOnwards cOnwards poolParams -> + conwayCertificateConstraints cOnwards + $ ConwayCertificate cOnwards + $ Ledger.mkRegPoolTxCert poolParams + StakePoolRegistrationRequirementsPreConway atMostBab poolParams -> + shelleyCertificateConstraints atMostBab + $ ShelleyRelatedCertificate atMostBab + $ Ledger.mkRegPoolTxCert poolParams + +data StakePoolRetirementRequirements era where + StakePoolRetirementRequirementsConwayOnwards + :: ConwayEraOnwards era + -> PoolId + -> Ledger.EpochNo + -> StakePoolRetirementRequirements era + + StakePoolRetirementRequirementsPreConway + :: AtMostBabbageEra era + -> PoolId + -> Ledger.EpochNo + -> StakePoolRetirementRequirements era makeStakePoolRetirementCertificate :: () - => ShelleyBasedEra era - -> PoolId - -> EpochNo + => StakePoolRetirementRequirements era -> Certificate era -makeStakePoolRetirementCertificate _ = - StakePoolRetirementCertificate +makeStakePoolRetirementCertificate req = + case req of + StakePoolRetirementRequirementsPreConway atMostBab poolId retirementEpoch -> + shelleyCertificateConstraints atMostBab + $ ShelleyRelatedCertificate atMostBab + $ Ledger.mkRetirePoolTxCert (unStakePoolKeyHash poolId) retirementEpoch + StakePoolRetirementRequirementsConwayOnwards atMostBab poolId retirementEpoch -> + conwayCertificateConstraints atMostBab + $ ConwayCertificate atMostBab + $ Ledger.mkRetirePoolTxCert (unStakePoolKeyHash poolId) retirementEpoch + +data GenesisKeyDelegationRequirements ere where + + GenesisKeyDelegationRequirements + :: AtMostBabbageEra era + -> Hash GenesisKey + -> Hash GenesisDelegateKey + -> Hash VrfKey + -> GenesisKeyDelegationRequirements era + +makeGenesisKeyDelegationCertificate :: GenesisKeyDelegationRequirements era -> Certificate era +makeGenesisKeyDelegationCertificate (GenesisKeyDelegationRequirements atMostEra + (GenesisKeyHash hGenKey) (GenesisDelegateKeyHash hGenDelegKey) (VrfKeyHash hVrfKey)) = + ShelleyRelatedCertificate atMostEra + $ shelleyCertificateConstraints atMostEra + $ Ledger.ShelleyTxCertGenesisDeleg $ Ledger.GenesisDelegCert hGenKey hGenDelegKey hVrfKey + +data MirCertificateRequirements era where + MirCertificateRequirements + :: AtMostBabbageEra era + -> Ledger.MIRPot + -> Ledger.MIRTarget (EraCrypto (ShelleyLedgerEra era)) + -> MirCertificateRequirements era -makeGenesisKeyDelegationCertificate :: () - => ShelleyBasedEra era - -> Hash GenesisKey - -> Hash GenesisDelegateKey - -> Hash VrfKey +makeMIRCertificate :: () + => MirCertificateRequirements era -> Certificate era -makeGenesisKeyDelegationCertificate _ = - GenesisKeyDelegationCertificate +makeMIRCertificate (MirCertificateRequirements atMostEra mirPot mirTarget) = + ShelleyRelatedCertificate atMostEra + $ Ledger.ShelleyTxCertMir $ Ledger.MIRCert mirPot mirTarget -makeCommitteeDelegationCertificate :: () - => ShelleyBasedEra era - -> Hash CommitteeColdKey - -> Hash CommitteeHotKey +data DRepRegistrationRequirements era where + DRepRegistrationRequirements + :: ConwayEraOnwards era + -> VotingCredential era + -> Lovelace + -> DRepRegistrationRequirements era + + +makeDrepRegistrationCertificate :: () + => DRepRegistrationRequirements era + -> Certificate era +makeDrepRegistrationCertificate (DRepRegistrationRequirements conwayOnwards (VotingCredential vcred) deposit) = + ConwayCertificate conwayOnwards + . Ledger.ConwayTxCertCommittee + . Ledger.ConwayRegDRep vcred + $ toShelleyLovelace deposit + +data CommitteeHotKeyAuthorizationRequirements era where + CommitteeHotKeyAuthorizationRequirements + :: ConwayEraOnwards era + -> Ledger.KeyHash Ledger.CommitteeColdKey (EraCrypto (ShelleyLedgerEra era)) + -> Ledger.KeyHash Ledger.CommitteeHotKey (EraCrypto (ShelleyLedgerEra era)) + -> CommitteeHotKeyAuthorizationRequirements era + +makeCommitteeHotKeyAuthorizationCertificate :: () + => CommitteeHotKeyAuthorizationRequirements era -> Certificate era -makeCommitteeDelegationCertificate _ = - CommitteeDelegationCertificate +makeCommitteeHotKeyAuthorizationCertificate (CommitteeHotKeyAuthorizationRequirements cOnwards coldKeyHash hotKeyHash) = + ConwayCertificate cOnwards + . Ledger.ConwayTxCertCommittee + $ Ledger.ConwayAuthCommitteeHotKey coldKeyHash hotKeyHash -makeCommitteeHotKeyUnregistrationCertificate :: () - => ShelleyBasedEra era - -> Hash CommitteeColdKey +data CommitteeColdkeyResignationRequirements era where + CommitteeColdkeyResignationRequirements + :: ConwayEraOnwards era + -> Ledger.KeyHash Ledger.CommitteeColdKey (EraCrypto (ShelleyLedgerEra era)) + -> CommitteeColdkeyResignationRequirements era + +makeCommitteeColdkeyResignationCertificate :: () + => CommitteeColdkeyResignationRequirements era -> Certificate era -makeCommitteeHotKeyUnregistrationCertificate _ = - CommitteeHotKeyDeregistrationCertificate +makeCommitteeColdkeyResignationCertificate (CommitteeColdkeyResignationRequirements cOnwards coldKeyHash) = + ConwayCertificate cOnwards + . Ledger.ConwayTxCertCommittee + $ Ledger.ConwayResignCommitteeColdKey coldKeyHash -makeMIRCertificate :: () - => ShelleyBasedEra era - -> MIRPot - -> MIRTarget +data DRepUnregistrationRequirements era where + DRepUnregistrationRequirements + :: ConwayEraOnwards era + -> VotingCredential era + -> Lovelace + -> DRepUnregistrationRequirements era + +makeDrepUnregistrationCertificate :: () + => DRepUnregistrationRequirements era -> Certificate era -makeMIRCertificate _ = - MIRCertificate +makeDrepUnregistrationCertificate (DRepUnregistrationRequirements conwayOnwards (VotingCredential vcred) deposit) = + ConwayCertificate conwayOnwards + . Ledger.ConwayTxCertCommittee + . Ledger.ConwayUnRegDRep vcred + $ toShelleyLovelace deposit + +-- ---------------------------------------------------------------------------- +-- Helper functions +-- -- ---------------------------------------------------------------------------- From c53ef6864e6073daaf539b2d2108acf96dd69226 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 17 Jul 2023 11:40:44 -0400 Subject: [PATCH 05/10] Simplify to/fromShelleyCertificate --- .../internal/Cardano/Api/Certificate.hs | 252 +++--------------- 1 file changed, 43 insertions(+), 209 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 76941bda95..fd1f2821df 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -586,220 +586,54 @@ makeDrepUnregistrationCertificate (DRepUnregistrationRequirements conwayOnwards toShelleyCertificate :: () => ShelleyBasedEra era -> Certificate era - -> Shelley.TxCert (ShelleyLedgerEra era) -toShelleyCertificate sbe = - case sbe of - ShelleyBasedEraShelley -> - obtainCertificateConstraints sbe toShelleyCertificateAtMostBabbage - ShelleyBasedEraAllegra -> - obtainCertificateConstraints sbe toShelleyCertificateAtMostBabbage - ShelleyBasedEraMary -> - obtainCertificateConstraints sbe toShelleyCertificateAtMostBabbage - ShelleyBasedEraAlonzo -> - obtainCertificateConstraints sbe toShelleyCertificateAtMostBabbage - ShelleyBasedEraBabbage -> - obtainCertificateConstraints sbe toShelleyCertificateAtMostBabbage - ShelleyBasedEraConway -> toShelleyCertificateAtLeastConway - -toShelleyCertificateAtMostBabbage :: () - => Shelley.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => Shelley.ShelleyEraTxCert (ShelleyLedgerEra era) - => Shelley.TxCert (ShelleyLedgerEra era) ~ Shelley.ShelleyTxCert (ShelleyLedgerEra era) - => L.AtMostEra L.BabbageEra (ShelleyLedgerEra era) - => Certificate era - -> Shelley.TxCert (ShelleyLedgerEra era) -toShelleyCertificateAtMostBabbage (StakeAddressRegistrationCertificate stakecred) = - Shelley.RegTxCert - (toShelleyStakeCredential stakecred) - -toShelleyCertificateAtMostBabbage (StakeAddressDeregistrationCertificate stakecred) = - Shelley.UnRegTxCert - (toShelleyStakeCredential stakecred) - -toShelleyCertificateAtMostBabbage (StakeAddressPoolDelegationCertificate - stakecred (StakePoolKeyHash poolid)) = - Shelley.DelegStakeTxCert - (toShelleyStakeCredential stakecred) - poolid - -toShelleyCertificateAtMostBabbage (StakePoolRegistrationCertificate poolparams) = - Shelley.RegPoolTxCert - (toShelleyPoolParams poolparams) - -toShelleyCertificateAtMostBabbage (StakePoolRetirementCertificate - (StakePoolKeyHash poolid) epochno) = - Shelley.RetirePoolTxCert - poolid - epochno - -toShelleyCertificateAtMostBabbage (GenesisKeyDelegationCertificate - (GenesisKeyHash genesiskh) - (GenesisDelegateKeyHash delegatekh) - (VrfKeyHash vrfkh)) = - Shelley.GenesisDelegTxCert - genesiskh - delegatekh - vrfkh - -toShelleyCertificateAtMostBabbage - ( CommitteeDelegationCertificate - (CommitteeColdKeyHash _ckh) - (CommitteeHotKeyHash _hkh) - ) = error "TODO CIP-1694 Need ledger types for CommitteeDelegationCertificate" - -- AuthCommitteeHotKeyTxCert - -toShelleyCertificateAtMostBabbage - ( CommitteeHotKeyDeregistrationCertificate - (CommitteeColdKeyHash _ckh) - ) = error "TODO CIP-1694 Need ledger types for CommitteeHotKeyDeregistrationCertificate" - -- ResignCommitteeColdTxCert - -toShelleyCertificateAtMostBabbage (MIRCertificate mirpot (StakeAddressesMIR amounts)) = - Shelley.MirTxCert $ - Shelley.MIRCert - mirpot - (Shelley.StakeAddressesMIR $ Map.fromListWith (<>) - [ (toShelleyStakeCredential sc, Shelley.toDeltaCoin . toShelleyLovelace $ v) - | (sc, v) <- amounts ]) - -toShelleyCertificateAtMostBabbage (MIRCertificate mirPot (SendToReservesMIR amount)) = - case mirPot of - TreasuryMIR -> - Shelley.MirTxCert $ - Shelley.MIRCert - TreasuryMIR - (Shelley.SendToOppositePotMIR $ toShelleyLovelace amount) - ReservesMIR -> - error "toShelleyCertificateAtMostBabbage: Incorrect MIRPot specified. Expected TreasuryMIR but got ReservesMIR" - -toShelleyCertificateAtMostBabbage (MIRCertificate mirPot (SendToTreasuryMIR amount)) = - case mirPot of - ReservesMIR -> - Shelley.MirTxCert $ - Shelley.MIRCert - ReservesMIR - (Shelley.SendToOppositePotMIR $ toShelleyLovelace amount) - TreasuryMIR -> - error "toShelleyCertificateAtMostBabbage: Incorrect MIRPot specified. Expected ReservesMIR but got TreasuryMIR" - - -toShelleyCertificateAtLeastConway :: () - => Shelley.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => Conway.ConwayEraTxCert (ShelleyLedgerEra era) - => Certificate era - -> Shelley.TxCert (ShelleyLedgerEra era) -toShelleyCertificateAtLeastConway (StakeAddressRegistrationCertificate stakecred) = - Shelley.RegTxCert - (toShelleyStakeCredential stakecred) - -toShelleyCertificateAtLeastConway (StakeAddressDeregistrationCertificate stakecred) = - Shelley.UnRegTxCert - (toShelleyStakeCredential stakecred) - -toShelleyCertificateAtLeastConway (StakeAddressPoolDelegationCertificate - stakecred (StakePoolKeyHash poolid)) = - Shelley.DelegStakeTxCert - (toShelleyStakeCredential stakecred) - poolid - -toShelleyCertificateAtLeastConway (StakePoolRegistrationCertificate poolparams) = - Shelley.RegPoolTxCert - (toShelleyPoolParams poolparams) - -toShelleyCertificateAtLeastConway (StakePoolRetirementCertificate - (StakePoolKeyHash poolid) epochno) = - Shelley.RetirePoolTxCert - poolid - epochno - -toShelleyCertificateAtLeastConway (GenesisKeyDelegationCertificate _ _ _) = - error "TODO CIP-1694 Delete this case" - -toShelleyCertificateAtLeastConway - ( CommitteeDelegationCertificate - (CommitteeColdKeyHash _ckh) - (CommitteeHotKeyHash _hkh) - ) = Conway.AuthCommitteeHotKeyTxCert (error "ckh") (error "hkh") - -toShelleyCertificateAtLeastConway - ( CommitteeHotKeyDeregistrationCertificate - (CommitteeColdKeyHash _ckh) - ) = error "TODO CIP-1694 Need ledger types for CommitteeHotKeyDeregistrationCertificate" - -- ResignCommitteeColdTxCert - -toShelleyCertificateAtLeastConway (MIRCertificate _ _) = - error "TODO CIP-1694 Delete this case" - + -> Ledger.TxCert (ShelleyLedgerEra era) +toShelleyCertificate sbe cert = + case cert of + ShelleyRelatedCertificate aMostBab _ -> + toShelleyCertificateAtMostBabbage aMostBab cert + ConwayCertificate cOn _ -> + case sbe of + ShelleyBasedEraShelley -> case cOn of {} + ShelleyBasedEraAllegra -> case cOn of {} + ShelleyBasedEraMary -> case cOn of {} + ShelleyBasedEraAlonzo -> case cOn of {} + ShelleyBasedEraBabbage -> case cOn of {} + ShelleyBasedEraConway -> toShelleyCertificateAtLeastConway cOn cert + where + toShelleyCertificateAtMostBabbage :: () + => AtMostBabbageEra era + -> Certificate era + -> Ledger.TxCert (ShelleyLedgerEra era) + toShelleyCertificateAtMostBabbage aMostBabbage (ShelleyRelatedCertificate _ shelleyTxCert) = + case aMostBabbage of + AtMostBabbageEraBabbage -> shelleyTxCert + AtMostBabbageEraAlonzo -> shelleyTxCert + AtMostBabbageEraMary -> shelleyTxCert + AtMostBabbageEraAllegra -> shelleyTxCert + AtMostBabbageEraShelley -> shelleyTxCert + toShelleyCertificateAtMostBabbage aMost (ConwayCertificate ConwayEraOnwardsConway _) = + case aMost of {} + + + toShelleyCertificateAtLeastConway :: () + => ConwayEraOnwards era + -> Certificate era + -> Ledger.ConwayTxCert (ShelleyLedgerEra era) + toShelleyCertificateAtLeastConway _ (ConwayCertificate _ c) = c + toShelleyCertificateAtLeastConway ConwayEraOnwardsConway (ShelleyRelatedCertificate aMostBab _) = + case aMostBab of {} fromShelleyCertificate :: () - => Shelley.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => Shelley.ShelleyEraTxCert (ShelleyLedgerEra era) => ShelleyBasedEra era - -> Shelley.TxCert (ShelleyLedgerEra era) + -> Ledger.TxCert (ShelleyLedgerEra era) -> Certificate era fromShelleyCertificate = \case - ShelleyBasedEraShelley -> fromShelleyCertificateAtMostBabbage - ShelleyBasedEraAllegra -> fromShelleyCertificateAtMostBabbage - ShelleyBasedEraMary -> fromShelleyCertificateAtMostBabbage - ShelleyBasedEraAlonzo -> fromShelleyCertificateAtMostBabbage - ShelleyBasedEraBabbage -> fromShelleyCertificateAtMostBabbage - ShelleyBasedEraConway -> fromShelleyCertificateAtLeastConway - -fromShelleyCertificateAtMostBabbage :: () - => Shelley.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - => Shelley.ShelleyEraTxCert (ShelleyLedgerEra era) - => L.AtMostEra L.BabbageEra (ShelleyLedgerEra era) - => Shelley.TxCert (ShelleyLedgerEra era) - -> Certificate era -fromShelleyCertificateAtMostBabbage = \case - Shelley.RegTxCert stakecred -> - StakeAddressRegistrationCertificate - (fromShelleyStakeCredential stakecred) - - Shelley.UnRegTxCert stakecred -> - StakeAddressDeregistrationCertificate - (fromShelleyStakeCredential stakecred) - - Shelley.DelegStakeTxCert stakecred poolid -> - StakeAddressPoolDelegationCertificate - (fromShelleyStakeCredential stakecred) - (StakePoolKeyHash poolid) - - Shelley.RegPoolTxCert poolparams -> - StakePoolRegistrationCertificate - (fromShelleyPoolParams poolparams) - - Shelley.RetirePoolTxCert poolid epochno -> - StakePoolRetirementCertificate - (StakePoolKeyHash poolid) - epochno - - Shelley.GenesisDelegTxCert genesiskh delegatekh vrfkh -> - GenesisKeyDelegationCertificate - (GenesisKeyHash genesiskh) - (GenesisDelegateKeyHash delegatekh) - (VrfKeyHash vrfkh) - - Shelley.MirTxCert (Shelley.MIRCert mirpot (Shelley.StakeAddressesMIR amounts)) -> - MIRCertificate - mirpot - (StakeAddressesMIR - [ (fromShelleyStakeCredential sc, fromShelleyDeltaLovelace v) - | (sc, v) <- Map.toList amounts ] - ) - - Shelley.MirTxCert (Shelley.MIRCert ReservesMIR (Shelley.SendToOppositePotMIR amount)) -> - MIRCertificate ReservesMIR - (SendToTreasuryMIR $ fromShelleyLovelace amount) - - Shelley.MirTxCert (Shelley.MIRCert TreasuryMIR (Shelley.SendToOppositePotMIR amount)) -> - MIRCertificate TreasuryMIR - (SendToReservesMIR $ fromShelleyLovelace amount) - -fromShelleyCertificateAtLeastConway :: () - => Shelley.TxCert (ShelleyLedgerEra era) - -> Certificate era -fromShelleyCertificateAtLeastConway = error "TODO CIP-1694 implement fromShelleyCertificateAtLeastConway" + ShelleyBasedEraShelley -> ShelleyRelatedCertificate AtMostBabbageEraShelley + ShelleyBasedEraAllegra -> ShelleyRelatedCertificate AtMostBabbageEraAllegra + ShelleyBasedEraMary -> ShelleyRelatedCertificate AtMostBabbageEraMary + ShelleyBasedEraAlonzo -> ShelleyRelatedCertificate AtMostBabbageEraAlonzo + ShelleyBasedEraBabbage -> ShelleyRelatedCertificate AtMostBabbageEraBabbage + ShelleyBasedEraConway -> ConwayCertificate ConwayEraOnwardsConway toShelleyPoolParams :: StakePoolParameters -> Shelley.PoolParams StandardCrypto toShelleyPoolParams StakePoolParameters { From ede3820517822d0415c53418cf10773e1b478b07 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 17 Jul 2023 11:45:33 -0400 Subject: [PATCH 06/10] Update HasTextEnvelope (Certificate era) instance Add helper functions selectStakeCredential and filterUnRegCreds --- .../internal/Cardano/Api/Certificate.hs | 58 ++++++++++++++++--- 1 file changed, 49 insertions(+), 9 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index fd1f2821df..874290406c 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -168,15 +168,28 @@ instance ) => HasTextEnvelope (Certificate era) where textEnvelopeType _ = "CertificateShelley" textEnvelopeDefaultDescr cert = case cert of - StakeAddressRegistrationCertificate{} -> "Stake address registration" - StakeAddressDeregistrationCertificate{} -> "Stake address deregistration" - StakeAddressPoolDelegationCertificate{} -> "Stake address stake pool delegation" - StakePoolRegistrationCertificate{} -> "Pool registration" - StakePoolRetirementCertificate{} -> "Pool retirement" - GenesisKeyDelegationCertificate{} -> "Genesis key delegation" - CommitteeDelegationCertificate{} -> "Constitution committee member key delegation" - CommitteeHotKeyDeregistrationCertificate{} -> "Constitution committee member hot key deregistration" - MIRCertificate{} -> "MIR" + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyRegCert{}) -> "Stake address registration" + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyUnRegCert{}) -> "Stake address deregistration" + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyDelegCert{}) -> "Stake address delegation" + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool Ledger.RetirePool{}) -> "Pool retirement" + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool Ledger.RegPool{}) -> "Pool registration" + ShelleyRelatedCertificate _ Ledger.ShelleyTxCertGenesisDeleg{} -> "Genesis key delegation" + ShelleyRelatedCertificate _ Ledger.ShelleyTxCertMir{} -> "MIR" + + -- Conway and onwards related + -- Constitutional Committee related + ConwayCertificate _ (Ledger.ConwayTxCertCommittee Ledger.ConwayRegDRep{}) -> "Constitution committee member key registration" + ConwayCertificate _ (Ledger.ConwayTxCertCommittee Ledger.ConwayUnRegDRep{}) -> "Constitution committee member key unregistration" + ConwayCertificate _ (Ledger.ConwayTxCertCommittee Ledger.ConwayAuthCommitteeHotKey{}) -> "Constitution committee member hot key registration" + ConwayCertificate _ (Ledger.ConwayTxCertCommittee Ledger.ConwayResignCommitteeColdKey{}) -> "Constitution committee member hot key resignation" + + ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayRegCert{}) -> "Stake address registration" + ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayUnRegCert{}) -> "Stake address deregistration" + ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayDelegCert{}) -> "Stake address delegation" + ConwayCertificate _ (Ledger.ConwayTxCertDeleg Ledger.ConwayRegDelegCert{}) -> "Stake address registration and delegation" + ConwayCertificate _ (Ledger.ConwayTxCertPool Ledger.RegPool{}) -> "Pool registration" + ConwayCertificate _ (Ledger.ConwayTxCertPool Ledger.RetirePool{}) -> "Pool retirement" + instance EraCast Certificate where @@ -578,6 +591,33 @@ makeDrepUnregistrationCertificate (DRepUnregistrationRequirements conwayOnwards -- Helper functions -- +selectStakeCredential + :: ShelleyBasedEra era -> Certificate era -> Maybe StakeCredential +selectStakeCredential sbe cert = + case cert of + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert (Ledger.ShelleyDelegCert stakecred _)) + -> Just $ obtainEraCryptoConstraints sbe $ fromShelleyStakeCredential stakecred + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool (Ledger.RegPool poolParams)) + -> let poolCred = Ledger.KeyHashObj $ Ledger.ppId poolParams + in Just $ obtainEraCryptoConstraints sbe $ fromShelleyStakeCredential $ Ledger.coerceKeyRole poolCred + + ConwayCertificate _ (Ledger.ConwayTxCertDeleg (Ledger.ConwayRegCert stakeCred _)) + -> Just $ obtainEraCryptoConstraints sbe $ fromShelleyStakeCredential stakeCred + ConwayCertificate _ (Ledger.ConwayTxCertPool (Ledger.RegPool poolParams)) + -> let poolCred = Ledger.KeyHashObj $ Ledger.ppId poolParams + in Just $ obtainEraCryptoConstraints sbe $ fromShelleyStakeCredential $ Ledger.coerceKeyRole poolCred + + _ -> Nothing + +filterUnRegCreds + :: ShelleyBasedEra era -> Certificate era -> Maybe StakeCredential +filterUnRegCreds sbe cert = + case cert of + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert (Ledger.ShelleyUnRegCert cred)) -> + Just $ obtainEraCryptoConstraints sbe $ fromShelleyStakeCredential cred + ConwayCertificate _ (Ledger.ConwayTxCertDeleg (Ledger.ConwayUnRegCert cred _)) -> + Just $ obtainEraCryptoConstraints sbe $ fromShelleyStakeCredential cred + _ -> Nothing -- ---------------------------------------------------------------------------- -- Internal conversion functions From 60640b80048c9e02bf62bcbcf4c363d3fd623e2c Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 17 Jul 2023 11:47:02 -0400 Subject: [PATCH 07/10] Expose new conway certificate constructor functions: makeCommitteeColdkeyResignationCertificate makeCommitteeHotKeyAuthorizationCertificate makeDrepRegistrationCertificate makeDrepUnregistrationCertificate Re-export ledger types: MIRTarget MIRPot Import Cardano.Api.ReexposeLedger with the aim of consolidating all of the ledger modules cardano-api depends on. This will make it easier to hand off the cardano-api's ledger functionality to the ledger team. --- .../internal/Cardano/Api/Certificate.hs | 43 +++++++++++-------- 1 file changed, 24 insertions(+), 19 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 874290406c..9d57e2bca3 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -16,8 +19,9 @@ module Cardano.Api.Certificate ( Certificate(..), -- * Registering stake address and delegating + StakeAddressRequirements(..), makeStakeAddressRegistrationCertificate, - makeStakeAddressDeregistrationCertificate, + makeStakeAddressUnregistrationCertificate, makeStakeAddressPoolDelegationCertificate, PoolId, @@ -28,8 +32,11 @@ module Cardano.Api.Certificate ( StakePoolRelay(..), StakePoolMetadataReference(..), - makeCommitteeDelegationCertificate, - makeCommitteeHotKeyUnregistrationCertificate, + -- * Conway specific certificates + makeCommitteeColdkeyResignationCertificate, + makeCommitteeHotKeyAuthorizationCertificate, + makeDrepRegistrationCertificate, + makeDrepUnregistrationCertificate, -- * Registering DReps DRepMetadataReference(..), @@ -37,7 +44,8 @@ module Cardano.Api.Certificate ( -- * Special certificates makeMIRCertificate, makeGenesisKeyDelegationCertificate, - MIRTarget (..), + Ledger.MIRTarget (..), + Ledger.MIRPot(..), -- * Internal conversion functions toShelleyCertificate, @@ -46,39 +54,36 @@ module Cardano.Api.Certificate ( fromShelleyPoolParams, -- * Data family instances - AsType(..) + AsType(..), + + -- * GADTs for Conway/Shelley differences + AtMostBabbageEra(..), + ConwayEraOnwards(..), + + -- * Internal functions + filterUnRegCreds, + selectStakeCredential, ) where import Cardano.Api.Address import Cardano.Api.DRepMetadata import Cardano.Api.EraCast import Cardano.Api.Eras +import Cardano.Api.Governance.Actions.VotingProcedure import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Praos import Cardano.Api.Keys.Shelley +import Cardano.Api.ReexposeLedger (EraCrypto, StandardCrypto) +import qualified Cardano.Api.ReexposeLedger as Ledger import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseTextEnvelope import Cardano.Api.StakePoolMetadata import Cardano.Api.Utils import Cardano.Api.Value -import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Ledger.Api.Era as L -import Cardano.Ledger.BaseTypes (maybeToStrictMaybe, strictMaybeToMaybe) -import qualified Cardano.Ledger.BaseTypes as Shelley -import qualified Cardano.Ledger.Coin as Shelley (toDeltaCoin) -import qualified Cardano.Ledger.Conway.TxCert as Conway -import qualified Cardano.Ledger.Core as Shelley -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Shelley.TxBody (MIRPot (..)) -import qualified Cardano.Ledger.Shelley.TxBody as Shelley -import qualified Cardano.Ledger.Shelley.TxCert as Shelley -import Cardano.Slotting.Slot (EpochNo (..)) - import Data.ByteString (ByteString) import qualified Data.Foldable as Foldable import Data.IP (IPv4, IPv6) -import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Sequence.Strict as Seq import qualified Data.Set as Set From e899efd92b8adeeb574f3eba32dc78098b878c9f Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 17 Jul 2023 11:51:48 -0400 Subject: [PATCH 08/10] Propagate new Cardano.Api.ReexposeLedger module exports in Cardano.Api.Certificate --- .../internal/Cardano/Api/Certificate.hs | 164 ++++++++++-------- 1 file changed, 94 insertions(+), 70 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 9d57e2bca3..f2352cf1f3 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -135,17 +135,17 @@ instance -- TODO CIP-1694 clean this up case shelleyBasedEra @era of ShelleyBasedEraShelley -> - Shelley.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra + Ledger.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra ShelleyBasedEraAllegra -> - Shelley.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra + Ledger.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra ShelleyBasedEraMary -> - Shelley.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra + Ledger.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra ShelleyBasedEraAlonzo -> - Shelley.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra + Ledger.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra ShelleyBasedEraBabbage -> - Shelley.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra + Ledger.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra ShelleyBasedEraConway -> - Shelley.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra + Ledger.toEraCBOR @(ShelleyLedgerEra era) . toShelleyCertificate shelleyBasedEra @@ -155,17 +155,17 @@ instance fromCBOR = case shelleyBasedEra @era of ShelleyBasedEraShelley -> - fromShelleyCertificate shelleyBasedEra <$> Shelley.fromEraCBOR @(ShelleyLedgerEra era) + fromShelleyCertificate shelleyBasedEra <$> Ledger.fromEraCBOR @(ShelleyLedgerEra era) ShelleyBasedEraAllegra -> - fromShelleyCertificate shelleyBasedEra <$> Shelley.fromEraCBOR @(ShelleyLedgerEra era) + fromShelleyCertificate shelleyBasedEra <$> Ledger.fromEraCBOR @(ShelleyLedgerEra era) ShelleyBasedEraMary -> - fromShelleyCertificate shelleyBasedEra <$> Shelley.fromEraCBOR @(ShelleyLedgerEra era) + fromShelleyCertificate shelleyBasedEra <$> Ledger.fromEraCBOR @(ShelleyLedgerEra era) ShelleyBasedEraAlonzo -> - fromShelleyCertificate shelleyBasedEra <$> Shelley.fromEraCBOR @(ShelleyLedgerEra era) + fromShelleyCertificate shelleyBasedEra <$> Ledger.fromEraCBOR @(ShelleyLedgerEra era) ShelleyBasedEraBabbage -> - fromShelleyCertificate shelleyBasedEra <$> Shelley.fromEraCBOR @(ShelleyLedgerEra era) + fromShelleyCertificate shelleyBasedEra <$> Ledger.fromEraCBOR @(ShelleyLedgerEra era) ShelleyBasedEraConway -> - fromShelleyCertificateAtLeastConway <$> Shelley.fromEraCBOR @(ShelleyLedgerEra era) + fromShelleyCertificate shelleyBasedEra <$> Ledger.fromEraCBOR @(ShelleyLedgerEra era) instance @@ -680,7 +680,8 @@ fromShelleyCertificate = \case ShelleyBasedEraBabbage -> ShelleyRelatedCertificate AtMostBabbageEraBabbage ShelleyBasedEraConway -> ConwayCertificate ConwayEraOnwardsConway -toShelleyPoolParams :: StakePoolParameters -> Shelley.PoolParams StandardCrypto + +toShelleyPoolParams :: StakePoolParameters -> Ledger.PoolParams StandardCrypto toShelleyPoolParams StakePoolParameters { stakePoolId = StakePoolKeyHash poolkh , stakePoolVRF = VrfKeyHash vrfkh @@ -694,117 +695,140 @@ toShelleyPoolParams StakePoolParameters { } = --TODO: validate pool parameters such as the PoolMargin below, but also -- do simple client-side sanity checks, e.g. on the pool metadata url - Shelley.PoolParams { - Shelley.ppId = poolkh - , Shelley.ppVrf = vrfkh - , Shelley.ppPledge = toShelleyLovelace stakePoolPledge - , Shelley.ppCost = toShelleyLovelace stakePoolCost - , Shelley.ppMargin = fromMaybe + Ledger.PoolParams { + Ledger.ppId = poolkh + , Ledger.ppVrf = vrfkh + , Ledger.ppPledge = toShelleyLovelace stakePoolPledge + , Ledger.ppCost = toShelleyLovelace stakePoolCost + , Ledger.ppMargin = fromMaybe (error "toShelleyPoolParams: invalid PoolMargin") - (Shelley.boundRational stakePoolMargin) - , Shelley.ppRewardAcnt = toShelleyStakeAddr stakePoolRewardAccount - , Shelley.ppOwners = Set.fromList + (Ledger.boundRational stakePoolMargin) + , Ledger.ppRewardAcnt = toShelleyStakeAddr stakePoolRewardAccount + , Ledger.ppOwners = Set.fromList [ kh | StakeKeyHash kh <- stakePoolOwners ] - , Shelley.ppRelays = Seq.fromList + , Ledger.ppRelays = Seq.fromList (map toShelleyStakePoolRelay stakePoolRelays) - , Shelley.ppMetadata = toShelleyPoolMetadata <$> - maybeToStrictMaybe stakePoolMetadata + , Ledger.ppMetadata = toShelleyPoolMetadata <$> + Ledger.maybeToStrictMaybe stakePoolMetadata } where - toShelleyStakePoolRelay :: StakePoolRelay -> Shelley.StakePoolRelay + toShelleyStakePoolRelay :: StakePoolRelay -> Ledger.StakePoolRelay toShelleyStakePoolRelay (StakePoolRelayIp mipv4 mipv6 mport) = - Shelley.SingleHostAddr - (fromIntegral <$> maybeToStrictMaybe mport) - (maybeToStrictMaybe mipv4) - (maybeToStrictMaybe mipv6) + Ledger.SingleHostAddr + (fromIntegral <$> Ledger.maybeToStrictMaybe mport) + (Ledger.maybeToStrictMaybe mipv4) + (Ledger.maybeToStrictMaybe mipv6) toShelleyStakePoolRelay (StakePoolRelayDnsARecord dnsname mport) = - Shelley.SingleHostName - (fromIntegral <$> maybeToStrictMaybe mport) + Ledger.SingleHostName + (fromIntegral <$> Ledger.maybeToStrictMaybe mport) (toShelleyDnsName dnsname) toShelleyStakePoolRelay (StakePoolRelayDnsSrvRecord dnsname) = - Shelley.MultiHostName + Ledger.MultiHostName (toShelleyDnsName dnsname) - toShelleyPoolMetadata :: StakePoolMetadataReference -> Shelley.PoolMetadata + toShelleyPoolMetadata :: StakePoolMetadataReference -> Ledger.PoolMetadata toShelleyPoolMetadata StakePoolMetadataReference { stakePoolMetadataURL , stakePoolMetadataHash = StakePoolMetadataHash mdh } = - Shelley.PoolMetadata { - Shelley.pmUrl = toShelleyUrl stakePoolMetadataURL - , Shelley.pmHash = Crypto.hashToBytes mdh + Ledger.PoolMetadata { + Ledger.pmUrl = toShelleyUrl stakePoolMetadataURL + , Ledger.pmHash = Ledger.hashToBytes mdh } - toShelleyDnsName :: ByteString -> Shelley.DnsName + toShelleyDnsName :: ByteString -> Ledger.DnsName toShelleyDnsName = fromMaybe (error "toShelleyDnsName: invalid dns name. TODO: proper validation") - . Shelley.textToDns + . Ledger.textToDns . Text.decodeLatin1 - toShelleyUrl :: Text -> Shelley.Url + toShelleyUrl :: Text -> Ledger.Url toShelleyUrl = fromMaybe (error "toShelleyUrl: invalid url. TODO: proper validation") - . Shelley.textToUrl + . Ledger.textToUrl -fromShelleyPoolParams :: Shelley.PoolParams StandardCrypto +fromShelleyPoolParams :: Ledger.PoolParams StandardCrypto -> StakePoolParameters fromShelleyPoolParams - Shelley.PoolParams { - Shelley.ppId - , Shelley.ppVrf - , Shelley.ppPledge - , Shelley.ppCost - , Shelley.ppMargin - , Shelley.ppRewardAcnt - , Shelley.ppOwners - , Shelley.ppRelays - , Shelley.ppMetadata + Ledger.PoolParams { + Ledger.ppId + , Ledger.ppVrf + , Ledger.ppPledge + , Ledger.ppCost + , Ledger.ppMargin + , Ledger.ppRewardAcnt + , Ledger.ppOwners + , Ledger.ppRelays + , Ledger.ppMetadata } = StakePoolParameters { stakePoolId = StakePoolKeyHash ppId , stakePoolVRF = VrfKeyHash ppVrf , stakePoolCost = fromShelleyLovelace ppCost - , stakePoolMargin = Shelley.unboundRational ppMargin + , stakePoolMargin = Ledger.unboundRational ppMargin , stakePoolRewardAccount = fromShelleyStakeAddr ppRewardAcnt , stakePoolPledge = fromShelleyLovelace ppPledge , stakePoolOwners = map StakeKeyHash (Set.toList ppOwners) , stakePoolRelays = map fromShelleyStakePoolRelay (Foldable.toList ppRelays) , stakePoolMetadata = fromShelleyPoolMetadata <$> - strictMaybeToMaybe ppMetadata + Ledger.strictMaybeToMaybe ppMetadata } where - fromShelleyStakePoolRelay :: Shelley.StakePoolRelay -> StakePoolRelay - fromShelleyStakePoolRelay (Shelley.SingleHostAddr mport mipv4 mipv6) = + fromShelleyStakePoolRelay :: Ledger.StakePoolRelay -> StakePoolRelay + fromShelleyStakePoolRelay (Ledger.SingleHostAddr mport mipv4 mipv6) = StakePoolRelayIp - (strictMaybeToMaybe mipv4) - (strictMaybeToMaybe mipv6) - (fromIntegral . Shelley.portToWord16 <$> strictMaybeToMaybe mport) + (Ledger.strictMaybeToMaybe mipv4) + (Ledger.strictMaybeToMaybe mipv6) + (fromIntegral . Ledger.portToWord16 <$> Ledger.strictMaybeToMaybe mport) - fromShelleyStakePoolRelay (Shelley.SingleHostName mport dnsname) = + fromShelleyStakePoolRelay (Ledger.SingleHostName mport dnsname) = StakePoolRelayDnsARecord (fromShelleyDnsName dnsname) - (fromIntegral . Shelley.portToWord16 <$> strictMaybeToMaybe mport) + (fromIntegral . Ledger.portToWord16 <$> Ledger.strictMaybeToMaybe mport) - fromShelleyStakePoolRelay (Shelley.MultiHostName dnsname) = + fromShelleyStakePoolRelay (Ledger.MultiHostName dnsname) = StakePoolRelayDnsSrvRecord (fromShelleyDnsName dnsname) - fromShelleyPoolMetadata :: Shelley.PoolMetadata -> StakePoolMetadataReference - fromShelleyPoolMetadata Shelley.PoolMetadata { - Shelley.pmUrl - , Shelley.pmHash + fromShelleyPoolMetadata :: Ledger.PoolMetadata -> StakePoolMetadataReference + fromShelleyPoolMetadata Ledger.PoolMetadata { + Ledger.pmUrl + , Ledger.pmHash } = StakePoolMetadataReference { - stakePoolMetadataURL = Shelley.urlToText pmUrl + stakePoolMetadataURL = Ledger.urlToText pmUrl , stakePoolMetadataHash = StakePoolMetadataHash . fromMaybe (error "fromShelleyPoolMetadata: invalid hash. TODO: proper validation") - . Crypto.hashFromBytes + . Ledger.hashFromBytes $ pmHash } --TODO: change the ledger rep of the DNS name to use ShortByteString - fromShelleyDnsName :: Shelley.DnsName -> ByteString + fromShelleyDnsName :: Ledger.DnsName -> ByteString fromShelleyDnsName = Text.encodeUtf8 - . Shelley.dnsToText + . Ledger.dnsToText + +shelleyCertificateConstraints + :: AtMostBabbageEra era + -> (( Ledger.ShelleyEraTxCert (ShelleyLedgerEra era) + , EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto + , Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ShelleyTxCert (ShelleyLedgerEra era) + ) => a) + -> a +shelleyCertificateConstraints AtMostBabbageEraBabbage f = f +shelleyCertificateConstraints AtMostBabbageEraAlonzo f = f +shelleyCertificateConstraints AtMostBabbageEraMary f = f +shelleyCertificateConstraints AtMostBabbageEraAllegra f = f +shelleyCertificateConstraints AtMostBabbageEraShelley f = f + +conwayCertificateConstraints + :: ConwayEraOnwards era + -> (( Ledger.ConwayEraTxCert (ShelleyLedgerEra era) + , EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto + , Ledger.TxCert (ShelleyLedgerEra era) ~ Ledger.ConwayTxCert (ShelleyLedgerEra era) + ) => a) + -> a +conwayCertificateConstraints ConwayEraOnwardsConway f = f + From 0a8a62fbd5b60b236dc6306b266a51196b674fe3 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 17 Jul 2023 12:44:20 -0400 Subject: [PATCH 09/10] Update CastEra Certificate instance to handle casting certificates from Babbage to Conway --- .../internal/Cardano/Api/Certificate.hs | 84 +++++++++++-------- 1 file changed, 47 insertions(+), 37 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index f2352cf1f3..f47c02dbe1 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -198,43 +198,53 @@ instance instance EraCast Certificate where - eraCast _ = \case - StakeAddressRegistrationCertificate c -> - pure $ StakeAddressRegistrationCertificate c - StakeAddressDeregistrationCertificate stakeCredential -> - pure $ StakeAddressDeregistrationCertificate stakeCredential - StakeAddressPoolDelegationCertificate stakeCredential poolId -> - pure $ StakeAddressPoolDelegationCertificate stakeCredential poolId - StakePoolRegistrationCertificate stakePoolParameters -> - pure $ StakePoolRegistrationCertificate stakePoolParameters - StakePoolRetirementCertificate poolId epochNo -> - pure $ StakePoolRetirementCertificate poolId epochNo - GenesisKeyDelegationCertificate genesisKH genesisDelegateKH vrfKH -> - pure $ GenesisKeyDelegationCertificate genesisKH genesisDelegateKH vrfKH - CommitteeDelegationCertificate coldKeyHash hotKeyHash -> - pure $ CommitteeDelegationCertificate coldKeyHash hotKeyHash - CommitteeHotKeyDeregistrationCertificate coldKeyHash -> - pure $ CommitteeHotKeyDeregistrationCertificate coldKeyHash - MIRCertificate mirPot mirTarget -> - pure $ MIRCertificate mirPot mirTarget - --- | The 'MIRTarget' determines the target of a 'MIRCertificate'. --- A 'MIRCertificate' moves lovelace from either the reserves or the treasury --- to either a collection of stake credentials or to the other pot. -data MIRTarget = - - -- | Use 'StakeAddressesMIR' to make the target of a 'MIRCertificate' - -- a mapping of stake credentials to lovelace. - StakeAddressesMIR [(StakeCredential, Lovelace)] - - -- | Use 'SendToReservesMIR' to make the target of a 'MIRCertificate' - -- the reserves pot. - | SendToReservesMIR Lovelace - - -- | Use 'SendToTreasuryMIR' to make the target of a 'MIRCertificate' - -- the treasury pot. - | SendToTreasuryMIR Lovelace - deriving stock (Eq, Show) + eraCast toEra cert = + case cert of + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyRegCert{}) -> + eraCast toEra cert + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyUnRegCert{}) -> + eraCast toEra cert + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertDelegCert Ledger.ShelleyDelegCert{}) -> + eraCast toEra cert + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool Ledger.RetirePool{}) -> + eraCast toEra cert + ShelleyRelatedCertificate _ (Ledger.ShelleyTxCertPool Ledger.RegPool{}) -> + eraCast toEra cert + + -- We cannot cast MIR and GenDeleg certs from Babbage to Conway era because they do not exist + ShelleyRelatedCertificate (_ :: AtMostBabbageEra fromEra) Ledger.ShelleyTxCertGenesisDeleg{} -> + case toEra of + ConwayEra -> Left $ EraCastError + { originalValue = cert + , fromEra = cardanoEra @fromEra + , toEra = toEra + } + BabbageEra -> eraCast toEra cert + AlonzoEra -> eraCast toEra cert + AllegraEra -> eraCast toEra cert + MaryEra -> eraCast toEra cert + ShelleyEra -> eraCast toEra cert + ByronEra -> error "TODO: EraCast Certififcate - Byron era" + -- TODO: We need to modify the EraCast class to only allow casting to a future era. + -- I can't imagine a use case where we would want to cast to a previous era + + ShelleyRelatedCertificate (_ :: AtMostBabbageEra fromEra) Ledger.ShelleyTxCertMir{} -> + case toEra of + ConwayEra -> Left $ EraCastError + { originalValue = cert + , fromEra = cardanoEra @fromEra + , toEra = toEra + } + BabbageEra -> eraCast toEra cert + AlonzoEra -> eraCast toEra cert + AllegraEra -> eraCast toEra cert + MaryEra -> eraCast toEra cert + ShelleyEra -> eraCast toEra cert + ByronEra -> error "TODO: EraCast Certififcate - Byron era" + -- TODO: We need to modify the EraCast class to only allow casting to a future era. + -- I can't imagine a use case where we would want to cast to a previous era + + ConwayCertificate{} -> eraCast toEra cert -- ---------------------------------------------------------------------------- -- Stake pool parameters From da9be77c686e5aad8d43ec9903044fde0a18bc71 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 17 Jul 2023 12:47:02 -0400 Subject: [PATCH 10/10] Propagate changes throughout the rest of cardano-api --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 43 ++++++++++++++----- .../internal/Cardano/Api/Convenience/Query.hs | 5 +-- cardano-api/internal/Cardano/Api/Fees.hs | 29 ++++++------- cardano-api/internal/Cardano/Api/TxBody.hs | 29 ++++++------- cardano-api/internal/Cardano/Api/Utils.hs | 15 +------ cardano-api/src/Cardano/Api.hs | 17 +++++--- 6 files changed, 71 insertions(+), 67 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index d70cb46c95..47d4107348 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -590,22 +590,43 @@ genTxCertificates :: CardanoEra era -> Gen (TxCertificates BuildTx era) genTxCertificates era = case certificatesSupportedInEra era of Nothing -> pure TxCertificatesNone - Just supported -> do - certs <- Gen.list (Range.constant 0 3) genCertificate - Gen.choice - [ pure TxCertificatesNone - , pure (TxCertificates supported certs $ BuildTxWith mempty) - -- TODO: Generate certificates - ] + Just supported -> + case cardanoEraStyle era of + LegacyByronEra -> pure TxCertificatesNone + ShelleyBasedEra sbe -> do + certs <- Gen.list (Range.constant 0 3) $ genCertificate sbe + Gen.choice + [ pure TxCertificatesNone + , pure (TxCertificates supported certs $ BuildTxWith mempty) + -- TODO: Generate certificates + ] -- TODO: Add remaining certificates -genCertificate :: Gen (Certificate era) -genCertificate = +-- TODO: This should be parameterised on ShelleyBasedEra +genCertificate :: ShelleyBasedEra era -> Gen (Certificate era) +genCertificate sbe = Gen.choice - [ StakeAddressRegistrationCertificate <$> genStakeCredential - , StakeAddressDeregistrationCertificate <$> genStakeCredential + [ makeStakeAddressRegistrationCertificate <$> genStakeAddressRequirements sbe + , makeStakeAddressUnregistrationCertificate <$> genStakeAddressRequirements sbe ] +genStakeAddressRequirements :: ShelleyBasedEra era -> Gen (StakeAddressRequirements era) +genStakeAddressRequirements sbe = + case sbe of + ShelleyBasedEraShelley -> + StakeAddrRegistrationPreConway AtMostBabbageEraShelley <$> genStakeCredential + ShelleyBasedEraAllegra -> + StakeAddrRegistrationPreConway AtMostBabbageEraAllegra <$> genStakeCredential + ShelleyBasedEraMary -> + StakeAddrRegistrationPreConway AtMostBabbageEraMary <$> genStakeCredential + ShelleyBasedEraAlonzo -> + StakeAddrRegistrationPreConway AtMostBabbageEraAlonzo <$> genStakeCredential + ShelleyBasedEraBabbage -> + StakeAddrRegistrationPreConway AtMostBabbageEraBabbage <$> genStakeCredential + ShelleyBasedEraConway -> + StakeAddrRegistrationConway ConwayEraOnwardsConway <$> genLovelace <*> genStakeCredential + + genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era) genTxUpdateProposal era = case updateProposalSupportedInEra era of diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index 1f7cf9b291..ff1c420867 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -88,9 +87,7 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do qeInMode <- pure (toEraInMode era CardanoMode) & onNothing (left (EraConsensusModeMismatch (AnyConsensusMode CardanoMode) (getIsCardanoEraConstraint era $ AnyCardanoEra era))) - let stakeCreds = Set.fromList $ flip mapMaybe certs $ \case - StakeAddressDeregistrationCertificate cred -> Just cred - _ -> Nothing + let stakeCreds = Set.fromList $ mapMaybe (filterUnRegCreds sbe) certs -- Query execution utxo <- lift (queryUtxo qeInMode sbe (QueryUTxOByTxIn (Set.fromList allTxIns))) diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 8f0c5336af..e22de79360 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -950,7 +950,7 @@ makeTransactionBodyAutoBalance systemstart history pparams poolids stakeDelegDep failures exUnitsMap' - txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent + txbodycontent1 <- substituteExecutionUnits sbe exUnitsMap' txbodycontent explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $ txFeesExplicitInEra era' @@ -1174,11 +1174,12 @@ makeTransactionBodyAutoBalance systemstart history pparams poolids stakeDelegDep (txOutInAnyEra txout) minUTxO -substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits +substituteExecutionUnits :: ShelleyBasedEra era + -> Map ScriptWitnessIndex ExecutionUnits -> TxBodyContent BuildTx era -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era) -substituteExecutionUnits exUnitsMap = - mapTxScriptWitnesses f +substituteExecutionUnits sbe exUnitsMap = + mapTxScriptWitnesses f sbe where f :: ScriptWitnessIndex -> ScriptWitness witctx era @@ -1195,9 +1196,10 @@ mapTxScriptWitnesses (forall witctx. ScriptWitnessIndex -> ScriptWitness witctx era -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)) + -> ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era) -mapTxScriptWitnesses f txbodycontent@TxBodyContent { +mapTxScriptWitnesses f sbe txbodycontent@TxBodyContent { txIns, txWithdrawals, txCertificates, @@ -1206,7 +1208,7 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { mappedTxIns <- mapScriptWitnessesTxIns txIns mappedWithdrawals <- mapScriptWitnessesWithdrawals txWithdrawals mappedMintedVals <- mapScriptWitnessesMinting txMintValue - mappedTxCertificates <- mapScriptWitnessesCertificates txCertificates + mappedTxCertificates <- mapScriptWitnessesCertificates sbe txCertificates Right $ txbodycontent & setTxIns mappedTxIns @@ -1271,10 +1273,11 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { adjustWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness' mapScriptWitnessesCertificates - :: TxCertificates BuildTx era + :: ShelleyBasedEra era + -> TxCertificates BuildTx era -> Either TxBodyErrorAutoBalance (TxCertificates BuildTx era) - mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone - mapScriptWitnessesCertificates (TxCertificates supported certs + mapScriptWitnessesCertificates _ TxCertificatesNone = Right TxCertificatesNone + mapScriptWitnessesCertificates sbe' (TxCertificates supported certs (BuildTxWith witnesses)) = let mappedScriptWitnesses :: [(StakeCredential, Either TxBodyErrorAutoBalance (Witness WitCtxStake era))] @@ -1282,7 +1285,7 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { [ (stakecred, ScriptWitness ctx <$> witness') -- The certs are indexed in list order | (ix, cert) <- zip [0..] certs - , stakecred <- maybeToList (selectStakeCredential cert) + , stakecred <- maybeToList (selectStakeCredential sbe' cert) , ScriptWitness ctx witness <- maybeToList (Map.lookup stakecred witnesses) , let witness' = f (ScriptWitnessIndexCertificate ix) witness @@ -1294,12 +1297,6 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { Right wit -> Right (sCred, wit) ) mappedScriptWitnesses - selectStakeCredential cert = - case cert of - StakeAddressDeregistrationCertificate stakecred -> Just stakecred - StakeAddressPoolDelegationCertificate stakecred _ -> Just stakecred - _ -> Nothing - mapScriptWitnessesMinting :: TxMintValue BuildTx era -> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 678a53feee..43162e0275 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -2359,7 +2359,7 @@ createTransactionBody -> Either TxBodyError (TxBody era) createTransactionBody sbe txBodyContent = let apiTxOuts = txOuts txBodyContent - apiScriptWitnesses = collectTxBodyScriptWitnesses txBodyContent + apiScriptWitnesses = collectTxBodyScriptWitnesses sbe txBodyContent apiScriptValidity = txScriptValidity txBodyContent apiMintValue = txMintValue txBodyContent apiProtocolParameters = txProtocolParams txBodyContent @@ -2553,7 +2553,7 @@ validateTxBodyContent sbe txBodContent@TxBodyContent { txProtocolParams, txMintValue, txMetadata} = - let witnesses = collectTxBodyScriptWitnesses txBodContent + let witnesses = collectTxBodyScriptWitnesses sbe txBodContent languages = Set.fromList [ toAlonzoLanguage (AnyPlutusScriptVersion v) | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses @@ -3679,7 +3679,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraShelley scripts_ = catMaybes [ toShelleyScript <$> scriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) - <- collectTxBodyScriptWitnesses txbodycontent + <- collectTxBodyScriptWitnesses sbe txbodycontent ] txAuxData :: Maybe (L.TxAuxData StandardShelley) @@ -3716,7 +3716,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAllegra scripts_ = catMaybes [ toShelleyScript <$> scriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) - <- collectTxBodyScriptWitnesses txbodycontent + <- collectTxBodyScriptWitnesses sbe txbodycontent ] txAuxData :: Maybe (L.TxAuxData StandardAllegra) @@ -3755,7 +3755,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraMary scripts = List.nub $ catMaybes [ toShelleyScript <$> scriptWitnessScript scriptwitness | (_, AnyScriptWitness scriptwitness) - <- collectTxBodyScriptWitnesses txbodycontent + <- collectTxBodyScriptWitnesses sbe txbodycontent ] txAuxData :: Maybe (L.TxAuxData StandardMary) @@ -3801,7 +3801,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo txScriptValidity where witnesses :: [(ScriptWitnessIndex, AnyScriptWitness AlonzoEra)] - witnesses = collectTxBodyScriptWitnesses txbodycontent + witnesses = collectTxBodyScriptWitnesses sbe txbodycontent scripts :: [Ledger.Script StandardAlonzo] scripts = List.nub $ catMaybes @@ -3894,7 +3894,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage txScriptValidity where witnesses :: [(ScriptWitnessIndex, AnyScriptWitness BabbageEra)] - witnesses = collectTxBodyScriptWitnesses txbodycontent + witnesses = collectTxBodyScriptWitnesses sbe txbodycontent scripts :: [Ledger.Script StandardBabbage] scripts = List.nub $ catMaybes @@ -3995,7 +3995,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway txScriptValidity where witnesses :: [(ScriptWitnessIndex, AnyScriptWitness ConwayEra)] - witnesses = collectTxBodyScriptWitnesses txbodycontent + witnesses = collectTxBodyScriptWitnesses sbe txbodycontent scripts :: [Ledger.Script StandardConway] scripts = catMaybes @@ -4181,10 +4181,10 @@ fromAlonzoRdmrPtr (Alonzo.RdmrPtr tag n) = Alonzo.Cert -> ScriptWitnessIndexCertificate (fromIntegral n) Alonzo.Rewrd -> ScriptWitnessIndexWithdrawal (fromIntegral n) -collectTxBodyScriptWitnesses :: forall era. - TxBodyContent BuildTx era +collectTxBodyScriptWitnesses :: forall era. ShelleyBasedEra era + -> TxBodyContent BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] -collectTxBodyScriptWitnesses TxBodyContent { +collectTxBodyScriptWitnesses sbe TxBodyContent { txIns, txWithdrawals, txCertificates, @@ -4227,15 +4227,10 @@ collectTxBodyScriptWitnesses TxBodyContent { -- The certs are indexed in list order | (ix, cert) <- zip [0..] certs , ScriptWitness _ witness <- maybeToList $ do - stakecred <- selectStakeCredential cert + stakecred <- obtainEraCryptoConstraints sbe $ selectStakeCredential sbe cert Map.lookup stakecred witnesses ] - selectStakeCredential cert = - case cert of - StakeAddressDeregistrationCertificate stakecred -> Just stakecred - StakeAddressPoolDelegationCertificate stakecred _ -> Just stakecred - _ -> Nothing scriptWitnessesMinting :: TxMintValue BuildTx era diff --git a/cardano-api/internal/Cardano/Api/Utils.hs b/cardano-api/internal/Cardano/Api/Utils.hs index de6003d128..0783145518 100644 --- a/cardano-api/internal/Cardano/Api/Utils.hs +++ b/cardano-api/internal/Cardano/Api/Utils.hs @@ -31,7 +31,6 @@ module Cardano.Api.Utils , bounded -- ** Constraint solvers - , obtainCertificateConstraints , obtainCryptoConstraints , obtainEraConstraints , obtainEraPParamsConstraint @@ -47,7 +46,6 @@ import qualified Cardano.Ledger.Core as Ledger import Cardano.Ledger.Crypto (Crypto, StandardCrypto) import qualified Cardano.Ledger.Crypto as Ledger import Cardano.Ledger.Shelley () -import qualified Cardano.Ledger.Shelley.TxCert as Shelley import Control.Exception (bracket) import Control.Monad (when) @@ -204,16 +202,5 @@ obtainSafeToHashConstraint ShelleyBasedEraMary f = f obtainSafeToHashConstraint ShelleyBasedEraAlonzo f = f obtainSafeToHashConstraint ShelleyBasedEraBabbage f = f obtainSafeToHashConstraint ShelleyBasedEraConway f = f -obtainCertificateConstraints - :: ShelleyBasedEra era - -> (( Shelley.ShelleyEraTxCert (ShelleyLedgerEra era) - , EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto - ) => a) - -> a -obtainCertificateConstraints ShelleyBasedEraShelley f = f -obtainCertificateConstraints ShelleyBasedEraAllegra f = f -obtainCertificateConstraints ShelleyBasedEraMary f = f -obtainCertificateConstraints ShelleyBasedEraAlonzo f = f -obtainCertificateConstraints ShelleyBasedEraBabbage f = f -obtainCertificateConstraints ShelleyBasedEraConway f = f + diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index f0fc1b9971..a7c1a7bcea 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -391,8 +391,9 @@ module Cardano.Api ( -- | Certificates that are embedded in transactions for registering and -- unregistering stake address, and for setting the stake pool delegation -- choice for a stake address. + StakeAddressRequirements(..), makeStakeAddressRegistrationCertificate, - makeStakeAddressDeregistrationCertificate, + makeStakeAddressUnregistrationCertificate, makeStakeAddressPoolDelegationCertificate, -- ** Registering stake pools @@ -792,6 +793,7 @@ module Cardano.Api ( makeMIRCertificate, makeGenesisKeyDelegationCertificate, MIRTarget (..), + MIRPot(..), -- * Protocol parameter updates UpdateProposal(..), @@ -894,7 +896,10 @@ module Cardano.Api ( querySystemStart, queryUtxo, determineEraExpr, - -- * Governance + + -- ** Conway related + AtMostBabbageEra(..), + ConwayEraOnwards(..), -- ** DReps DRepKey, @@ -903,9 +908,11 @@ module Cardano.Api ( DRepMetadataValidationError, validateAndHashDRepMetadata, - -- ** Governance Committee - makeCommitteeDelegationCertificate, - makeCommitteeHotKeyUnregistrationCertificate, + -- ** Governance related certificates + makeCommitteeColdkeyResignationCertificate, + makeCommitteeHotKeyAuthorizationCertificate, + makeDrepRegistrationCertificate, + makeDrepUnregistrationCertificate, ResolvablePointers(..), ) where