diff --git a/cabal.project b/cabal.project index e2c18aa305..2162410163 100644 --- a/cabal.project +++ b/cabal.project @@ -16,7 +16,7 @@ index-state: -- Bump this if you need newer packages from Hackage , hackage.haskell.org 2025-07-22T09:13:54Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2025-08-06T10:58:15Z + , cardano-haskell-packages 2025-08-21T09:41:03Z packages: ouroboros-consensus diff --git a/flake.lock b/flake.lock index 282b5306b4..70f4df31ec 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1754478832, - "narHash": "sha256-iJ0g2vuGh2f9Y9USYdaZnhBK3zz4zAE0IKh3Li2HQSM=", + "lastModified": 1755770112, + "narHash": "sha256-BE9+swBBPBi9iRQNqsUNUjS02nyRF+OwfCkhIjted6I=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "71cbaa8ebe4514ea5292f48018b54a083768bea8", + "rev": "7af503772adf627cd23be5431440a0ffae74de52", "type": "github" }, "original": { @@ -237,11 +237,11 @@ "hackage-for-stackage": { "flake": false, "locked": { - "lastModified": 1751502422, - "narHash": "sha256-Wu5kEMaddVijZP77iEwX4kIiIB6ykjVIczmS9gSYV+g=", + "lastModified": 1755044837, + "narHash": "sha256-vAi3NGzKR03vKWFHfJdxdeMmxWlesyeYMTD1gjD/j40=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "dc64a68eaaab22702acbe5b657900f5b091c08f1", + "rev": "1784199a4f48db7b8d6290a6e2cab89e7081dbf7", "type": "github" }, "original": { @@ -254,11 +254,11 @@ "hackage-internal": { "flake": false, "locked": { - "lastModified": 1751964054, - "narHash": "sha256-eDtXxc0y9W7z3F7bbn4dJ882vf4g0Qaydj0hRXO6zLo=", + "lastModified": 1750307553, + "narHash": "sha256-iiafNoeLHwlSLQTyvy8nPe2t6g5AV4PPcpMeH/2/DLs=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "14b34911fda0a6812d077ad283d3003ac77df95b", + "rev": "f7867baa8817fab296528f4a4ec39d1c7c4da4f3", "type": "github" }, "original": { @@ -270,11 +270,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1753683895, - "narHash": "sha256-LRF4FwscoEoxmE4LxWme0+Usu6u4nuGUQXuPKIEuitU=", + "lastModified": 1755004253, + "narHash": "sha256-LPPqtFJEbeJHwnnTR0ir0XNw/4YPHBkJsZTAlFH6pfI=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "f904455fa549b0d994140d4977d4e87c1668f2f1", + "rev": "2cb556e80a10e46cd47651d3601a889416af0eb3", "type": "github" }, "original": { @@ -326,11 +326,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1751506224, - "narHash": "sha256-QPevuZ+ylPwEstNeGMiuIJOo0Iclbi2UkeIm6ziIeZc=", + "lastModified": 1755056648, + "narHash": "sha256-IPj8nXV4qSlW0F1Mda3+QmV6bwDtwgT1PqhNm9EBKhw=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "71a34a6ac49f112807cdb3656ec3b2222775d23e", + "rev": "a8741b115ccc957d97ec4c48269fbeed028bf854", "type": "github" }, "original": { @@ -618,11 +618,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1750543273, - "narHash": "sha256-WaswH0Y+Fmupvv8AkIlQBlUy/IdD3Inx9PDuE+5iRYY=", + "lastModified": 1755040634, + "narHash": "sha256-8W7uHpAIG8HhO3ig5OGHqvwduoye6q6dlrea1IrP2eI=", "owner": "stable-haskell", "repo": "iserv-proxy", - "rev": "a53c57c9a8d22a66a2f0c4c969e806da03f08c28", + "rev": "1383d199a2c64f522979005d112b4fbdee38dd92", "type": "github" }, "original": { @@ -800,11 +800,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1751501628, - "narHash": "sha256-PnDFY/V8njVjWN8Aj3AVBh0o0D9K8yyKmU+YRncEvrI=", + "lastModified": 1755044020, + "narHash": "sha256-NTctHZ+IM/rnwltZOTMz8BV1kubk5Fc57Eilih/ICZo=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "8a84369d967800bbe51847005dcd44aed4562b19", + "rev": "be18f53fdcd5834e81c4c16d8ac39663544b2c90", "type": "github" }, "original": { diff --git a/ouroboros-consensus-cardano/changelog.d/20250902_113907_javier.sagredo_lmdb.md b/ouroboros-consensus-cardano/changelog.d/20250902_113907_javier.sagredo_lmdb.md new file mode 100644 index 0000000000..41b1fa620d --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20250902_113907_javier.sagredo_lmdb.md @@ -0,0 +1,25 @@ + + + + + diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index 22068447d9..a71fc8ec8c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -1331,17 +1331,12 @@ answerShelleyTraversingQueries ejTxOut ejTxIn filt cfg q forker = case q of ) vs - vnull :: ValuesMK k v -> Bool - vnull (ValuesMK vs) = Map.null vs - - toMaxKey (LedgerTables (ValuesMK vs)) = fst $ Map.findMax vs - loop queryPredicate !prev !acc = do - extValues <- LedgerDB.roforkerRangeReadTables forker prev - if ltcollapse $ ltmap (K2 . vnull) extValues - then pure acc - else + (extValues, k) <- LedgerDB.roforkerRangeReadTables forker prev + case k of + Nothing -> pure acc + Just k' -> loop queryPredicate - (PreviousQueryWasUpTo $ toMaxKey extValues) + (PreviousQueryWasUpTo k') (combUtxo acc $ partial queryPredicate extValues) diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 3b3d472a38..d34e717e76 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -704,7 +704,7 @@ runThreadNetwork let emptySt = emptySt' doRangeQuery = roforkerRangeReadTables forker fullLedgerSt <- fmap ledgerState $ do - fullUTxO <- doRangeQuery NoPreviousQuery + (fullUTxO, _) <- doRangeQuery NoPreviousQuery pure $! withLedgerTables emptySt fullUTxO roforkerClose forker -- Combine the node's seed with the current slot number, to make sure diff --git a/ouroboros-consensus/changelog.d/20250822_163712_jasataco_lmdb.md b/ouroboros-consensus/changelog.d/20250822_163712_jasataco_lmdb.md new file mode 100644 index 0000000000..ee880667ca --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250822_163712_jasataco_lmdb.md @@ -0,0 +1,23 @@ + + + + + +### Breaking + +- `forkerRangeRead` now returns also the maximal key found in the backend. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs index cea2fc630d..da373f93b9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs @@ -66,6 +66,7 @@ import Control.Monad.Except import Control.Monad.Reader (ReaderT (..)) import Control.Monad.Trans (MonadTrans (..)) import Control.ResourceRegistry +import Data.Bifunctor (first) import Data.Kind import Data.Set (Set) import qualified Data.Set as Set @@ -105,11 +106,20 @@ data Forker m l blk = Forker forkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)) -- ^ Read ledger tables from disk. - , forkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK)) + , forkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l))) -- ^ Range-read ledger tables from disk. -- - -- This range read will return as many values as the 'QueryBatchSize' that - -- was passed when opening the LedgerDB. + -- This range read will return as many values as the 'QueryBatchSize' that was + -- passed when opening the LedgerDB. + -- + -- The second component of the returned tuple is the maximal key found by the + -- forker. This is only necessary because some backends have a different + -- sorting for the keys than the order defined in Haskell. + -- + -- The last key retrieved is part of the map too. It is intended to be fed + -- back into the next iteration of the range read. If the function returns + -- Nothing, it means the read returned no results, or in other words, we + -- reached the end of the ledger tables. , forkerGetLedgerState :: !(STM m (l EmptyMK)) -- ^ Get the full ledger state without tables. -- @@ -206,7 +216,8 @@ ledgerStateReadOnlyForker frk = ReadOnlyForker { roforkerClose = roforkerClose , roforkerReadTables = fmap castLedgerTables . roforkerReadTables . castLedgerTables - , roforkerRangeReadTables = fmap castLedgerTables . roforkerRangeReadTables . castRangeQueryPrevious + , roforkerRangeReadTables = + fmap (first castLedgerTables) . roforkerRangeReadTables . castRangeQueryPrevious , roforkerGetLedgerState = ledgerState <$> roforkerGetLedgerState , roforkerReadStatistics = roforkerReadStatistics } @@ -239,7 +250,7 @@ data ReadOnlyForker m l blk = ReadOnlyForker -- ^ See 'forkerClose' , roforkerReadTables :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)) -- ^ See 'forkerReadTables' - , roforkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK)) + , roforkerRangeReadTables :: !(RangeQueryPrevious l -> m (LedgerTables l ValuesMK, Maybe (TxIn l))) -- ^ See 'forkerRangeReadTables'. , roforkerGetLedgerState :: !(STM m (l EmptyMK)) -- ^ See 'forkerGetLedgerState' diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs index f992d7c8a3..1109be6a3c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/API.hs @@ -58,6 +58,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API ) where import Cardano.Slotting.Slot (SlotNo, WithOrigin (..)) +import Data.Bifunctor import Data.Kind import GHC.Generics import NoThunks.Class (OnlyCheckWhnfNamed (..)) @@ -93,7 +94,7 @@ data DiffsToFlush l = DiffsToFlush -- considered as "last flushed" in the kept 'DbChangelog' } -data BackingStore m keys values diff = BackingStore +data BackingStore m keys key values diff = BackingStore { bsClose :: !(m ()) -- ^ Close the backing store -- @@ -107,7 +108,7 @@ data BackingStore m keys values diff = BackingStore -- -- The destination path must not already exist. After this operation, it -- will be a directory. - , bsValueHandle :: !(m (BackingStoreValueHandle m keys values)) + , bsValueHandle :: !(m (BackingStoreValueHandle m keys key values)) -- ^ Open a 'BackingStoreValueHandle' capturing the current value of the -- entire database , bsWrite :: !(SlotNo -> WriteHint diff -> diff -> m ()) @@ -118,14 +119,15 @@ data BackingStore m keys values diff = BackingStore } deriving via - OnlyCheckWhnfNamed "BackingStore" (BackingStore m keys values diff) + OnlyCheckWhnfNamed "BackingStore" (BackingStore m keys key values diff) instance - NoThunks (BackingStore m keys values diff) + NoThunks (BackingStore m keys key values diff) type LedgerBackingStore m l = BackingStore m (LedgerTables l KeysMK) + (TxIn l) (LedgerTables l ValuesMK) (LedgerTables l DiffMK) @@ -157,7 +159,7 @@ data InitFrom values -- The performance cost is usually minimal unless this handle is held open too -- long. We expect clients of the 'BackingStore' to not retain handles for a -- long time. -data BackingStoreValueHandle m keys values = BackingStoreValueHandle +data BackingStoreValueHandle m keys key values = BackingStoreValueHandle { bsvhAtSlot :: !(WithOrigin SlotNo) -- ^ At which slot this handle was created , bsvhClose :: !(m ()) @@ -165,7 +167,7 @@ data BackingStoreValueHandle m keys values = BackingStoreValueHandle -- -- Other methods throw exceptions if called on a closed handle. 'bsvhClose' -- itself is idempotent. - , bsvhRangeRead :: !(ReadHint values -> RangeQuery keys -> m values) + , bsvhRangeRead :: !(ReadHint values -> RangeQuery keys -> m (values, Maybe key)) -- ^ See 'RangeQuery' , bsvhReadAll :: !(ReadHint values -> m values) -- ^ Costly read all operation, not to be used in Consensus but only in @@ -180,14 +182,15 @@ data BackingStoreValueHandle m keys values = BackingStoreValueHandle } deriving via - OnlyCheckWhnfNamed "BackingStoreValueHandle" (BackingStoreValueHandle m keys values) + OnlyCheckWhnfNamed "BackingStoreValueHandle" (BackingStoreValueHandle m keys key values) instance - NoThunks (BackingStoreValueHandle m keys values) + NoThunks (BackingStoreValueHandle m keys key values) type LedgerBackingStoreValueHandle m l = BackingStoreValueHandle m (LedgerTables l KeysMK) + (TxIn l) (LedgerTables l ValuesMK) type BackingStoreValueHandle' m blk = LedgerBackingStoreValueHandle m (ExtLedgerState blk) @@ -196,15 +199,16 @@ castBackingStoreValueHandle :: (Functor m, ReadHint values ~ ReadHint values') => (values -> values') -> (keys' -> keys) -> - BackingStoreValueHandle m keys values -> - BackingStoreValueHandle m keys' values' -castBackingStoreValueHandle f g bsvh = + (key -> key') -> + BackingStoreValueHandle m keys key values -> + BackingStoreValueHandle m keys' key' values' +castBackingStoreValueHandle f g h bsvh = BackingStoreValueHandle { bsvhAtSlot , bsvhClose , bsvhReadAll = \rhint -> f <$> bsvhReadAll rhint , bsvhRangeRead = \rhint (RangeQuery prev count) -> - fmap f . bsvhRangeRead rhint $ RangeQuery (fmap g prev) count + fmap (second (fmap h) . first f) . bsvhRangeRead rhint $ RangeQuery (fmap g prev) count , bsvhRead = \rhint -> fmap f . bsvhRead rhint . g , bsvhStat } @@ -221,7 +225,7 @@ castBackingStoreValueHandle f g bsvh = -- | A combination of 'bsValueHandle' and 'bsvhRead' bsRead :: MonadThrow m => - BackingStore m keys values diff -> + BackingStore m keys key values diff -> ReadHint values -> keys -> m (WithOrigin SlotNo, values) @@ -231,7 +235,7 @@ bsRead store rhint keys = withBsValueHandle store $ \vh -> do bsReadAll :: MonadThrow m => - BackingStore m keys values diff -> + BackingStore m keys key values diff -> ReadHint values -> m values bsReadAll store rhint = withBsValueHandle store $ \vh -> bsvhReadAll vh rhint @@ -239,8 +243,8 @@ bsReadAll store rhint = withBsValueHandle store $ \vh -> bsvhReadAll vh rhint -- | A 'IOLike.bracket'ed 'bsValueHandle' withBsValueHandle :: MonadThrow m => - BackingStore m keys values diff -> - (BackingStoreValueHandle m keys values -> m a) -> + BackingStore m keys key values diff -> + (BackingStoreValueHandle m keys key values -> m a) -> m a withBsValueHandle store = bracket diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs index a7104b1ec9..81231c0243 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/InMemory.hs @@ -247,12 +247,14 @@ newInMemoryBackingStore tracer (SnapshotsFS (SomeHasFS fs)) initialization = do rangeRead :: RangeQuery (LedgerTables l KeysMK) -> LedgerTables l ValuesMK -> - LedgerTables l ValuesMK - rangeRead rq values = case rqPrev rq of - Nothing -> - ltmap (rangeRead0' (rqCount rq)) values - Just keys -> - ltliftA2 (rangeRead' (rqCount rq)) keys values + (LedgerTables l ValuesMK, Maybe (TxIn l)) + rangeRead rq values = + let vs@(LedgerTables (ValuesMK m)) = case rqPrev rq of + Nothing -> + ltmap (rangeRead0' (rqCount rq)) values + Just keys -> + ltliftA2 (rangeRead' (rqCount rq)) keys values + in (vs, fst <$> Map.lookupMax m) rangeRead0' :: Int -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs index ef2b1aa33e..919db97859 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/BackingStore/Impl/LMDB.hs @@ -36,6 +36,7 @@ import Control.Monad (forM_, unless, void, when) import qualified Control.Monad.Class.MonadSTM as IOLike import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Control.Tracer as Trace +import Data.Bifunctor (first) import Data.Functor (($>), (<&>)) import Data.Functor.Contravariant ((>$<)) import Data.Map (Map) @@ -189,12 +190,12 @@ rangeRead :: API.RangeQuery (LedgerTables l KeysMK) -> idx -> LMDBMK (TxIn l) (TxOut l) -> - LMDB.Transaction mode (ValuesMK (TxIn l) (TxOut l)) + LMDB.Transaction mode (ValuesMK (TxIn l) (TxOut l), Maybe (TxIn l)) rangeRead rq st dbMK = - ValuesMK <$> case ksMK of + first ValuesMK <$> case ksMK of Nothing -> runCursorHelper Nothing Just (LedgerTables (KeysMK ks)) -> case Set.lookupMax ks of - Nothing -> pure mempty + Nothing -> pure (mempty, Nothing) Just lastExcludedKey -> runCursorHelper $ Just (lastExcludedKey, LMDB.Cursor.Exclusive) where @@ -205,11 +206,11 @@ rangeRead rq st dbMK = runCursorHelper :: Maybe (TxIn l, LMDB.Cursor.Bound) -> -- \^ Lower bound on read range - LMDB.Transaction mode (Map (TxIn l) (TxOut l)) + LMDB.Transaction mode (Map (TxIn l) (TxOut l), Maybe (TxIn l)) runCursorHelper lb = Bridge.runCursorAsTransaction' st - (LMDB.Cursor.cgetMany lb count) + (LMDB.Cursor.cgetManyAndLast lb count) db initLMDBTable :: @@ -631,7 +632,7 @@ mkLMDBBackingStoreValueHandle db = do bsvhRangeRead :: l EmptyMK -> API.RangeQuery (LedgerTables l KeysMK) -> - m (LedgerTables l ValuesMK) + m (LedgerTables l ValuesMK, Maybe (TxIn l)) bsvhRangeRead st rq = Status.withReadAccess dbStatusLock (throwIO LMDBErrClosed) $ do Status.withReadAccess vhStatusLock (throwIO (LMDBErrNoValueHandle vhId)) $ do @@ -640,7 +641,7 @@ mkLMDBBackingStoreValueHandle db = do liftIO $ TrH.submitReadOnly trh $ let dbMK = getLedgerTables dbBackingTables - in LedgerTables <$> rangeRead rq st dbMK + in first LedgerTables <$> rangeRead rq st dbMK Trace.traceWith tracer API.BSVHRangeRead pure res diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs index a018764611..f47ab0e4f6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs @@ -143,7 +143,7 @@ implForkerRangeReadTables :: QueryBatchSize -> ForkerEnv m l blk -> RangeQueryPrevious l -> - m (LedgerTables l ValuesMK) + m (LedgerTables l ValuesMK, Maybe (TxIn l)) implForkerRangeReadTables qbs env rq0 = do traceWith (foeTracer env) ForkerRangeReadTablesStart ldb <- readTVarIO $ foeChangelog env @@ -170,9 +170,10 @@ implForkerRangeReadTables qbs env rq0 = do let st = changelogLastFlushedState ldb bsvh <- getValueHandle env - values <- BackingStore.bsvhRangeRead bsvh st (rq{BackingStore.rqCount = nrequested}) + (values, mx) <- BackingStore.bsvhRangeRead bsvh st (rq{BackingStore.rqCount = nrequested}) traceWith (foeTracer env) ForkerRangeReadTablesEnd - pure $ ltliftA2 (doFixupReadResult nrequested) diffs values + let res = ltliftA2 (doFixupReadResult nrequested) diffs values + pure (res, mx) where rq = BackingStore.RangeQuery rq1 (fromIntegral $ defaultQueryBatchSize qbs) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs index 1de77005f2..53a7fb8142 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs @@ -72,7 +72,8 @@ implForkerReadTables :: implForkerReadTables env ks = do traceWith (foeTracer env) ForkerReadTablesStart lseq <- readTVarIO (foeLedgerSeq env) - tbs <- read (tables $ currentHandle lseq) ks + let stateRef = currentHandle lseq + tbs <- read (tables stateRef) ks traceWith (foeTracer env) ForkerReadTablesEnd pure tbs @@ -81,16 +82,17 @@ implForkerRangeReadTables :: QueryBatchSize -> ForkerEnv m l blk -> RangeQueryPrevious l -> - m (LedgerTables l ValuesMK) + m (LedgerTables l ValuesMK, Maybe (TxIn l)) implForkerRangeReadTables qbs env rq0 = do traceWith (foeTracer env) ForkerRangeReadTablesStart ldb <- readTVarIO $ foeLedgerSeq env let n = fromIntegral $ defaultQueryBatchSize qbs + stateRef = currentHandle ldb case rq0 of NoPreviousQuery -> readRange (tables $ currentHandle ldb) (Nothing, n) - PreviousQueryWasFinal -> pure $ LedgerTables emptyMK + PreviousQueryWasFinal -> pure (LedgerTables emptyMK, Nothing) PreviousQueryWasUpTo k -> do - tbs <- readRange (tables $ currentHandle ldb) (Just k, n) + tbs <- readRange (tables stateRef) (Just k, n) traceWith (foeTracer env) ForkerRangeReadTablesEnd pure tbs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs index b065142210..0715d41e26 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs @@ -120,7 +120,8 @@ newInMemoryLedgerTablesHandle tracer someFS@(SomeHasFS hasFS) l = do guardClosed hs ( \(LedgerTables (ValuesMK m)) -> - pure . LedgerTables . ValuesMK . Map.take t . (maybe id (\g -> snd . Map.split g) f) $ m + let m' = Map.take t . (maybe id (\g -> snd . Map.split g) f) $ m + in pure (LedgerTables (ValuesMK m'), fst <$> Map.lookupMax m') ) , readAll = do hs <- readTVarIO tv diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs index 6768a6d44b..a92244b64e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LedgerSeq.hs @@ -85,7 +85,7 @@ data LedgerTablesHandle m l = LedgerTablesHandle , duplicate :: !(m (LedgerTablesHandle m l)) -- ^ It is expected that this operation takes constant time. , read :: !(LedgerTables l KeysMK -> m (LedgerTables l ValuesMK)) - , readRange :: !((Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK)) + , readRange :: !((Maybe (TxIn l), Int) -> m (LedgerTables l ValuesMK, Maybe (TxIn l))) , readAll :: !(m (LedgerTables l ValuesMK)) -- ^ Costly read all operation, not to be used in Consensus but only in -- snapshot-converter executable. diff --git a/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs b/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs index f0e09f43a9..5481c5f261 100644 --- a/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs +++ b/ouroboros-consensus/src/unstable-mempool-test-utils/Test/Consensus/Mempool/Mocked.hs @@ -97,7 +97,7 @@ openMockedMempool capacityOverride tracer initialParams = do , roforkerReadTables = \keys -> pure $ projectLedgerTables st `restrictValues'` keys , roforkerReadStatistics = pure Nothing - , roforkerRangeReadTables = \_ -> pure emptyLedgerTables + , roforkerRangeReadTables = \_ -> pure (emptyLedgerTables, Nothing) } ) } diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs index 434bcfa9c6..7d46b78cf2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs @@ -716,7 +716,7 @@ withTestMempool setup@TestSetup{..} prop = { roforkerClose = pure () , roforkerReadTables = pure . (projectLedgerTables st `restrictValues'`) - , roforkerRangeReadTables = const $ pure emptyLedgerTables + , roforkerRangeReadTables = const $ pure (emptyLedgerTables, Nothing) , roforkerGetLedgerState = pure $ forgetLedgerTables st , roforkerReadStatistics = pure Nothing } diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs index 8ddb62e312..4a240e0911 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness.hs @@ -107,7 +107,7 @@ testTxSizeFairness TestParams{mempoolMaxCapacity, smallTxSize, largeTxSize, nrOf ReadOnlyForker { roforkerClose = pure () , roforkerReadTables = const $ pure emptyLedgerTables - , roforkerRangeReadTables = const $ pure emptyLedgerTables + , roforkerRangeReadTables = const $ pure (emptyLedgerTables, Nothing) , roforkerGetLedgerState = pure $ testInitLedgerWithState NoPayLoadDependentState , roforkerReadStatistics = pure Nothing } diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs index 6b0a95c317..7a12b44eee 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs @@ -543,7 +543,7 @@ newLedgerInterface initialLedger = do { roforkerClose = pure () , roforkerReadStatistics = pure Nothing , roforkerReadTables = pure . (projectLedgerTables st `restrictValues'`) - , roforkerRangeReadTables = const $ pure emptyLedgerTables + , roforkerRangeReadTables = const $ pure (emptyLedgerTables, Nothing) , roforkerGetLedgerState = pure $ forgetLedgerTables st } ) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore.hs index 61ba36f83b..5d83cd9243 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore.hs @@ -101,14 +101,14 @@ scaleQuickCheckTests :: Int -> QuickCheckTests -> QuickCheckTests scaleQuickCheckTests c (QuickCheckTests n) = QuickCheckTests $ c * n testWithIO :: - IO (BSEnv IO K V D) -> + IO (BSEnv IO K K' V D) -> Actions (Lockstep T) -> Property testWithIO mkBSEnv = runActionsBracket pT mkBSEnv bsCleanup runner runner :: - RealMonad m ks vs d a -> - BSEnv m ks vs d -> + RealMonad m ks k vs d a -> + BSEnv m ks k vs d -> m a runner c r = runReaderT c $ bsRealEnv r @@ -120,8 +120,8 @@ labelledExamples = QC.labelledExamples $ tagActions pT Resources -------------------------------------------------------------------------------} -data BSEnv m ks vs d = BSEnv - { bsRealEnv :: RealEnv m ks vs d +data BSEnv m ks k vs d = BSEnv + { bsRealEnv :: RealEnv m ks k vs d , bsCleanup :: m () } @@ -146,7 +146,7 @@ setupBSEnv :: Complete BS.BackingStoreArgs m -> m (SomeHasFS m) -> m () -> - m (BSEnv m K V D) + m (BSEnv m K K' V D) setupBSEnv mkBsArgs mkShfs cleanup = do shfs@(SomeHasFS hfs) <- mkShfs @@ -188,12 +188,13 @@ closeHandlers = Types under test -------------------------------------------------------------------------------} -type T = BackingStoreState K V D +type T = BackingStoreState K K' V D pT :: Proxy T pT = Proxy type K = LedgerTables (OTLedgerState (QC.Fixed Word) (QC.Fixed Word)) KeysMK +type K' = QC.Fixed Word type V = LedgerTables (OTLedgerState (QC.Fixed Word) (QC.Fixed Word)) ValuesMK type D = LedgerTables (OTLedgerState (QC.Fixed Word) (QC.Fixed Word)) DiffMK @@ -207,13 +208,14 @@ instance Mock.EmptyValues V where instance Mock.ApplyDiff V D where applyDiff = applyDiffs' -instance Mock.LookupKeysRange K V where +instance Mock.LookupKeysRange K K' V where lookupKeysRange = \prev n vs -> - case prev of - Nothing -> - ltmap (rangeRead n) vs - Just ks -> - ltliftA2 (rangeRead' n) ks vs + let m'@(LedgerTables (ValuesMK v)) = case prev of + Nothing -> + ltmap (rangeRead n) vs + Just ks -> + ltliftA2 (rangeRead' n) ks vs + in (m', fst <$> Map.lookupMax v) where rangeRead :: Int -> ValuesMK k v -> ValuesMK k v rangeRead n (ValuesMK vs) = @@ -273,7 +275,7 @@ instance Mock.MakeReadHint V where instance Mock.MakeSerializeTablesHint V where makeSerializeTablesHint _ = emptyOTLedgerState -instance Mock.HasOps K V D +instance Mock.HasOps K K' V D {------------------------------------------------------------------------------- Orphan Arbitrary instances diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Lockstep.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Lockstep.hs index f9d235a83d..9f753b8d84 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Lockstep.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Lockstep.hs @@ -78,13 +78,13 @@ newtype Values vs = Values {unValues :: vs} Model state -------------------------------------------------------------------------------} -data BackingStoreState ks vs d = BackingStoreState +data BackingStoreState ks k vs d = BackingStoreState { bssMock :: Mock vs - , bssStats :: Stats ks vs d + , bssStats :: Stats ks k vs d } deriving (Show, Eq) -initState :: Mock.EmptyValues vs => BackingStoreState ks vs d +initState :: Mock.EmptyValues vs => BackingStoreState ks k vs d initState = BackingStoreState { bssMock = Mock.emptyMock @@ -102,92 +102,96 @@ maxOpenValueHandles = 32 @'StateModel'@ and @'RunModel'@ instances -------------------------------------------------------------------------------} -type BackingStoreInitializer m ks vs d = +type BackingStoreInitializer m ks k vs d = BS.InitFrom vs -> - m (BS.BackingStore m ks vs d) + m (BS.BackingStore m ks k vs d) -data RealEnv m ks vs d = RealEnv - { reBackingStoreInit :: BackingStoreInitializer m ks vs d - , reBackingStore :: StrictMVar m (BS.BackingStore m ks vs d) +data RealEnv m ks k vs d = RealEnv + { reBackingStoreInit :: BackingStoreInitializer m ks k vs d + , reBackingStore :: StrictMVar m (BS.BackingStore m ks k vs d) } -type RealMonad m ks vs d = ReaderT (RealEnv m ks vs d) m +type RealMonad m ks k vs d = ReaderT (RealEnv m ks k vs d) m -type BSAct ks vs d a = +type BSAct ks k vs d a = Action - (Lockstep (BackingStoreState ks vs d)) + (Lockstep (BackingStoreState ks k vs d)) (Either Err a) -type BSVar ks vs d a = - ModelVar (BackingStoreState ks vs d) a +type BSVar ks k vs d a = + ModelVar (BackingStoreState ks k vs d) a instance ( Show ks , Show vs + , Show k , Show d , Show (BS.InitHint vs) , Show (BS.WriteHint d) , Show (BS.ReadHint vs) , Eq ks + , Eq k , Eq vs , Eq d , Eq (BS.InitHint vs) , Eq (BS.WriteHint d) , Eq (BS.ReadHint vs) , Typeable ks + , Typeable k , Typeable vs , Typeable d , Typeable (BS.WriteHint d) , QC.Arbitrary ks + , QC.Arbitrary k , QC.Arbitrary vs , QC.Arbitrary d , QC.Arbitrary (BS.RangeQuery ks) - , Mock.HasOps ks vs d + , Mock.HasOps ks k vs d ) => - StateModel (Lockstep (BackingStoreState ks vs d)) + StateModel (Lockstep (BackingStoreState ks k vs d)) where - data Action (Lockstep (BackingStoreState ks vs d)) a where + data Action (Lockstep (BackingStoreState ks k vs d)) a where -- Reopen a backing store by intialising from values. BSInitFromValues :: WithOrigin SlotNo -> BS.InitHint vs -> Values vs -> - BSAct ks vs d () + BSAct ks k vs d () -- Reopen a backing store by initialising from a copy. BSInitFromCopy :: BS.InitHint vs -> FS.FsPath -> - BSAct ks vs d () - BSClose :: BSAct ks vs d () + BSAct ks k vs d () + BSClose :: BSAct ks k vs d () BSCopy :: SerializeTablesHint vs -> FS.FsPath -> - BSAct ks vs d () - BSValueHandle :: BSAct ks vs d (BS.BackingStoreValueHandle IO ks vs) + BSAct ks k vs d () + BSValueHandle :: BSAct ks k vs d (BS.BackingStoreValueHandle IO ks k vs) BSWrite :: SlotNo -> BS.WriteHint d -> d -> - BSAct ks vs d () + BSAct ks k vs d () BSVHClose :: - BSVar ks vs d (BS.BackingStoreValueHandle IO ks vs) -> - BSAct ks vs d () + BSVar ks k vs d (BS.BackingStoreValueHandle IO ks k vs) -> + BSAct ks k vs d () BSVHRangeRead :: - BSVar ks vs d (BS.BackingStoreValueHandle IO ks vs) -> + BSVar ks k vs d (BS.BackingStoreValueHandle IO ks k vs) -> BS.ReadHint vs -> BS.RangeQuery ks -> - BSAct ks vs d (Values vs) + BSAct ks k vs d (Values vs, Maybe k) BSVHRead :: - BSVar ks vs d (BS.BackingStoreValueHandle IO ks vs) -> + BSVar ks k vs d (BS.BackingStoreValueHandle IO ks k vs) -> BS.ReadHint vs -> ks -> - BSAct ks vs d (Values vs) + BSAct ks k vs d (Values vs) BSVHAtSlot :: - BSVar ks vs d (BS.BackingStoreValueHandle IO ks vs) -> - BSAct ks vs d (WithOrigin SlotNo) + BSVar ks k vs d (BS.BackingStoreValueHandle IO ks k vs) -> + BSAct ks k vs d (WithOrigin SlotNo) -- \| Corresponds to 'bsvhStat' BSVHStat :: - BSVar ks vs d (BS.BackingStoreValueHandle IO ks vs) -> - BSAct ks vs d BS.Statistics + BSVar ks k vs d (BS.BackingStoreValueHandle IO ks k vs) -> + BSAct ks k vs d BS.Statistics initialState = Lockstep.initialState initState nextState = Lockstep.nextState @@ -206,7 +210,7 @@ deriving stock instance , Show (BS.ReadHint vs) , Show (SerializeTablesHint vs) ) => - Show (LockstepAction (BackingStoreState ks vs d) a) + Show (LockstepAction (BackingStoreState ks k vs d) a) deriving stock instance ( Eq ks , Eq vs @@ -216,46 +220,50 @@ deriving stock instance , Eq (BS.ReadHint vs) , Eq (SerializeTablesHint vs) ) => - Eq (LockstepAction (BackingStoreState ks vs d) a) + Eq (LockstepAction (BackingStoreState ks k vs d) a) instance ( Show ks , Show vs + , Show k , Show d , Show (BS.InitHint vs) , Show (BS.WriteHint d) , Show (BS.ReadHint vs) , Eq ks , Eq vs + , Eq k , Eq d , Eq (BS.InitHint vs) , Eq (BS.WriteHint d) , Eq (BS.ReadHint vs) , Typeable ks + , Typeable k , Typeable vs , Typeable d , Typeable (BS.WriteHint d) , QC.Arbitrary ks + , QC.Arbitrary k , QC.Arbitrary vs , QC.Arbitrary d , QC.Arbitrary (BS.RangeQuery ks) - , Mock.HasOps ks vs d + , Mock.HasOps ks k vs d ) => RunModel - (Lockstep (BackingStoreState ks vs d)) - (RealMonad IO ks vs d) + (Lockstep (BackingStoreState ks k vs d)) + (RealMonad IO ks k vs d) where perform = \_st -> runIO postcondition = Lockstep.postcondition - monitoring = Lockstep.monitoring (Proxy @(RealMonad IO ks vs d)) + monitoring = Lockstep.monitoring (Proxy @(RealMonad IO ks k vs d)) -- | Custom precondition that prevents errors in the @'LMDB'@ backing store due -- to exceeding the maximum number of LMDB readers. -- -- See @'maxOpenValueHandles'@. modelPrecondition :: - BackingStoreState ks vs d -> - LockstepAction (BackingStoreState ks vs d) a -> + BackingStoreState ks k vs d -> + LockstepAction (BackingStoreState ks k vs d) a -> Bool modelPrecondition (BackingStoreState mock _stats) action = case action of BSInitFromValues _ _ _ -> isClosed mock @@ -271,73 +279,82 @@ modelPrecondition (BackingStoreState mock _stats) action = case action of @'InLockstep'@ instance -------------------------------------------------------------------------------} -type BSVal ks vs d a = ModelValue (BackingStoreState ks vs d) a -type BSObs ks vs d a = Observable (BackingStoreState ks vs d) a +type BSVal ks k vs d a = ModelValue (BackingStoreState ks k vs d) a +type BSObs ks k vs d a = Observable (BackingStoreState ks k vs d) a instance ( Show ks , Show vs , Show d + , Show k , Show (BS.InitHint vs) , Show (BS.WriteHint d) , Show (BS.ReadHint vs) , Eq ks , Eq vs + , Eq k , Eq d , Eq (BS.InitHint vs) , Eq (BS.WriteHint d) , Eq (BS.ReadHint vs) , Typeable ks + , Typeable k , Typeable vs , Typeable d , Typeable (BS.WriteHint d) , QC.Arbitrary ks + , QC.Arbitrary k , QC.Arbitrary vs , QC.Arbitrary d , QC.Arbitrary (BS.RangeQuery ks) - , Mock.HasOps ks vs d + , Mock.HasOps ks k vs d ) => - InLockstep (BackingStoreState ks vs d) + InLockstep (BackingStoreState ks k vs d) where - data ModelValue (BackingStoreState ks vs d) a where - MValueHandle :: ValueHandle vs -> BSVal ks vs d (BS.BackingStoreValueHandle IO ks vs) + data ModelValue (BackingStoreState ks k vs d) a where + MValueHandle :: ValueHandle vs -> BSVal ks k vs d (BS.BackingStoreValueHandle IO ks k vs) MErr :: Err -> - BSVal ks vs d Err + BSVal ks k vs d Err MSlotNo :: WithOrigin SlotNo -> - BSVal ks vs d (WithOrigin SlotNo) + BSVal ks k vs d (WithOrigin SlotNo) MValues :: vs -> - BSVal ks vs d (Values vs) + BSVal ks k vs d (Values vs) + MValuesAndLast :: + (vs, Maybe k) -> + BSVal ks k vs d (Values vs, Maybe k) MUnit :: () -> - BSVal ks vs d () + BSVal ks k vs d () MStatistics :: BS.Statistics -> - BSVal ks vs d BS.Statistics + BSVal ks k vs d BS.Statistics MEither :: - Either (BSVal ks vs d a) (BSVal ks vs d b) -> - BSVal ks vs d (Either a b) + Either (BSVal ks k vs d a) (BSVal ks k vs d b) -> + BSVal ks k vs d (Either a b) MPair :: - (BSVal ks vs d a, BSVal ks vs d b) -> - BSVal ks vs d (a, b) - - data Observable (BackingStoreState ks vs d) a where - OValueHandle :: BSObs ks vs d (BS.BackingStoreValueHandle IO ks vs) - OValues :: (Show a, Eq a, Typeable a) => a -> BSObs ks vs d (Values a) - OId :: (Show a, Eq a, Typeable a) => a -> BSObs ks vs d a + (BSVal ks k vs d a, BSVal ks k vs d b) -> + BSVal ks k vs d (a, b) + + data Observable (BackingStoreState ks k vs d) a where + OValueHandle :: BSObs ks k vs d (BS.BackingStoreValueHandle IO ks k vs) + OValues :: (Show a, Eq a, Typeable a) => a -> BSObs ks k vs d (Values a) + OValuesAndLast :: (Show a, Eq a, Typeable a) => (a, Maybe k) -> BSObs ks k vs d (Values a, Maybe k) + OId :: (Show a, Eq a, Typeable a) => a -> BSObs ks k vs d a OEither :: - Either (BSObs ks vs d a) (BSObs ks vs d b) -> - BSObs ks vs d (Either a b) - OPair :: (BSObs ks vs d a, BSObs ks vs d b) -> BSObs ks vs d (a, b) + Either (BSObs ks k vs d a) (BSObs ks k vs d b) -> + BSObs ks k vs d (Either a b) + OPair :: (BSObs ks k vs d a, BSObs ks k vs d b) -> BSObs ks k vs d (a, b) - observeModel :: BSVal ks vs d a -> BSObs ks vs d a + observeModel :: BSVal ks k vs d a -> BSObs ks k vs d a observeModel = \case MValueHandle _ -> OValueHandle MErr x -> OId x MSlotNo x -> OId x MValues x -> OValues x + MValuesAndLast x -> OValuesAndLast x MUnit x -> OId x MStatistics x -> OId x MEither x -> OEither $ bimap observeModel observeModel x @@ -345,26 +362,26 @@ instance modelNextState :: forall a. - LockstepAction (BackingStoreState ks vs d) a -> - ModelVarContext (BackingStoreState ks vs d) -> - BackingStoreState ks vs d -> - (BSVal ks vs d a, BackingStoreState ks vs d) + LockstepAction (BackingStoreState ks k vs d) a -> + ModelVarContext (BackingStoreState ks k vs d) -> + BackingStoreState ks k vs d -> + (BSVal ks k vs d a, BackingStoreState ks k vs d) modelNextState action lookUp (BackingStoreState mock stats) = auxStats $ runMock lookUp action mock where auxStats :: - (BSVal ks vs d a, Mock vs) -> - (BSVal ks vs d a, BackingStoreState ks vs d) + (BSVal ks k vs d a, Mock vs) -> + (BSVal ks k vs d a, BackingStoreState ks k vs d) auxStats (result, state') = ( result , BackingStoreState state' $ updateStats action lookUp result stats ) - type ModelOp (BackingStoreState ks vs d) = Op + type ModelOp (BackingStoreState ks k vs d) = Op usedVars :: - LockstepAction (BackingStoreState ks vs d) a -> - [AnyGVar (ModelOp (BackingStoreState ks vs d))] + LockstepAction (BackingStoreState ks k vs d) a -> + [AnyGVar (ModelOp (BackingStoreState ks k vs d))] usedVars = \case BSInitFromValues _ _ _ -> [] BSInitFromCopy _ _ -> [] @@ -379,22 +396,22 @@ instance BSVHStat h -> [SomeGVar h] arbitraryWithVars :: - ModelVarContext (BackingStoreState ks vs d) -> - BackingStoreState ks vs d -> - Gen (Any (LockstepAction (BackingStoreState ks vs d))) + ModelVarContext (BackingStoreState ks k vs d) -> + BackingStoreState ks k vs d -> + Gen (Any (LockstepAction (BackingStoreState ks k vs d))) arbitraryWithVars = arbitraryBackingStoreAction shrinkWithVars :: - ModelVarContext (BackingStoreState ks vs d) -> - BackingStoreState ks vs d -> - LockstepAction (BackingStoreState ks vs d) a -> - [Any (LockstepAction (BackingStoreState ks vs d))] + ModelVarContext (BackingStoreState ks k vs d) -> + BackingStoreState ks k vs d -> + LockstepAction (BackingStoreState ks k vs d) a -> + [Any (LockstepAction (BackingStoreState ks k vs d))] shrinkWithVars = shrinkBackingStoreAction tagStep :: - (BackingStoreState ks vs d, BackingStoreState ks vs d) -> - LockstepAction (BackingStoreState ks vs d) a -> - BSVal ks vs d a -> + (BackingStoreState ks k vs d, BackingStoreState ks k vs d) -> + LockstepAction (BackingStoreState ks k vs d) a -> + BSVal ks k vs d a -> [String] tagStep (BackingStoreState _ before, BackingStoreState _ after) action val = map show $ tagBSAction before after action val @@ -402,29 +419,32 @@ instance deriving stock instance ( Show ks , Show vs + , Show k , Show d , Show (BS.WriteHint d) , Show (BS.ReadHint vs) ) => - Show (BSVal ks vs d a) + Show (BSVal ks k vs d a) deriving stock instance ( Show ks , Show vs + , Show k , Show d , Show (BS.WriteHint d) , Show (BS.ReadHint vs) ) => - Show (BSObs ks vs d a) + Show (BSObs ks k vs d a) deriving stock instance ( Eq ks , Eq vs + , Eq k , Eq d , Eq (BS.WriteHint d) , Eq (BS.ReadHint vs) ) => - Eq (BSObs ks vs d a) + Eq (BSObs ks k vs d a) {------------------------------------------------------------------------------- @'RunLockstep'@ instance @@ -433,33 +453,37 @@ deriving stock instance instance ( Show ks , Show vs + , Show k , Show d , Show (BS.InitHint vs) , Show (BS.WriteHint d) , Show (BS.ReadHint vs) , Eq ks , Eq vs + , Eq k , Eq d , Eq (BS.InitHint vs) , Eq (BS.WriteHint d) , Eq (BS.ReadHint vs) , Typeable ks , Typeable vs + , Typeable k , Typeable d , Typeable (BS.WriteHint d) , QC.Arbitrary ks , QC.Arbitrary vs + , QC.Arbitrary k , QC.Arbitrary d , QC.Arbitrary (BS.RangeQuery ks) - , Mock.HasOps ks vs d + , Mock.HasOps ks k vs d ) => - RunLockstep (BackingStoreState ks vs d) (RealMonad IO ks vs d) + RunLockstep (BackingStoreState ks k vs d) (RealMonad IO ks k vs d) where observeReal :: - Proxy (RealMonad IO ks vs d) -> - LockstepAction (BackingStoreState ks vs d) a -> + Proxy (RealMonad IO ks k vs d) -> + LockstepAction (BackingStoreState ks k vs d) a -> a -> - BSObs ks vs d a + BSObs ks k vs d a observeReal _proxy = \case BSInitFromValues _ _ _ -> OEither . bimap OId OId BSInitFromCopy _ _ -> OEither . bimap OId OId @@ -468,14 +492,14 @@ instance BSValueHandle -> OEither . bimap OId (const OValueHandle) BSWrite _ _ _ -> OEither . bimap OId OId BSVHClose _ -> OEither . bimap OId OId - BSVHRangeRead _ _ _ -> OEither . bimap OId (OValues . unValues) + BSVHRangeRead _ _ _ -> OEither . bimap OId (OValuesAndLast . first unValues) BSVHRead _ _ _ -> OEither . bimap OId (OValues . unValues) BSVHAtSlot _ -> OEither . bimap OId OId BSVHStat _ -> OEither . bimap OId OId showRealResponse :: - Proxy (RealMonad IO ks vs d) -> - LockstepAction (BackingStoreState ks vs d) a -> + Proxy (RealMonad IO ks k vs d) -> + LockstepAction (BackingStoreState ks k vs d) a -> Maybe (Dict (Show a)) showRealResponse _proxy = \case BSInitFromValues _ _ _ -> Just Dict @@ -495,17 +519,18 @@ instance -------------------------------------------------------------------------------} runMock :: - forall ks vs d a. - ( Mock.HasOps ks vs d + forall ks k vs d a. + ( Mock.HasOps ks k vs d , QC.Arbitrary ks , QC.Arbitrary vs + , QC.Arbitrary k , QC.Arbitrary d , QC.Arbitrary (BS.RangeQuery ks) ) => - ModelVarContext (BackingStoreState ks vs d) -> - Action (Lockstep (BackingStoreState ks vs d)) a -> + ModelVarContext (BackingStoreState ks k vs d) -> + Action (Lockstep (BackingStoreState ks k vs d)) a -> Mock vs -> - ( BSVal ks vs d a + ( BSVal ks k vs d a , Mock vs ) runMock lookUp = \case @@ -524,7 +549,7 @@ runMock lookUp = \case BSVHClose h -> wrap MUnit . runMockMonad (Mock.mBSVHClose (getHandle $ lookupVar lookUp h)) BSVHRangeRead h rhint rq -> - wrap MValues . runMockMonad (Mock.mBSVHRangeRead (getHandle $ lookupVar lookUp h) rhint rq) + wrap MValuesAndLast . runMockMonad (Mock.mBSVHRangeRead (getHandle $ lookupVar lookUp h) rhint rq) BSVHRead h rhint ks -> wrap MValues . runMockMonad (Mock.mBSVHRead (getHandle $ lookupVar lookUp h) rhint ks) BSVHAtSlot h -> @@ -534,7 +559,7 @@ runMock lookUp = \case where wrap f = first (MEither . bimap MErr f) - getHandle :: BSVal ks vs d (BS.BackingStoreValueHandle IO ks vs) -> ValueHandle vs + getHandle :: BSVal ks k vs d (BS.BackingStoreValueHandle IO ks k vs) -> ValueHandle vs getHandle (MValueHandle h) = h {------------------------------------------------------------------------------- @@ -542,24 +567,25 @@ runMock lookUp = \case -------------------------------------------------------------------------------} arbitraryBackingStoreAction :: - forall ks vs d. - ( Mock.HasOps ks vs d + forall ks k vs d. + ( Mock.HasOps ks k vs d , QC.Arbitrary ks , QC.Arbitrary vs + , QC.Arbitrary k , QC.Arbitrary d , QC.Arbitrary (BS.RangeQuery ks) ) => - ModelVarContext (BackingStoreState ks vs d) -> - BackingStoreState ks vs d -> - Gen (Any (LockstepAction (BackingStoreState ks vs d))) + ModelVarContext (BackingStoreState ks k vs d) -> + BackingStoreState ks k vs d -> + Gen (Any (LockstepAction (BackingStoreState ks k vs d))) arbitraryBackingStoreAction fv (BackingStoreState mock _stats) = QC.frequency $ withoutVars - ++ case findVars fv (Proxy @(Either Err (BS.BackingStoreValueHandle IO ks vs))) of + ++ case findVars fv (Proxy @(Either Err (BS.BackingStoreValueHandle IO ks k vs))) of [] -> [] vars -> withVars (QC.elements vars) where - withoutVars :: [(Int, Gen (Any (LockstepAction (BackingStoreState ks vs d))))] + withoutVars :: [(Int, Gen (Any (LockstepAction (BackingStoreState ks k vs d))))] withoutVars = [ ( 5 @@ -590,8 +616,8 @@ arbitraryBackingStoreAction fv (BackingStoreState mock _stats) = ] withVars :: - Gen (BSVar ks vs d (Either Err (BS.BackingStoreValueHandle IO ks vs))) -> - [(Int, Gen (Any (LockstepAction (BackingStoreState ks vs d))))] + Gen (BSVar ks k vs d (Either Err (BS.BackingStoreValueHandle IO ks k vs))) -> + [(Int, Gen (Any (LockstepAction (BackingStoreState ks k vs d))))] withVars genVar = [ (5, fmap Some $ BSVHClose <$> (opFromRight <$> genVar)) , @@ -651,8 +677,9 @@ arbitraryBackingStoreAction fv (BackingStoreState mock _stats) = -------------------------------------------------------------------------------} shrinkBackingStoreAction :: - forall ks vs d a. + forall ks k vs d a. ( Typeable vs + , Typeable k , Eq ks , Eq vs , Eq d @@ -664,10 +691,10 @@ shrinkBackingStoreAction :: , QC.Arbitrary (BS.RangeQuery ks) , QC.Arbitrary ks ) => - ModelVarContext (BackingStoreState ks vs d) -> - BackingStoreState ks vs d -> - LockstepAction (BackingStoreState ks vs d) a -> - [Any (LockstepAction (BackingStoreState ks vs d))] + ModelVarContext (BackingStoreState ks k vs d) -> + BackingStoreState ks k vs d -> + LockstepAction (BackingStoreState ks k vs d) a -> + [Any (LockstepAction (BackingStoreState ks k vs d))] shrinkBackingStoreAction _findVars (BackingStoreState _mock _) = \case BSWrite sl st d -> [Some $ BSWrite sl st d' | d' <- QC.shrink d] @@ -682,10 +709,14 @@ shrinkBackingStoreAction _findVars (BackingStoreState _mock _) = \case Interpret @'Op'@ against @'ModelValue'@ -------------------------------------------------------------------------------} -instance InterpretOp Op (ModelValue (BackingStoreState ks vs d)) where +instance InterpretOp Op (ModelValue (BackingStoreState ks k vs d)) where intOp OpId = Just - intOp OpFst = \case MPair x -> Just (fst x) - intOp OpSnd = \case MPair x -> Just (snd x) + intOp OpFst = \case + MPair x -> Just (fst x) + MValuesAndLast{} -> error "What?" + intOp OpSnd = \case + MPair x -> Just (snd x) + MValuesAndLast{} -> error "What?" intOp OpLeft = \case MEither x -> either Just (const Nothing) x intOp OpRight = \case MEither x -> either (const Nothing) Just x intOp (OpComp g f) = intOp g <=< intOp f @@ -695,16 +726,16 @@ instance InterpretOp Op (ModelValue (BackingStoreState ks vs d)) where -------------------------------------------------------------------------------} runIO :: - forall ks vs d a. - LockstepAction (BackingStoreState ks vs d) a -> + forall ks k vs d a. + LockstepAction (BackingStoreState ks k vs d) a -> LookUp -> - RealMonad IO ks vs d a + RealMonad IO ks k vs d a runIO action lookUp = ReaderT $ \renv -> aux renv action where aux :: - RealEnv IO ks vs d -> - LockstepAction (BackingStoreState ks vs d) a -> + RealEnv IO ks k vs d -> + LockstepAction (BackingStoreState ks k vs d) a -> IO a aux renv = \case BSInitFromValues sl h (Values vs) -> catchErr $ do @@ -730,7 +761,7 @@ runIO action lookUp = ReaderT $ \renv -> BS.bsvhClose (lookUp' var) BSVHRangeRead var rhint rq -> catchErr $ - Values + first Values <$> BS.bsvhRangeRead (lookUp' var) rhint rq BSVHRead var rhint ks -> catchErr $ @@ -748,7 +779,7 @@ runIO action lookUp = ReaderT $ \renv -> , reBackingStore = bsVar } = renv - lookUp' :: BSVar ks vs d x -> x + lookUp' :: BSVar ks k vs d x -> x lookUp' = realLookupVar lookUp catchErr :: forall m a. IOLike m => m a -> m (Either Err a) @@ -761,7 +792,7 @@ catchErr act = Statistics and tagging -------------------------------------------------------------------------------} -data Stats ks vs d = Stats +data Stats ks k vs d = Stats { handleSlots :: Map (ValueHandle vs) (WithOrigin SlotNo) -- ^ Slots that value handles were created in , writeSlots :: Map SlotNo Int @@ -774,7 +805,7 @@ data Stats ks vs d = Stats } deriving stock (Show, Eq) -initStats :: Stats ks vs d +initStats :: Stats ks k vs d initStats = Stats { handleSlots = Map.empty @@ -784,18 +815,19 @@ initStats = } updateStats :: - forall ks vs d a. - ( Mock.HasOps ks vs d + forall ks k vs d a. + ( Mock.HasOps ks k vs d , QC.Arbitrary ks , QC.Arbitrary vs + , QC.Arbitrary k , QC.Arbitrary d , QC.Arbitrary (BS.RangeQuery ks) ) => - LockstepAction (BackingStoreState ks vs d) a -> - ModelVarContext (BackingStoreState ks vs d) -> - BSVal ks vs d a -> - Stats ks vs d -> - Stats ks vs d + LockstepAction (BackingStoreState ks k vs d) a -> + ModelVarContext (BackingStoreState ks k vs d) -> + BSVal ks k vs d a -> + Stats ks k vs d -> + Stats ks k vs d updateStats action lookUp result stats@Stats{handleSlots, writeSlots} = updateHandleSlots . updateWriteSlots @@ -803,10 +835,10 @@ updateStats action lookUp result stats@Stats{handleSlots, writeSlots} = . updateRangeReadAfterWrite $ stats where - getHandle :: BSVal ks vs d (BS.BackingStoreValueHandle IO ks vs) -> ValueHandle vs + getHandle :: BSVal ks k vs d (BS.BackingStoreValueHandle IO ks k vs) -> ValueHandle vs getHandle (MValueHandle h) = h - updateHandleSlots :: Stats ks vs d -> Stats ks vs d + updateHandleSlots :: Stats ks k vs d -> Stats ks k vs d updateHandleSlots s = case (action, result) of (BSValueHandle, MEither (Right (MValueHandle h))) -> s{handleSlots = Map.insert h (seqNo h) handleSlots} @@ -816,7 +848,7 @@ updateStats action lookUp result stats@Stats{handleSlots, writeSlots} = s{handleSlots = Map.delete (getHandle $ lookupVar lookUp h) handleSlots} _ -> s - updateWriteSlots :: Stats ks vs d -> Stats ks vs d + updateWriteSlots :: Stats ks k vs d -> Stats ks k vs d updateWriteSlots s = case (action, result) of (BSWrite sl _ d, MEither (Right (MUnit ()))) | 1 <= Mock.diffSize d -> @@ -825,7 +857,7 @@ updateStats action lookUp result stats@Stats{handleSlots, writeSlots} = s{writeSlots = Map.empty} _ -> s - updateReadAfterWrite :: Stats ks vs d -> Stats ks vs d + updateReadAfterWrite :: Stats ks k vs d -> Stats ks k vs d updateReadAfterWrite s = case (action, result) of (BSVHRead h _ _, MEither (Right (MValues vs))) | h' <- getHandle $ lookupVar lookUp h @@ -836,9 +868,9 @@ updateStats action lookUp result stats@Stats{handleSlots, writeSlots} = s{readAfterWrite = True} _ -> s - updateRangeReadAfterWrite :: Stats ks vs d -> Stats ks vs d + updateRangeReadAfterWrite :: Stats ks k vs d -> Stats ks k vs d updateRangeReadAfterWrite s = case (action, result) of - (BSVHRangeRead h _ _, MEither (Right (MValues vs))) + (BSVHRangeRead h _ _, MEither (Right (MValuesAndLast (vs, _)))) | h' <- getHandle $ lookupVar lookUp h , Just wosl <- Map.lookup h' handleSlots , Just (sl, _) <- Map.lookupMax writeSlots @@ -862,7 +894,7 @@ data TagAction deriving (Show, Eq, Ord, Bounded, Enum) -- | Identify actions by their constructor. -tAction :: LockstepAction (BackingStoreState ks vs d) a -> TagAction +tAction :: LockstepAction (BackingStoreState ks k vs d) a -> TagAction tAction = \case BSInitFromValues _ _ _ -> TBSInitFromValues BSInitFromCopy _ _ -> TBSInitFromCopy @@ -888,10 +920,10 @@ data Tag deriving Show tagBSAction :: - Stats ks vs d -> - Stats ks vs d -> - LockstepAction (BackingStoreState ks vs d) a -> - BSVal ks vs d a -> + Stats ks k vs d -> + Stats ks k vs d -> + LockstepAction (BackingStoreState ks k vs d) a -> + BSVal ks k vs d a -> [Tag] tagBSAction before after action result = globalTags ++ case (action, result) of diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Mock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Mock.hs index bb0968cc7b..7e81b1986e 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Mock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/V1/BackingStore/Mock.hs @@ -139,7 +139,7 @@ data Err class ( EmptyValues vs , ApplyDiff vs d - , LookupKeysRange ks vs + , LookupKeysRange ks k vs , LookupKeys ks vs , ValuesLength vs , MakeDiff vs d @@ -151,6 +151,7 @@ class , MakeSerializeTablesHint vs , Show ks , Show vs + , Show k , Show d , Show (BS.InitHint vs) , Show (BS.WriteHint d) @@ -158,6 +159,7 @@ class , Show (SerializeTablesHint vs) , Eq ks , Eq vs + , Eq k , Eq d , Eq (BS.InitHint vs) , Eq (BS.WriteHint d) @@ -165,13 +167,14 @@ class , Eq (SerializeTablesHint vs) , Typeable ks , Typeable vs + , Typeable k , Typeable d , Typeable (BS.InitHint vs) , Typeable (BS.WriteHint d) , Typeable (BS.ReadHint vs) , Typeable (SerializeTablesHint vs) ) => - HasOps ks vs d + HasOps ks k vs d class EmptyValues vs where emptyValues :: vs @@ -179,8 +182,8 @@ class EmptyValues vs where class ApplyDiff vs d where applyDiff :: vs -> d -> vs -class LookupKeysRange ks vs where - lookupKeysRange :: Maybe ks -> Int -> vs -> vs +class LookupKeysRange ks k vs where + lookupKeysRange :: Maybe ks -> Int -> vs -> (vs, Maybe k) class LookupKeys ks vs where lookupKeys :: ks -> vs -> vs @@ -216,7 +219,7 @@ class MakeSerializeTablesHint vs where -------------------------------------------------------------------------------} -- | State within which the mock runs. -newtype MockMonad ks vs d a +newtype MockMonad ks k vs d a = MockMonad (ExceptT Err (State (Mock vs)) a) deriving stock Functor deriving newtype @@ -227,7 +230,7 @@ newtype MockMonad ks vs d a ) runMockMonad :: - MockMonad ks vs d a -> + MockMonad ks k vs d a -> Mock vs -> (Either Err a, Mock vs) runMockMonad (MockMonad t) = runState . runExceptT $ t @@ -398,11 +401,11 @@ mBSVHClose vh = do -- | Perform a range read on a backing store value handle. mBSVHRangeRead :: - (MonadState (Mock vs) m, MonadError Err m, LookupKeysRange ks vs) => + (MonadState (Mock vs) m, MonadError Err m, LookupKeysRange ks k vs) => ValueHandle vs -> BS.ReadHint vs -> BS.RangeQuery ks -> - m vs + m (vs, Maybe k) mBSVHRangeRead vh _ BS.RangeQuery{BS.rqPrev, BS.rqCount} = do mGuardBSClosed mGuardBSVHClosed vh