Skip to content

Commit 0a2f860

Browse files
Merge #3984
3984: Add script evaluation events to LedgerEvent r=zliu41 a=zliu41 I need to access Plutus script evalution from `LedgerEvent`: https://input-output.atlassian.net/browse/PLT-106 I'm unfamiliar with this repo so I don't know if there's a better approach, but this does seem to work. cc `@Jimbo4350` `@JaredCorduan` and thanks `@JaredCorduan` for the discussion. Co-authored-by: Ziyang Liu <[email protected]>
2 parents 7299a7c + 67fab54 commit 0a2f860

File tree

1 file changed

+134
-18
lines changed

1 file changed

+134
-18
lines changed

cardano-api/src/Cardano/Api/LedgerEvent.hs

+134-18
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
34
{-# LANGUAGE GADTs #-}
45
{-# LANGUAGE PartialTypeSignatures #-}
56
{-# LANGUAGE PatternSynonyms #-}
@@ -21,35 +22,59 @@ import Cardano.Api.Block (EpochNo)
2122
import Cardano.Api.Certificate (Certificate)
2223
import Cardano.Api.Keys.Shelley (Hash (StakePoolKeyHash), StakePoolKey)
2324
import Cardano.Api.Value (Lovelace, fromShelleyDeltaLovelace, fromShelleyLovelace)
25+
import Cardano.Ledger.Alonzo (AlonzoEra)
26+
import Cardano.Ledger.Alonzo.Rules
27+
( AlonzoBbodyEvent (..),
28+
AlonzoUtxoEvent (..),
29+
AlonzoUtxosEvent
30+
( FailedPlutusScriptsEvent,
31+
SuccessfulPlutusScriptsEvent
32+
),
33+
AlonzoUtxowEvent (..),
34+
)
35+
import Cardano.Ledger.Alonzo.TxInfo (PlutusDebug)
36+
import Cardano.Ledger.Babbage (BabbageEra)
2437
import qualified Cardano.Ledger.Coin as Ledger
2538
import qualified Cardano.Ledger.Core as Ledger.Core
2639
import qualified Cardano.Ledger.Credential as Ledger
2740
import Cardano.Ledger.Crypto (StandardCrypto)
2841
import Cardano.Ledger.Era (Crypto)
2942
import qualified Cardano.Ledger.Keys as Ledger
3043
import Cardano.Ledger.Shelley.API (InstantaneousRewards (InstantaneousRewards))
31-
import Cardano.Ledger.Shelley.Rewards
32-
33-
import Cardano.Ledger.Shelley.Rules.Tick (ShelleyTickEvent (NewEpochEvent))
34-
import Cardano.Ledger.Shelley.Rules.NewEpoch (ShelleyNewEpochEvent (..))
44+
import Cardano.Ledger.Shelley.Rewards ( Reward )
45+
import Cardano.Ledger.Shelley.Rules.Bbody
46+
( ShelleyBbodyEvent (LedgersEvent),
47+
)
3548
import Cardano.Ledger.Shelley.Rules.Epoch (ShelleyEpochEvent (..))
36-
import Cardano.Ledger.Shelley.Rules.PoolReap (ShelleyPoolreapEvent (..))
49+
import qualified Cardano.Ledger.Shelley.Rules.Ledger as Shelley (ShelleyLedgerEvent (UtxowEvent))
50+
import qualified Cardano.Ledger.Shelley.Rules.Ledgers as Shelley (ShelleyLedgersEvent (LedgerEvent))
3751
import Cardano.Ledger.Shelley.Rules.Mir (ShelleyMirEvent (..))
52+
import Cardano.Ledger.Shelley.Rules.NewEpoch (ShelleyNewEpochEvent (..))
53+
import Cardano.Ledger.Shelley.Rules.PoolReap (ShelleyPoolreapEvent (..))
3854
import Cardano.Ledger.Shelley.Rules.Rupd (RupdEvent (..))
39-
55+
import Cardano.Ledger.Shelley.Rules.Tick (ShelleyTickEvent (NewEpochEvent))
56+
import Cardano.Ledger.Shelley.Rules.Utxow (ShelleyUtxowEvent (UtxoEvent))
4057
import Control.State.Transition (Event)
58+
import Data.List.NonEmpty (NonEmpty)
4159
import Data.Map.Strict (Map)
4260
import qualified Data.Map.Strict as Map
4361
import Data.Set (Set)
4462
import Data.SOP.Strict
4563
import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
4664
import Ouroboros.Consensus.Cardano.Block (HardForkBlock)
4765
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras (getOneEraLedgerEvent)
48-
import Ouroboros.Consensus.Ledger.Abstract (LedgerState)
4966
import Ouroboros.Consensus.Ledger.Basics (AuxLedgerEvent)
50-
import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock,
51-
ShelleyLedgerEvent (ShelleyLedgerEventTICK))
52-
import Ouroboros.Consensus.TypeFamilyWrappers
67+
import Ouroboros.Consensus.Shelley.Ledger
68+
( LedgerState,
69+
ShelleyBlock,
70+
ShelleyLedgerEvent
71+
( ShelleyLedgerEventBBODY,
72+
ShelleyLedgerEventTICK
73+
),
74+
)
75+
import Ouroboros.Consensus.TypeFamilyWrappers
76+
( WrapLedgerEvent (unwrapLedgerEvent),
77+
)
5378

5479
data LedgerEvent
5580
= -- | The given pool is being registered for the first time on chain.
@@ -64,6 +89,10 @@ data LedgerEvent
6489
MIRDistribution MIRDistributionDetails
6590
| -- | Pools have been reaped and deposits refunded.
6691
PoolReap PoolReapDetails
92+
-- | A number of succeeded Plutus script evaluations.
93+
| SuccessfulPlutusScript (NonEmpty PlutusDebug)
94+
-- | A number of failed Plutus script evaluations.
95+
| FailedPlutusScript (NonEmpty PlutusDebug)
6796

6897
class ConvertLedgerEvent blk where
6998
toLedgerEvent :: WrapLedgerEvent blk -> Maybe LedgerEvent
@@ -81,16 +110,22 @@ instance
81110
Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera)
82111
) =>
83112
ConvertLedgerEvent (ShelleyBlock protocol ledgerera)
113+
where
114+
toLedgerEvent = toLedgerEventShelley
115+
116+
instance {-# OVERLAPPING #-} ConvertLedgerEvent (ShelleyBlock protocol (AlonzoEra StandardCrypto))
117+
where
118+
toLedgerEvent evt = case unwrapLedgerEvent evt of
119+
LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds
120+
LEPlutusFailure ds -> Just $ FailedPlutusScript ds
121+
_ -> toLedgerEventShelley evt
122+
123+
instance {-# OVERLAPPING #-} ConvertLedgerEvent (ShelleyBlock protocol (BabbageEra StandardCrypto))
84124
where
85125
toLedgerEvent evt = case unwrapLedgerEvent evt of
86-
LEDeltaRewardEvent e m -> Just $ IncrementalRewardsDistribution e m
87-
LERewardEvent e m -> Just $ RewardsDistribution e m
88-
LEMirTransfer rp rt rtt ttr ->
89-
Just $
90-
MIRDistribution $
91-
MIRDistributionDetails rp rt rtt ttr
92-
LERetiredPools r u e -> Just $ PoolReap $ PoolReapDetails e r u
93-
_ -> Nothing
126+
LEPlutusSuccess ds -> Just $ SuccessfulPlutusScript ds
127+
LEPlutusFailure ds -> Just $ FailedPlutusScript ds
128+
_ -> toLedgerEventShelley evt
94129

95130
instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) where
96131
toLedgerEvent =
@@ -99,6 +134,27 @@ instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) wher
99134
. getOneEraLedgerEvent
100135
. unwrapLedgerEvent
101136

137+
toLedgerEventShelley ::
138+
( Crypto ledgerera ~ StandardCrypto,
139+
Event (Ledger.Core.EraRule "TICK" ledgerera) ~ ShelleyTickEvent ledgerera,
140+
Event (Ledger.Core.EraRule "NEWEPOCH" ledgerera) ~ ShelleyNewEpochEvent ledgerera,
141+
Event (Ledger.Core.EraRule "EPOCH" ledgerera) ~ ShelleyEpochEvent ledgerera,
142+
Event (Ledger.Core.EraRule "POOLREAP" ledgerera) ~ ShelleyPoolreapEvent ledgerera,
143+
Event (Ledger.Core.EraRule "MIR" ledgerera) ~ ShelleyMirEvent ledgerera,
144+
Event (Ledger.Core.EraRule "RUPD" ledgerera) ~ RupdEvent (Crypto ledgerera)
145+
) =>
146+
WrapLedgerEvent (ShelleyBlock protocol ledgerera) ->
147+
Maybe LedgerEvent
148+
toLedgerEventShelley evt = case unwrapLedgerEvent evt of
149+
LEDeltaRewardEvent e m -> Just $ IncrementalRewardsDistribution e m
150+
LERewardEvent e m -> Just $ RewardsDistribution e m
151+
LEMirTransfer rp rt rtt ttr ->
152+
Just $
153+
MIRDistribution $
154+
MIRDistributionDetails rp rt rtt ttr
155+
LERetiredPools r u e -> Just $ PoolReap $ PoolReapDetails e r u
156+
_ -> Nothing
157+
102158
--------------------------------------------------------------------------------
103159
-- Event details
104160
--------------------------------------------------------------------------------
@@ -206,6 +262,66 @@ pattern LERetiredPools r u e <-
206262
)
207263
)
208264

265+
pattern LEPlutusSuccess ::
266+
( Crypto ledgerera ~ StandardCrypto,
267+
Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera,
268+
Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera,
269+
Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera,
270+
Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera,
271+
Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera,
272+
Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera
273+
) =>
274+
NonEmpty PlutusDebug ->
275+
AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
276+
pattern LEPlutusSuccess ds <-
277+
ShelleyLedgerEventBBODY
278+
( ShelleyInAlonzoEvent
279+
( LedgersEvent
280+
( Shelley.LedgerEvent
281+
( Shelley.UtxowEvent
282+
( WrappedShelleyEraEvent
283+
( UtxoEvent
284+
( UtxosEvent
285+
( SuccessfulPlutusScriptsEvent ds
286+
)
287+
)
288+
)
289+
)
290+
)
291+
)
292+
)
293+
)
294+
295+
pattern LEPlutusFailure ::
296+
( Crypto ledgerera ~ StandardCrypto,
297+
Event (Ledger.Core.EraRule "BBODY" ledgerera) ~ AlonzoBbodyEvent ledgerera,
298+
Event (Ledger.Core.EraRule "LEDGERS" ledgerera) ~ Shelley.ShelleyLedgersEvent ledgerera,
299+
Event (Ledger.Core.EraRule "LEDGER" ledgerera) ~ Shelley.ShelleyLedgerEvent ledgerera,
300+
Event (Ledger.Core.EraRule "UTXOW" ledgerera) ~ AlonzoUtxowEvent ledgerera,
301+
Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ AlonzoUtxoEvent ledgerera,
302+
Event (Ledger.Core.EraRule "UTXOS" ledgerera) ~ AlonzoUtxosEvent ledgerera
303+
) =>
304+
NonEmpty PlutusDebug ->
305+
AuxLedgerEvent (LedgerState (ShelleyBlock protocol ledgerera))
306+
pattern LEPlutusFailure ds <-
307+
ShelleyLedgerEventBBODY
308+
( ShelleyInAlonzoEvent
309+
( LedgersEvent
310+
( Shelley.LedgerEvent
311+
( Shelley.UtxowEvent
312+
( WrappedShelleyEraEvent
313+
( UtxoEvent
314+
( UtxosEvent
315+
( FailedPlutusScriptsEvent ds
316+
)
317+
)
318+
)
319+
)
320+
)
321+
)
322+
)
323+
)
324+
209325
convertRetiredPoolsMap ::
210326
Map (Ledger.StakeCredential StandardCrypto) (Map (Ledger.KeyHash Ledger.StakePool StandardCrypto) Ledger.Coin)
211327
-> Map StakeCredential (Map (Hash StakePoolKey) Lovelace)

0 commit comments

Comments
 (0)