diff --git a/cardano-api/src/Cardano/Api/LedgerEvent.hs b/cardano-api/src/Cardano/Api/LedgerEvent.hs index 9c883019f20..ae86f8dee03 100644 --- a/cardano-api/src/Cardano/Api/LedgerEvent.hs +++ b/cardano-api/src/Cardano/Api/LedgerEvent.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternSynonyms #-} @@ -21,6 +22,14 @@ import Cardano.Api.Block (EpochNo) import Cardano.Api.Certificate (Certificate) import Cardano.Api.KeysShelley (Hash (StakePoolKeyHash), StakePoolKey) import Cardano.Api.Value (Lovelace, fromShelleyDeltaLovelace, fromShelleyLovelace) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.TxInfo (PlutusDebug) +import Cardano.Ledger.Alonzo.Rules.Bbody (AlonzoBbodyEvent (ShelleyInAlonzoEvent)) +import Cardano.Ledger.Alonzo.Rules.Utxo (UtxoEvent (UtxosEvent)) +import Cardano.Ledger.Alonzo.Rules.Utxos + (UtxosEvent (FailedPlutusScriptsEvent, SuccessfulPlutusScriptsEvent)) +import Cardano.Ledger.Alonzo.Rules.Utxow (AlonzoEvent (WrappedShelleyEraEvent)) +import Cardano.Ledger.Babbage (BabbageEra) import qualified Cardano.Ledger.Coin as Ledger import qualified Cardano.Ledger.Core as Ledger.Core import qualified Cardano.Ledger.Credential as Ledger @@ -29,16 +38,21 @@ import Cardano.Ledger.Era (Crypto) import qualified Cardano.Ledger.Keys as Ledger import Cardano.Ledger.Shelley.API (InstantaneousRewards (InstantaneousRewards)) import Cardano.Ledger.Shelley.Rewards +import Cardano.Ledger.Shelley.Rules.Bbody (BbodyEvent (LedgersEvent)) import Cardano.Ledger.Shelley.Rules.Epoch (EpochEvent (PoolReapEvent)) +import qualified Cardano.Ledger.Shelley.Rules.Ledger as Shelley (LedgerEvent (UtxowEvent)) +import qualified Cardano.Ledger.Shelley.Rules.Ledgers as Shelley (LedgersEvent (LedgerEvent)) import Cardano.Ledger.Shelley.Rules.Mir (MirEvent (..)) import Cardano.Ledger.Shelley.Rules.NewEpoch (NewEpochEvent (DeltaRewardEvent, EpochEvent, MirEvent, TotalRewardEvent)) import Cardano.Ledger.Shelley.Rules.PoolReap (PoolreapEvent (RetiredPools)) import Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent (RupdEvent)) import Cardano.Ledger.Shelley.Rules.Tick (TickEvent (NewEpochEvent)) +import Cardano.Ledger.Shelley.Rules.Utxow (UtxowEvent (UtxoEvent)) import Control.State.Transition (Event) import Data.Function (($), (.)) import Data.Functor (fmap) +import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (Maybe (Just, Nothing)) @@ -50,7 +64,7 @@ import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLe import Ouroboros.Consensus.Ledger.Abstract (LedgerState) import Ouroboros.Consensus.Ledger.Basics (AuxLedgerEvent) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, - ShelleyLedgerEvent (ShelleyLedgerEventTICK)) + ShelleyLedgerEvent (ShelleyLedgerEventBBODY, ShelleyLedgerEventTICK)) import Ouroboros.Consensus.TypeFamilyWrappers data LedgerEvent @@ -66,6 +80,10 @@ data LedgerEvent 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) class ConvertLedgerEvent blk where toLedgerEvent :: WrapLedgerEvent blk -> Maybe LedgerEvent @@ -83,16 +101,22 @@ instance Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) ) => ConvertLedgerEvent (ShelleyBlock protocol ledgerera) + where + toLedgerEvent = toLedgerEventShelley + +instance {-# OVERLAPPING #-} 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 {-# OVERLAPPING #-} ConvertLedgerEvent (ShelleyBlock protocol (BabbageEra StandardCrypto)) where toLedgerEvent 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 + LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds + LEPlutusFailure ds -> Just $ FailedPlutusScript ds + _ -> toLedgerEventShelley evt instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) where toLedgerEvent = @@ -101,6 +125,28 @@ instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) wher . getOneEraLedgerEvent . unwrapLedgerEvent +toLedgerEventShelley :: + ( Crypto ledgerera ~ StandardCrypto, + Event (Ledger.Core.EraRule "TICK" ledgerera) ~ TickEvent ledgerera, + Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera, + Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ EpochEvent ledgerera, + Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ PoolreapEvent ledgerera, + Event (Ledger.Core.EraRule "MIR" ledgerera) ~ MirEvent ledgerera, + Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera) + ) => + 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 + + -------------------------------------------------------------------------------- -- Event details -------------------------------------------------------------------------------- @@ -208,6 +254,66 @@ pattern LERetiredPools r u e <- ) ) +pattern LEPlutusSuccess :: + ( Crypto ledgerera ~ StandardCrypto, + Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera, + Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.LedgersEvent ledgerera, + Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.LedgerEvent ledgerera, + Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoEvent ledgerera, + Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ UtxoEvent ledgerera, + Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ UtxosEvent 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 :: + ( Crypto ledgerera ~ StandardCrypto, + Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera, + Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.LedgersEvent ledgerera, + Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.LedgerEvent ledgerera, + Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoEvent ledgerera, + Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ UtxoEvent ledgerera, + Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ UtxosEvent 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)