diff --git a/cardano-api/src/Cardano/Api/LedgerEvent.hs b/cardano-api/src/Cardano/Api/LedgerEvent.hs index 0dbe7ce067a..06416df2377 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,15 @@ 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) +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.Rules + ( AlonzoBbodyEvent (..), + AlonzoUtxoEvent (..), + AlonzoUtxosEvent (..), + AlonzoUtxowEvent (..), + ) +import Cardano.Ledger.Alonzo.TxInfo (PlutusDebug) +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,15 +39,20 @@ 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 import Cardano.Ledger.Shelley.Rules.Epoch (ShelleyEpochEvent (..)) +import qualified Cardano.Ledger.Shelley.Rules.Ledger as Shelley (ShelleyLedgerEvent (UtxowEvent)) +import qualified Cardano.Ledger.Shelley.Rules.Ledgers as Shelley (ShelleyLedgersEvent (LedgerEvent)) import Cardano.Ledger.Shelley.Rules.Mir (ShelleyMirEvent (..)) import Cardano.Ledger.Shelley.Rules.NewEpoch (ShelleyNewEpochEvent (..)) import Cardano.Ledger.Shelley.Rules.PoolReap (ShelleyPoolreapEvent (..)) import Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent (..)) import Cardano.Ledger.Shelley.Rules.Tick (ShelleyTickEvent (NewEpochEvent)) +import Cardano.Ledger.Shelley.Rules.Utxow (ShelleyUtxowEvent (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)) @@ -49,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 (..)) import Ouroboros.Consensus.TypeFamilyWrappers data LedgerEvent @@ -65,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 @@ -82,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 = @@ -100,6 +125,27 @@ instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) wher . getOneEraLedgerEvent . unwrapLedgerEvent +toLedgerEventShelley :: + ( Crypto 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 (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 -------------------------------------------------------------------------------- @@ -207,6 +253,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.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 :: + ( Crypto 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)