diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs index 738ca8bbc94..16cd1d7082b 100644 --- a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ImmutableDB/StateMachine.hs @@ -189,7 +189,7 @@ closeOpenIterators varIters = do open :: ImmutableDbArgs Identity IO TestBlock -> IO ImmutableDBState open args = do - (db, internal) <- openDBInternal args (runWithTempRegistry . completeComputation) + (db, internal) <- openDBInternal args (runWithTempRegistry . runnableInnerWithTempRegistry) return ImmutableDBState { db, internal } -- | Opens a new ImmutableDB and stores it in 'varDB'. diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs index 175b1d9dfa4..de560b12625 100644 --- a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs +++ b/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/VolatileDB/StateMachine.hs @@ -40,7 +40,7 @@ import Ouroboros.Network.Block (MaxSlotNo) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (runWithTempRegistry, completeComputation) +import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.FS.API (SomeHasFS (..), hPutAll, @@ -484,7 +484,7 @@ data VolatileDBEnv = VolatileDBEnv -- Does not close the current VolatileDB stored in 'varDB'. reopenDB :: VolatileDBEnv -> IO () reopenDB VolatileDBEnv { varDB, args } = do - db <- openDB args (runWithTempRegistry . completeComputation) + db <- openDB args (runWithTempRegistry . runnableInnerWithTempRegistry) void $ swapMVar varDB db semanticsImpl :: VolatileDBEnv -> At CmdErr Concrete -> IO (At Resp Concrete) @@ -588,7 +588,7 @@ test cmds = do } (hist, res, trace) <- bracket - (openDB args (runWithTempRegistry . completeComputation) >>= newMVar) + (openDB args (runWithTempRegistry . runnableInnerWithTempRegistry) >>= newMVar) -- Note: we might be closing a different VolatileDB than the one we -- opened, as we can reopen it the VolatileDB, swapping the VolatileDB -- in the MVar. diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs index d008abf3fc6..2c0f0a2fe09 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs @@ -225,7 +225,7 @@ openDB :: WithTempRegistry (OpenState m blk h) m (ImmutableDB m blk, OpenState m blk h, OpenState m blk h, OpenState m blk h -> m Bool) -> ans) -> ans) -openDB args f = openDBInternal args (f . swizzle) +openDB args cont = openDBInternal args (cont . swizzle) where swizzle w = w >>= \((a, _), c, d, e) -> return (a, c, d, e) -- | For testing purposes: exposes internals via 'Internal' @@ -245,7 +245,7 @@ openDBInternal :: WithTempRegistry (OpenState m blk h) m ((ImmutableDB m blk, Internal m blk), OpenState m blk h, OpenState m blk h, OpenState m blk h -> m Bool) -> ans) -> ans) -openDBInternal ImmutableDbArgs { immHasFS = SomeHasFS hasFS, .. } f = f $ do +openDBInternal ImmutableDbArgs { immHasFS = SomeHasFS hasFS, .. } cont = cont $ do lift $ createDirectoryIfMissing hasFS True (mkFsPath []) let validateEnv = ValidateEnv { hasFS = hasFS diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs index 391e8ad1747..dbac93e7bc0 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs @@ -200,7 +200,7 @@ openDB :: WithTempRegistry (OpenState blk h) m (VolatileDB m blk, OpenState blk h, OpenState blk h, OpenState blk h -> m Bool) -> ans) -> ans) -openDB VolatileDbArgs { volHasFS = SomeHasFS hasFS, .. } f = f $ do +openDB VolatileDbArgs { volHasFS = SomeHasFS hasFS, .. } cont = cont $ do lift $ createDirectoryIfMissing hasFS True (mkFsPath []) ost <- mkOpenState volCodecConfig diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/ResourceRegistry.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/ResourceRegistry.hs index bddc8541ea8..2c7ff99ffb2 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/ResourceRegistry.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/ResourceRegistry.hs @@ -44,6 +44,7 @@ module Ouroboros.Consensus.Util.ResourceRegistry ( , modifyWithTempRegistry , runWithTempRegistry , runInnerWithTempRegistry + , runnableInnerWithTempRegistry -- ** opaque , WithTempRegistry -- * Combinators primarily for testing @@ -52,7 +53,7 @@ module Ouroboros.Consensus.Util.ResourceRegistry ( , unsafeNewRegistry -- * opaque , ResourceRegistry - ,InnerWithTempRegistry,completeComputation) where + ) where import Control.Applicative ((<|>)) import Control.Exception (asyncExceptionFromException) @@ -777,6 +778,9 @@ runWithTempRegistry m = withRegistry $ \rr -> do -- Combined with the following assumption, this establishes the invariant that -- all resources are (transitively) in a temporary registry. -- +-- As the resource might require some implementation details to be closed, the +-- function to close it will also be provided by the inner computation. +-- -- ASSUMPTION: closing @res@ closes every resource contained in @inner_st@ -- -- NOTE: In the current implementation, there will be a brief moment where the @@ -814,6 +818,17 @@ runInnerWithTempRegistry inner isTransferred = do withFixedTempRegistry env (WithTempRegistry (ReaderT f)) = WithTempRegistry $ ReaderT $ \_ -> f env +-- | Convenience function. +-- +-- When a @WithTempRegistry@ computation has the shape expected by +-- @runInnerWithTempRegistry@, but instead it is run directly, some of the +-- returned values have to be omitted. +runnableInnerWithTempRegistry + :: Monad m + => WithTempRegistry st m (a, st, st, st -> m Bool) + -> WithTempRegistry st m (a, st) +runnableInnerWithTempRegistry = (>>= \(a,b,_,_) -> return (a,b)) + -- | When 'runWithTempRegistry' exits successfully while there are still -- resources remaining in the temporary registry that haven't been transferred -- to the final state. @@ -860,11 +875,6 @@ instance MonadTrans (WithTempRegistry st) where instance MonadState s m => MonadState s (WithTempRegistry st m) where state = WithTempRegistry . state -type InnerWithTempRegistry st m a = WithTempRegistry st m (a, st, st, st -> m Bool) - -completeComputation :: Monad m => InnerWithTempRegistry st m a -> WithTempRegistry st m (a, st) -completeComputation w = w >>= \(a,b,_,_) -> return (a,b) - -- | Untrack all the resources from the registry that have been transferred to -- the given state. --