Skip to content

Commit 3fa1d99

Browse files
andreabediniandreabedini
committed
Merge remote-tracking branch 'origin/master' into fix-flake-inputs-recursion
2 parents e09e598 + c0fdc49 commit 3fa1d99

File tree

7 files changed

+315
-198
lines changed

7 files changed

+315
-198
lines changed

‎Makefile

+1-1
Original file line numberDiff line numberDiff line change
@@ -52,7 +52,7 @@ ci-targets: $(CI_TARGETS)
5252
shell: ## Nix shell, (workbench from /nix/store), vars: PROFILE, CMD, RUN
5353
nix-shell -A 'workbench-shell' --max-jobs 8 --cores 0 --show-trace --argstr profileName ${PROFILE} --argstr backendName ${BACKEND} ${ARGS} ${if ${CMD},--command "${CMD}"} ${if ${RUN},--run "${RUN}"}
5454
shell-dev shell-prof shell-nix: shell
55-
shell-nix: ARGS += --arg 'workbenchDevMode' false ## Nix shell, (workbench from Nix store), vars: PROFILE, CMD, RUN
55+
shell-nix: ARGS += --arg 'useCabalRun' false ## Nix shell, (workbench from Nix store), vars: PROFILE, CMD, RUN
5656
shell-prof: ARGS += --arg 'profiled' true ## Nix shell, everything Haskell built profiled
5757

5858
analyse: RUN := wb analyse std ${TAG}

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

+2
Original file line numberDiff line numberDiff line change
@@ -541,6 +541,8 @@ module Cardano.Api (
541541
envSecurityParam,
542542
LedgerState(..),
543543
initialLedgerState,
544+
encodeLedgerState,
545+
decodeLedgerState,
544546
applyBlock,
545547
ValidationMode(..),
546548

‎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)

‎cardano-api/src/Cardano/Api/LedgerState.hs

+31-1
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,8 @@ module Cardano.Api.LedgerState
2424
, LedgerStateMary
2525
, LedgerStateAlonzo
2626
)
27+
, encodeLedgerState
28+
, decodeLedgerState
2729
, initialLedgerState
2830
, applyBlock
2931
, ValidationMode(..)
@@ -52,6 +54,7 @@ module Cardano.Api.LedgerState
5254
)
5355
where
5456

57+
import qualified Cardano.Binary as CBOR
5558
import Control.Exception
5659
import Control.Monad (when)
5760
import Control.Monad.Trans.Class
@@ -78,7 +81,7 @@ import qualified Data.Sequence as Seq
7881
import Data.Set (Set)
7982
import qualified Data.Set as Set
8083
import Data.Sharing (FromSharedCBOR, Interns, Share)
81-
import Data.SOP.Strict (NP (..))
84+
import Data.SOP.Strict (K (..), NP (..), fn, (:.:) (Comp))
8285
import Data.Text (Text)
8386
import qualified Data.Text as Text
8487
import qualified Data.Text.Encoding as Text
@@ -142,6 +145,7 @@ import Cardano.Slotting.Slot (WithOrigin (At, Origin))
142145
import qualified Cardano.Slotting.Slot as Slot
143146
import qualified Ouroboros.Consensus.Block.Abstract as Consensus
144147
import qualified Ouroboros.Consensus.Byron.Ledger.Block as Byron
148+
import qualified Ouroboros.Consensus.Byron.Ledger.Ledger as Byron
145149
import qualified Ouroboros.Consensus.Cardano as Consensus
146150
import qualified Ouroboros.Consensus.Cardano.Block as Consensus
147151
import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus
@@ -150,6 +154,7 @@ import qualified Ouroboros.Consensus.Config as Consensus
150154
import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus
151155
import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as HFC
152156
import qualified Ouroboros.Consensus.HardFork.Combinator.Basics as HFC
157+
import qualified Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common as HFC
153158
import qualified Ouroboros.Consensus.Ledger.Abstract as Ledger
154159
import Ouroboros.Consensus.Ledger.Basics (LedgerResult (lrEvents), lrResult)
155160
import qualified Ouroboros.Consensus.Ledger.Extended as Ledger
@@ -866,6 +871,31 @@ newtype LedgerState = LedgerState
866871
(Consensus.CardanoEras Consensus.StandardCrypto))
867872
}
868873

874+
encodeLedgerState :: LedgerState -> CBOR.Encoding
875+
encodeLedgerState (LedgerState (HFC.HardForkLedgerState st)) =
876+
HFC.encodeTelescope
877+
(byron :* shelley :* allegra :* mary :* alonzo :* babbage :* Nil)
878+
st
879+
where
880+
byron = fn (K . Byron.encodeByronLedgerState)
881+
shelley = fn (K . Shelley.encodeShelleyLedgerState)
882+
allegra = fn (K . Shelley.encodeShelleyLedgerState)
883+
mary = fn (K . Shelley.encodeShelleyLedgerState)
884+
alonzo = fn (K . Shelley.encodeShelleyLedgerState)
885+
babbage = fn (K . Shelley.encodeShelleyLedgerState)
886+
887+
decodeLedgerState :: forall s. CBOR.Decoder s LedgerState
888+
decodeLedgerState =
889+
LedgerState . HFC.HardForkLedgerState
890+
<$> HFC.decodeTelescope (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* Nil)
891+
where
892+
byron = Comp Byron.decodeByronLedgerState
893+
shelley = Comp Shelley.decodeShelleyLedgerState
894+
allegra = Comp Shelley.decodeShelleyLedgerState
895+
mary = Comp Shelley.decodeShelleyLedgerState
896+
alonzo = Comp Shelley.decodeShelleyLedgerState
897+
babbage = Comp Shelley.decodeShelleyLedgerState
898+
869899
type LedgerStateEvents = (LedgerState, [LedgerEvent])
870900

871901
toLedgerStateEvents ::

0 commit comments

Comments
 (0)