Skip to content

Commit 65447bc

Browse files
kdermekderme
committed
Fix tests
Signed-off-by: Kostas Dermentzis <kostas.dermentzis@iohk.io>
1 parent d5d141f commit 65447bc

File tree

9 files changed

+77
-63
lines changed

9 files changed

+77
-63
lines changed

‎cardano-chain-gen/src/Cardano/Mock/Chain.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,7 @@ module Cardano.Mock.Chain (
1818
) where
1919

2020
import Ouroboros.Consensus.Block
21-
import Ouroboros.Consensus.Ledger.Basics (ValuesMK)
21+
import Ouroboros.Consensus.Ledger.Basics (EmptyMK, ValuesMK)
2222
import qualified Ouroboros.Consensus.Ledger.Extended as Consensus
2323
import qualified Ouroboros.Network.AnchoredFragment as AF
2424
import Ouroboros.Network.Block
@@ -30,9 +30,9 @@ data Chain' block st
3030
| Chain' block st :> (block, st)
3131
deriving (Eq, Ord, Show, Functor)
3232

33-
type State block = Consensus.ExtLedgerState block
33+
type State block = (Consensus.ExtLedgerState block EmptyMK, Consensus.LedgerTables (Consensus.ExtLedgerState block) ValuesMK)
3434

35-
type Chain block = Chain' block (State block ValuesMK)
35+
type Chain block = Chain' block (State block)
3636

3737
infixl 5 :>
3838

‎cardano-chain-gen/src/Cardano/Mock/ChainDB.hs‎

Lines changed: 21 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -27,7 +27,8 @@ import Ouroboros.Consensus.Config
2727
import Ouroboros.Consensus.Ledger.Abstract
2828
import qualified Ouroboros.Consensus.Ledger.Extended as Consensus
2929
import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol)
30-
import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs)
30+
import qualified Ouroboros.Consensus.Ledger.Tables as Consensus
31+
import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffsMK, forgetLedgerTables, restrictValuesMK)
3132
import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
3233
import Ouroboros.Network.Block (Tip (..))
3334

@@ -49,7 +50,7 @@ instance Show (Chain block) => Show (ChainDB block) where
4950

5051
initChainDB ::
5152
TopLevelConfig block ->
52-
State block ValuesMK ->
53+
State block ->
5354
ChainDB block
5455
initChainDB config st = ChainDB config (Genesis st)
5556

@@ -59,37 +60,48 @@ headTip chainDB =
5960
Genesis _ -> TipGenesis
6061
(_ :> (b, _)) -> Tip (blockSlot b) (blockHash b) (blockNo b)
6162

62-
currentState :: ChainDB block -> State block ValuesMK
63+
currentState :: ChainDB block -> State block
6364
currentState chainDB =
6465
case cchain chainDB of
6566
Genesis st -> st
6667
_ :> (_, st) -> st
6768

6869
replaceGenesisDB ::
6970
ChainDB block ->
70-
State block ValuesMK ->
71+
State block ->
7172
ChainDB block
7273
replaceGenesisDB chainDB st = chainDB {cchain = Genesis st}
7374

7475
extendChainDB ::
76+
forall block.
7577
LedgerSupportsProtocol block =>
7678
ChainDB block ->
7779
block ->
7880
ChainDB block
7981
extendChainDB chainDB blk = do
8082
let !chain = cchain chainDB
8183
-- Get the current ledger state
82-
!tipState = getTipState chain
84+
(tipState, tables) = getTipState chain
8385
-- Apply the block and compute the diffs
86+
keys :: LedgerTables (Consensus.ExtLedgerState block) KeysMK
87+
keys = getBlockKeySets blk
88+
ledgerTables = Consensus.getLedgerTables tables
89+
restrictedTables = restrictValuesMK ledgerTables (Consensus.getLedgerTables keys)
90+
ledgerState = Consensus.withLedgerTables tipState (Consensus.LedgerTables restrictedTables)
8491
!diffState =
8592
tickThenReapply
8693
ComputeLedgerEvents
8794
(Consensus.ExtLedgerCfg $ chainConfig chainDB)
8895
blk
89-
tipState
90-
-- Apply the diffs
91-
!newTipState = applyDiffs tipState diffState
92-
in chainDB {cchain = chain :> (blk, newTipState)}
96+
ledgerState
97+
!ledgerTables' =
98+
Consensus.LedgerTables
99+
. applyDiffsMK ledgerTables
100+
. Consensus.getLedgerTables
101+
. Consensus.projectLedgerTables
102+
$ diffState
103+
!ledgerState' = forgetLedgerTables diffState
104+
in chainDB {cchain = chain :> (blk, (ledgerState', ledgerTables'))}
93105

94106
findFirstPoint :: HasHeader block => [Point block] -> ChainDB block -> Maybe (Point block)
95107
findFirstPoint points chainDB = findFirstPointChain points (cchain chainDB)

‎cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs‎

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,6 @@ import Network.TypedProtocol.Stateful.Codec ()
5555
import qualified Network.TypedProtocol.Stateful.Peer as St
5656
import Ouroboros.Consensus.Block (CodecConfig, HasHeader, Point, StandardHash, castPoint)
5757
import Ouroboros.Consensus.Config (TopLevelConfig, configCodec)
58-
import Ouroboros.Consensus.Ledger.Basics (ValuesMK)
5958
import Ouroboros.Consensus.Ledger.Query (BlockQuery, BlockSupportsLedgerQuery, QueryFootprint (..), ShowQuery)
6059
import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, TxId)
6160
import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol)
@@ -117,7 +116,7 @@ data ServerHandle m blk = ServerHandle
117116
, forkAgain :: m (Async ())
118117
}
119118

120-
replaceGenesis :: MonadSTM m => ServerHandle m blk -> State blk ValuesMK -> STM m ()
119+
replaceGenesis :: MonadSTM m => ServerHandle m blk -> State blk -> STM m ()
121120
replaceGenesis handle st =
122121
modifyTVar (chainProducerState handle) $ \cps ->
123122
cps {chainDB = replaceGenesisDB (chainDB cps) st}
@@ -180,7 +179,7 @@ forkServerThread ::
180179
MockServerConstraint blk =>
181180
IOManager ->
182181
TopLevelConfig blk ->
183-
State blk ValuesMK ->
182+
State blk ->
184183
NetworkMagic ->
185184
FilePath ->
186185
IO (ServerHandle IO blk)
@@ -195,7 +194,7 @@ withServerHandle ::
195194
MockServerConstraint blk =>
196195
IOManager ->
197196
TopLevelConfig blk ->
198-
State blk ValuesMK ->
197+
State blk ->
199198
NetworkMagic ->
200199
FilePath ->
201200
(ServerHandle IO blk -> IO a) ->

‎cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,6 @@ import qualified Data.Map.Strict as Map
2424
import Ouroboros.Consensus.Block (HasHeader, HeaderHash, Point, blockPoint, castPoint)
2525
import Ouroboros.Consensus.Config (TopLevelConfig)
2626
import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol)
27-
import Ouroboros.Consensus.Ledger.Tables (ValuesMK)
2827
import Ouroboros.Network.Block (ChainUpdate (..))
2928

3029
data ChainProducerState block = ChainProducerState
@@ -56,7 +55,7 @@ data FollowerNext
5655

5756
initChainProducerState ::
5857
TopLevelConfig block ->
59-
Chain.State block ValuesMK ->
58+
Chain.State block ->
6059
ChainProducerState block
6160
initChainProducerState config st = ChainProducerState (initChainDB config st) Map.empty 0
6261

‎cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs‎

Lines changed: 22 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,7 @@
1212
{-# OPTIONS_GHC -Wno-orphans #-}
1313

1414
module Cardano.Mock.Forging.Interpreter (
15+
InterpreterState (..),
1516
Interpreter,
1617
initInterpreter,
1718
withInterpreter,
@@ -95,8 +96,8 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus
9596
import Ouroboros.Consensus.HardFork.Combinator.Ledger ()
9697
import qualified Ouroboros.Consensus.HardFork.Combinator.Mempool as Consensus
9798
import Ouroboros.Consensus.HeaderValidation (headerStateChainDep)
98-
import Ouroboros.Consensus.Ledger.Abstract (TickedLedgerState, applyChainTick)
99-
import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), ValuesMK)
99+
import Ouroboros.Consensus.Ledger.Abstract (TickedLedgerState, applyChainTick, projectLedgerTables, stowLedgerTables, withLedgerTables)
100+
import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), EmptyMK, ValuesMK)
100101
import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, headerState, ledgerState)
101102
import Ouroboros.Consensus.Ledger.SupportsMempool (
102103
ApplyTxErr,
@@ -235,12 +236,14 @@ initInterpreter ::
235236
initInterpreter pinfo forging traceForge mFingerprintFile = do
236237
let topLeverCfg = pInfoConfig pinfo
237238
let initSt = pInfoInitLedger pinfo
238-
let ledgerView' = mkForecast topLeverCfg initSt
239+
let st = forgetLedgerTables initSt
240+
let tables = projectLedgerTables initSt
241+
let ledgerView' = mkForecast topLeverCfg st
239242
(mode, fingerprint) <- mkFingerprint mFingerprintFile
240243
stvar <-
241244
newTVarIO $
242245
InterpreterState
243-
{ istChain = initChainDB topLeverCfg initSt
246+
{ istChain = initChainDB topLeverCfg (st, tables)
244247
, istForecast = ledgerView'
245248
, istSlot = SlotNo 0
246249
, -- The first real Byron block (ie block that can contain txs) is number 1.
@@ -323,7 +326,7 @@ forgeNextLeaders interpreter txes possibleLeaders = do
323326
interState <- getCurrentInterpreterState interpreter
324327
(blk, fingerprint) <- tryOrValidateSlot interState possibleLeaders
325328
let !chain' = extendChainDB (istChain interState) blk
326-
let !newSt = currentState chain'
329+
let (newSt, _) = currentState chain'
327330
let newInterState =
328331
InterpreterState
329332
{ istChain = chain'
@@ -363,7 +366,7 @@ forgeNextLeaders interpreter txes possibleLeaders = do
363366
else throwIO $ FailedToValidateSlot currentSlot (lengthSlots <$> istFingerprint interState) (interpFingerFile interpreter)
364367
Just (proof, blockForging) -> do
365368
-- Tick the ledger state for the 'SlotNo' we're producing a block for
366-
let ledgerState' = ledgerState $ currentState (istChain interState)
369+
let ledgerState' = ledgerState $ fst $ currentState (istChain interState)
367370

368371
tickedLedgerSt =
369372
applyChainTick
@@ -424,7 +427,7 @@ tryAllForging interpreter interState currentSlot xs = do
424427
(configConsensus cfg)
425428
ledgerView'
426429
currentSlot
427-
(headerStateChainDep (headerState $ currentState $ istChain interState))
430+
(headerStateChainDep (headerState $ fst $ currentState $ istChain interState))
428431

429432
!shouldForge <-
430433
checkShouldForge
@@ -455,15 +458,15 @@ rollbackInterpreter interpreter pnt = do
455458
!chain' <- case rollbackChainDB (istChain interState) pnt of
456459
Just c -> pure c
457460
Nothing -> throwIO RollbackFailed
458-
let newSt = currentState chain'
461+
let (newSt, _) = currentState chain'
459462
let tip = headTip chain'
460463
let (nextSlot, nextBlock) = case tip of
461464
TipGenesis -> (SlotNo 0, BlockNo 1)
462465
Tip slt _ blkNo -> (slt + 1, blkNo + 1)
463466
let !newInterState =
464467
InterpreterState
465468
{ istChain = chain'
466-
, istForecast = mkForecast cfg newSt
469+
, istForecast = mkForecast cfg $ forgetLedgerTables newSt
467470
, istSlot = nextSlot
468471
, istNextBlockNo = nextBlock
469472
, istFingerprint = istFingerprint interState
@@ -476,8 +479,10 @@ rollbackInterpreter interpreter pnt = do
476479
getCurrentInterpreterState :: Interpreter -> IO InterpreterState
477480
getCurrentInterpreterState = readTVarIO . interpState
478481

479-
getCurrentLedgerState :: Interpreter -> IO (ExtLedgerState CardanoBlock ValuesMK)
480-
getCurrentLedgerState = fmap (currentState . istChain) . getCurrentInterpreterState
482+
getCurrentLedgerState :: Interpreter -> IO (ExtLedgerState CardanoBlock EmptyMK)
483+
getCurrentLedgerState = fmap (stow . currentState . istChain) . getCurrentInterpreterState
484+
where
485+
stow (st, tables) = stowLedgerTables $ st `withLedgerTables` tables
481486

482487
getNextBlockNo :: Interpreter -> IO BlockNo
483488
getNextBlockNo inter =
@@ -500,7 +505,7 @@ getCurrentSlot interp = istSlot <$> readTVarIO (interpState interp)
500505

501506
withBabbageLedgerState ::
502507
Interpreter ->
503-
(LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK -> Either ForgingError a) ->
508+
(LedgerState (ShelleyBlock PraosStandard BabbageEra) EmptyMK -> Either ForgingError a) ->
504509
IO a
505510
withBabbageLedgerState inter mk = do
506511
st <- getCurrentLedgerState inter
@@ -512,7 +517,7 @@ withBabbageLedgerState inter mk = do
512517

513518
withConwayLedgerState ::
514519
Interpreter ->
515-
(LedgerState (ShelleyBlock PraosStandard ConwayEra) ValuesMK -> Either ForgingError a) ->
520+
(LedgerState (ShelleyBlock PraosStandard ConwayEra) EmptyMK -> Either ForgingError a) ->
516521
IO a
517522
withConwayLedgerState inter mk = do
518523
st <- getCurrentLedgerState inter
@@ -524,7 +529,7 @@ withConwayLedgerState inter mk = do
524529

525530
withAlonzoLedgerState ::
526531
Interpreter ->
527-
(LedgerState (ShelleyBlock TPraosStandard AlonzoEra) ValuesMK -> Either ForgingError a) ->
532+
(LedgerState (ShelleyBlock TPraosStandard AlonzoEra) EmptyMK -> Either ForgingError a) ->
528533
IO a
529534
withAlonzoLedgerState inter mk = do
530535
st <- getCurrentLedgerState inter
@@ -536,7 +541,7 @@ withAlonzoLedgerState inter mk = do
536541

537542
withShelleyLedgerState ::
538543
Interpreter ->
539-
(LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK -> Either ForgingError a) ->
544+
(LedgerState (ShelleyBlock TPraosStandard ShelleyEra) EmptyMK -> Either ForgingError a) ->
540545
IO a
541546
withShelleyLedgerState inter mk = do
542547
st <- getCurrentLedgerState inter
@@ -628,12 +633,9 @@ mkValidated txe =
628633

629634
mkForecast ::
630635
TopLevelConfig CardanoBlock ->
631-
ExtLedgerState CardanoBlock ValuesMK ->
636+
ExtLedgerState CardanoBlock mk ->
632637
Forecast (LedgerView (BlockProtocol CardanoBlock))
633-
mkForecast cfg st = ledgerViewForecastAt (configLedger cfg) (ledgerState st')
634-
where
635-
st' :: ExtLedgerState CardanoBlock ValuesMK
636-
st' = st
638+
mkForecast cfg st = ledgerViewForecastAt (configLedger cfg) (ledgerState st)
637639

638640
throwLeftIO :: Exception e => Either e a -> IO a
639641
throwLeftIO = either throwIO pure

‎cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ import Cardano.Prelude
3333
import Data.List.Extra (chunksOf)
3434
import Data.Maybe.Strict (StrictMaybe (..))
3535
import Ouroboros.Consensus.Cardano.Block (LedgerState (..))
36-
import Ouroboros.Consensus.Ledger.Basics (ValuesMK)
36+
import Ouroboros.Consensus.Ledger.Basics (EmptyMK)
3737
import Ouroboros.Consensus.Shelley.Eras (ConwayEra ())
3838
import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock ())
3939
import qualified Prelude
@@ -89,7 +89,7 @@ mkPaymentBlocks utxoIx addresses interpreter =
8989
forgeBlocksChunked ::
9090
Interpreter ->
9191
[a] ->
92-
([a] -> ShelleyLedgerState ConwayEra ValuesMK -> Either ForgingError (Tx ConwayEra)) ->
92+
([a] -> ShelleyLedgerState ConwayEra EmptyMK -> Either ForgingError (Tx ConwayEra)) ->
9393
IO [CardanoBlock]
9494
forgeBlocksChunked interpreter vs f = forM (chunksOf 500 vs) $ \blockCreds -> do
9595
blockTxs <- withConwayLedgerState interpreter $ \state' ->

‎cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -87,6 +87,8 @@ import Ouroboros.Consensus.Block.Forging
8787
import Ouroboros.Consensus.Byron.Ledger.Mempool ()
8888
import Ouroboros.Consensus.Config (TopLevelConfig)
8989
import Ouroboros.Consensus.HardFork.Combinator.Mempool ()
90+
import Ouroboros.Consensus.Ledger.Abstract (projectLedgerTables)
91+
import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables)
9092
import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus
9193
import Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
9294
import Ouroboros.Consensus.Shelley.Ledger.Mempool ()
@@ -596,7 +598,7 @@ withFullConfig' WithConfigArgs {..} cmdLineArgs mSyncNodeConfig configFilePath t
596598
withServerHandle @CardanoBlock
597599
iom
598600
(topLevelConfig cfg)
599-
initSt
601+
(forgetLedgerTables initSt, projectLedgerTables initSt)
600602
(NetworkMagic 42)
601603
(unSocketPath (enpSocketPath $ syncNodeParams cfg))
602604
$ \mockServer ->

0 commit comments

Comments
 (0)