diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index d9b47378d6..d399744ed8 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -105,8 +105,14 @@ library internal Cardano.Api.Keys.Read Cardano.Api.Keys.Shelley Cardano.Api.Ledger.Lens - Cardano.Api.LedgerEvent Cardano.Api.LedgerState + Cardano.Api.LedgerEvents.ConvertLedgerEvent + Cardano.Api.LedgerEvents.Rule.DELEGS + Cardano.Api.LedgerEvents.Rule.LEDGER + Cardano.Api.LedgerEvents.Rule.NEWEPOCH + Cardano.Api.LedgerEvents.Rule.RUPD + Cardano.Api.LedgerEvents.Rule.UTXOW + Cardano.Api.LedgerEvents.LedgerEvent Cardano.Api.Modes Cardano.Api.NetworkId Cardano.Api.OperationalCertificate diff --git a/cardano-api/internal/Cardano/Api/LedgerEvent.hs b/cardano-api/internal/Cardano/Api/LedgerEvent.hs deleted file mode 100644 index 3ff20c7245..0000000000 --- a/cardano-api/internal/Cardano/Api/LedgerEvent.hs +++ /dev/null @@ -1,425 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} - -module Cardano.Api.LedgerEvent - ( LedgerEvent (..), - MIRDistributionDetails (..), - PoolReapDetails (..), - AnyProposals(..), - AnyRatificationState(..), - toLedgerEvent, - ) -where - -import Cardano.Api.Address (StakeCredential, fromShelleyStakeCredential) -import Cardano.Api.Block (EpochNo) -import Cardano.Api.Keys.Shelley (Hash (StakePoolKeyHash), StakePoolKey) -import Cardano.Api.Value (Lovelace, fromShelleyDeltaLovelace, fromShelleyLovelace) - -import Cardano.Ledger.Alonzo.Plutus.TxInfo (PlutusDebug) -import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyEvent (..), AlonzoUtxoEvent (..), - AlonzoUtxosEvent (FailedPlutusScriptsEvent, SuccessfulPlutusScriptsEvent), - AlonzoUtxowEvent (..)) -import Cardano.Ledger.Api.Era (AllegraEra, AlonzoEra, BabbageEra, ConwayEra, MaryEra, - ShelleyEra) -import qualified Cardano.Ledger.Coin as Ledger -import qualified Cardano.Ledger.Conway.Governance as Ledger -import qualified Cardano.Ledger.Conway.Rules as Conway -import Cardano.Ledger.Core (EraCrypto) -import qualified Cardano.Ledger.Core as Ledger.Core -import qualified Cardano.Ledger.Credential as Ledger -import Cardano.Ledger.Crypto (StandardCrypto) -import qualified Cardano.Ledger.Keys as Ledger -import Cardano.Ledger.Shelley.API (InstantaneousRewards (InstantaneousRewards)) -import Cardano.Ledger.Shelley.Rewards (Reward) -import Cardano.Ledger.Shelley.Rules (RupdEvent (..), ShelleyBbodyEvent (LedgersEvent), - ShelleyEpochEvent (..), ShelleyMirEvent (..), ShelleyNewEpochEvent (..), - ShelleyPoolreapEvent (..), ShelleyTickEvent (TickNewEpochEvent), - ShelleyUtxowEvent (UtxoEvent)) -import qualified Cardano.Ledger.Shelley.Rules as Shelley (ShelleyLedgerEvent (UtxowEvent), - ShelleyLedgersEvent (LedgerEvent)) -import qualified Cardano.Ledger.TxIn as Ledger -import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) -import Ouroboros.Consensus.Cardano.Block (HardForkBlock) -import qualified Ouroboros.Consensus.Cardano.Block as Consensus -import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLedgerEvent) -import Ouroboros.Consensus.Ledger.Basics (AuxLedgerEvent) -import qualified Ouroboros.Consensus.Protocol.Praos as Consensus -import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus -import Ouroboros.Consensus.Shelley.Ledger (LedgerState, ShelleyBlock, - ShelleyLedgerEvent (ShelleyLedgerEventBBODY, ShelleyLedgerEventTICK)) -import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (unwrapLedgerEvent)) - -import Control.State.Transition (Event) -import Data.List.NonEmpty (NonEmpty) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import Data.SOP.Strict - -data AnyProposals - = forall era. Ledger.Core.EraPParams era => AnyProposals (Ledger.Proposals era) - -deriving instance Show AnyProposals - -data AnyRatificationState - = forall era. Ledger.Core.EraPParams era => AnyRatificationState (Ledger.RatifyState era) - -deriving instance Show AnyRatificationState - -data LedgerEvent - = -- | The given pool is being registered for the first time on chain. - PoolRegistration - | -- | The given pool already exists and is being re-registered. - PoolReRegistration - | -- | Incremental rewards are being computed. - IncrementalRewardsDistribution EpochNo (Map StakeCredential (Set (Reward StandardCrypto))) - | -- | Reward distribution has completed. - RewardsDistribution EpochNo (Map StakeCredential (Set (Reward StandardCrypto))) - | -- | MIR are being distributed. - MIRDistribution MIRDistributionDetails - | -- | Pools have been reaped and deposits refunded. - PoolReap PoolReapDetails - -- | A number of succeeded Plutus script evaluations. - | SuccessfulPlutusScript (NonEmpty PlutusDebug) - -- | A number of failed Plutus script evaluations. - | FailedPlutusScript (NonEmpty PlutusDebug) - - - -- Only events available on the Conway Era. - -- TODO: Update the above constructors to work in the conway era. - -- See toLedgerEventConway - -- | Newly submittted governance proposals in a single transaction. - | NewGovernanceProposals (Ledger.TxId StandardCrypto) AnyProposals - -- | The current state of governance matters at the epoch boundary. - -- I.E the current constitution, committee, protocol parameters, etc. - | EpochBoundaryRatificationState AnyRatificationState - deriving Show - -class ConvertLedgerEvent blk where - toLedgerEvent :: WrapLedgerEvent blk -> Maybe LedgerEvent - -instance ConvertLedgerEvent ByronBlock where - toLedgerEvent _ = Nothing - -instance ConvertLedgerEvent (ShelleyBlock protocol (ShelleyEra StandardCrypto)) where - toLedgerEvent = toLedgerEventShelley - -instance ConvertLedgerEvent (ShelleyBlock protocol (MaryEra StandardCrypto)) where - toLedgerEvent = toLedgerEventShelley - -instance ConvertLedgerEvent (ShelleyBlock protocol (AllegraEra StandardCrypto)) where - toLedgerEvent = toLedgerEventShelley - -instance ConvertLedgerEvent (ShelleyBlock protocol (AlonzoEra StandardCrypto)) where - toLedgerEvent evt = case unwrapLedgerEvent evt of - LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds - LEPlutusFailure ds -> Just $ FailedPlutusScript ds - _ -> toLedgerEventShelley evt - -instance ConvertLedgerEvent (ShelleyBlock protocol (BabbageEra StandardCrypto)) where - toLedgerEvent evt = case unwrapLedgerEvent evt of - LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds - LEPlutusFailure ds -> Just $ FailedPlutusScript ds - _ -> toLedgerEventShelley evt - -instance ConvertLedgerEvent (ShelleyBlock protocol (ConwayEra StandardCrypto)) where - toLedgerEvent = toLedgerEventConway - -- LEDGER rule is defined anew in Conway - -instance ConvertLedgerEvent (HardForkBlock (Consensus.CardanoEras StandardCrypto)) where - toLedgerEvent wrappedLedgerEvent = - case getOneEraLedgerEvent $ unwrapLedgerEvent wrappedLedgerEvent of - ShelleyLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent - AllegraLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent - MaryLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent - AlonzoLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent - BabbageLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent - ConwayLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent - -{-# COMPLETE ShelleyLedgerEvent, - AllegraLedgerEvent, - MaryLedgerEvent, - AlonzoLedgerEvent, - BabbageLedgerEvent, - ConwayLedgerEvent #-} - - -pattern ShelleyLedgerEvent - :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (ShelleyEra StandardCrypto)) - -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern ShelleyLedgerEvent x = S (Z x) - -pattern AllegraLedgerEvent - :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (AllegraEra StandardCrypto)) - -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern AllegraLedgerEvent x = S (S (Z x)) - -pattern MaryLedgerEvent - :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (MaryEra StandardCrypto)) - -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern MaryLedgerEvent x = S (S (S (Z x))) - -pattern AlonzoLedgerEvent - :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (AlonzoEra StandardCrypto)) - -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern AlonzoLedgerEvent x = S (S (S (S (Z x)))) - -pattern BabbageLedgerEvent - :: WrapLedgerEvent (ShelleyBlock (Consensus.Praos StandardCrypto) (BabbageEra StandardCrypto)) - -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern BabbageLedgerEvent x = S (S (S (S (S (Z x))))) - -pattern ConwayLedgerEvent - :: WrapLedgerEvent (ShelleyBlock (Consensus.Praos StandardCrypto) (ConwayEra StandardCrypto)) - -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) -pattern ConwayLedgerEvent x = S (S (S (S (S (S (Z x)))))) - -toLedgerEventShelley :: - ( EraCrypto ledgerera ~ StandardCrypto, - Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, - Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, - Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera, - Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera, - Event (Ledger.Core.EraRule "MIR" ledgerera) ~ ShelleyMirEvent ledgerera, - Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto - ) => - WrapLedgerEvent (ShelleyBlock protocol ledgerera) -> - Maybe LedgerEvent -toLedgerEventShelley evt = case unwrapLedgerEvent evt of - LEDeltaRewardEvent e m -> Just $ IncrementalRewardsDistribution e m - LERewardEvent e m -> Just $ RewardsDistribution e m - LEMirTransfer rp rt rtt ttr -> - Just $ - MIRDistribution $ - MIRDistributionDetails rp rt rtt ttr - LERetiredPools r u e -> Just $ PoolReap $ PoolReapDetails e r u - _ -> Nothing - --- TODO: Extract era specific events to their own modules and use the COMPLETE paramsAllegra -toLedgerEventConway - :: WrapLedgerEvent (ShelleyBlock protocol (ConwayEra StandardCrypto)) - -> Maybe LedgerEvent -toLedgerEventConway evt = case unwrapLedgerEvent evt of --- TODO: Return all existing ledger events - LEGovNewProposals txid proposals -> - Just $ NewGovernanceProposals txid (AnyProposals proposals) - LEEpochBoundaryRatificationState ratState -> - Just $ EpochBoundaryRatificationState (AnyRatificationState ratState) - _ -> Nothing - --------------------------------------------------------------------------------- --- Event details --------------------------------------------------------------------------------- - --- | Details of fund transfers due to MIR certificates. --- --- Note that the transfers from reserves to treasury and treasury to reserves --- are inverse; a transfer of 100 ADA in either direction will result in a net --- movement of 0, but we include both directions for assistance in debugging. -data MIRDistributionDetails = MIRDistributionDetails - { mirddReservePayouts :: Map StakeCredential Lovelace, - mirddTreasuryPayouts :: Map StakeCredential Lovelace, - mirddReservesToTreasury :: Lovelace, - mirddTreasuryToReserves :: Lovelace - } deriving Show - -data PoolReapDetails = PoolReapDetails - { prdEpochNo :: EpochNo, - -- | Refunded deposits. The pools referenced are now retired, and the - -- 'StakeCredential' accounts are credited with the deposits. - prdRefunded :: Map StakeCredential (Map (Hash StakePoolKey) Lovelace), - -- | Unclaimed deposits. The 'StakeCredential' referenced in this map is not - -- actively registered at the time of the pool reaping, and as such the - -- funds are returned to the treasury. - prdUnclaimed :: Map StakeCredential (Map (Hash StakePoolKey) Lovelace) - } deriving Show - --------------------------------------------------------------------------------- --- Patterns for event access --------------------------------------------------------------------------------- - -pattern LEGovNewProposals :: - ( EraCrypto ledgerera ~ StandardCrypto - , Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera - , Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera - , Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Conway.ConwayLedgerEvent ledgerera - , Event (Ledger.Core.EraRule "GOV" ledgerera) ~ Conway.ConwayGovEvent ledgerera - ) => Ledger.TxId StandardCrypto - -> Ledger.Proposals ledgerera - -> AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) -pattern LEGovNewProposals txid props <- - ShelleyLedgerEventBBODY - (ShelleyInAlonzoEvent - (LedgersEvent - (Shelley.LedgerEvent - (Conway.GovEvent - (Conway.GovNewProposals txid props) - ) - ) - ) - ) - -pattern LEEpochBoundaryRatificationState - :: ( EraCrypto ledgerera ~ StandardCrypto - , Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera - , Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ Conway.ConwayNewEpochEvent ledgerera - , Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ Conway.ConwayEpochEvent ledgerera - ) => Ledger.RatifyState ledgerera - -> AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) -pattern LEEpochBoundaryRatificationState ratifyState <- - ShelleyLedgerEventTICK (TickNewEpochEvent (Conway.EpochEvent (Conway.EpochBoundaryRatifyState ratifyState))) - - -pattern LERewardEvent :: - ( EraCrypto ledgerera ~ StandardCrypto, - Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, - Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera - ) => - EpochNo -> - Map StakeCredential (Set (Reward StandardCrypto)) -> - AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) -pattern LERewardEvent e m <- - ShelleyLedgerEventTICK - (TickNewEpochEvent (TotalRewardEvent e (Map.mapKeys fromShelleyStakeCredential -> m))) - -pattern LEDeltaRewardEvent :: - ( EraCrypto ledgerera ~ StandardCrypto, - Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, - Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, - Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto - ) => - EpochNo -> - Map StakeCredential (Set (Reward StandardCrypto)) -> - AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) -pattern LEDeltaRewardEvent e m <- - ShelleyLedgerEventTICK - (TickNewEpochEvent (DeltaRewardEvent (RupdEvent e (Map.mapKeys fromShelleyStakeCredential -> m)))) - -pattern LEMirTransfer :: - ( EraCrypto ledgerera ~ StandardCrypto, - Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, - Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, - Event (Ledger.Core.EraRule "MIR" ledgerera) ~ ShelleyMirEvent ledgerera - ) => - Map StakeCredential Lovelace -> - Map StakeCredential Lovelace -> - Lovelace -> - Lovelace -> - AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) -pattern LEMirTransfer rp tp rtt ttr <- - ShelleyLedgerEventTICK - ( TickNewEpochEvent - ( MirEvent - ( MirTransfer - ( InstantaneousRewards - (Map.mapKeys fromShelleyStakeCredential . fmap fromShelleyLovelace -> rp) - (Map.mapKeys fromShelleyStakeCredential . fmap fromShelleyLovelace -> tp) - (fromShelleyDeltaLovelace -> rtt) - (fromShelleyDeltaLovelace -> ttr) - ) - ) - ) - ) - -pattern LERetiredPools :: - ( EraCrypto ledgerera ~ StandardCrypto, - Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera, - Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera, - Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera, - Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera - ) => - Map StakeCredential (Map (Hash StakePoolKey) Lovelace) -> - Map StakeCredential (Map (Hash StakePoolKey) Lovelace) -> - EpochNo -> - AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) -pattern LERetiredPools r u e <- - ShelleyLedgerEventTICK - ( TickNewEpochEvent - ( EpochEvent - ( PoolReapEvent - ( RetiredPools - (convertRetiredPoolsMap -> r) - (convertRetiredPoolsMap -> u) - e - ) - ) - ) - ) - -pattern LEPlutusSuccess :: - ( EraCrypto ledgerera ~ StandardCrypto, - Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera, - Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera, - Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera, - Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera, - Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera, - Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera - ) => - NonEmpty PlutusDebug -> - AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) -pattern LEPlutusSuccess ds <- - ShelleyLedgerEventBBODY - ( ShelleyInAlonzoEvent - ( LedgersEvent - ( Shelley.LedgerEvent - ( Shelley.UtxowEvent - ( WrappedShelleyEraEvent - ( UtxoEvent - ( UtxosEvent - ( SuccessfulPlutusScriptsEvent ds - ) - ) - ) - ) - ) - ) - ) - ) - -pattern LEPlutusFailure :: - ( EraCrypto ledgerera ~ StandardCrypto, - Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera, - Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera, - Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera, - Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera, - Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera, - Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera - ) => - NonEmpty PlutusDebug -> - AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera)) -pattern LEPlutusFailure ds <- - ShelleyLedgerEventBBODY - ( ShelleyInAlonzoEvent - ( LedgersEvent - ( Shelley.LedgerEvent - ( Shelley.UtxowEvent - ( WrappedShelleyEraEvent - ( UtxoEvent - ( UtxosEvent - ( FailedPlutusScriptsEvent ds - ) - ) - ) - ) - ) - ) - ) - ) - -convertRetiredPoolsMap :: - Map (Ledger.StakeCredential StandardCrypto) (Map (Ledger.KeyHash Ledger.StakePool StandardCrypto) Ledger.Coin) - -> Map StakeCredential (Map (Hash StakePoolKey) Lovelace) -convertRetiredPoolsMap = - Map.mapKeys fromShelleyStakeCredential - . fmap (Map.mapKeys StakePoolKeyHash . fmap fromShelleyLovelace) diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/ConvertLedgerEvent.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/ConvertLedgerEvent.hs new file mode 100644 index 0000000000..924edcc558 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/ConvertLedgerEvent.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} + +module Cardano.Api.LedgerEvents.ConvertLedgerEvent + ( LedgerEvent (..), + toLedgerEvent, + ) where + +import Cardano.Api.LedgerEvents.LedgerEvent +import Cardano.Api.LedgerEvents.Rule.DELEGS +import Cardano.Api.LedgerEvents.Rule.LEDGER +import Cardano.Api.LedgerEvents.Rule.NEWEPOCH +import Cardano.Api.LedgerEvents.Rule.RUPD +import Cardano.Api.LedgerEvents.Rule.UTXOW + +import qualified Cardano.Ledger.Allegra.Rules as Allegra +import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyEvent (..)) +import Cardano.Ledger.Api.Era (AllegraEra, AlonzoEra, BabbageEra, ConwayEra, MaryEra, + ShelleyEra) +import qualified Cardano.Ledger.Conway.Rules as Conway +import Cardano.Ledger.Core +import qualified Cardano.Ledger.Core as Ledger.Core +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Shelley.Rules (RupdEvent (..), ShelleyBbodyEvent (LedgersEvent), + ShelleyNewEpochEvent (..), ShelleyTickEvent (TickNewEpochEvent, TickRupdEvent), + ShelleyUtxowEvent (..)) +import qualified Cardano.Ledger.Shelley.Rules as Shelley +import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) +import Ouroboros.Consensus.Cardano.Block (HardForkBlock) +import qualified Ouroboros.Consensus.Cardano.Block as Consensus +import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLedgerEvent) +import qualified Ouroboros.Consensus.Protocol.Praos as Consensus +import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus +import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, + ShelleyLedgerEvent (ShelleyLedgerEventBBODY, ShelleyLedgerEventTICK)) +import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (unwrapLedgerEvent)) + +import Control.State.Transition (Event) +import Data.SOP.Strict + +class ConvertLedgerEvent blk where + toLedgerEvent :: WrapLedgerEvent blk -> Maybe LedgerEvent + +instance ConvertLedgerEvent ByronBlock where + toLedgerEvent _ = Nothing + +instance ConvertLedgerEvent (ShelleyBlock protocol (ShelleyEra StandardCrypto)) where + toLedgerEvent = toLedgerEventShelley + +toLedgerEventShelley + :: EraCrypto ledgerera ~ StandardCrypto + => Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera + => Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera + => Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ Shelley.ShelleyPoolreapEvent ledgerera + => Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ Shelley.ShelleyEpochEvent ledgerera + => Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto + => Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ ShelleyBbodyEvent ledgerera + => Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera + => Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera + => Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ ShelleyUtxowEvent ledgerera + => Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Shelley.UtxoEvent ledgerera + => Event (Ledger.Core.EraRule "PPUP" ledgerera) ~ Shelley.PpupEvent ledgerera + => Event (EraRule "DELEGS" ledgerera) ~ Shelley.ShelleyDelegsEvent ledgerera + => WrapLedgerEvent (ShelleyBlock protocol ledgerera) -> Maybe LedgerEvent +toLedgerEventShelley evt = case unwrapLedgerEvent evt of + ShelleyLedgerEventTICK e -> handleLedgerTICKEvents e + ShelleyLedgerEventBBODY e -> handleShelleyLedgerBBODYEvents e + +handleShelleyLedgerBBODYEvents + :: Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera + => Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera + => Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ ShelleyUtxowEvent ledgerera + => Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Shelley.UtxoEvent ledgerera + => Event (Ledger.Core.EraRule "PPUP" ledgerera) ~ Shelley.PpupEvent ledgerera + => Event (EraRule "DELEGS" ledgerera) ~ Shelley.ShelleyDelegsEvent ledgerera + => ShelleyBbodyEvent ledgerera -> Maybe LedgerEvent +handleShelleyLedgerBBODYEvents (LedgersEvent (Shelley.LedgerEvent e)) = + case e of + Shelley.UtxowEvent ev -> handlePreAlonzoUTxOWEvent ev + Shelley.DelegsEvent ev -> handleShelleyDELEGSEvent ev + + +instance ConvertLedgerEvent (ShelleyBlock protocol (MaryEra StandardCrypto)) where + toLedgerEvent = toLedgerEventAllegraMary + +instance ConvertLedgerEvent (ShelleyBlock protocol (AllegraEra StandardCrypto)) where + toLedgerEvent = toLedgerEventAllegraMary + +toLedgerEventAllegraMary + :: EraCrypto ledgerera ~ StandardCrypto + => Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera + => Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera + => Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ Shelley.ShelleyPoolreapEvent ledgerera + => Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ Shelley.ShelleyEpochEvent ledgerera + => Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto + => Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ ShelleyBbodyEvent ledgerera + => Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera + => Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera + => Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ ShelleyUtxowEvent ledgerera + => Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Allegra.AllegraUtxoEvent ledgerera + => Event (Ledger.Core.EraRule "PPUP" ledgerera) ~ Shelley.PpupEvent ledgerera + => Event (Ledger.Core.EraRule "DELEGS" ledgerera) ~ Shelley.ShelleyDelegsEvent ledgerera + => WrapLedgerEvent (ShelleyBlock protocol ledgerera) -> + Maybe LedgerEvent +toLedgerEventAllegraMary evt = case unwrapLedgerEvent evt of + ShelleyLedgerEventTICK e -> handleLedgerTICKEvents e + ShelleyLedgerEventBBODY e -> handleAllegraMaryLedgerBBODYEvents e + +handleAllegraMaryLedgerBBODYEvents + :: Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera + => Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera + => Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ ShelleyUtxowEvent ledgerera + => Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Allegra.AllegraUtxoEvent ledgerera + => Event (Ledger.Core.EraRule "PPUP" ledgerera) ~ Shelley.PpupEvent ledgerera + => Event (Ledger.Core.EraRule "DELEGS" ledgerera) ~ Shelley.ShelleyDelegsEvent ledgerera + => ShelleyBbodyEvent ledgerera -> Maybe LedgerEvent +handleAllegraMaryLedgerBBODYEvents (LedgersEvent (Shelley.LedgerEvent e)) = + case e of + Shelley.UtxowEvent ev -> handleAllegraMaryUTxOWEvent ev + Shelley.DelegsEvent ev -> handleShelleyDELEGSEvent ev + +instance ConvertLedgerEvent (ShelleyBlock protocol (AlonzoEra StandardCrypto)) where + toLedgerEvent = toAlonzoOrBabbageLedgerEvents + +instance ConvertLedgerEvent (ShelleyBlock protocol (BabbageEra StandardCrypto)) where + toLedgerEvent = toAlonzoOrBabbageLedgerEvents + +toAlonzoOrBabbageLedgerEvents + :: EraCrypto ledgerera ~ StandardCrypto + => LatestTickEventConstraints ledgerera + => LatestBBodyEventConstraints ledgerera + => WrapLedgerEvent (ShelleyBlock protocol ledgerera) -> Maybe LedgerEvent +toAlonzoOrBabbageLedgerEvents e = + case unwrapLedgerEvent e of + ShelleyLedgerEventTICK tickEvent -> handleLedgerTICKEvents tickEvent + ShelleyLedgerEventBBODY bbodyEvent -> handleAlonzoToBabbageLedgerBBODYEvents bbodyEvent + +handleAlonzoToBabbageLedgerBBODYEvents + :: LatestBBodyEventConstraints ledgerera + => AlonzoBbodyEvent ledgerera -> Maybe LedgerEvent +handleAlonzoToBabbageLedgerBBODYEvents (ShelleyInAlonzoEvent (LedgersEvent (Shelley.LedgerEvent ledgerEvent))) = + handleShelleyLEDGEREvents ledgerEvent + + +instance ConvertLedgerEvent (ShelleyBlock protocol (ConwayEra StandardCrypto)) where + toLedgerEvent = toLedgerEventConway + -- LEDGER rule is defined anew in Conway + +toLedgerEventConway + :: WrapLedgerEvent (ShelleyBlock protocol (ConwayEra StandardCrypto)) + -> Maybe LedgerEvent +toLedgerEventConway evt = + case unwrapLedgerEvent evt of + ShelleyLedgerEventTICK (TickNewEpochEvent newEpochEvent) -> handleConwayNEWEPOCHEvents newEpochEvent + ShelleyLedgerEventTICK (TickRupdEvent rewardUpdate) -> handleLedgerRUPDEvents rewardUpdate + ShelleyLedgerEventBBODY (ShelleyInAlonzoEvent (LedgersEvent (Shelley.LedgerEvent conwayLedgerEvent))) -> + case conwayLedgerEvent of + Conway.UtxowEvent{} -> Nothing + Conway.CertsEvent{} -> Nothing + Conway.GovEvent govEvent -> + case govEvent of + Conway.GovNewProposals txid props -> + Just $ NewGovernanceProposals txid (AnyProposals props) + +instance ConvertLedgerEvent (HardForkBlock (Consensus.CardanoEras StandardCrypto)) where + toLedgerEvent wrappedLedgerEvent = + case getOneEraLedgerEvent $ unwrapLedgerEvent wrappedLedgerEvent of + ShelleyLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent + AllegraLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent + MaryLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent + AlonzoLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent + BabbageLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent + ConwayLedgerEvent ledgerEvent -> toLedgerEvent ledgerEvent + +{-# COMPLETE ShelleyLedgerEvent, + AllegraLedgerEvent, + MaryLedgerEvent, + AlonzoLedgerEvent, + BabbageLedgerEvent, + ConwayLedgerEvent #-} + + +pattern ShelleyLedgerEvent + :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (ShelleyEra StandardCrypto)) + -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) +pattern ShelleyLedgerEvent x = S (Z x) + +pattern AllegraLedgerEvent + :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (AllegraEra StandardCrypto)) + -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) +pattern AllegraLedgerEvent x = S (S (Z x)) + +pattern MaryLedgerEvent + :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (MaryEra StandardCrypto)) + -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) +pattern MaryLedgerEvent x = S (S (S (Z x))) + +pattern AlonzoLedgerEvent + :: WrapLedgerEvent (ShelleyBlock (Consensus.TPraos StandardCrypto) (AlonzoEra StandardCrypto)) + -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) +pattern AlonzoLedgerEvent x = S (S (S (S (Z x)))) + +pattern BabbageLedgerEvent + :: WrapLedgerEvent (ShelleyBlock (Consensus.Praos StandardCrypto) (BabbageEra StandardCrypto)) + -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) +pattern BabbageLedgerEvent x = S (S (S (S (S (Z x))))) + +pattern ConwayLedgerEvent + :: WrapLedgerEvent (ShelleyBlock (Consensus.Praos StandardCrypto) (ConwayEra StandardCrypto)) + -> NS WrapLedgerEvent (Consensus.CardanoEras StandardCrypto) +pattern ConwayLedgerEvent x = S (S (S (S (S (S (Z x)))))) diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs new file mode 100644 index 0000000000..606ae89a08 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Api.LedgerEvents.LedgerEvent + ( LedgerEvent(..) + , AnyProposals(..) + , AnyRatificationState(..) + , MIRDistributionDetails(..) + , PoolReapDetails(..) + , convertRetiredPoolsMap + ) where + +import Cardano.Api.Address (StakeCredential, fromShelleyStakeCredential) +import Cardano.Api.Block (EpochNo) +import Cardano.Api.Keys.Shelley (Hash (..), StakePoolKey) +import Cardano.Api.Value (Lovelace, fromShelleyLovelace) + +import Cardano.Ledger.Alonzo.Plutus.TxInfo (PlutusDebug) +import qualified Cardano.Ledger.Coin as Ledger +import qualified Cardano.Ledger.Conway.Governance as Ledger +import qualified Cardano.Ledger.Core as Ledger.Core +import qualified Cardano.Ledger.Credential as Ledger +import Cardano.Ledger.Crypto (StandardCrypto) +import qualified Cardano.Ledger.Keys as Ledger +import Cardano.Ledger.Shelley.Rewards (Reward) +import qualified Cardano.Ledger.TxIn as Ledger + +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) + + +data AnyProposals + = forall era. Ledger.Core.EraPParams era => AnyProposals (Ledger.Proposals era) + +deriving instance Show AnyProposals + +data AnyRatificationState + = forall era. Ledger.Core.EraPParams era => AnyRatificationState (Ledger.RatifyState era) + +deriving instance Show AnyRatificationState + +data LedgerEvent + = -- | The given pool is being registered for the first time on chain. + PoolRegistration + | -- | The given pool already exists and is being re-registered. + PoolReRegistration + | -- | Incremental rewards are being computed. + IncrementalRewardsDistribution EpochNo (Map StakeCredential (Set (Reward StandardCrypto))) + | -- | Reward distribution has completed. + RewardsDistribution EpochNo (Map StakeCredential (Set (Reward StandardCrypto))) + | -- | MIR are being distributed. + MIRDistribution MIRDistributionDetails + | -- | Pools have been reaped and deposits refunded. + PoolReap PoolReapDetails + -- | A number of succeeded Plutus script evaluations. + | SuccessfulPlutusScript (NonEmpty PlutusDebug) + -- | A number of failed Plutus script evaluations. + | FailedPlutusScript (NonEmpty PlutusDebug) + + + -- Only events available on the Conway Era. + -- TODO: Update the above constructors to work in the conway era. + -- See toLedgerEventConway + -- | Newly submittted governance proposals in a single transaction. + | NewGovernanceProposals (Ledger.TxId StandardCrypto) AnyProposals + -- | The current state of governance matters at the epoch boundary. + -- I.E the current constitution, committee, protocol parameters, etc. + | EpochBoundaryRatificationState AnyRatificationState + deriving Show + + +-------------------------------------------------------------------------------- +-- Event details +-------------------------------------------------------------------------------- + +-- | Details of fund transfers due to MIR certificates. +-- +-- Note that the transfers from reserves to treasury and treasury to reserves +-- are inverse; a transfer of 100 ADA in either direction will result in a net +-- movement of 0, but we include both directions for assistance in debugging. +data MIRDistributionDetails = MIRDistributionDetails + { mirddReservePayouts :: Map StakeCredential Lovelace, + mirddTreasuryPayouts :: Map StakeCredential Lovelace, + mirddReservesToTreasury :: Lovelace, + mirddTreasuryToReserves :: Lovelace + } deriving Show + +data PoolReapDetails = PoolReapDetails + { prdEpochNo :: EpochNo, + -- | Refunded deposits. The pools referenced are now retired, and the + -- 'StakeCredential' accounts are credited with the deposits. + prdRefunded :: Map StakeCredential (Map (Hash StakePoolKey) Lovelace), + -- | Unclaimed deposits. The 'StakeCredential' referenced in this map is not + -- actively registered at the time of the pool reaping, and as such the + -- funds are returned to the treasury. + prdUnclaimed :: Map StakeCredential (Map (Hash StakePoolKey) Lovelace) + } deriving Show + +convertRetiredPoolsMap + :: Map (Ledger.StakeCredential StandardCrypto) (Map (Ledger.KeyHash Ledger.StakePool StandardCrypto) Ledger.Coin) + -> Map StakeCredential (Map (Hash StakePoolKey) Lovelace) +convertRetiredPoolsMap = + Map.mapKeys fromShelleyStakeCredential + . fmap (Map.mapKeys StakePoolKeyHash . fmap fromShelleyLovelace) diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/DELEGS.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/DELEGS.hs new file mode 100644 index 0000000000..0725d7f923 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/DELEGS.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Api.LedgerEvents.Rule.DELEGS + ( handleShelleyDELEGSEvent + ) where + +import Cardano.Api.LedgerEvents.LedgerEvent + +import qualified Cardano.Ledger.Shelley.Rules as Shelley + +handleShelleyDELEGSEvent :: Shelley.ShelleyDelegsEvent ledgerera -> Maybe LedgerEvent +handleShelleyDELEGSEvent _ = Nothing diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/LEDGER.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/LEDGER.hs new file mode 100644 index 0000000000..1b34177d64 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/LEDGER.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Api.LedgerEvents.Rule.LEDGER + ( LatestBBodyEventConstraints + , handleShelleyLEDGEREvents + ) where + +import Cardano.Api.LedgerEvents.LedgerEvent +import Cardano.Api.LedgerEvents.Rule.DELEGS +import Cardano.Api.LedgerEvents.Rule.UTXOW + +import Cardano.Ledger.Alonzo.Rules (AlonzoUtxoEvent (..), AlonzoUtxosEvent (..), + AlonzoUtxowEvent (..)) +import qualified Cardano.Ledger.Alonzo.Rules as Alonzo +import qualified Cardano.Ledger.Core as Ledger.Core +import qualified Cardano.Ledger.Shelley.Rules as Shelley + +import Control.State.Transition.Extended + +type LatestBBodyEventConstraints ledgerera = + ( Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ Alonzo.AlonzoBbodyEvent ledgerera + , Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera + , Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera + , Event (Ledger.Core.EraRule "DELEGS" ledgerera) ~ Shelley.ShelleyDelegsEvent ledgerera + , Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera + , Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera + , Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera + ) + +handleShelleyLEDGEREvents + :: Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera + => Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera + => Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera + => Event (Ledger.Core.EraRule "DELEGS" ledgerera) ~ Shelley.ShelleyDelegsEvent ledgerera + => Shelley.ShelleyLedgerEvent ledgerera -> Maybe LedgerEvent +handleShelleyLEDGEREvents ledgerEvent = + case ledgerEvent of + Shelley.UtxowEvent e -> handleAlonzoOnwardsUTxOWEvent e + Shelley.DelegsEvent e -> handleShelleyDELEGSEvent e diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/NEWEPOCH.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/NEWEPOCH.hs new file mode 100644 index 0000000000..a9a02c3ef9 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/NEWEPOCH.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Api.LedgerEvents.Rule.NEWEPOCH + ( LatestTickEventConstraints + , handleShelleyNEWEPOCHEvents + , handleLedgerTICKEvents + , handleConwayNEWEPOCHEvents + ) where + +import Cardano.Api.Address (fromShelleyStakeCredential) +import Cardano.Api.LedgerEvents.LedgerEvent +import Cardano.Api.LedgerEvents.Rule.RUPD +import Cardano.Api.ReexposeLedger + +import Cardano.Ledger.Conway.Rules (ConwayNewEpochEvent) +import qualified Cardano.Ledger.Conway.Rules as Conway +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Shelley.Rules +import qualified Cardano.Ledger.Shelley.Rules as Shelley + +import qualified Data.Map.Strict as Map + +type LatestTickEventConstraints ledgerera = + ( Event (Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera + , Event (Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto + , Event (Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera + , Event (Core.EraRule "EPOCH" ledgerera) ~ Shelley.ShelleyEpochEvent ledgerera + , Event (Core.EraRule "POOLREAP" ledgerera) ~ Shelley.ShelleyPoolreapEvent ledgerera + ) + +handleLedgerTICKEvents + :: EraCrypto ledgerera ~ StandardCrypto + => LatestTickEventConstraints ledgerera + => ShelleyTickEvent ledgerera -> Maybe LedgerEvent +handleLedgerTICKEvents (TickNewEpochEvent newEpochEvent) = handleShelleyNEWEPOCHEvents newEpochEvent +handleLedgerTICKEvents (TickRupdEvent rewardUpdate) = handleLedgerRUPDEvents rewardUpdate + +handleShelleyNEWEPOCHEvents + :: EraCrypto ledgerera ~ StandardCrypto + => Event (Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera + => Event (Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera + => ShelleyNewEpochEvent ledgerera -> Maybe LedgerEvent +handleShelleyNEWEPOCHEvents shelleyNewEpochEvent = + case shelleyNewEpochEvent of + Shelley.DeltaRewardEvent{} -> Nothing + Shelley.RestrainedRewards{} -> Nothing + Shelley.TotalRewardEvent epochNo rewardsMap -> + Just $ RewardsDistribution epochNo (Map.mapKeys fromShelleyStakeCredential rewardsMap) + Shelley.EpochEvent e -> handleEpochEvents e + Shelley.MirEvent{} -> Nothing -- We no longer care about MIR events + Shelley.TotalAdaPotsEvent{} -> Nothing + +handleEpochEvents + :: EraCrypto ledgerera ~ StandardCrypto + => Event (Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera + => ShelleyEpochEvent ledgerera -> Maybe LedgerEvent +handleEpochEvents (PoolReapEvent e) = + case e of + RetiredPools {refundPools, unclaimedPools, epochNo} -> + Just . PoolReap + $ PoolReapDetails epochNo + (convertRetiredPoolsMap refundPools) + (convertRetiredPoolsMap unclaimedPools) +handleEpochEvents (SnapEvent{}) = Nothing +handleEpochEvents (UpecEvent{}) = Nothing + + +handleConwayNEWEPOCHEvents + :: EraCrypto ledgerera ~ StandardCrypto + => Core.EraPParams ledgerera + => Event (Core.EraRule "EPOCH" ledgerera) ~ Conway.ConwayEpochEvent ledgerera + => Event (Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera + => Event (Core.EraRule "RUPD" ledgerera) ~ RupdEvent StandardCrypto + => ConwayNewEpochEvent ledgerera -> Maybe LedgerEvent +handleConwayNEWEPOCHEvents conwayNewEpochEvent = + case conwayNewEpochEvent of + Conway.DeltaRewardEvent rewardUpdate -> + case rewardUpdate of + RupdEvent epochNum rewards -> + Just $ IncrementalRewardsDistribution epochNum (Map.mapKeys fromShelleyStakeCredential rewards) + Conway.RestrainedRewards{} -> Nothing + Conway.TotalRewardEvent epochNo rewardsMap -> + Just $ RewardsDistribution epochNo (Map.mapKeys fromShelleyStakeCredential rewardsMap) + Conway.EpochEvent epochEvent -> + case epochEvent of + Conway.EpochBoundaryRatifyState ratifyState -> + Just $ EpochBoundaryRatificationState (AnyRatificationState ratifyState) + Conway.PoolReapEvent poolReap -> + case poolReap of + RetiredPools {refundPools, unclaimedPools, epochNo} -> + Just . PoolReap $ PoolReapDetails epochNo + (convertRetiredPoolsMap refundPools) + (convertRetiredPoolsMap unclaimedPools) + Conway.SnapEvent _ -> Nothing + Conway.TotalAdaPotsEvent _ -> Nothing + + diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/RUPD.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/RUPD.hs new file mode 100644 index 0000000000..7d646cf55a --- /dev/null +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/RUPD.hs @@ -0,0 +1,17 @@ +module Cardano.Api.LedgerEvents.Rule.RUPD + ( handleLedgerRUPDEvents + ) where + +import Cardano.Api.Address (fromShelleyStakeCredential) +import Cardano.Api.LedgerEvents.LedgerEvent (LedgerEvent (IncrementalRewardsDistribution)) + +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Shelley.Rules + +import qualified Data.Map.Strict as Map + + +handleLedgerRUPDEvents :: RupdEvent StandardCrypto -> Maybe LedgerEvent +handleLedgerRUPDEvents (RupdEvent epochNum rewards) = + Just $ IncrementalRewardsDistribution epochNum (Map.mapKeys fromShelleyStakeCredential rewards) + diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/UTXOW.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/UTXOW.hs new file mode 100644 index 0000000000..85cd02b4b4 --- /dev/null +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/UTXOW.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Api.LedgerEvents.Rule.UTXOW + ( handleAlonzoOnwardsUTxOWEvent + , handleAllegraMaryUTxOWEvent + , handlePreAlonzoUTxOWEvent + ) where + +import Cardano.Api.LedgerEvents.LedgerEvent + +import qualified Cardano.Ledger.Allegra.Rules as Allegra +import Cardano.Ledger.Alonzo.Rules (AlonzoUtxoEvent (..), AlonzoUtxosEvent (..), + AlonzoUtxowEvent (..)) +import qualified Cardano.Ledger.Alonzo.Rules as Alonzo +import qualified Cardano.Ledger.Core as Ledger.Core +import qualified Cardano.Ledger.Shelley.Rules as Shelley + +import Control.State.Transition.Extended + + + +handleAlonzoOnwardsUTxOWEvent + :: Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera + => Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera + => AlonzoUtxowEvent ledgerera -> Maybe LedgerEvent +handleAlonzoOnwardsUTxOWEvent (WrappedShelleyEraEvent (Shelley.UtxoEvent (UtxosEvent utxoEvent))) = + case utxoEvent of + Alonzo.AlonzoPpupToUtxosEvent{} -> Nothing + Alonzo.TotalDeposits{} -> Nothing + Alonzo.SuccessfulPlutusScriptsEvent e -> Just $ SuccessfulPlutusScript e + Alonzo.FailedPlutusScriptsEvent e -> Just $ FailedPlutusScript e + +handlePreAlonzoUTxOWEvent + :: Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Shelley.UtxoEvent ledgerera + => Event (Ledger.Core.EraRule "PPUP" ledgerera) ~ Shelley.PpupEvent ledgerera + => Shelley.ShelleyUtxowEvent ledgerera -> Maybe LedgerEvent +handlePreAlonzoUTxOWEvent (Shelley.UtxoEvent e)= + case e of + Shelley.TotalDeposits{} -> Nothing + Shelley.UpdateEvent (Shelley.NewEpoch _) -> Nothing + + +handleAllegraMaryUTxOWEvent + :: Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Allegra.AllegraUtxoEvent ledgerera + => Event (Ledger.Core.EraRule "PPUP" ledgerera) ~ Shelley.PpupEvent ledgerera + => Shelley.ShelleyUtxowEvent ledgerera -> Maybe LedgerEvent +handleAllegraMaryUTxOWEvent (Shelley.UtxoEvent e)= + case e of + Allegra.TotalDeposits{} -> Nothing + Allegra.UpdateEvent (Shelley.NewEpoch _) -> Nothing diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 7565893c1b..c3841dede1 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -94,7 +94,7 @@ import Cardano.Api.IPC (ConsensusModeParams (..), LocalNodeClientProtocols (..), LocalNodeClientProtocolsInMode, LocalNodeConnectInfo (..), connectToLocalNode) import Cardano.Api.Keys.Praos -import Cardano.Api.LedgerEvent (LedgerEvent, toLedgerEvent) +import Cardano.Api.LedgerEvents.ConvertLedgerEvent (LedgerEvent, toLedgerEvent) import Cardano.Api.Modes (EpochSlots (..)) import qualified Cardano.Api.Modes as Api import Cardano.Api.NetworkId (NetworkId (..), NetworkMagic (NetworkMagic)) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index e8a143266b..2fdcd77eed 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -737,14 +737,6 @@ module Cardano.Api ( applyBlock, ValidationMode(..), - -- *** Ledger Events - LedgerEvent(..), - AnyProposals(..), - AnyRatificationState(..), - MIRDistributionDetails(..), - PoolReapDetails(..), - toLedgerEvent, - -- *** Traversing the block chain foldBlocks, FoldStatus(..), @@ -1026,7 +1018,6 @@ import Cardano.Api.Keys.Byron import Cardano.Api.Keys.Class import Cardano.Api.Keys.Read import Cardano.Api.Keys.Shelley -import Cardano.Api.LedgerEvent import Cardano.Api.LedgerState import Cardano.Api.Modes import Cardano.Api.NetworkId diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 961c7e1257..feb6354fef 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -218,6 +218,13 @@ module Cardano.Api.Shelley -- ** Shelley based eras ShelleyLedgerEra, + -- *** Ledger Events + LedgerEvent(..), + AnyProposals(..), + AnyRatificationState(..), + MIRDistributionDetails(..), + PoolReapDetails(..), + toLedgerEvent, -- ** Local State Query DebugLedgerState(..), @@ -297,6 +304,8 @@ import Cardano.Api.InMode import Cardano.Api.IPC import Cardano.Api.Keys.Praos import Cardano.Api.Keys.Shelley +import Cardano.Api.LedgerEvents.ConvertLedgerEvent +import Cardano.Api.LedgerEvents.LedgerEvent import Cardano.Api.LedgerState import Cardano.Api.NetworkId import Cardano.Api.OperationalCertificate