Skip to content

Commit ba5addb

Browse files
lehinslehins
committed
Change ApplyTx interface to accomodate different entrypoints
1 parent c0546e0 commit ba5addb

File tree

16 files changed

+93
-183
lines changed

16 files changed

+93
-183
lines changed

‎eras/allegra/impl/src/Cardano/Ledger/Allegra.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE FlexibleInstances #-}
33
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE TypeApplications #-}
45
{-# LANGUAGE UndecidableInstances #-}
56
{-# OPTIONS_GHC -Wno-orphans #-}
67

@@ -19,7 +20,7 @@ import Cardano.Ledger.Allegra.Translation ()
1920
import Cardano.Ledger.Allegra.Tx ()
2021
import Cardano.Ledger.Allegra.TxSeq ()
2122
import Cardano.Ledger.Allegra.UTxO ()
22-
import Cardano.Ledger.Shelley.API (ApplyBlock, ApplyTx)
23+
import Cardano.Ledger.Shelley.API
2324

2425
type Allegra = AllegraEra
2526

@@ -29,6 +30,7 @@ type Allegra = AllegraEra
2930
-- Mempool instances
3031
--------------------------------------------------------------------------------
3132

32-
instance ApplyTx AllegraEra
33+
instance ApplyTx AllegraEra where
34+
applyTxValidation = ruleApplyTxValidation @"LEDGER"
3335

3436
instance ApplyBlock AllegraEra

‎eras/alonzo/impl/CHANGELOG.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22

33
## 1.13.0.0
44

5+
* Remove `reapplyAlonzoTx` as no longer needed.
56
* Add `TxInfoResult` data family, `mkTxInfoResult` and `lookupTxInfoResult` to `EraPlutusContext`
67
* Add `lookupTxInfoResultImpossible` helper
78
* Add `TxInfoResult era` parameter to `toPlutusWithContext` and `mkPlutusWithContext`

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

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -91,7 +91,6 @@ library
9191
deepseq,
9292
mempack,
9393
microlens,
94-
mtl,
9594
nothunks,
9695
plutus-ledger-api >=1.37,
9796
set-algebra >=1.0,

‎eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs‎

Lines changed: 1 addition & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,6 @@ module Cardano.Ledger.Alonzo (
1414
AlonzoTxBody,
1515
AlonzoScript,
1616
AlonzoTxAuxData,
17-
reapplyAlonzoTx,
1817
)
1918
where
2019

@@ -30,39 +29,17 @@ import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData)
3029
import Cardano.Ledger.Alonzo.TxBody (AlonzoTxBody, AlonzoTxOut)
3130
import Cardano.Ledger.Alonzo.TxWits ()
3231
import Cardano.Ledger.Alonzo.UTxO ()
33-
import Cardano.Ledger.Core
3432
import Cardano.Ledger.Mary.Value (MaryValue)
3533
import Cardano.Ledger.Plutus.Data ()
36-
import Cardano.Ledger.Rules.ValidationMode (applySTSNonStatic)
3734
import Cardano.Ledger.Shelley.API
38-
import Control.Arrow (left)
39-
import Control.Monad.Except (MonadError, liftEither)
40-
import Control.Monad.Reader (runReader)
41-
import Control.State.Transition.Extended (TRC (TRC))
4235

4336
type Alonzo = AlonzoEra
4437

4538
{-# DEPRECATED Alonzo "In favor of `AlonzoEra`" #-}
4639

4740
-- =====================================================
4841

49-
reapplyAlonzoTx ::
50-
forall era m.
51-
(ApplyTx era, MonadError (ApplyTxError era) m) =>
52-
Globals ->
53-
MempoolEnv era ->
54-
MempoolState era ->
55-
Validated (Tx era) ->
56-
m (MempoolState era)
57-
reapplyAlonzoTx globals env state vtx =
58-
let res =
59-
flip runReader globals
60-
. applySTSNonStatic
61-
@(EraRule "LEDGER" era)
62-
$ TRC (env, state, extractTx vtx)
63-
in liftEither . left ApplyTxError $ res
64-
6542
instance ApplyTx AlonzoEra where
66-
reapplyTx = reapplyAlonzoTx
43+
applyTxValidation = ruleApplyTxValidation @"LEDGER"
6744

6845
instance ApplyBlock AlonzoEra

‎eras/babbage/impl/src/Cardano/Ledger/Babbage.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE FlexibleInstances #-}
33
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE TypeApplications #-}
45
{-# LANGUAGE UndecidableInstances #-}
56
{-# OPTIONS_GHC -Wno-orphans #-}
67

@@ -14,7 +15,6 @@ module Cardano.Ledger.Babbage (
1415
)
1516
where
1617

17-
import Cardano.Ledger.Alonzo (reapplyAlonzoTx)
1818
import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..))
1919
import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..))
2020
import Cardano.Ledger.Babbage.Era (BabbageEra)
@@ -33,6 +33,6 @@ type Babbage = BabbageEra
3333
-- =====================================================
3434

3535
instance ApplyTx BabbageEra where
36-
reapplyTx = reapplyAlonzoTx
36+
applyTxValidation = ruleApplyTxValidation @"LEDGER"
3737

3838
instance ApplyBlock BabbageEra

‎eras/conway/impl/CHANGELOG.md‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,9 @@
22

33
## 1.19.0.0
44

5+
* Remove `ConwayMempoolPredFailure` and `ConwayMempoolEvent`
6+
* Switch to `MEMPOOL` rule to be the entry point for `ApplyTx` instead of `LEDGER` and invert their
7+
ivocation.
58
* Added `ToCBOR` and `FromCBOR` instances for `DefaultVote`.
69
* Made the fields of predicate failures and environments lazy
710
* Add `MemPack` instance for `PlutusScript ConwayEra`

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -180,6 +180,7 @@ library testlib
180180
plutus-ledger-api,
181181
prettyprinter,
182182
small-steps >=1.1,
183+
text,
183184

184185
executable huddle-cddl
185186
main-is: Main.hs

‎eras/conway/impl/src/Cardano/Ledger/Conway.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE FlexibleInstances #-}
33
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE TypeApplications #-}
45
{-# LANGUAGE UndecidableInstances #-}
56
{-# OPTIONS_GHC -Wno-orphans #-}
67

@@ -10,7 +11,6 @@ module Cardano.Ledger.Conway (
1011
)
1112
where
1213

13-
import Cardano.Ledger.Alonzo (reapplyAlonzoTx)
1414
import Cardano.Ledger.Babbage.TxBody ()
1515
import Cardano.Ledger.Conway.Era (ConwayEra)
1616
import Cardano.Ledger.Conway.Governance (RunConwayRatify (..))
@@ -30,7 +30,7 @@ type Conway = ConwayEra
3030
-- =====================================================
3131

3232
instance ApplyTx ConwayEra where
33-
reapplyTx = reapplyAlonzoTx
33+
applyTxValidation = ruleApplyTxValidation @"MEMPOOL"
3434

3535
instance ApplyBlock ConwayEra
3636

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

Lines changed: 1 addition & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ import Cardano.Ledger.Alonzo.Rules (
1616
)
1717
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure)
1818
import Cardano.Ledger.Babbage.TxInfo (BabbageContextError)
19-
import Cardano.Ledger.BaseTypes (Inject, ShelleyBase)
19+
import Cardano.Ledger.BaseTypes (Inject)
2020
import Cardano.Ledger.Conway.Core
2121
import Cardano.Ledger.Conway.Rules (
2222
ConwayBbodyPredFailure,
@@ -26,20 +26,16 @@ import Cardano.Ledger.Conway.Rules (
2626
ConwayGovCertPredFailure,
2727
ConwayGovPredFailure,
2828
ConwayHardForkEvent,
29-
ConwayLedgerEvent,
3029
ConwayLedgerPredFailure,
3130
ConwayNewEpochEvent,
3231
)
3332
import Cardano.Ledger.Conway.TxInfo (ConwayContextError)
3433
import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..))
3534
import Cardano.Ledger.Shelley.Rules (
36-
ShelleyLedgersEnv,
37-
ShelleyLedgersEvent,
3835
ShelleyUtxoPredFailure,
3936
ShelleyUtxowPredFailure,
4037
)
4138
import Control.State.Transition.Extended
42-
import Data.Sequence (Seq)
4339
import Data.Typeable (Typeable)
4440
import qualified Test.Cardano.Ledger.Babbage.Imp as BabbageImp
4541
import qualified Test.Cardano.Ledger.Conway.Imp.BbodySpec as Bbody
@@ -84,13 +80,7 @@ spec ::
8480
, InjectRuleEvent "TICK" ConwayEpochEvent era
8581
, Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
8682
, Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
87-
, Event (EraRule "LEDGERS" era) ~ ShelleyLedgersEvent era
88-
, Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era
8983
, Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
90-
, BaseM (EraRule "LEDGERS" era) ~ ShelleyBase
91-
, Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
92-
, Signal (EraRule "LEDGERS" era) ~ Seq (Tx era)
93-
, STS (EraRule "LEDGERS" era)
9484
, ApplyTx era
9585
, NFData (Event (EraRule "ENACT" era))
9686
, ToExpr (Event (EraRule "ENACT" era))
@@ -125,13 +115,7 @@ conwaySpec ::
125115
, InjectRuleEvent "TICK" ConwayEpochEvent era
126116
, Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
127117
, Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
128-
, Event (EraRule "LEDGERS" era) ~ ShelleyLedgersEvent era
129-
, Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era
130118
, Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
131-
, BaseM (EraRule "LEDGERS" era) ~ ShelleyBase
132-
, Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
133-
, Signal (EraRule "LEDGERS" era) ~ Seq (Tx era)
134-
, STS (EraRule "LEDGERS" era)
135119
, ApplyTx era
136120
, NFData (Event (EraRule "ENACT" era))
137121
, ToExpr (Event (EraRule "ENACT" era))

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

Lines changed: 9 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE FlexibleContexts #-}
33
{-# LANGUAGE NumericUnderscores #-}
44
{-# LANGUAGE OverloadedLists #-}
5+
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE ScopedTypeVariables #-}
67
{-# LANGUAGE TypeApplications #-}
78
{-# LANGUAGE TypeFamilies #-}
@@ -14,21 +15,18 @@ import Cardano.Ledger.Coin (Coin (..))
1415
import Cardano.Ledger.Conway.Core
1516
import Cardano.Ledger.Conway.Governance
1617
import Cardano.Ledger.Conway.Rules (
17-
ConwayLedgerEvent (..),
1818
ConwayLedgerPredFailure (..),
1919
maxRefScriptSizePerTx,
2020
)
2121
import Cardano.Ledger.Credential (Credential (..))
2222
import Cardano.Ledger.DRep
2323
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
24-
import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..), applyTx, mkMempoolEnv)
24+
import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..), ApplyTxError (..), applyTx, mkMempoolEnv)
2525
import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
2626
import Cardano.Ledger.Shelley.LedgerState
27-
import Cardano.Ledger.Shelley.Rules (ShelleyLedgersEnv (..), ShelleyLedgersEvent (..))
28-
import Control.State.Transition.Extended
2927
import qualified Data.Map.Strict as Map
30-
import qualified Data.Sequence as Seq
3128
import qualified Data.Set as Set
29+
import qualified Data.Text as T
3230
import Lens.Micro ((&), (.~), (^.))
3331
import Lens.Micro.Mtl (use)
3432
import Test.Cardano.Ledger.Conway.ImpTest
@@ -43,12 +41,6 @@ spec ::
4341
forall era.
4442
( ConwayEraImp era
4543
, InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
46-
, BaseM (EraRule "LEDGERS" era) ~ ShelleyBase
47-
, Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
48-
, Signal (EraRule "LEDGERS" era) ~ Seq.Seq (Tx era)
49-
, Event (EraRule "LEDGERS" era) ~ ShelleyLedgersEvent era
50-
, Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era
51-
, STS (EraRule "LEDGERS" era)
5244
, ApplyTx era
5345
) =>
5446
SpecWith (ImpInit (LedgerSpec era))
@@ -219,43 +211,7 @@ spec = do
219211
mkBasicTx $
220212
mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(ra, mempty)]
221213

222-
describe "Mempool events" $ do
223-
it "No Mempool events should be emitted via LEDGERS rules " $ do
224-
nes <- use impNESL
225-
slotNo <- use impLastTickG
226-
let ls = nes ^. nesEsL . esLStateL
227-
pp = nes ^. nesEsL . curPParamsEpochStateL
228-
account = nes ^. nesEsL . esAccountStateL
229-
epochNo = nes ^. nesELL
230-
tx <- fixupTx $ mkBasicTx mkBasicTxBody
231-
Right (_, evs) <-
232-
tryRunImpRule @"LEDGERS"
233-
(LedgersEnv slotNo epochNo pp account)
234-
ls
235-
(Seq.singleton tx)
236-
let mempoolEvents = [ev | LedgerEvent ev <- evs]
237-
mempoolEvents `shouldBeExpr` []
238-
239-
it "Mempool events should be emitted via `applyTx` with `mkMempoolEnv`" $ do
240-
globals <- use impGlobalsL
241-
slotNo <- use impLastTickG
242-
nes <- use impNESL
243-
let ls = nes ^. nesEsL . esLStateL
244-
245-
let mempoolEnv = mkMempoolEnv nes slotNo
246-
tx <- fixupTx $ mkBasicTx mkBasicTxBody
247-
let stsOpts =
248-
ApplySTSOpts
249-
{ asoAssertions = AssertionsAll
250-
, asoValidation = ValidateAll
251-
, asoEvents = EPReturn
252-
}
253-
case applyTxOpts stsOpts globals mempoolEnv ls tx of
254-
Left e ->
255-
assertFailure $ "Unexpected failure while applyingTx: " <> show tx <> ": " <> show e
256-
Right (_, evs) ->
257-
length [ev | ev <- evs] `shouldBe` 1
258-
214+
describe "Mempool" $ do
259215
it "Unelected Committee voting" $ whenPostBootstrap $ do
260216
globals <- use impGlobalsL
261217
slotNo <- use impLastTickG
@@ -291,6 +247,10 @@ spec = do
291247
)
292248

293249
case applyTx globals mempoolEnv ls tx of
294-
Left _ -> pure ()
250+
Left err ->
251+
let expectedFailure =
252+
ConwayMempoolFailure $
253+
"Unelected committee members are not allowed to cast votes: " <> T.pack (show (pure @[] ccHot))
254+
in err `shouldBe` ApplyTxError @era (pure (injectFailure expectedFailure))
295255
Right _ -> assertFailure $ "Expected failure due to an unallowed vote: " <> show tx
296256
withNoFixup $ submitTx_ tx

0 commit comments

Comments
 (0)