diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/ResourceRegistry.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/ResourceRegistry.hs index 0a45be7828a..ad52fa87b2d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/ResourceRegistry.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/ResourceRegistry.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.Util.ResourceRegistry ( , withRegistry , registryThread -- * Allocating and releasing regular resources + , ResourceKey , allocate , allocateEither , release @@ -342,6 +343,7 @@ data RegistryStatus = -- -- Resource keys are tied to a particular registry. data ResourceKey m = ResourceKey !(ResourceRegistry m) !ResourceId + deriving (Generic, NoUnexpectedThunks) -- | Resource ID -- @@ -841,7 +843,7 @@ ensureKnownThread :: forall m. IOLike m ensureKnownThread rr context = do isKnown <- checkIsKnown unless isKnown $ - throwM $ ResourceRegistryUsedFromUnknownThread { + throwM $ ResourceRegistryUsedFromUntrackedThread { resourceRegistryCreatedIn = registryContext rr , resourceRegistryUsedIn = context } @@ -854,13 +856,14 @@ ensureKnownThread rr context = do KnownThreads ts <- registryThreads <$> readTVar (registryState rr) return $ contextThreadId context `Set.member` ts --- | Registry used from unknown threads +-- | Registry used from untracked threads -- -- If this exception is raised, it indicates a bug in the caller. data ResourceRegistryThreadException = - -- | If the registry is used from an unknown thread, we cannot do proper - -- reference counting - forall m. IOLike m => ResourceRegistryUsedFromUnknownThread { + -- | If the registry is used from an untracked thread, we cannot do proper + -- reference counting. The following threads are /tracked/: the thread + -- that spawned the registry and all threads spawned by the registry. + forall m. IOLike m => ResourceRegistryUsedFromUntrackedThread { -- | Information about the context in which the registry was created resourceRegistryCreatedIn :: !(Context m) 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