Further revamp

ouroboros-consensus-cardano/tools/db-analyser/Main.hs

@@ -240,7 +240,7 @@ analyse CmdLine {..} args =
             Nothing       -> pure genesisLedger
             Just snapshot -> readSnapshot ledgerDbFS (decodeExtLedgerState' cfg) decode snapshot
           initLedger <- either (error . show) pure initLedgerErr
-          ImmutableDB.withDB (ImmutableDB.openDB immutableDbArgs) $ \immutableDB -> do
+          ImmutableDB.withDB (runWithTempRegistry $ ImmutableDB.openDB immutableDbArgs) $ \immutableDB -> do
             runAnalysis analysis $ AnalysisEnv {
                 cfg
               , initLedger

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
+    (db, internal) <- runWithTempRegistry $ openDBInternal args
     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,6 +40,7 @@ import           Ouroboros.Network.Block (MaxSlotNo)
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Util.IOLike
+import           Ouroboros.Consensus.Util.ResourceRegistry (runWithTempRegistry)
 
 import           Ouroboros.Consensus.Storage.Common
 import           Ouroboros.Consensus.Storage.FS.API (SomeHasFS (..), hPutAll,
@@ -483,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
+    db <- runWithTempRegistry $ openDB args
     void $ swapMVar varDB db
 
 semanticsImpl :: VolatileDBEnv -> At CmdErr Concrete -> IO (At Resp Concrete)
@@ -587,7 +588,7 @@ test cmds = do
                  }
 
     (hist, res, trace) <- bracket
-      (openDB args >>= newMVar)
+      (runWithTempRegistry (openDB args) >>= 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/Node.hs

@@ -284,11 +284,9 @@ runWith RunNodeArgs{..} LowLevelRunNodeArgs{..} =
                 , ChainDB.cdbVolatileDbValidation  = ValidateAll
                 }
 
-
       chainDB <- openChainDB registry inFuture cfg initLedger
                 llrnChainDbArgsDefaults customiseChainDbArgs'
 
-
       btime <-
         hardForkBlockchainTime $
         llrnCustomiseHardForkBlockchainTimeArgs $

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DisambiguateRecordFields #-}
 {-# LANGUAGE FlexibleContexts         #-}
-{-# LANGUAGE GADTs                    #-}
 {-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE PatternSynonyms          #-}
 {-# LANGUAGE RecordWildCards          #-}
@@ -57,7 +56,7 @@ import           Ouroboros.Consensus.Util.STM (Fingerprint (..),
 
 import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
 import qualified Ouroboros.Consensus.Storage.ChainDB.API as API
-import           Ouroboros.Consensus.Util.ResourceRegistry (runWithTempRegistry, WithTempRegistry, decorateWithTempRegistry, allocate)
+import           Ouroboros.Consensus.Util.ResourceRegistry (runWithTempRegistry, allocate)
 
 import           Ouroboros.Consensus.Storage.ChainDB.Impl.Args (ChainDbArgs,
                      defaultArgs)
@@ -70,40 +69,8 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB as LgrDB
 import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query
 import           Ouroboros.Consensus.Storage.ChainDB.Impl.Types
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
-import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.State as ImmState
-import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl.State as VolState
-import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Cache as ImmCache
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 
-
-{-------------------------------------------------------------------------------
-  Resources
--------------------------------------------------------------------------------}
-
-data Resources m blk where
-  Resources
-    :: Eq h
-    => ImmState.OpenState m blk h
-    -> ImmCache.CacheEnv m blk h
-    -> VolState.OpenState blk h
-    -> Resources m blk
-
-runWithImmDBResources
-  :: forall blk m a.
-     (MonadSTM m)
-  => WithTempRegistry (ImmutableDB.Resources m blk) m a
-  -> WithTempRegistry (Resources m blk)   m a
-runWithImmDBResources action =
-  decorateWithTempRegistry action (\(ImmutableDB.Resources a b) -> Resources a b undefined)
-
-runWithVolDBResources
-  :: forall blk m a.
-     (MonadSTM m)
-  => WithTempRegistry (VolatileDB.Resources blk) m a
-  -> WithTempRegistry (Resources m blk)   m a
-runWithVolDBResources a =
-  decorateWithTempRegistry a (\(VolatileDB.Resources c) -> Resources undefined undefined c)
-
 {-------------------------------------------------------------------------------
   Initialization
 -------------------------------------------------------------------------------}
@@ -148,15 +115,15 @@ openDBInternal
   -> Bool -- ^ 'True' = Launch background tasks
   -> m (ChainDB m blk, Internal m blk)
 openDBInternal args launchBgTasks = runWithTempRegistry $ do
-    immutableDB <- runWithImmDBResources $ ImmutableDB.openDB argsImmutableDb
+    immutableDB <- fst <$> ImmutableDB.openDB argsImmutableDb
     immutableDbTipPoint <- lift $ atomically $ ImmutableDB.getTipPoint immutableDB
     let immutableDbTipChunk =
           chunkIndexOfPoint (Args.cdbChunkInfo args) immutableDbTipPoint
     lift $ traceWith tracer $
       TraceOpenEvent $
         OpenedImmutableDB immutableDbTipPoint immutableDbTipChunk
 
-    volatileDB <- runWithVolDBResources $ VolatileDB.openDB argsVolatileDb
+    volatileDB <- fst <$> VolatileDB.openDB argsVolatileDb
     lift $ traceWith tracer $ TraceOpenEvent OpenedVolatileDB
     let lgrReplayTracer =
           LgrDB.decorateReplayTracer
@@ -249,20 +216,15 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
       (castPoint $ AF.anchorPoint chain)
       (castPoint $ AF.headPoint   chain)
 
-    when launchBgTasks $ lift $ Background.launchBgTasks env replayed -- TODO @js
-
-    let res = resourcesFromChainDB env
+    when launchBgTasks $ lift $ Background.launchBgTasks env replayed
 
     _ <- lift $ allocate (Args.cdbRegistry args) (\_ -> return $ chainDB) API.closeDB
 
-    return ((chainDB, testing), res)
+    return ((chainDB, testing), ())
   where
     tracer = Args.cdbTracer args
     (argsImmutableDb, argsVolatileDb, argsLgrDb, _) = Args.fromChainDbArgs args
 
-    resourcesFromChainDB :: ChainDbEnv m blk -> Resources m blk
-    resourcesFromChainDB = undefined -- TODO @js
-
 isOpen :: IOLike m => ChainDbHandle m blk -> STM m Bool
 isOpen (CDBHandle varState) = readTVar varState <&> \case
     ChainDbClosed    -> False

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs

@@ -89,6 +89,7 @@ data ChainDbSpecificArgs f m blk = ChainDbSpecificArgs {
     , cdbsGcInterval      :: DiffTime
       -- ^ Batch all scheduled GCs so that at most one GC happens every
       -- 'cdbsGcInterval'.
+    , cdbsRegistry        :: HKD f (ResourceRegistry m)
     , cdbsTracer          :: Tracer m (TraceEvent blk)
     }
 
@@ -120,6 +121,7 @@ defaultSpecificArgs = ChainDbSpecificArgs {
     , cdbsCheckInFuture   = NoDefault
     , cdbsGcDelay         = secondsToDiffTime 60
     , cdbsGcInterval      = secondsToDiffTime 10
+    , cdbsRegistry        = NoDefault
     , cdbsTracer          = nullTracer
     }
 
@@ -163,6 +165,7 @@ fromChainDbArgs ChainDbArgs{..} = (
         , immChunkInfo        = cdbChunkInfo
         , immCodecConfig      = mapHKD (Proxy @(f (CodecConfig blk))) configCodec cdbTopLevelConfig
         , immHasFS            = cdbHasFSImmutableDB
+        , immRegistry         = cdbRegistry
         , immTracer           = contramap TraceImmutableDBEvent cdbTracer
         , immValidationPolicy = cdbImmutableDbValidation
         }
@@ -184,6 +187,7 @@ fromChainDbArgs ChainDbArgs{..} = (
         }
     , ChainDbSpecificArgs {
           cdbsTracer          = cdbTracer
+        , cdbsRegistry        = cdbRegistry
         , cdbsGcDelay         = cdbGcDelay
         , cdbsGcInterval      = cdbGcInterval
         , cdbsCheckInFuture   = cdbCheckInFuture
@@ -224,7 +228,7 @@ toChainDbArgs ImmutableDB.ImmutableDbArgs {..}
       -- Misc
     , cdbTracer                 = cdbsTracer
     , cdbTraceLedger            = lgrTraceLedger
-    , cdbRegistry               = undefined
+    , cdbRegistry               = cdbsRegistry
     , cdbGcDelay                = cdbsGcDelay
     , cdbGcInterval             = cdbsGcInterval
     , cdbBlocksToAddSize        = cdbsBlocksToAddSize

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs

@@ -61,8 +61,10 @@ import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Protocol.Abstract
+import           Ouroboros.Consensus.Util ((.:))
 import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.IOLike
+import           Ouroboros.Consensus.Util.ResourceRegistry
 
 import           Ouroboros.Consensus.Storage.ChainDB.API (BlockComponent (..))
 import           Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel
@@ -103,11 +105,7 @@ launchBgTasks cdb@CDB{..} replayed = do
       sequence_ [addBlockThread, gcThread, copyAndSnapshotThread]
   where
     launch :: String -> m Void -> m (m ())
-    launch t body =
-      fmap uninterruptibleCancel (do
-                                     me <- myThreadId
-                                     labelThread me t
-                                     async body)
+    launch = fmap cancelThread .: forkLinkedThread cdbRegistry
 
 {-------------------------------------------------------------------------------
   Copying blocks from the VolatileDB to the ImmutableDB

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE RecordWildCards           #-}
 {-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE TupleSections             #-}
 {-# LANGUAGE TypeApplications          #-}
 
 -- | Immutable on-disk database of binary blobs
@@ -97,8 +98,6 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Impl (
   , Internal (..)
   , deleteAfter
   , openDBInternal
-    -- * Resources
-  , Resources(..)
   ) where
 
 import qualified Codec.CBOR.Write as CBOR
@@ -113,7 +112,7 @@ import           Ouroboros.Consensus.Block hiding (headerHash)
 import           Ouroboros.Consensus.Util (SomePair (..))
 import           Ouroboros.Consensus.Util.Args
 import           Ouroboros.Consensus.Util.IOLike
-import           Ouroboros.Consensus.Util.ResourceRegistry (WithTempRegistry)
+import           Ouroboros.Consensus.Util.ResourceRegistry
 
 import           Ouroboros.Consensus.Storage.Common
 import           Ouroboros.Consensus.Storage.FS.API
@@ -146,6 +145,7 @@ data ImmutableDbArgs f m blk = ImmutableDbArgs {
     , immChunkInfo        :: HKD f ChunkInfo
     , immCodecConfig      :: HKD f (CodecConfig blk)
     , immHasFS            :: SomeHasFS m
+    , immRegistry         :: HKD f (ResourceRegistry m)
     , immTracer           :: Tracer m (TraceEvent blk)
     , immValidationPolicy :: ValidationPolicy
     }
@@ -158,6 +158,7 @@ defaultArgs immHasFS = ImmutableDbArgs {
     , immChunkInfo        = NoDefault
     , immCodecConfig      = NoDefault
     , immHasFS
+    , immRegistry         = NoDefault
     , immTracer           = nullTracer
     , immValidationPolicy = ValidateMostRecentChunk
     }
@@ -219,8 +220,8 @@ openDB ::
      , HasCallStack
      )
   => ImmutableDbArgs Identity m blk
-  -> WithTempRegistry (Resources m blk) m (ImmutableDB m blk)
-openDB args = fst <$> openDBInternal args
+  -> WithTempRegistry () m (ImmutableDB m blk, ())
+openDB args = (,()) . fst . fst <$> openDBInternal args
 
 -- | For testing purposes: exposes internals via 'Internal'
 --
@@ -234,7 +235,7 @@ openDBInternal ::
      , HasCallStack
      )
   => ImmutableDbArgs Identity m blk
-  -> WithTempRegistry (Resources m blk) m (ImmutableDB m blk, Internal m blk)
+  -> WithTempRegistry () m ((ImmutableDB m blk, Internal m blk), ())
 openDBInternal ImmutableDbArgs { immHasFS = SomeHasFS hasFS, .. } = do
     lift $ createDirectoryIfMissing hasFS True (mkFsPath [])
     let validateEnv = ValidateEnv {
@@ -245,8 +246,7 @@ openDBInternal ImmutableDbArgs { immHasFS = SomeHasFS hasFS, .. } = do
           , codecConfig    = immCodecConfig
           , checkIntegrity = immCheckIntegrity
           }
-
-    ost <- validateAndReopen validateEnv immValidationPolicy
+    ost <- validateAndReopen validateEnv immRegistry immValidationPolicy
 
     stVar <- lift $ newMVar (DbOpen ost)
 
@@ -274,7 +274,7 @@ openDBInternal ImmutableDbArgs { immHasFS = SomeHasFS hasFS, .. } = do
     -- Note that we can still leak resources if the caller of
     -- 'openDBInternal' doesn't bracket his call with 'closeDB' or doesn't
     -- use a 'ResourceRegistry'.
-    return (db, internal)
+    return ((db, internal), ())
 
 closeDBImpl ::
      forall m blk. (HasCallStack, IOLike m)

ouroboros-consensus/src/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index.hs

@@ -34,7 +34,7 @@ import           Ouroboros.Consensus.Storage.FS.API.Types (AllowExisting,
 
 import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks
 import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Cache
-                     (CacheConfig (..), CacheEnv)
+                     (CacheConfig (..))
 import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Cache as Cache
 import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Primary
                      (SecondaryOffset)
@@ -183,15 +183,16 @@ cachedIndex
   :: forall m blk h.
      (IOLike m, ConvertRawHash blk, StandardHash blk, Typeable blk)
   => HasFS m h
+  -> ResourceRegistry m
   -> Tracer m TraceCacheEvent
   -> CacheConfig
   -> ChunkInfo
   -> ChunkNo  -- ^ Current chunk
-  -> WithTempRegistry (CacheEnv m blk h) m (Index m blk h)
-cachedIndex hasFS tracer cacheConfig chunkInfo chunk = do
-    cacheEnv <- undefined --Cache.newEnv  Could not deduce (NoThunks (Async m Data.Void.Void))
-       -- arising from a use of ‘Cache.newEnv’
+  -> m (Index m blk h)
+cachedIndex hasFS registry tracer cacheConfig chunkInfo chunk = do
+    cacheEnv <- Cache.newEnv
                   hasFS
+                  registry
                   tracer
                   cacheConfig
                   chunkInfo