Further revamp III

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'.

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.

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

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

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.
 --