Skip to content

Commit 95bd119

Browse files
jasagredojasagredo
committed
WIP
1 parent 2c33a4b commit 95bd119

File tree

8 files changed

+109
-62
lines changed

8 files changed

+109
-62
lines changed

‎ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs‎

Lines changed: 7 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -865,17 +865,13 @@ reproMempoolForge numBlks env = do
865865
mempool <-
866866
Mempool.openMempoolWithoutSyncThread
867867
Mempool.LedgerInterface
868-
{ Mempool.getCurrentLedgerState = ledgerState <$> LedgerDB.getVolatileTip ledgerDB
869-
, Mempool.getLedgerTablesAtFor = \pt keys -> do
870-
frk <- LedgerDB.getForkerAtTarget ledgerDB registry (SpecificPoint pt)
871-
case frk of
872-
Left _ -> pure Nothing
873-
Right fr -> do
874-
tbs <-
875-
Just . castLedgerTables
876-
<$> LedgerDB.forkerReadTables fr (castLedgerTables keys)
877-
LedgerDB.forkerClose fr
878-
pure tbs
868+
{ Mempool.getCurrentLedgerState = do
869+
st <- LedgerDB.getVolatileTip ledgerDB
870+
pure
871+
( ledgerState st
872+
, fmap (LedgerDB.ledgerStateReadOnlyForker . LedgerDB.readOnlyForker)
873+
<$> LedgerDB.getForkerAtTarget ledgerDB registry (SpecificPoint (castPoint $ getTip st))
874+
)
879875
}
880876
lCfg
881877
-- one mebibyte should generously accomodate two blocks' worth of txs

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -192,7 +192,7 @@ initInternalState capacityOverride lastTicketNo cfg slot st =
192192
-- | Abstract interface needed to run a Mempool.
193193
data LedgerInterface m blk = LedgerInterface
194194
{ getCurrentLedgerState ::
195-
STM m (LedgerState blk EmptyMK, m (Either GetForkerError (ReadOnlyForker' m blk)))
195+
STM m (LedgerState blk EmptyMK, m (Either GetForkerError (ReadOnlyForker m (LedgerState blk) blk)))
196196
-- ^ Get the current tip of the LedgerDB and an action to get a forker there.
197197
}
198198

@@ -207,7 +207,8 @@ chainDBLedgerInterface chainDB registry =
207207
st <- ChainDB.getCurrentLedger chainDB
208208
pure
209209
( ledgerState st
210-
, ChainDB.getReadOnlyForkerAtPoint chainDB registry (SpecificPoint (castPoint $ getTip st))
210+
, fmap (fmap ledgerStateReadOnlyForker) $
211+
ChainDB.getReadOnlyForkerAtPoint chainDB registry (SpecificPoint (castPoint $ getTip st))
211212
)
212213
in LedgerInterface
213214
{ getCurrentLedgerState = getStateAndForker
@@ -222,7 +223,7 @@ chainDBLedgerInterface chainDB registry =
222223
-- different operations.
223224
data MempoolEnv m blk = MempoolEnv
224225
{ mpEnvLedger :: LedgerInterface m blk
225-
, mpEnvForker :: StrictMVar m (ReadOnlyForker' m blk)
226+
, mpEnvForker :: StrictMVar m (ReadOnlyForker m (LedgerState blk) blk)
226227
, mpEnvLedgerCfg :: LedgerConfig blk
227228
, mpEnvStateVar :: StrictTMVar m (InternalState blk)
228229
, mpEnvAddTxsRemoteFifo :: StrictMVar m ()

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs‎

Lines changed: 10 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ import qualified Data.Set as Set
2121
import Ouroboros.Consensus.HeaderValidation
2222
import Ouroboros.Consensus.Ledger.Abstract
2323
import Ouroboros.Consensus.Ledger.SupportsMempool
24+
import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables)
2425
import Ouroboros.Consensus.Mempool.API
2526
import Ouroboros.Consensus.Mempool.Capacity
2627
import Ouroboros.Consensus.Mempool.Impl.Common
@@ -172,7 +173,9 @@ doAddTx mpEnv wti tx =
172173
res <- withTMVarAnd istate additionalCheck $
173174
\is () -> do
174175
frkr <- readMVar forker
175-
tbs <- castLedgerTables <$> roforkerReadTables frkr (castLedgerTables $ getTransactionKeySets tx)
176+
tbs <-
177+
castLedgerTables
178+
<$> roforkerReadTables frkr (castLedgerTables $ getTransactionKeySets tx)
176179
case pureTryAddTx cfg wti tx is tbs of
177180
NotEnoughSpaceLeft -> do
178181
pure (Left (isMempoolSize is), is)
@@ -194,7 +197,11 @@ pureTryAddTx ::
194197
LedgerTables (LedgerState blk) ValuesMK ->
195198
TriedToAddTx blk
196199
pureTryAddTx cfg wti tx is values =
197-
let st = applyMempoolDiffs values (getTransactionKeySets tx) (isLedgerState is)
200+
let st =
201+
applyMempoolDiffs
202+
values
203+
(getTransactionKeySets tx)
204+
(isLedgerState is)
198205
in case runExcept $ txMeasure cfg st tx of
199206
Left err ->
200207
-- The transaction does not have a valid measure (eg its ExUnits is
@@ -325,7 +332,7 @@ implRemoveTxsEvenIfValid mpEnv toRemove =
325332
capacityOverride
326333
cfg
327334
(isSlotNo is)
328-
(isLedgerState is)
335+
(isLedgerState is `withLedgerTables` emptyLedgerTables)
329336
tbs
330337
(isLastTicketNo is)
331338
toKeep

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,8 @@ module Ouroboros.Consensus.Storage.LedgerDB.Forker
2828
, RangeQueryPrevious (..)
2929
, Statistics (..)
3030
, forkerCurrentPoint
31+
, castRangeQueryPrevious
32+
, ledgerStateReadOnlyForker
3133

3234
-- ** Read only
3335
, ReadOnlyForker (..)
@@ -146,6 +148,11 @@ instance
146148

147149
data RangeQueryPrevious l = NoPreviousQuery | PreviousQueryWasFinal | PreviousQueryWasUpTo (TxIn l)
148150

151+
castRangeQueryPrevious :: TxIn l ~ TxIn l' => RangeQueryPrevious l -> RangeQueryPrevious l'
152+
castRangeQueryPrevious NoPreviousQuery = NoPreviousQuery
153+
castRangeQueryPrevious PreviousQueryWasFinal = PreviousQueryWasFinal
154+
castRangeQueryPrevious (PreviousQueryWasUpTo txin) = PreviousQueryWasUpTo txin
155+
149156
data RangeQuery l = RangeQuery
150157
{ rqPrev :: !(RangeQueryPrevious l)
151158
, rqCount :: !Int
@@ -193,6 +200,25 @@ forkerCurrentPoint forker =
193200
. getTip
194201
<$> forkerGetLedgerState forker
195202

203+
ledgerStateReadOnlyForker ::
204+
IOLike m => ReadOnlyForker m (ExtLedgerState blk) blk -> ReadOnlyForker m (LedgerState blk) blk
205+
ledgerStateReadOnlyForker frk =
206+
ReadOnlyForker
207+
{ roforkerClose = roforkerClose
208+
, roforkerReadTables = fmap castLedgerTables . roforkerReadTables . castLedgerTables
209+
, roforkerRangeReadTables = fmap castLedgerTables . roforkerRangeReadTables . castRangeQueryPrevious
210+
, roforkerGetLedgerState = ledgerState <$> roforkerGetLedgerState
211+
, roforkerReadStatistics = roforkerReadStatistics
212+
}
213+
where
214+
ReadOnlyForker
215+
{ roforkerClose
216+
, roforkerReadTables
217+
, roforkerRangeReadTables
218+
, roforkerGetLedgerState
219+
, roforkerReadStatistics
220+
} = frk
221+
196222
{-------------------------------------------------------------------------------
197223
Read-only forkers
198224
-------------------------------------------------------------------------------}

‎ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs‎

Lines changed: 19 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -22,19 +22,18 @@ import Control.Concurrent.Class.MonadSTM.Strict
2222
, atomically
2323
, newTVarIO
2424
, readTVar
25-
, readTVarIO
2625
, writeTVar
2726
)
2827
import Control.DeepSeq (NFData (rnf))
2928
import Control.Tracer (Tracer)
3029
import qualified Data.List.NonEmpty as NE
31-
import Ouroboros.Consensus.Block (castPoint)
3230
import Ouroboros.Consensus.HeaderValidation as Header
3331
import Ouroboros.Consensus.Ledger.Basics
3432
import qualified Ouroboros.Consensus.Ledger.Basics as Ledger
3533
import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Ledger
3634
import Ouroboros.Consensus.Ledger.Tables.Utils
37-
( forgetLedgerTables
35+
( emptyLedgerTables
36+
, forgetLedgerTables
3837
, restrictValues'
3938
)
4039
import Ouroboros.Consensus.Mempool (Mempool)
@@ -43,6 +42,7 @@ import Ouroboros.Consensus.Mempool.API
4342
( AddTxOnBehalfOf
4443
, MempoolAddTxResult
4544
)
45+
import Ouroboros.Consensus.Storage.LedgerDB.Forker
4646

4747
data MockedMempool m blk = MockedMempool
4848
{ getLedgerInterface :: !(Mempool.LedgerInterface m blk)
@@ -62,7 +62,7 @@ instance NFData (MockedMempool m blk) where
6262
rnf MockedMempool{} = ()
6363

6464
data InitialMempoolAndModelParams blk = MempoolAndModelParams
65-
{ immpInitialState :: !(Ledger.LedgerState blk ValuesMK)
65+
{ immpInitialState :: !(LedgerState blk ValuesMK)
6666
-- ^ Initial ledger state for the mocked Ledger DB interface.
6767
, immpLedgerConfig :: !(Ledger.LedgerConfig blk)
6868
-- ^ Ledger configuration, which is needed to open the mempool.
@@ -81,12 +81,21 @@ openMockedMempool capacityOverride tracer initialParams = do
8181
currentLedgerStateTVar <- newTVarIO (immpInitialState initialParams)
8282
let ledgerItf =
8383
Mempool.LedgerInterface
84-
{ Mempool.getCurrentLedgerState = forgetLedgerTables <$> readTVar currentLedgerStateTVar
85-
, Mempool.getLedgerTablesAtFor = \pt keys -> do
86-
st <- readTVarIO currentLedgerStateTVar
87-
if castPoint (getTip st) == pt
88-
then pure $ Just $ restrictValues' st keys
89-
else pure Nothing
84+
{ Mempool.getCurrentLedgerState = do
85+
st <- readTVar currentLedgerStateTVar
86+
pure
87+
( forgetLedgerTables st
88+
, pure $
89+
Right $
90+
ReadOnlyForker
91+
{ roforkerClose = pure ()
92+
, roforkerGetLedgerState = pure (forgetLedgerTables st)
93+
, roforkerReadTables = \keys ->
94+
pure $ projectLedgerTables st `restrictValues'` keys
95+
, roforkerReadStatistics = pure Nothing
96+
, roforkerRangeReadTables = \_ -> pure emptyLedgerTables
97+
}
98+
)
9099
}
91100
mempool <-
92101
Mempool.openMempoolWithoutSyncThread

‎ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs‎

Lines changed: 16 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -47,13 +47,13 @@ import Data.Maybe (mapMaybe)
4747
import Data.Semigroup (stimes)
4848
import qualified Data.Set as Set
4949
import Data.Word
50-
import Ouroboros.Consensus.Block
5150
import Ouroboros.Consensus.Ledger.Abstract
5251
import Ouroboros.Consensus.Ledger.SupportsMempool
5352
import Ouroboros.Consensus.Ledger.Tables.Utils
5453
import Ouroboros.Consensus.Mempool
5554
import Ouroboros.Consensus.Mempool.TxSeq as TxSeq
5655
import Ouroboros.Consensus.Mock.Ledger hiding (TxId)
56+
import Ouroboros.Consensus.Storage.LedgerDB.Forker
5757
import Ouroboros.Consensus.Util (repeatedly, repeatedlyM)
5858
import Ouroboros.Consensus.Util.Condense (condense)
5959
import Ouroboros.Consensus.Util.IOLike
@@ -703,12 +703,21 @@ withTestMempool setup@TestSetup{..} prop =
703703
varCurrentLedgerState <- uncheckedNewTVarM testLedgerState
704704
let ledgerInterface =
705705
LedgerInterface
706-
{ getCurrentLedgerState = forgetLedgerTables <$> readTVar varCurrentLedgerState
707-
, getLedgerTablesAtFor = \pt keys -> do
708-
st <- atomically $ readTVar varCurrentLedgerState
709-
if castPoint (getTip st) == pt
710-
then pure $ Just $ restrictValues' st keys
711-
else pure Nothing
706+
{ getCurrentLedgerState = do
707+
st <- readTVar varCurrentLedgerState
708+
pure
709+
( forgetLedgerTables st
710+
, pure $
711+
Right $
712+
ReadOnlyForker
713+
{ roforkerClose = pure ()
714+
, roforkerReadTables =
715+
pure . (projectLedgerTables st `restrictValues'`)
716+
, roforkerRangeReadTables = const $ pure emptyLedgerTables
717+
, roforkerGetLedgerState = pure $ forgetLedgerTables st
718+
, roforkerReadStatistics = pure Nothing
719+
}
720+
)
712721
}
713722

714723
-- Set up the Tracer

‎ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs‎

Lines changed: 12 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Ouroboros.Consensus.Ledger.Tables.Utils
3232
import Ouroboros.Consensus.Mempool (Mempool)
3333
import qualified Ouroboros.Consensus.Mempool as Mempool
3434
import qualified Ouroboros.Consensus.Mempool.Capacity as Mempool
35+
import Ouroboros.Consensus.Storage.LedgerDB.Forker
3536
import Ouroboros.Consensus.Util.IOLike (STM, atomically, retry)
3637
import System.Random (randomIO)
3738
import Test.Consensus.Mempool.Fairness.TestBlock
@@ -97,10 +98,17 @@ testTxSizeFairness TestParams{mempoolMaxCapacity, smallTxSize, largeTxSize, nrOf
9798
Mempool.LedgerInterface
9899
{ Mempool.getCurrentLedgerState =
99100
pure $
100-
testInitLedgerWithState NoPayLoadDependentState
101-
, Mempool.getLedgerTablesAtFor = \_ _ ->
102-
pure $
103-
Just emptyLedgerTables
101+
( testInitLedgerWithState NoPayLoadDependentState
102+
, pure $
103+
Right $
104+
ReadOnlyForker
105+
{ roforkerClose = pure ()
106+
, roforkerReadTables = const $ pure emptyLedgerTables
107+
, roforkerRangeReadTables = const $ pure emptyLedgerTables
108+
, roforkerGetLedgerState = pure $ testInitLedgerWithState NoPayLoadDependentState
109+
, roforkerReadStatistics = pure Nothing
110+
}
111+
)
104112
}
105113

106114
eraParams =

‎ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs‎

Lines changed: 15 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -58,6 +58,7 @@ import Ouroboros.Consensus.Mock.Ledger.Block
5858
import Ouroboros.Consensus.Mock.Ledger.State
5959
import Ouroboros.Consensus.Mock.Ledger.UTxO (Expiry, Tx, TxIn, TxOut)
6060
import qualified Ouroboros.Consensus.Mock.Ledger.UTxO as Mock
61+
import Ouroboros.Consensus.Storage.LedgerDB.Forker
6162
import Ouroboros.Consensus.Util
6263
import Ouroboros.Consensus.Util.Condense (condense)
6364
import Ouroboros.Consensus.Util.IOLike hiding (bracket)
@@ -555,33 +556,23 @@ newLedgerInterface initialLedger = do
555556
t <- newTVarIO $ MockedLedgerDB initialLedger Set.empty Set.empty
556557
pure
557558
( LedgerInterface
558-
{ getCurrentLedgerState = forgetLedgerTables . ldbTip <$> readTVar t
559-
, getLedgerTablesAtFor = \pt keys -> do
560-
MockedLedgerDB ti oldReachableTips _ <- atomically $ readTVar t
561-
if pt == castPoint (getTip ti) -- if asking for tables at the tip of the
562-
-- ledger db
563-
then
564-
let tbs = ltliftA2 f keys $ projectLedgerTables ti
565-
in pure $ Just tbs
566-
else case Foldable.find ((castPoint pt ==) . getTip) oldReachableTips of
567-
Nothing -> pure Nothing
568-
Just mtip ->
569-
if pt == castPoint (getTip mtip)
570-
-- if asking for tables at some still reachable state
571-
then
572-
let tbs = ltliftA2 f keys $ projectLedgerTables mtip
573-
in pure $ Just tbs
574-
else
575-
-- if asking for tables at other point or at the mempool tip but
576-
-- it is not reachable
577-
pure Nothing
559+
{ getCurrentLedgerState = do
560+
st <- ldbTip <$> readTVar t
561+
pure
562+
( forgetLedgerTables st
563+
, pure $
564+
Right $
565+
ReadOnlyForker
566+
{ roforkerClose = pure ()
567+
, roforkerReadStatistics = pure Nothing
568+
, roforkerReadTables = pure . (projectLedgerTables st `restrictValues'`)
569+
, roforkerRangeReadTables = const $ pure emptyLedgerTables
570+
, roforkerGetLedgerState = pure $ forgetLedgerTables st
571+
}
572+
)
578573
}
579574
, t
580575
)
581-
where
582-
f :: Ord k => KeysMK k v -> ValuesMK k v -> ValuesMK k v
583-
f (KeysMK s) (ValuesMK v) =
584-
ValuesMK (Map.restrictKeys v s)
585576

586577
-- | Make a SUT
587578
mkSUT ::

0 commit comments

Comments
 (0)