diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index b9e0eb1ba5..56ee85cd04 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -598,7 +598,7 @@ genTxCertificates era = ] -- TODO: Add remaining certificates -genCertificate :: Gen Certificate +genCertificate :: Gen (Certificate era) genCertificate = Gen.choice [ StakeAddressRegistrationCertificate <$> genStakeCredential diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 4abac79fdb..1355922620 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -45,6 +46,8 @@ module Cardano.Api.Certificate ( import Cardano.Api.Address import Cardano.Api.DRepMetadata +import Cardano.Api.EraCast +import Cardano.Api.Eras import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Praos import Cardano.Api.Keys.Shelley @@ -73,6 +76,7 @@ import qualified Data.Sequence.Strict as Seq import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text.Encoding as Text +import Data.Typeable import Network.Socket (PortNumber) @@ -80,7 +84,7 @@ import Network.Socket (PortNumber) -- Certificates embedded in transactions -- -data Certificate = +data Certificate era = -- Stake address certificates StakeAddressRegistrationCertificate StakeCredential @@ -109,28 +113,49 @@ data Certificate = deriving stock (Eq, Show) deriving anyclass SerialiseAsCBOR -instance HasTypeProxy Certificate where - data AsType Certificate = AsCertificate +instance Typeable era => HasTypeProxy (Certificate era) where + data AsType (Certificate era) = AsCertificate proxyToAsType _ = AsCertificate -instance ToCBOR Certificate where +instance Typeable era => ToCBOR (Certificate era) where toCBOR = Shelley.toEraCBOR @Shelley.Shelley . toShelleyCertificate -instance FromCBOR Certificate where +instance Typeable era => FromCBOR (Certificate era) where fromCBOR = fromShelleyCertificate <$> Shelley.fromEraCBOR @Shelley.Shelley -instance HasTextEnvelope Certificate where +instance Typeable era => 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" + 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" + +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 @@ -209,47 +234,81 @@ data DRepMetadataReference = -- Constructor functions -- -makeStakeAddressRegistrationCertificate :: StakeCredential -> Certificate -makeStakeAddressRegistrationCertificate = StakeAddressRegistrationCertificate - -makeStakeAddressDeregistrationCertificate :: StakeCredential -> Certificate -makeStakeAddressDeregistrationCertificate = StakeAddressDeregistrationCertificate - -makeStakeAddressPoolDelegationCertificate :: StakeCredential -> PoolId -> Certificate -makeStakeAddressPoolDelegationCertificate = StakeAddressPoolDelegationCertificate - -makeStakePoolRegistrationCertificate :: StakePoolParameters -> Certificate -makeStakePoolRegistrationCertificate = StakePoolRegistrationCertificate - -makeStakePoolRetirementCertificate :: PoolId -> EpochNo -> Certificate -makeStakePoolRetirementCertificate = StakePoolRetirementCertificate - -makeGenesisKeyDelegationCertificate :: Hash GenesisKey - -> Hash GenesisDelegateKey - -> Hash VrfKey - -> Certificate -makeGenesisKeyDelegationCertificate = GenesisKeyDelegationCertificate +makeStakeAddressRegistrationCertificate :: () + => CardanoEra era + -> StakeCredential + -> Certificate era +makeStakeAddressRegistrationCertificate _ = + StakeAddressRegistrationCertificate + +makeStakeAddressDeregistrationCertificate :: () + => CardanoEra era + -> StakeCredential + -> Certificate era +makeStakeAddressDeregistrationCertificate _ = + StakeAddressDeregistrationCertificate + +makeStakeAddressPoolDelegationCertificate :: () + => CardanoEra era + -> StakeCredential + -> PoolId + -> Certificate era +makeStakeAddressPoolDelegationCertificate _ = + StakeAddressPoolDelegationCertificate + +makeStakePoolRegistrationCertificate :: () + => CardanoEra era + -> StakePoolParameters + -> Certificate era +makeStakePoolRegistrationCertificate _ = + StakePoolRegistrationCertificate + +makeStakePoolRetirementCertificate :: () + => CardanoEra era + -> PoolId + -> EpochNo + -> Certificate era +makeStakePoolRetirementCertificate _ = + StakePoolRetirementCertificate + +makeGenesisKeyDelegationCertificate :: () + => CardanoEra era + -> Hash GenesisKey + -> Hash GenesisDelegateKey + -> Hash VrfKey + -> Certificate era +makeGenesisKeyDelegationCertificate _ = + GenesisKeyDelegationCertificate makeCommitteeDelegationCertificate :: () - => Hash CommitteeColdKey + => CardanoEra era + -> Hash CommitteeColdKey -> Hash CommitteeHotKey - -> Certificate -makeCommitteeDelegationCertificate = CommitteeDelegationCertificate + -> Certificate era +makeCommitteeDelegationCertificate _ = + CommitteeDelegationCertificate makeCommitteeHotKeyUnregistrationCertificate :: () - => Hash CommitteeColdKey - -> Certificate -makeCommitteeHotKeyUnregistrationCertificate = CommitteeHotKeyDeregistrationCertificate + => CardanoEra era + -> Hash CommitteeColdKey + -> Certificate era +makeCommitteeHotKeyUnregistrationCertificate _ = + CommitteeHotKeyDeregistrationCertificate -makeMIRCertificate :: MIRPot -> MIRTarget -> Certificate -makeMIRCertificate = MIRCertificate +makeMIRCertificate :: () + => CardanoEra era + -> MIRPot + -> MIRTarget + -> Certificate era +makeMIRCertificate _ = + MIRCertificate -- ---------------------------------------------------------------------------- -- Internal conversion functions -- -toShelleyCertificate :: Certificate -> Shelley.DCert StandardCrypto +toShelleyCertificate :: Certificate era -> Shelley.DCert StandardCrypto toShelleyCertificate (StakeAddressRegistrationCertificate stakecred) = Shelley.DCertDeleg $ Shelley.RegKey @@ -330,7 +389,7 @@ toShelleyCertificate (MIRCertificate mirPot (SendToTreasuryMIR amount)) = error "toShelleyCertificate: Incorrect MIRPot specified. Expected ReservesMIR but got TreasuryMIR" -fromShelleyCertificate :: Shelley.DCert StandardCrypto -> Certificate +fromShelleyCertificate :: Shelley.DCert StandardCrypto -> Certificate era fromShelleyCertificate (Shelley.DCertDeleg (Shelley.RegKey stakecred)) = StakeAddressRegistrationCertificate (fromShelleyStakeCredential stakecred) diff --git a/cardano-api/internal/Cardano/Api/Convenience/Query.hs b/cardano-api/internal/Cardano/Api/Convenience/Query.hs index 33d6f7c6e2..1f7cf9b291 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Query.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Query.hs @@ -71,7 +71,7 @@ renderQueryConvenienceError (QceUnsupportedNtcVersion (UnsupportedNtcVersionErro queryStateForBalancedTx :: () => CardanoEra era -> [TxIn] - -> [Certificate] + -> [Certificate era] -> LocalStateQueryExpr block point (QueryInMode CardanoMode) r IO ( Either QueryConvenienceError diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index 5b1c06577b..f83ed72eee 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -25,6 +25,7 @@ module Cardano.Api.Eras , IsCardanoEra(..) , AnyCardanoEra(..) , anyCardanoEra + , cardanoEraConstraints , InAnyCardanoEra(..) -- * Deprecated aliases @@ -69,6 +70,7 @@ import Control.DeepSeq import Data.Aeson (FromJSON (..), ToJSON, toJSON, withText) import qualified Data.Text as Text import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) +import Data.Typeable (Typeable) -- | A type used as a tag to distinguish the Byron era. data ByronEra @@ -558,3 +560,13 @@ withShelleyBasedEraConstraintsForLedger = \case ShelleyBasedEraAlonzo -> id ShelleyBasedEraBabbage -> id ShelleyBasedEraConway -> id + +cardanoEraConstraints :: CardanoEra era -> (Typeable era => IsCardanoEra era => a) -> a +cardanoEraConstraints = \case + ByronEra -> id + ShelleyEra -> id + AllegraEra -> id + MaryEra -> id + AlonzoEra -> id + BabbageEra -> id + ConwayEra -> id diff --git a/cardano-api/internal/Cardano/Api/LedgerEvent.hs b/cardano-api/internal/Cardano/Api/LedgerEvent.hs index b8fae479cd..e8dab70383 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvent.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvent.hs @@ -19,7 +19,6 @@ where import Cardano.Api.Address (StakeCredential, fromShelleyStakeCredential) import Cardano.Api.Block (EpochNo) -import Cardano.Api.Certificate (Certificate) import Cardano.Api.Keys.Shelley (Hash (StakePoolKeyHash), StakePoolKey) import Cardano.Api.Value (Lovelace, fromShelleyDeltaLovelace, fromShelleyLovelace) @@ -60,9 +59,9 @@ import Data.SOP.Strict data LedgerEvent = -- | The given pool is being registered for the first time on chain. - PoolRegistration Certificate + PoolRegistration | -- | The given pool already exists and is being re-registered. - PoolReRegistration Certificate + PoolReRegistration | -- | Incremental rewards are being computed. IncrementalRewardsDistribution EpochNo (Map StakeCredential (Set (Reward StandardCrypto))) | -- | Reward distribution has completed. diff --git a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs index 23a89d8840..a7f0bbc5f8 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseTextEnvelope.hs @@ -11,6 +11,7 @@ -- module Cardano.Api.SerialiseTextEnvelope ( HasTextEnvelope(..) + , textEnvelopeTypeInEra , TextEnvelope(..) , TextEnvelopeType(..) , TextEnvelopeDescr(..) @@ -33,6 +34,7 @@ module Cardano.Api.SerialiseTextEnvelope , AsType(..) ) where +import Cardano.Api.Eras import Cardano.Api.Error import Cardano.Api.HasTypeProxy import Cardano.Api.IO @@ -165,6 +167,13 @@ class SerialiseAsCBOR a => HasTextEnvelope a where textEnvelopeDefaultDescr :: a -> TextEnvelopeDescr textEnvelopeDefaultDescr _ = "" +textEnvelopeTypeInEra :: () + => HasTextEnvelope (f era) + => CardanoEra era + -> AsType (f era) + -> TextEnvelopeType +textEnvelopeTypeInEra _ = + textEnvelopeType serialiseToTextEnvelope :: forall a. HasTextEnvelope a => Maybe TextEnvelopeDescr -> a -> TextEnvelope diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 8f03079c7e..7353e17978 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1693,7 +1693,7 @@ data TxCertificates build era where TxCertificatesNone :: TxCertificates build era TxCertificates :: CertificatesSupportedInEra era - -> [Certificate] + -> [Certificate era] -> BuildTxWith build (Map StakeCredential (Witness WitCtxStake era)) -> TxCertificates build era diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 092d495b9a..64295b5986 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -23,6 +23,7 @@ module Cardano.Api ( IsCardanoEra(..), AnyCardanoEra(..), anyCardanoEra, + cardanoEraConstraints, InAnyCardanoEra(..), -- ** Shelley-based eras @@ -564,6 +565,7 @@ module Cardano.Api ( TextEnvelopeType(..), TextEnvelopeDescr, TextEnvelopeError(..), + textEnvelopeTypeInEra, textEnvelopeRawCBOR, textEnvelopeToJSON, serialiseToTextEnvelope,