Skip to content

Commit 0d64142

Browse files
f-ff-f
committed
Swap hierarchy of Mempool/Ledger failures in Dijkstra
1 parent 828ca51 commit 0d64142

File tree

6 files changed

+155
-26
lines changed

6 files changed

+155
-26
lines changed

‎eras/dijkstra/impl/cardano-ledger-dijkstra.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -102,7 +102,6 @@ library
102102
nothunks,
103103
plutus-ledger-api,
104104
small-steps >=1.1.2,
105-
text,
106105

107106
if flag(asserts)
108107
ghc-options: -fno-ignore-asserts
@@ -152,6 +151,7 @@ library testlib
152151
cardano-strict-containers,
153152
containers,
154153
cuddle >=0.4,
154+
data-default,
155155
generic-random,
156156
heredoc,
157157
microlens,

‎eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ import Cardano.Ledger.Dijkstra.BlockBody ()
1010
import Cardano.Ledger.Dijkstra.Era
1111
import Cardano.Ledger.Dijkstra.Genesis ()
1212
import Cardano.Ledger.Dijkstra.Governance ()
13-
import Cardano.Ledger.Dijkstra.Rules (DijkstraLedgerPredFailure)
13+
import Cardano.Ledger.Dijkstra.Rules (DijkstraMempoolPredFailure)
1414
import Cardano.Ledger.Dijkstra.Scripts ()
1515
import Cardano.Ledger.Dijkstra.State.CertState ()
1616
import Cardano.Ledger.Dijkstra.State.Stake ()
@@ -25,7 +25,7 @@ import Cardano.Ledger.Shelley.API (ApplyBlock, ApplyTx (..), ruleApplyTxValidati
2525
import Data.List.NonEmpty (NonEmpty)
2626

2727
instance ApplyTx DijkstraEra where
28-
type ApplyTxError DijkstraEra = NonEmpty (DijkstraLedgerPredFailure DijkstraEra)
28+
type ApplyTxError DijkstraEra = NonEmpty (DijkstraMempoolPredFailure DijkstraEra)
2929
applyTxValidation = ruleApplyTxValidation @"MEMPOOL"
3030

3131
instance ApplyBlock DijkstraEra

‎eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Ledger.hs‎

Lines changed: 15 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@
1717
module Cardano.Ledger.Dijkstra.Rules.Ledger (
1818
DijkstraLEDGER,
1919
DijkstraLedgerPredFailure (..),
20+
shelleyToDijkstraLedgerPredFailure,
2021
conwayToDijkstraLedgerPredFailure,
2122
) where
2223

@@ -70,7 +71,6 @@ import Cardano.Ledger.Conway.Rules (
7071
GovEnv (..),
7172
GovSignal (..),
7273
conwayLedgerTransition,
73-
shelleyToConwayLedgerPredFailure,
7474
)
7575
import qualified Cardano.Ledger.Conway.Rules as Conway
7676
import Cardano.Ledger.Conway.State
@@ -105,7 +105,6 @@ import Control.State.Transition.Extended (
105105
import Data.List.NonEmpty (NonEmpty)
106106
import qualified Data.Map.Strict as Map
107107
import Data.Sequence (Seq)
108-
import Data.Text (Text)
109108
import GHC.Generics (Generic (..))
110109
import NoThunks.Class (NoThunks (..))
111110

@@ -116,7 +115,6 @@ data DijkstraLedgerPredFailure era
116115
| DijkstraWdrlNotDelegatedToDRep (NonEmpty (KeyHash Staking))
117116
| DijkstraTreasuryValueMismatch (Mismatch RelEQ Coin)
118117
| DijkstraTxRefScriptsSizeTooBig (Mismatch RelLTEQ Int)
119-
| DijkstraMempoolFailure Text
120118
| DijkstraWithdrawalsMissingAccounts Withdrawals
121119
| DijkstraIncompleteWithdrawals (Map.Map RewardAccount (Mismatch RelEQ Coin))
122120
deriving (Generic)
@@ -131,7 +129,7 @@ instance InjectRuleFailure "LEDGER" ConwayLedgerPredFailure DijkstraEra where
131129
injectFailure = conwayToDijkstraLedgerPredFailure
132130

133131
instance InjectRuleFailure "LEDGER" ShelleyLedgerPredFailure DijkstraEra where
134-
injectFailure = conwayToDijkstraLedgerPredFailure . shelleyToConwayLedgerPredFailure
132+
injectFailure = shelleyToDijkstraLedgerPredFailure
135133

136134
instance InjectRuleFailure "LEDGER" DijkstraUtxowPredFailure DijkstraEra where
137135
injectFailure = DijkstraUtxowFailure
@@ -244,9 +242,8 @@ instance
244242
DijkstraWdrlNotDelegatedToDRep x -> Sum (DijkstraWdrlNotDelegatedToDRep @era) 4 !> To x
245243
DijkstraTreasuryValueMismatch mm -> Sum (DijkstraTreasuryValueMismatch @era) 5 !> To mm
246244
DijkstraTxRefScriptsSizeTooBig mm -> Sum DijkstraTxRefScriptsSizeTooBig 6 !> To mm
247-
DijkstraMempoolFailure t -> Sum DijkstraMempoolFailure 7 !> To t
248-
DijkstraWithdrawalsMissingAccounts w -> Sum DijkstraWithdrawalsMissingAccounts 8 !> To w
249-
DijkstraIncompleteWithdrawals w -> Sum DijkstraIncompleteWithdrawals 9 !> To w
245+
DijkstraWithdrawalsMissingAccounts w -> Sum DijkstraWithdrawalsMissingAccounts 7 !> To w
246+
DijkstraIncompleteWithdrawals w -> Sum DijkstraIncompleteWithdrawals 8 !> To w
250247

251248
instance
252249
( Era era
@@ -263,9 +260,8 @@ instance
263260
4 -> SumD DijkstraWdrlNotDelegatedToDRep <! From
264261
5 -> SumD DijkstraTreasuryValueMismatch <! From
265262
6 -> SumD DijkstraTxRefScriptsSizeTooBig <! From
266-
7 -> SumD DijkstraMempoolFailure <! From
267-
8 -> SumD DijkstraWithdrawalsMissingAccounts <! From
268-
9 -> SumD DijkstraIncompleteWithdrawals <! From
263+
7 -> SumD DijkstraWithdrawalsMissingAccounts <! From
264+
8 -> SumD DijkstraIncompleteWithdrawals <! From
269265
n -> Invalid n
270266

271267
instance
@@ -390,10 +386,18 @@ conwayToDijkstraLedgerPredFailure = \case
390386
Conway.ConwayWdrlNotDelegatedToDRep kh -> DijkstraWdrlNotDelegatedToDRep kh
391387
Conway.ConwayTreasuryValueMismatch mm -> DijkstraTreasuryValueMismatch mm
392388
Conway.ConwayTxRefScriptsSizeTooBig mm -> DijkstraTxRefScriptsSizeTooBig mm
393-
Conway.ConwayMempoolFailure f -> DijkstraMempoolFailure f
389+
Conway.ConwayMempoolFailure _ -> error "Impossible: MempoolFailure has ben removed in Dijkstra"
394390
Conway.ConwayWithdrawalsMissingAccounts ws -> DijkstraWithdrawalsMissingAccounts ws
395391
Conway.ConwayIncompleteWithdrawals ws -> DijkstraIncompleteWithdrawals ws
396392

393+
shelleyToDijkstraLedgerPredFailure ::
394+
forall era. ShelleyLedgerPredFailure era -> DijkstraLedgerPredFailure era
395+
shelleyToDijkstraLedgerPredFailure = \case
396+
UtxowFailure x -> DijkstraUtxowFailure x
397+
DelegsFailure _ -> error "Impossible: DELEGS has ben removed in Dijkstra"
398+
ShelleyWithdrawalsMissingAccounts x -> DijkstraWithdrawalsMissingAccounts x
399+
ShelleyIncompleteWithdrawals x -> DijkstraIncompleteWithdrawals x
400+
397401
instance
398402
( EraTx era
399403
, ConwayEraTxBody era

‎eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Mempool.hs‎

Lines changed: 73 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,14 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveGeneric #-}
23
{-# LANGUAGE DerivingStrategies #-}
34
{-# LANGUAGE EmptyDataDeriving #-}
45
{-# LANGUAGE FlexibleContexts #-}
56
{-# LANGUAGE FlexibleInstances #-}
7+
{-# LANGUAGE LambdaCase #-}
68
{-# LANGUAGE MultiParamTypeClasses #-}
79
{-# LANGUAGE OverloadedStrings #-}
810
{-# LANGUAGE ScopedTypeVariables #-}
11+
{-# LANGUAGE StandaloneDeriving #-}
912
{-# LANGUAGE TypeApplications #-}
1013
{-# LANGUAGE TypeFamilies #-}
1114
{-# LANGUAGE TypeOperators #-}
@@ -14,30 +17,41 @@
1417

1518
module Cardano.Ledger.Dijkstra.Rules.Mempool (
1619
DijkstraMEMPOOL,
20+
DijkstraMempoolPredFailure (..),
21+
DijkstraMempoolEvent (..),
1722
) where
1823

1924
import Cardano.Ledger.BaseTypes (ShelleyBase)
25+
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
26+
import Cardano.Ledger.Binary.Coders (
27+
Decode (..),
28+
Encode (..),
29+
decode,
30+
encode,
31+
(!>),
32+
)
2033
import Cardano.Ledger.Conway.Governance (
2134
ConwayEraGov,
2235
ConwayGovState,
2336
Proposals,
2437
)
2538
import Cardano.Ledger.Conway.Rules (
2639
CertsEnv,
27-
ConwayLedgerEvent,
2840
ConwayLedgerPredFailure,
2941
GovEnv,
3042
GovSignal,
3143
)
3244
import Cardano.Ledger.Dijkstra.Core
3345
import Cardano.Ledger.Dijkstra.Era (
46+
DijkstraEra,
3447
DijkstraLEDGER,
3548
DijkstraMEMPOOL,
3649
)
3750
import Cardano.Ledger.Dijkstra.Rules.Ledger (DijkstraLedgerPredFailure (..))
3851
import Cardano.Ledger.Dijkstra.State
3952
import Cardano.Ledger.Shelley.LedgerState
4053
import Cardano.Ledger.Shelley.Rules (LedgerEnv (..), ShelleyLedgerPredFailure, UtxoEnv)
54+
import Control.DeepSeq (NFData)
4155
import Control.State.Transition (
4256
BaseM,
4357
Environment,
@@ -56,8 +70,61 @@ import Control.State.Transition (
5670
import Control.State.Transition.Extended (Embed (..), trans)
5771
import qualified Data.Map.Strict as Map
5872
import Data.Sequence (Seq)
73+
import GHC.Generics (Generic (..))
5974
import Lens.Micro ((^.))
6075

76+
data DijkstraMempoolPredFailure era
77+
= LedgerFailure (PredicateFailure (EraRule "LEDGER" era))
78+
| AllInputsAreSpent
79+
deriving (Generic)
80+
81+
type instance EraRuleFailure "MEMPOOL" DijkstraEra = DijkstraMempoolPredFailure DijkstraEra
82+
83+
type instance EraRuleEvent "MEMPOOL" DijkstraEra = DijkstraMempoolEvent DijkstraEra
84+
85+
instance InjectRuleFailure "MEMPOOL" DijkstraMempoolPredFailure DijkstraEra
86+
87+
deriving instance
88+
Eq (PredicateFailure (EraRule "LEDGER" era)) =>
89+
Eq (DijkstraMempoolPredFailure era)
90+
91+
deriving instance
92+
Show (PredicateFailure (EraRule "LEDGER" era)) =>
93+
Show (DijkstraMempoolPredFailure era)
94+
95+
instance
96+
( Era era
97+
, EncCBOR (PredicateFailure (EraRule "LEDGER" era))
98+
) =>
99+
EncCBOR (DijkstraMempoolPredFailure era)
100+
where
101+
encCBOR =
102+
encode . \case
103+
LedgerFailure x -> Sum (LedgerFailure @era) 1 !> To x
104+
AllInputsAreSpent -> Sum AllInputsAreSpent 2
105+
106+
instance
107+
( Era era
108+
, DecCBOR (PredicateFailure (EraRule "LEDGER" era))
109+
) =>
110+
DecCBOR (DijkstraMempoolPredFailure era)
111+
where
112+
decCBOR = decode . Summands "DijkstraMempoolPredFailure" $ \case
113+
1 -> SumD AllInputsAreSpent
114+
n -> Invalid n
115+
116+
data DijkstraMempoolEvent era
117+
= LedgerEvent (Event (EraRule "LEDGER" era))
118+
deriving (Generic)
119+
120+
deriving instance
121+
Eq (Event (EraRule "LEDGER" era)) =>
122+
Eq (DijkstraMempoolEvent era)
123+
124+
instance
125+
NFData (Event (EraRule "LEDGER" era)) =>
126+
NFData (DijkstraMempoolEvent era)
127+
61128
instance
62129
( EraTx era
63130
, ConwayEraTxBody era
@@ -82,8 +149,8 @@ instance
82149
type Signal (DijkstraMEMPOOL era) = Tx TopTx era
83150
type Environment (DijkstraMEMPOOL era) = LedgerEnv era
84151
type BaseM (DijkstraMEMPOOL era) = ShelleyBase
85-
type PredicateFailure (DijkstraMEMPOOL era) = DijkstraLedgerPredFailure era
86-
type Event (DijkstraMEMPOOL era) = ConwayLedgerEvent era
152+
type PredicateFailure (DijkstraMEMPOOL era) = DijkstraMempoolPredFailure era
153+
type Event (DijkstraMEMPOOL era) = DijkstraMempoolEvent era
87154

88155
transitionRules = [mempoolTransition @era]
89156

@@ -109,8 +176,7 @@ mempoolTransition = do
109176
UTxO utxo = ledgerState ^. utxoG
110177
notAllSpent = any (`Map.member` utxo) inputs
111178
notAllSpent
112-
?! DijkstraMempoolFailure
113-
"All inputs are spent. Transaction has probably already been included"
179+
?! AllInputsAreSpent
114180

115181
-- Continue with LEDGER rules if the transaction is not a duplicate,
116182
whenFailureFreeDefault ledgerState $ do
@@ -148,5 +214,5 @@ instance
148214
) =>
149215
Embed (DijkstraLEDGER era) (DijkstraMEMPOOL era)
150216
where
151-
wrapFailed = id
152-
wrapEvent = id
217+
wrapFailed = LedgerFailure
218+
wrapEvent = LedgerEvent

‎eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs‎

Lines changed: 54 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE RankNTypes #-}
55
{-# LANGUAGE ScopedTypeVariables #-}
66
{-# LANGUAGE TypeApplications #-}
7+
{-# LANGUAGE TypeOperators #-}
78

89
module Test.Cardano.Ledger.Dijkstra.Examples (
910
ledgerExamples,
@@ -17,7 +18,7 @@ import Cardano.Ledger.Conway.Core
1718
import Cardano.Ledger.Conway.Governance (VotingProcedures (..))
1819
import Cardano.Ledger.Conway.Rules (ConwayDELEG, ConwayDelegPredFailure (..))
1920
import Cardano.Ledger.Dijkstra (DijkstraEra)
20-
import Cardano.Ledger.Dijkstra.Rules (DijkstraLEDGER)
21+
import Cardano.Ledger.Dijkstra.Rules (DijkstraLEDGER, DijkstraMEMPOOL)
2122
import Cardano.Ledger.Dijkstra.Scripts (DijkstraPlutusPurpose (..))
2223
import Cardano.Ledger.Dijkstra.TxBody (TxBody (..))
2324
import Cardano.Ledger.Dijkstra.TxCert
@@ -28,22 +29,30 @@ import Cardano.Ledger.Plutus.Data (
2829
)
2930
import Cardano.Ledger.Plutus.Language (Language (..))
3031
import Cardano.Ledger.Shelley.API (
32+
ApplyTx (ApplyTxError),
3133
Credential (..),
34+
NewEpochState,
35+
ProposedPPUpdates (ProposedPPUpdates),
3236
RewardAccount (..),
3337
TxId (..),
3438
)
3539
import Cardano.Ledger.Shelley.Scripts
3640
import Cardano.Ledger.TxIn (mkTxInPartial)
37-
import Control.State.Transition.Extended (Embed (..))
41+
import Control.State.Transition.Extended (
42+
Embed (..),
43+
STS (..),
44+
)
45+
import Data.Default (def)
46+
import Data.List.NonEmpty (NonEmpty)
3847
import qualified Data.Map.Strict as Map
3948
import qualified Data.OSet.Strict as OSet
4049
import qualified Data.Sequence.Strict as StrictSeq
4150
import qualified Data.Set as Set
51+
import Lens.Micro
4252
import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceeds)
4353
import Test.Cardano.Ledger.Alonzo.Examples (
4454
exampleDatum,
4555
exampleTx,
46-
mkLedgerExamples,
4756
)
4857
import Test.Cardano.Ledger.Babbage.Examples (exampleBabbageNewEpochState, exampleCollateralOutput)
4958
import Test.Cardano.Ledger.Core.KeyPair (mkAddr)
@@ -53,25 +62,65 @@ import Test.Cardano.Ledger.Dijkstra.ImpTest (exampleDijkstraGenesis)
5362
import Test.Cardano.Ledger.Mary.Examples (exampleMultiAssetValue)
5463
import Test.Cardano.Ledger.Shelley.Examples (
5564
LedgerExamples (..),
65+
exampleNonMyopicRewards,
5666
examplePayKey,
67+
examplePoolDistr,
5768
exampleStakeKey,
5869
exampleStakePoolParams,
5970
keyToCredential,
6071
mkKeyHash,
6172
mkScriptHash,
73+
testShelleyGenesis,
6274
)
6375

6476
ledgerExamples :: LedgerExamples DijkstraEra
6577
ledgerExamples =
6678
mkLedgerExamples
6779
( pure $
68-
wrapFailed @(ConwayDELEG DijkstraEra) @(DijkstraLEDGER DijkstraEra) $
69-
DelegateeStakePoolNotRegisteredDELEG @DijkstraEra (mkKeyHash 1)
80+
wrapFailed @(DijkstraLEDGER DijkstraEra) @(DijkstraMEMPOOL DijkstraEra) $
81+
wrapFailed @(ConwayDELEG DijkstraEra) @(DijkstraLEDGER DijkstraEra) $
82+
DelegateeStakePoolNotRegisteredDELEG @DijkstraEra (mkKeyHash 1)
7083
)
7184
exampleBabbageNewEpochState
7285
exampleTxDijkstra
7386
exampleDijkstraGenesis
7487

88+
mkLedgerExamples ::
89+
forall era.
90+
AlonzoEraPParams era =>
91+
ApplyTxError era ~ NonEmpty (PredicateFailure (EraRule "MEMPOOL" era)) =>
92+
NonEmpty (PredicateFailure (EraRule "MEMPOOL" era)) ->
93+
NewEpochState era ->
94+
Tx TopTx era ->
95+
TranslationContext era ->
96+
LedgerExamples era
97+
mkLedgerExamples
98+
applyTxError
99+
newEpochState
100+
tx
101+
translationContext =
102+
LedgerExamples
103+
{ leTx = tx
104+
, leApplyTxError = applyTxError
105+
, lePParams = def
106+
, leProposedPPUpdates =
107+
ProposedPPUpdates $
108+
Map.singleton
109+
(mkKeyHash 0)
110+
(emptyPParamsUpdate & ppuCollateralPercentageL .~ SJust 150)
111+
, leNewEpochState = newEpochState
112+
, lePoolDistr = examplePoolDistr
113+
, leRewardsCredentials =
114+
Set.fromList
115+
[ Left (Coin 100)
116+
, Right (ScriptHashObj (mkScriptHash 1))
117+
, Right (KeyHashObj (mkKeyHash 2))
118+
]
119+
, leNonMyopicRewards = exampleNonMyopicRewards
120+
, leTranslationContext = translationContext
121+
, leShelleyGenesis = testShelleyGenesis
122+
}
123+
75124
exampleTxDijkstra :: Tx TopTx DijkstraEra
76125
exampleTxDijkstra =
77126
exampleTx

0 commit comments

Comments
 (0)