From 4919c4aecee85535d9ad379437f0d465bc5031ff Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Fri, 31 Jan 2020 11:13:43 +0100 Subject: [PATCH] ImmutableDB.Iterator: allocate handles in the ResourceRegistry Fixes #1543. The ChainDB.Iterators and ChainDB.Readers use ImmutableDB.Iterators internally. Both take a ResourceRegistry to allocate the ImmutableDB.Iterator in so that the ImmutableDB.Iterator and the open handle it contains is closed when an exception occurs. If an exception occurs at the wrong time while opening an ImmutableDB.Iterator, after opening the handle, we might leak the handle. Fix this by directly allocating the handle in the ResourceRegistry instead of the ImmutableDB.Iterator that refers to the handle. --- .../Ouroboros/Storage/ChainDB/Impl/ImmDB.hs | 45 ++--- .../src/Ouroboros/Storage/ImmutableDB/API.hs | 5 +- .../Storage/ImmutableDB/Impl/Iterator.hs | 176 ++++++++++-------- .../test-consensus/Test/ThreadNet/RealPBFT.hs | 29 +++ .../Ouroboros/Storage/ImmutableDB/Mock.hs | 4 +- .../Storage/ImmutableDB/StateMachine.hs | 20 +- 6 files changed, 158 insertions(+), 121 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/ImmDB.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/ImmDB.hs index 792c95e05aa..db707192578 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/ImmDB.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/ImmDB.hs @@ -80,8 +80,7 @@ import Ouroboros.Network.Point (WithOrigin (..)) import Ouroboros.Consensus.Block (GetHeader (..), IsEBB (..)) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry, - allocateEither, unsafeRelease) +import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Storage.ChainDB.API (ChainDB) import Ouroboros.Storage.ChainDB.API hiding (ChainDB (..), @@ -417,14 +416,10 @@ appendBlock db@ImmDB{..} b = withDB db $ \imm -> case isEBB (getHeader b) of Streaming -------------------------------------------------------------------------------} --- | Wrapper around 'ImmDB.stream' that 'allocate's the iterator in the --- 'ResourceRegistry' so that 'ImmDB.iteratorClose' is registered as the --- clean-up action. Translates the requested 'BlockComponent' into the --- 'ImmDB.BlockComponent' the ImmutableDB understands. --- --- When the returned iterator is closed, it will be 'release'd from the --- 'ResourceRegistry'. -registeredStream +-- | Wrapper around 'ImmDB.stream' that translates the requested +-- 'BlockComponent' into the 'ImmDB.BlockComponent' the ImmutableDB +-- understands. +openIterator :: forall m blk b. (IOLike m, HasHeader blk) => ImmDB m blk -> ResourceRegistry m @@ -433,20 +428,8 @@ registeredStream -> Maybe (SlotNo, HeaderHash blk) -> m (Either (ImmDB.WrongBoundError (HeaderHash blk)) (ImmDB.Iterator (HeaderHash blk) m b)) -registeredStream db registry blockComponent start end = do - errOrKeyAndIt <- allocateEither registry - (\_key -> withDB db $ \imm -> - ImmDB.stream imm blockComponent' start end) - (iteratorClose db) - return $ case errOrKeyAndIt of - Left e -> Left e - -- The iterator will be used by a thread that is unknown to the registry - -- (which, after all, is entirely internal to the chain DB). This means - -- that the registry cannot guarantee that the iterator will be live for - -- the duration of that thread, and indeed, it may not be: the chain DB - -- might be closed before that thread terminates. We will deal with this - -- in the chain DB itself (throw ClosedDBError exception). - Right (key, it) -> Right it { ImmDB.iteratorClose = unsafeRelease key } +openIterator db registry blockComponent start end = + withDB db $ \imm -> ImmDB.stream imm registry blockComponent' start end where blockComponent' = translateToRawDB (parse db) (addHdrEnv db) blockComponent @@ -489,29 +472,29 @@ stream db registry blockComponent from to = runExceptT $ do case from of StreamFromExclusive pt@BlockPoint { atSlot = slot, withHash = hash } -> do when (pointSlot pt > slotNoAtTip) $ throwError $ MissingBlock pt - it <- openRegisteredStream (Just (slot, hash)) end + it <- openStream (Just (slot, hash)) end -- Skip the first block, as the bound is exclusive void $ lift $ iteratorNext db it return it StreamFromExclusive GenesisPoint -> - openRegisteredStream Nothing end + openStream Nothing end StreamFromInclusive pt@BlockPoint { atSlot = slot, withHash = hash } -> do when (pointSlot pt > slotNoAtTip) $ throwError $ MissingBlock pt - openRegisteredStream (Just (slot, hash)) end + openStream (Just (slot, hash)) end StreamFromInclusive GenesisPoint -> throwM NoGenesisBlock where - openRegisteredStream + openStream :: Maybe (SlotNo, HeaderHash blk) -> Maybe (SlotNo, HeaderHash blk) -> ExceptT (UnknownRange blk) m (ImmDB.Iterator (HeaderHash blk) m b) - openRegisteredStream start end = ExceptT $ + openStream start end = ExceptT $ bimap toUnknownRange (fmap snd . stopAt to) <$> -- 'stopAt' needs to know the hash of each streamed block, so we \"Get\" -- it in addition to @b@, but we drop it afterwards. - registeredStream db registry ((,) <$> GetHash <*> blockComponent) start end + openIterator db registry ((,) <$> GetHash <*> blockComponent) start end where toUnknownRange :: ImmDB.WrongBoundError (HeaderHash blk) -> UnknownRange blk toUnknownRange e @@ -570,7 +553,7 @@ streamAfter (ImmDB.WrongBoundError (HeaderHash blk)) (ImmDB.Iterator (HeaderHash blk) m b)) streamAfter db registry blockComponent low = - registeredStream db registry blockComponent low' Nothing >>= \case + openIterator db registry blockComponent low' Nothing >>= \case Left err -> return $ Left err Right itr -> do case low of diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/API.hs b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/API.hs index 383d83a8a6e..eaff80bd45c 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/API.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/API.hs @@ -22,6 +22,8 @@ import Data.ByteString.Builder (Builder) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) +import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) + import Ouroboros.Storage.Common import Ouroboros.Storage.ImmutableDB.Types import Ouroboros.Storage.Util.ErrorHandling (ErrorHandling) @@ -197,7 +199,8 @@ data ImmutableDB hash m = ImmutableDB -- prematurely closed with 'iteratorClose'. , stream :: forall b. HasCallStack - => BlockComponent (ImmutableDB hash m) b + => ResourceRegistry m + -> BlockComponent (ImmutableDB hash m) b -> Maybe (SlotNo, hash) -> Maybe (SlotNo, hash) -> m (Either (WrongBoundError hash) diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/Iterator.hs b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/Iterator.hs index dbdd229135c..5432f5b45e4 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/Iterator.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ImmutableDB/Impl/Iterator.hs @@ -35,13 +35,14 @@ import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block (IsEBB (..)) import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.ResourceRegistry (ResourceKey, + ResourceRegistry, allocate, release, unsafeRelease) import Ouroboros.Storage.Common import Ouroboros.Storage.EpochInfo import Ouroboros.Storage.FS.API import Ouroboros.Storage.FS.API.Types import Ouroboros.Storage.FS.CRC -import Ouroboros.Storage.Util.ErrorHandling (ErrorHandling) import Ouroboros.Storage.ImmutableDB.API import Ouroboros.Storage.ImmutableDB.Impl.Index (Index) @@ -65,7 +66,7 @@ data IteratorHandle hash m = forall h. IteratorHandle -- ^ Bundled HasFS instance allows to hide type parameters , itIndex :: !(Index m hash h) -- ^ Bundled Index instance allows to hide type parameters - , itState :: !(StrictTVar m (IteratorStateOrExhausted hash h)) + , itState :: !(StrictTVar m (IteratorStateOrExhausted hash m h)) -- ^ The state of the iterator. If it is 'Nothing', the iterator is -- exhausted and/or closed. , itEnd :: !EpochSlot @@ -74,8 +75,8 @@ data IteratorHandle hash m = forall h. IteratorHandle -- ^ The @hash@ of the last block the iterator should return. } -data IteratorStateOrExhausted hash h = - IteratorStateOpen !(IteratorState hash h) +data IteratorStateOrExhausted hash m h = + IteratorStateOpen !(IteratorState hash m h) | IteratorStateExhausted deriving (Generic, NoUnexpectedThunks) @@ -93,11 +94,17 @@ instance ( forall a. NoUnexpectedThunks (StrictTVar m a) , noUnexpectedThunks ctxt itEndHash ] -data IteratorState hash h = IteratorState +data IteratorState hash m h = IteratorState { itEpoch :: !EpochNo -- ^ The current epoch the iterator is streaming from. , itEpochHandle :: !(Handle h) -- ^ A handle to the epoch file corresponding with 'itEpoch'. + , itEpochKey :: !(ResourceKey m) + -- ^ The 'ResourceKey' corresponding to the 'itEpochHandle'. We use it to + -- release the handle from the 'ResourceRegistry'. + -- + -- NOTE: if we only close the handle but don't release the resource, the + -- registry will still hold on to the (closed) handle/resource. , itEpochEntries :: !(NonEmpty (WithBlockSize (Secondary.Entry hash))) -- ^ The entries from the secondary index corresponding to the current -- epoch. The first entry in the list is the next one to stream. @@ -117,6 +124,7 @@ data CurrentEpochInfo = CurrentEpochInfo !EpochNo !BlockOffset streamImpl :: forall m hash b. (HasCallStack, IOLike m, Eq hash, NoUnexpectedThunks hash) => ImmutableDBEnv m hash + -> ResourceRegistry m -> BlockComponent (ImmutableDB hash m) b -> Maybe (SlotNo, hash) -- ^ When to start streaming (inclusive). @@ -124,7 +132,7 @@ streamImpl -- ^ When to stop streaming (inclusive). -> m (Either (WrongBoundError hash) (Iterator hash m b)) -streamImpl dbEnv blockComponent mbStart mbEnd = +streamImpl dbEnv registry blockComponent mbStart mbEnd = withOpenState dbEnv $ \hasFS OpenState{..} -> runExceptT $ do lift $ validateIteratorRange _dbErr _dbEpochInfo (forgetHash <$> _currentTip) mbStart mbEnd @@ -160,7 +168,7 @@ streamImpl dbEnv blockComponent mbStart mbEnd = -- TODO avoid rereading the indices of the start epoch. We read -- from both the primary and secondary index in 'fillInStartBound' - iteratorState <- iteratorStateForEpoch hasFS _dbErr _index + iteratorState <- iteratorStateForEpoch hasFS _index registry curEpochInfo endHash startEpoch secondaryOffset startIsEBB varIteratorState <- newTVarM $ IteratorStateOpen iteratorState @@ -257,8 +265,8 @@ streamImpl dbEnv blockComponent mbStart mbEnd = mkIterator :: IteratorHandle hash m -> Iterator hash m b mkIterator ith = Iterator - { iteratorNext = iteratorNextImpl dbEnv ith blockComponent True - , iteratorPeek = iteratorNextImpl dbEnv ith blockComponent False + { iteratorNext = iteratorNextImpl dbEnv ith registry blockComponent True + , iteratorPeek = iteratorNextImpl dbEnv ith registry blockComponent False , iteratorHasNext = iteratorHasNextImpl ith , iteratorClose = iteratorCloseImpl ith } @@ -339,13 +347,15 @@ iteratorNextImpl :: forall m hash b. (IOLike m, Eq hash) => ImmutableDBEnv m hash -> IteratorHandle hash m + -> ResourceRegistry m -> BlockComponent (ImmutableDB hash m) b -> Bool -- ^ Step the iterator after reading iff True -> m (IteratorResult b) iteratorNextImpl dbEnv it@IteratorHandle { itHasFS = hasFS :: HasFS m h , itIndex = index :: Index m hash h - , .. } blockComponent step = do + , .. + } registry blockComponent step = do -- The idea is that if the state is not 'IteratorStateExhausted, then the -- head of 'itEpochEntries' is always ready to be read. After reading it -- with 'readNextBlock' or 'readNextHeader', 'stepIterator' will advance @@ -364,7 +374,6 @@ iteratorNextImpl dbEnv it@IteratorHandle return $ IteratorResult b where ImmutableDBEnv { _dbErr, _dbEpochInfo, _dbHashInfo } = dbEnv - HasFS { hClose } = hasFS getBlockComponent :: Handle h @@ -436,7 +445,7 @@ iteratorNextImpl dbEnv it@IteratorHandle -- | Move the iterator to the next position that can be read from, -- advancing epochs if necessary. If no next position can be found, the -- iterator is closed. - stepIterator :: CurrentEpochInfo -> IteratorState hash h -> m () + stepIterator :: CurrentEpochInfo -> IteratorState hash m h -> m () stepIterator curEpochInfo iteratorState@IteratorState {..} = case NE.nonEmpty (NE.tail itEpochEntries) of -- There are entries left in this epoch, so continue. See the @@ -446,7 +455,8 @@ iteratorNextImpl dbEnv it@IteratorHandle -- No more entries in this epoch, so open the next. Nothing -> do - hClose itEpochHandle + -- Release the resource, i.e., close the handle. + release itEpochKey -- If this was the final epoch, close the iterator if itEpoch >= _epoch itEnd then iteratorCloseImpl it @@ -459,7 +469,7 @@ iteratorNextImpl dbEnv it@IteratorHandle :: CurrentEpochInfo -> EpochSlot -- ^ The end bound -> EpochNo -- ^ The epoch to open - -> m (IteratorState hash h) + -> m (IteratorState hash m h) openNextEpoch curEpochInfo end epoch = Index.readFirstFilledSlot index epoch >>= \case -- This epoch is empty, look in the next one. @@ -481,7 +491,7 @@ iteratorNextImpl dbEnv it@IteratorHandle | otherwise = IsNotEBB secondaryOffset = 0 - iteratorStateForEpoch hasFS _dbErr index curEpochInfo itEndHash + iteratorStateForEpoch hasFS index registry curEpochInfo itEndHash epoch secondaryOffset firstIsEBB iteratorHasNextImpl @@ -503,24 +513,35 @@ iteratorCloseImpl :: (HasCallStack, IOLike m) => IteratorHandle hash m -> m () -iteratorCloseImpl IteratorHandle {..} = do +iteratorCloseImpl IteratorHandle { itState } = do atomically (readTVar itState) >>= \case -- Already closed IteratorStateExhausted -> return () - IteratorStateOpen IteratorState {..} -> do + IteratorStateOpen IteratorState { itEpochKey } -> do -- First set it to Nothing to indicate it is closed, as the call to - -- 'hClose' might fail, which would leave the iterator open in an + -- 'release' might fail, which would leave the iterator open in an -- invalid state. atomically $ writeTVar itState IteratorStateExhausted - hClose itEpochHandle - where - HasFS { hClose } = itHasFS + -- TODO: we must use 'unsafeRelease' instead of 'release' because we + -- might close the iterator from an /untracked thread/, i.e., a thread + -- that was not spawned by the resource registry (or the thread that + -- opened the resource registry) in which the handle was allocated. + -- + -- This happens in the consensus tests (but not in the actual node), + -- where the protocol threads that open iterators (BlockFetchServer + -- and ChainSyncServer) are spawned using a different resource + -- registry (A) than the one the ImmutableDB (and ChainDB) use (B). + -- When the ChainDB is closed (by the thread that opened B), we're + -- closing all open iterators, i.e., the iterators opened by the + -- protocol threads. So we're releasing handles allocated in resource + -- registry A from a thread tracked by resource registry B. See #1390. + unsafeRelease itEpochKey iteratorStateForEpoch :: (HasCallStack, IOLike m, Eq hash) => HasFS m h - -> ErrorHandling ImmutableDBError m -> Index m hash h + -> ResourceRegistry m -> CurrentEpochInfo -> hash -- ^ Hash of the end bound @@ -529,62 +550,61 @@ iteratorStateForEpoch -- ^ Where to start in the secondary index -> IsEBB -- ^ Whether the first expected block will be an EBB or not. - -> m (IteratorState hash h) -iteratorStateForEpoch hasFS err index + -> m (IteratorState hash m h) +iteratorStateForEpoch hasFS index registry (CurrentEpochInfo curEpoch curEpochOffset) endHash epoch secondaryOffset firstIsEBB = do - -- Open the epoch file - eHnd <- hOpen (renderFile "epoch" epoch) ReadMode - - -- If we don't close the handle when an exception is thrown, we leak a - -- file handle, since this handle is not stored in a state that can be - -- closed yet. - onException hasFsErr err (hClose eHnd) $ do - - -- If the last entry in @entries@ corresponds to the last block in the - -- epoch, we cannot calculate the block size based on the next block. - -- Instead, we calculate it based on the size of the epoch file. - -- - -- IMPORTANT: for older epochs, this is fine, as the secondary index - -- (entries) and the epoch file (size) are immutable. However, when - -- doing this for the current epoch, there is a potential race condition - -- between reading of the entries from the secondary index and obtaining - -- the epoch file size: what if a new block was appended after reading - -- the entries but before obtaining the epoch file size? Then the epoch - -- file size will not correspond to the last entry we read, but to the - -- block after it. Similarly if we switch the order of the two - -- operations. - -- - -- To avoid this race condition, we use the value of - -- '_currentEpochOffset' from the state as the file size of the current - -- epoch (stored in 'CurrentEpochInfo'). This value corresponds to the - -- epoch file size at the time we /read the state/. We also know that - -- the end bound of our iterator is always <= the tip from that same - -- state, so all @entries@ must be <= the tip from that state because - -- we'll never stream beyond the tip. Remember that we only actually use - -- the current epoch file size if the last entry we have read from the - -- secondary index is the last entry in the file, in which case it would - -- correspond to the tip from the state. In this case, the epoch file - -- size (@curEpochOffset@) we are passed is consistent with the tip, as - -- it was obtained from the same consistent state. - epochFileSize <- if epoch == curEpoch - then return (unBlockOffset curEpochOffset) - else hGetSize eHnd - - entries <- Index.readAllEntries index secondaryOffset epoch - ((== endHash) . Secondary.headerHash) epochFileSize firstIsEBB - - case NE.nonEmpty entries of - -- We still haven't encountered the end bound, so it cannot be - -- that this non-empty epoch contains no entries <= the end bound. - Nothing -> error - "impossible: there must be entries according to the primary index" - - Just itEpochEntries -> return IteratorState - { itEpoch = epoch - , itEpochHandle = eHnd - -- Force so we don't store any thunks in the state - , itEpochEntries = forceElemsToWHNF itEpochEntries - } + -- Open the epoch file. Allocate the handle in the registry so that it + -- will be closed in case of an exception. + (key, eHnd) <- allocate + registry + (\_key -> hOpen (renderFile "epoch" epoch) ReadMode) + hClose + + -- If the last entry in @entries@ corresponds to the last block in the + -- epoch, we cannot calculate the block size based on the next block. + -- Instead, we calculate it based on the size of the epoch file. + -- + -- IMPORTANT: for older epochs, this is fine, as the secondary index + -- (entries) and the epoch file (size) are immutable. However, when doing + -- this for the current epoch, there is a potential race condition between + -- reading of the entries from the secondary index and obtaining the epoch + -- file size: what if a new block was appended after reading the entries + -- but before obtaining the epoch file size? Then the epoch file size will + -- not correspond to the last entry we read, but to the block after it. + -- Similarly if we switch the order of the two operations. + -- + -- To avoid this race condition, we use the value of '_currentEpochOffset' + -- from the state as the file size of the current epoch (stored in + -- 'CurrentEpochInfo'). This value corresponds to the epoch file size at + -- the time we /read the state/. We also know that the end bound of our + -- iterator is always <= the tip from that same state, so all @entries@ + -- must be <= the tip from that state because we'll never stream beyond + -- the tip. Remember that we only actually use the current epoch file size + -- if the last entry we have read from the secondary index is the last + -- entry in the file, in which case it would correspond to the tip from + -- the state. In this case, the epoch file size (@curEpochOffset@) we are + -- passed is consistent with the tip, as it was obtained from the same + -- consistent state. + epochFileSize <- if epoch == curEpoch + then return (unBlockOffset curEpochOffset) + else hGetSize eHnd + + entries <- Index.readAllEntries index secondaryOffset epoch + ((== endHash) . Secondary.headerHash) epochFileSize firstIsEBB + + case NE.nonEmpty entries of + -- We still haven't encountered the end bound, so it cannot be + -- that this non-empty epoch contains no entries <= the end bound. + Nothing -> error + "impossible: there must be entries according to the primary index" + + Just itEpochEntries -> return IteratorState + { itEpoch = epoch + , itEpochHandle = eHnd + , itEpochKey = key + -- Force so we don't store any thunks in the state + , itEpochEntries = forceElemsToWHNF itEpochEntries + } where - HasFS { hOpen, hClose, hGetSize, hasFsErr } = hasFS + HasFS { hOpen, hClose, hGetSize } = hasFS diff --git a/ouroboros-consensus/test-consensus/Test/ThreadNet/RealPBFT.hs b/ouroboros-consensus/test-consensus/Test/ThreadNet/RealPBFT.hs index 293bcfb1c68..95392b0a99e 100644 --- a/ouroboros-consensus/test-consensus/Test/ThreadNet/RealPBFT.hs +++ b/ouroboros-consensus/test-consensus/Test/ThreadNet/RealPBFT.hs @@ -169,6 +169,35 @@ tests = testGroup "RealPBFT" $ , slotLengths = defaultSlotLengths , initSeed = Seed (11044330969750026700,14522662956180538128,9026549867550077426,3049168255170604478,643621447671665184) } + , testProperty "ImmutableDB is leaking file handles, #1543" $ + -- The failure was: c0 leaks one ImmDB file handle (for path + -- @00000.epoch@, read only, offset at 0). + -- + -- The test case seems somewhat fragile, since the 'slotLengths' + -- value seems to matter! + once $ + let ncn5 = NumCoreNodes 5 in + prop_simple_real_pbft_convergence NoEBBs (SecurityParam 2) TestConfig + { numCoreNodes = ncn5 + -- Still fails if I increase numSlots. + , numSlots = NumSlots 54 + , nodeJoinPlan = NodeJoinPlan $ Map.fromList + [ (CoreNodeId 0, SlotNo {unSlotNo = 0}) + , (CoreNodeId 1, SlotNo {unSlotNo = 0}) + , (CoreNodeId 2, SlotNo {unSlotNo = 0}) + , (CoreNodeId 3, SlotNo {unSlotNo = 53}) + , (CoreNodeId 4, SlotNo {unSlotNo = 53}) + ] + -- Passes if I drop either of these restarts. + , nodeRestarts = NodeRestarts $ Map.fromList + [ (SlotNo {unSlotNo = 50},Map.fromList [(CoreNodeId 0,NodeRestart)]) + , (SlotNo {unSlotNo = 53},Map.fromList [(CoreNodeId 3,NodeRestart)]) + ] + , nodeTopology = meshNodeTopology ncn5 + -- Slot length of 19s passes, and 21s also fails; I haven't seen this matter before. + , slotLengths = singletonSlotLengths (slotLengthFromSec 20) + , initSeed = Seed {getSeed = (15062108706768000853,6202101653126031470,15211681930891010376,1718914402782239589,12639712845887620121)} + } , -- RealPBFT runs are slow, so do 10x less of this narrow test adjustOption (\(QuickCheckTests i) -> QuickCheckTests $ max 1 $ i `div` 10) $ testProperty "re-delegation via NodeRekey" $ \seed w -> diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/Mock.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/Mock.hs index 21ebf158c04..861ed057183 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/Mock.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/Mock.hs @@ -9,7 +9,7 @@ import Data.Tuple (swap) import Control.Monad.Class.MonadThrow -import Ouroboros.Consensus.Util ((..:), (.:)) +import Ouroboros.Consensus.Util ((...:), (..:), (.:)) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Storage.Common (BlockComponent, EpochSize) @@ -41,7 +41,7 @@ openDBMock err epochSize = do , getBlockOrEBBComponent = queryE ..: getBlockOrEBBComponentModel , appendBlock = updateE_ ..: appendBlockModel , appendEBB = updateE_ ..: appendEBBModel - , stream = updateEE ..: \bc s e -> fmap (fmap (first (iterator bc))) . streamModel s e + , stream = updateEE ...: \_rr bc s e -> fmap (fmap (first (iterator bc))) . streamModel s e , immutableDBErr = err } where diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs index d895cbd7dd0..01e209850ed 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs @@ -213,16 +213,17 @@ run :: forall m. (HasCallStack, IOLike m) -> [TestIterator m] -> ImmutableDB Hash m -> ImmDB.Internal Hash m + -> ResourceRegistry m -> StrictTVar m Id -> Cmd (TestIterator m) -> m (Success (TestIterator m)) -run runCorruption its db internal varNextId cmd = case cmd of +run runCorruption its db internal registry varNextId cmd = case cmd of GetBlockComponent s -> MbAllComponents <$> getBlockComponent db allComponents s GetEBBComponent e -> MbAllComponents <$> getEBBComponent db allComponents e GetBlockOrEBBComponent s h -> MbAllComponents <$> getBlockOrEBBComponent db allComponents s h AppendBlock s h b -> Unit <$> appendBlock db s h (toBuilder <$> testBlockToBinaryInfo b) AppendEBB e h b -> Unit <$> appendEBB db e h (toBuilder <$> testBlockToBinaryInfo b) - Stream s e -> iter =<< stream db allComponents s e + Stream s e -> iter =<< stream db registry allComponents s e IteratorNext it -> IterResult <$> iteratorNext (unWithEq it) IteratorPeek it -> IterResult <$> iteratorPeek (unWithEq it) IteratorHasNext it -> IterHasNext <$> iteratorHasNext (unWithEq it) @@ -755,12 +756,12 @@ semantics varErrors varNextId registry hasFS db internal (At cmdErr) = At . fmap (reference . Opaque) . Resp <$> case opaque <$> cmdErr of CmdErr Nothing cmd its -> try $ - run (semanticsCorruption hasFS) its db internal varNextId cmd + run (semanticsCorruption hasFS) its db internal registry varNextId cmd CmdErr (Just errors) cmd its -> do tipBefore <- fmap forgetHash <$> getTip db res <- withErrors varErrors errors $ try $ - run (semanticsCorruption hasFS) its db internal varNextId cmd + run (semanticsCorruption hasFS) its db internal registry varNextId cmd case res of -- If the command resulted in a 'UserError', we didn't even get the -- chance to run into a simulated error. Note that we still @@ -846,7 +847,7 @@ sm varErrors varNextId registry hasFS db internal dbm = StateMachine Validation -------------------------------------------------------------------------------} -validate :: forall m. Monad m +validate :: forall m. IOLike m => Model m Concrete -> ImmutableDB Hash m -> QC.PropertyM m Property validate Model {..} realDB = do @@ -858,10 +859,11 @@ validate Model {..} realDB = do where modelContents = dbmBlockList dbModel - getDBContents db = stream db GetRawBlock Nothing Nothing >>= \case - -- This should never happen - Left e -> error (show e) - Right it -> iteratorToList it + getDBContents db = withRegistry $ \registry -> + stream db registry GetRawBlock Nothing Nothing >>= \case + -- This should never happen + Left e -> error (show e) + Right it -> iteratorToList it {------------------------------------------------------------------------------- Labelling