Add script evaluation events to LedgerEvent

IntersectMBO · Dec 5, 2022 · b55aec7 · b55aec7
1 parent 63a9c42
commit b55aec7
Showing 1 changed file with 115 additions and 9 deletions.
diff --git 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)