Skip to content

Commit 1edb1fb

Browse files
f-ff-f
committed
Add Imp tests for Mempool in Dijkstra
1 parent f7da0a4 commit 1edb1fb

File tree

9 files changed

+260
-117
lines changed

9 files changed

+260
-117
lines changed

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -149,6 +149,7 @@ library testlib
149149
Test.Cardano.Ledger.Conway.Imp.GovSpec
150150
Test.Cardano.Ledger.Conway.Imp.HardForkSpec
151151
Test.Cardano.Ledger.Conway.Imp.LedgerSpec
152+
Test.Cardano.Ledger.Conway.Imp.MempoolSpec
152153
Test.Cardano.Ledger.Conway.Imp.RatifySpec
153154
Test.Cardano.Ledger.Conway.Imp.UtxoSpec
154155
Test.Cardano.Ledger.Conway.Imp.UtxosSpec

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ import qualified Test.Cardano.Ledger.Conway.Imp.GovCertSpec as GovCert
2828
import qualified Test.Cardano.Ledger.Conway.Imp.GovSpec as Gov
2929
import qualified Test.Cardano.Ledger.Conway.Imp.HardForkSpec as HardFork
3030
import qualified Test.Cardano.Ledger.Conway.Imp.LedgerSpec as Ledger
31+
import qualified Test.Cardano.Ledger.Conway.Imp.MempoolSpec as Mempool
3132
import qualified Test.Cardano.Ledger.Conway.Imp.RatifySpec as Ratify
3233
import qualified Test.Cardano.Ledger.Conway.Imp.UtxoSpec as Utxo
3334
import qualified Test.Cardano.Ledger.Conway.Imp.UtxosSpec as Utxos
@@ -75,6 +76,7 @@ conwayEraSpecificSpec :: SpecWith (ImpInit (LedgerSpec ConwayEra))
7576
conwayEraSpecificSpec = do
7677
describe "Conway era specific Imp spec" $ do
7778
describe "UTXO" Utxo.conwayEraSpecificSpec
79+
describe "MEMPOOL" Mempool.conwayEraSpecificSpec
7880

7981
instance EraSpecificSpec ConwayEra where
8082
eraSpecificSpec =

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs‎

Lines changed: 1 addition & 113 deletions
Original file line numberDiff line numberDiff line change
@@ -14,34 +14,20 @@ import Cardano.Ledger.BaseTypes
1414
import Cardano.Ledger.Coin (Coin (..))
1515
import Cardano.Ledger.Conway (
1616
hardforkConwayBootstrapPhase,
17-
hardforkConwayDisallowUnelectedCommitteeFromVoting,
1817
)
1918
import Cardano.Ledger.Conway.Core
20-
import Cardano.Ledger.Conway.Governance
2119
import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..))
2220
import Cardano.Ledger.Conway.Rules (
23-
ConwayGovPredFailure (UnelectedCommitteeVoters),
2421
ConwayLedgerPredFailure (..),
25-
ConwayUtxoPredFailure (BadInputsUTxO),
26-
PredicateFailure,
2722
)
2823
import Cardano.Ledger.Credential (Credential (..))
2924
import Cardano.Ledger.DRep
3025
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
31-
import Cardano.Ledger.Shelley.API.Mempool (applyTx, mkMempoolEnv)
3226
import Cardano.Ledger.Shelley.LedgerState
33-
import Control.Monad.Reader (asks)
34-
import Data.List.NonEmpty (NonEmpty)
35-
import qualified Data.List.NonEmpty as NonEmpty
36-
import qualified Data.Map.Strict as Map
3727
import qualified Data.Set as Set
38-
import qualified Data.Text as T
3928
import Data.Word (Word32)
40-
import GHC.Exts (fromList)
41-
import Lens.Micro ((&), (.~), (<>~), (^.))
42-
import Lens.Micro.Mtl (use)
29+
import Lens.Micro ((&), (.~), (^.))
4330
import Test.Cardano.Ledger.Conway.ImpTest
44-
import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
4531
import Test.Cardano.Ledger.Imp.Common
4632
import Test.Cardano.Ledger.Plutus.Examples (
4733
alwaysSucceedsNoDatum,
@@ -213,101 +199,3 @@ spec = do
213199
submitTx_ $
214200
mkBasicTx $
215201
mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(ra, mempty)]
216-
217-
describe "Mempool" $ do
218-
let
219-
submitFailingMempoolTx ::
220-
String ->
221-
Tx TopTx era ->
222-
NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
223-
ImpM (LedgerSpec era) (Tx TopTx era)
224-
submitFailingMempoolTx cause tx expectedFailures = do
225-
globals <- use impGlobalsL
226-
nes <- use impNESL
227-
slotNo <- use impCurSlotNoG
228-
let
229-
mempoolEnv = mkMempoolEnv nes slotNo
230-
ls = nes ^. nesEsL . esLStateL
231-
txFixed <- (tx &) =<< asks iteFixup
232-
logToExpr txFixed
233-
case applyTx globals mempoolEnv ls txFixed of
234-
Left err -> do
235-
err `shouldBe` inject expectedFailures
236-
Right _ ->
237-
assertFailure $ "Expected failure due to " <> cause <> ": " <> show txFixed
238-
pure txFixed
239-
240-
submitFailingMempoolTx_ ::
241-
String ->
242-
Tx TopTx era ->
243-
NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
244-
ImpM (LedgerSpec era) ()
245-
submitFailingMempoolTx_ c t = void . submitFailingMempoolTx c t
246-
247-
it "Duplicate transactions" $ do
248-
let
249-
newInput = do
250-
addr <- freshKeyAddr_
251-
amount <- Coin <$> choose (2_000_000, 8_000_000)
252-
sendCoinTo addr amount
253-
254-
inputsCommon <- replicateM 5 newInput
255-
inputs1 <- replicateM 2 newInput
256-
inputs2 <- replicateM 3 newInput
257-
258-
txFinal <-
259-
submitTx $
260-
mkBasicTx $
261-
mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs1)
262-
263-
impAnn "Identical transaction" $ do
264-
withNoFixup $
265-
submitFailingMempoolTx_ "duplicate transaction" txFinal $
266-
NonEmpty.singleton . injectFailure . ConwayMempoolFailure $
267-
"All inputs are spent. Transaction has probably already been included"
268-
269-
impAnn "Overlapping transaction" $ do
270-
let txOverlap = mkBasicTx $ mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs2)
271-
submitFailingMempoolTx_
272-
"overlapping transaction"
273-
txOverlap
274-
[injectFailure $ BadInputsUTxO $ fromList inputsCommon]
275-
276-
it "Unelected Committee voting" $ whenPostBootstrap $ do
277-
_ <- registerInitialCommittee
278-
ccCold <- KeyHashObj <$> freshKeyHash
279-
curEpochNo <- getsNES nesELL
280-
let action =
281-
UpdateCommittee
282-
SNothing
283-
mempty
284-
(Map.singleton ccCold (addEpochInterval curEpochNo (EpochInterval 7)))
285-
(1 %! 1)
286-
proposal <- mkProposal action
287-
submitTx_ $
288-
mkBasicTx (mkBasicTxBody & proposalProceduresTxBodyL .~ [proposal])
289-
ccHot <- registerCommitteeHotKey ccCold
290-
govActionId <- do
291-
rewardAccount <- registerRewardAccount
292-
submitTreasuryWithdrawals [(rewardAccount, Coin 1)]
293-
294-
let
295-
tx =
296-
mkBasicTx $
297-
mkBasicTxBody
298-
& votingProceduresTxBodyL
299-
.~ VotingProcedures
300-
( Map.singleton
301-
(CommitteeVoter ccHot)
302-
(Map.singleton govActionId (VotingProcedure VoteYes SNothing))
303-
)
304-
pv <- getProtVer
305-
if hardforkConwayDisallowUnelectedCommitteeFromVoting pv
306-
then
307-
submitFailingTx tx [injectFailure $ UnelectedCommitteeVoters [ccHot]]
308-
else do
309-
txFixed <-
310-
submitFailingMempoolTx "unallowed votes" tx $
311-
pure . injectFailure . ConwayMempoolFailure $
312-
"Unelected committee members are not allowed to cast votes: " <> T.pack (show (pure @[] ccHot))
313-
withNoFixup $ submitTx_ txFixed

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/MempoolSpec.hs‎

Lines changed: 142 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,142 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE NumericUnderscores #-}
4+
{-# LANGUAGE OverloadedLists #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE ScopedTypeVariables #-}
7+
{-# LANGUAGE TypeApplications #-}
8+
{-# LANGUAGE TypeFamilies #-}
9+
{-# LANGUAGE TypeOperators #-}
10+
11+
module Test.Cardano.Ledger.Conway.Imp.MempoolSpec (conwayEraSpecificSpec) where
12+
13+
import Cardano.Ledger.BaseTypes
14+
import Cardano.Ledger.Coin (Coin (..))
15+
import Cardano.Ledger.Conway (
16+
hardforkConwayDisallowUnelectedCommitteeFromVoting,
17+
)
18+
import Cardano.Ledger.Conway.Core
19+
import Cardano.Ledger.Conway.Governance
20+
import Cardano.Ledger.Conway.Rules (
21+
ConwayGovPredFailure (UnelectedCommitteeVoters),
22+
ConwayLedgerPredFailure (..),
23+
ConwayUtxoPredFailure (BadInputsUTxO),
24+
PredicateFailure,
25+
)
26+
import Cardano.Ledger.Credential (Credential (..))
27+
import Cardano.Ledger.Shelley.API.Mempool (applyTx, mkMempoolEnv)
28+
import Cardano.Ledger.Shelley.LedgerState
29+
import Control.Monad.Reader (asks)
30+
import Data.List.NonEmpty (NonEmpty)
31+
import qualified Data.List.NonEmpty as NonEmpty
32+
import qualified Data.Map.Strict as Map
33+
import qualified Data.Text as T
34+
import GHC.Exts (fromList)
35+
import Lens.Micro ((&), (.~), (<>~), (^.))
36+
import Lens.Micro.Mtl (use)
37+
import Test.Cardano.Ledger.Conway.ImpTest
38+
import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
39+
import Test.Cardano.Ledger.Imp.Common
40+
41+
conwayEraSpecificSpec ::
42+
forall era.
43+
ConwayEraImp era =>
44+
SpecWith (ImpInit (LedgerSpec era))
45+
conwayEraSpecificSpec =
46+
describe "Mempool" $ do
47+
let
48+
submitFailingMempoolTx ::
49+
String ->
50+
Tx TopTx era ->
51+
NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
52+
ImpM (LedgerSpec era) (Tx TopTx era)
53+
submitFailingMempoolTx cause tx expectedFailures = do
54+
globals <- use impGlobalsL
55+
nes <- use impNESL
56+
slotNo <- use impCurSlotNoG
57+
let
58+
mempoolEnv = mkMempoolEnv nes slotNo
59+
ls = nes ^. nesEsL . esLStateL
60+
txFixed <- (tx &) =<< asks iteFixup
61+
logToExpr txFixed
62+
case applyTx globals mempoolEnv ls txFixed of
63+
Left err -> do
64+
err `shouldBe` inject expectedFailures
65+
Right _ ->
66+
assertFailure $ "Expected failure due to " <> cause <> ": " <> show txFixed
67+
pure txFixed
68+
69+
submitFailingMempoolTx_ ::
70+
String ->
71+
Tx TopTx era ->
72+
NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
73+
ImpM (LedgerSpec era) ()
74+
submitFailingMempoolTx_ c t = void . submitFailingMempoolTx c t
75+
76+
it "Duplicate transactions" $ do
77+
let
78+
newInput = do
79+
addr <- freshKeyAddr_
80+
amount <- Coin <$> choose (2_000_000, 8_000_000)
81+
sendCoinTo addr amount
82+
83+
inputsCommon <- replicateM 5 newInput
84+
inputs1 <- replicateM 2 newInput
85+
inputs2 <- replicateM 3 newInput
86+
87+
txFinal <-
88+
submitTx $
89+
mkBasicTx $
90+
mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs1)
91+
92+
impAnn "Identical transaction" $ do
93+
withNoFixup $
94+
submitFailingMempoolTx_ "duplicate transaction" txFinal $
95+
NonEmpty.singleton . injectFailure . ConwayMempoolFailure $
96+
"All inputs are spent. Transaction has probably already been included"
97+
98+
impAnn "Overlapping transaction" $ do
99+
let txOverlap = mkBasicTx $ mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs2)
100+
submitFailingMempoolTx_
101+
"overlapping transaction"
102+
txOverlap
103+
[injectFailure $ BadInputsUTxO $ fromList inputsCommon]
104+
105+
it "Unelected Committee voting" $ whenPostBootstrap $ do
106+
_ <- registerInitialCommittee
107+
ccCold <- KeyHashObj <$> freshKeyHash
108+
curEpochNo <- getsNES nesELL
109+
let action =
110+
UpdateCommittee
111+
SNothing
112+
mempty
113+
(Map.singleton ccCold (addEpochInterval curEpochNo (EpochInterval 7)))
114+
(1 %! 1)
115+
proposal <- mkProposal action
116+
submitTx_ $
117+
mkBasicTx (mkBasicTxBody & proposalProceduresTxBodyL .~ [proposal])
118+
ccHot <- registerCommitteeHotKey ccCold
119+
govActionId <- do
120+
rewardAccount <- registerRewardAccount
121+
submitTreasuryWithdrawals [(rewardAccount, Coin 1)]
122+
123+
let
124+
tx =
125+
mkBasicTx $
126+
mkBasicTxBody
127+
& votingProceduresTxBodyL
128+
.~ VotingProcedures
129+
( Map.singleton
130+
(CommitteeVoter ccHot)
131+
(Map.singleton govActionId (VotingProcedure VoteYes SNothing))
132+
)
133+
pv <- getProtVer
134+
if hardforkConwayDisallowUnelectedCommitteeFromVoting pv
135+
then
136+
submitFailingTx tx [injectFailure $ UnelectedCommitteeVoters [ccHot]]
137+
else do
138+
txFixed <-
139+
submitFailingMempoolTx "unallowed votes" tx $
140+
pure . injectFailure . ConwayMempoolFailure $
141+
"Unelected committee members are not allowed to cast votes: " <> T.pack (show (pure @[] ccHot))
142+
withNoFixup $ submitTx_ txFixed

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -120,6 +120,7 @@ library testlib
120120
Test.Cardano.Ledger.Dijkstra.Era
121121
Test.Cardano.Ledger.Dijkstra.Examples
122122
Test.Cardano.Ledger.Dijkstra.Imp
123+
Test.Cardano.Ledger.Dijkstra.Imp.MempoolSpec
123124
Test.Cardano.Ledger.Dijkstra.Imp.UtxoSpec
124125
Test.Cardano.Ledger.Dijkstra.Imp.UtxowSpec
125126
Test.Cardano.Ledger.Dijkstra.ImpTest
@@ -157,6 +158,8 @@ library testlib
157158
generic-random,
158159
heredoc,
159160
microlens,
161+
microlens-mtl,
162+
mtl,
160163
small-steps,
161164
tree-diff,
162165

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@ module Cardano.Ledger.Dijkstra.Rules (
1212
module Cardano.Ledger.Dijkstra.Rules.Mempool,
1313
module Cardano.Ledger.Dijkstra.Rules.Utxo,
1414
module Cardano.Ledger.Dijkstra.Rules.Utxow,
15+
module Control.State.Transition.Extended,
1516
) where
1617

1718
import Cardano.Ledger.Conway.Rules (
@@ -35,6 +36,7 @@ import Cardano.Ledger.Dijkstra.Rules.Utxo
3536
import Cardano.Ledger.Dijkstra.Rules.Utxos ()
3637
import Cardano.Ledger.Dijkstra.Rules.Utxow
3738
import Cardano.Ledger.Shelley.Rules (ShelleyTickEvent (..))
39+
import Control.State.Transition.Extended (STS (PredicateFailure))
3840

3941
type instance EraRuleEvent "TICK" DijkstraEra = ShelleyTickEvent DijkstraEra
4042

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

Lines changed: 0 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -35,9 +35,6 @@ import Cardano.Ledger.Dijkstra.TxInfo (DijkstraContextError)
3535
import Cardano.Ledger.Shelley.Scripts (
3636
pattern RequireSignature,
3737
)
38-
import Control.State.Transition (
39-
STS (..),
40-
)
4138
import Data.Functor.Identity (Identity)
4239
import qualified Data.OMap.Strict as OMap
4340
import Data.Typeable (Typeable)

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

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,13 +8,17 @@
88

99
module Test.Cardano.Ledger.Dijkstra.Imp where
1010

11+
import Cardano.Ledger.BaseTypes (Inject (..))
1112
import Cardano.Ledger.Conway.Rules
1213
import Cardano.Ledger.Dijkstra (DijkstraEra)
1314
import Cardano.Ledger.Dijkstra.Core
14-
import Cardano.Ledger.Dijkstra.Rules (DijkstraUtxoPredFailure)
15+
import Cardano.Ledger.Dijkstra.Rules (DijkstraMempoolPredFailure, DijkstraUtxoPredFailure)
16+
import Cardano.Ledger.Shelley.API.Mempool (ApplyTxError)
1517
import Cardano.Ledger.Shelley.Rules
18+
import Data.List.NonEmpty (NonEmpty)
1619
import Test.Cardano.Ledger.Common
1720
import qualified Test.Cardano.Ledger.Conway.Imp as ConwayImp
21+
import qualified Test.Cardano.Ledger.Dijkstra.Imp.MempoolSpec as Mempool
1822
import qualified Test.Cardano.Ledger.Dijkstra.Imp.UtxoSpec as Utxo
1923
import qualified Test.Cardano.Ledger.Dijkstra.Imp.UtxowSpec as Utxow
2024
import Test.Cardano.Ledger.Dijkstra.ImpTest
@@ -27,6 +31,8 @@ spec ::
2731
, Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
2832
, Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
2933
, InjectRuleFailure "LEDGER" DijkstraUtxoPredFailure era
34+
, Inject (NonEmpty (DijkstraMempoolPredFailure era)) (ApplyTxError era)
35+
, PredicateFailure (EraRule "MEMPOOL" era) ~ DijkstraMempoolPredFailure era
3036
) =>
3137
Spec
3238
spec = do
@@ -37,10 +43,13 @@ dijkstraEraGenericSpec ::
3743
forall era.
3844
( DijkstraEraImp era
3945
, InjectRuleFailure "LEDGER" DijkstraUtxoPredFailure era
46+
, PredicateFailure (EraRule "MEMPOOL" era) ~ DijkstraMempoolPredFailure era
47+
, Inject (NonEmpty (DijkstraMempoolPredFailure era)) (ApplyTxError era)
4048
) =>
4149
SpecWith (ImpInit (LedgerSpec era))
4250
dijkstraEraGenericSpec = do
4351
describe "UTXOW" Utxow.spec
4452
describe "UTXO" Utxo.spec
53+
describe "MEMPOOL" Mempool.spec
4554

4655
instance EraSpecificSpec DijkstraEra

0 commit comments

Comments
 (0)