Forward-port of #1746: Fix double read-lock acquisition in V1 (#1747)

Forward-port of #1746

Author: geo2a

ouroboros-consensus/changelog.d/20251030_130836_javier.sagredo_fix_double_read_lock.md

@@ -0,0 +1,25 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+### Patch
+
+- Fix double read lock acquisition when opening a forker in LedgerDB V1.
+- Ensure the read lock acquired when opening a forker is released in the presence of exceptions.
+- Ensure the forker is tracked in the resource registry from the start and it will only deallocate the read lock once.
+
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs

@@ -722,12 +722,7 @@ newForkerAtTarget ::
   ResourceRegistry m ->
   Target (Point blk) ->
   m (Either GetForkerError (Forker m l blk))
-newForkerAtTarget h rr pt = getEnv h $ \ldbEnv ->
-  withReadLock
-    (ldbLock ldbEnv)
-    ( acquireAtTarget ldbEnv (Right pt)
-        >>= traverse (newForker h ldbEnv rr)
-    )
+newForkerAtTarget h rr pt = withTransferrableReadAccess h rr (Right pt)
 
 newForkerByRollback ::
   ( HeaderHash l ~ HeaderHash blk
@@ -742,8 +737,41 @@ newForkerByRollback ::
   -- | How many blocks to rollback from the tip
   Word64 ->
   m (Either GetForkerError (Forker m l blk))
-newForkerByRollback h rr n = getEnv h $ \ldbEnv -> do
-  withReadLock (ldbLock ldbEnv) (acquireAtTarget ldbEnv (Left n) >>= traverse (newForker h ldbEnv rr))
+newForkerByRollback h rr n = withTransferrableReadAccess h rr (Left n)
+
+-- | Acquire read access and then allocate a forker, acquiring it at the given
+-- point or rollback.
+withTransferrableReadAccess ::
+  ( HeaderHash l ~ HeaderHash blk
+  , IOLike m
+  , IsLedger l
+  , StandardHash l
+  , HasLedgerTables l
+  , LedgerSupportsProtocol blk
+  ) =>
+  LedgerDBHandle m l blk ->
+  ResourceRegistry m ->
+  Either Word64 (Target (Point blk)) ->
+  m (Either GetForkerError (Forker m l blk))
+withTransferrableReadAccess h rr f = getEnv h $ \ldbEnv -> do
+  -- This TVar will be used to maybe release the read lock by the resource
+  -- registry. Once the forker was opened it will be emptied.
+  tv <- newTVarIO (pure ())
+  (rk, _) <-
+    allocate
+      rr
+      ( \_ -> atomically $ do
+          -- Populate the tvar with the releasing action. Creating the forker will empty this
+          writeTVar tv (atomically $ unsafeReleaseReadAccess (ldbLock ldbEnv))
+          -- Acquire the read access
+          unsafeAcquireReadAccess (ldbLock ldbEnv)
+      )
+      ( \_ ->
+          -- Run the contents of the releasing TVar which will be `pure ()` if
+          -- the forker was opened.
+          join $ readTVarIO tv
+      )
+  unsafeRunReadLocked (acquireAtTarget ldbEnv f >>= traverse (newForker h ldbEnv (rk, tv) rr))
 
 -- | Acquire both a value handle and a db changelog at the tip. Holds a read lock
 -- while doing so.
@@ -801,6 +829,7 @@ acquireAtTarget ldbEnv target = readLocked $ runExceptT $ do
 -------------------------------------------------------------------------------}
 
 newForker ::
+  forall m l blk.
   ( IOLike m
   , HasLedgerTables l
   , LedgerSupportsProtocol blk
@@ -810,33 +839,42 @@ newForker ::
   ) =>
   LedgerDBHandle m l blk ->
   LedgerDBEnv m l blk ->
+  (ResourceKey m, StrictTVar m (m ())) ->
   ResourceRegistry m ->
   DbChangelog l ->
   ReadLocked m (Forker m l blk)
-newForker h ldbEnv rr dblog = readLocked $ do
-  dblogVar <- newTVarIO dblog
-  forkerKey <- atomically $ stateTVar (ldbNextForkerKey ldbEnv) $ \r -> (r, r + 1)
-  forkerMVar <- newMVar $ Left (ldbLock ldbEnv, ldbBackingStore ldbEnv, rr)
-  let forkerEnv =
-        ForkerEnv
-          { foeBackingStoreValueHandle = forkerMVar
-          , foeChangelog = dblogVar
-          , foeSwitchVar = ldbChangelog ldbEnv
-          , foeTracer =
-              LedgerDBForkerEvent . TraceForkerEventWithKey forkerKey >$< ldbTracer ldbEnv
-          }
-  atomically $ do
-    -- We need to make sure to release this read access when we drop the value
-    -- handle, so in 'closeForkerEnv' (if it wasn't promoted) or in
-    -- 'getValueHandle' (if it was promoted).
-    unsafeAcquireReadAccess (ldbLock ldbEnv)
-
-    -- Note that we add the forkerEnv to the 'ldbForkers' so that an exception
-    -- which will close all the forkers, also closes this one, releasing the
-    -- read access we acquired above.
-    modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
-  traceWith (foeTracer forkerEnv) ForkerOpen
-  pure $ mkForker h (ldbQueryBatchSize ldbEnv) forkerKey forkerEnv
+newForker h ldbEnv (rk, releaseVar) rr dblog =
+  readLocked $ do
+    (rk', frk) <-
+      allocate
+        rr
+        ( \_ -> do
+            dblogVar <- newTVarIO dblog
+            forkerKey <- atomically $ stateTVar (ldbNextForkerKey ldbEnv) $ \r -> (r, r + 1)
+            forkerMVar <- newMVar $ Left (ldbLock ldbEnv, ldbBackingStore ldbEnv, rr)
+            let forkerEnv =
+                  ForkerEnv
+                    { foeBackingStoreValueHandle = forkerMVar
+                    , foeChangelog = dblogVar
+                    , foeSwitchVar = ldbChangelog ldbEnv
+                    , foeTracer =
+                        LedgerDBForkerEvent . TraceForkerEventWithKey forkerKey >$< ldbTracer ldbEnv
+                    }
+            atomically $ do
+              -- Note that we add the forkerEnv to the 'ldbForkers' so that an exception
+              -- which will close all the forkers, also closes this one, releasing the
+              -- read access we acquired above.
+              modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
+              -- Empty the tvar created for allocating the unsafe read access,
+              -- so that it is the forker the one that takes care of releasing
+              -- it.
+              writeTVar releaseVar (pure ())
+            void $ release rk
+            traceWith (foeTracer forkerEnv) ForkerOpen
+            pure $ (mkForker h (ldbQueryBatchSize ldbEnv) forkerKey forkerEnv)
+        )
+        forkerClose
+    pure $ frk{forkerClose = void $ release rk'}
 
 mkForker ::
   ( IOLike m

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs

@@ -90,10 +90,14 @@ deriving instance
 
 closeForkerEnv :: IOLike m => ForkerEnv m l blk -> m ()
 closeForkerEnv ForkerEnv{foeBackingStoreValueHandle} = do
-  either
-    (\(l, _, _) -> atomically . unsafeReleaseReadAccess $ l)
-    (Monad.void . release . fst)
-    =<< takeMVar foeBackingStoreValueHandle
+  -- If this MVar is empty, we already closed the forker in the past so do nothing.
+  tryTakeMVar foeBackingStoreValueHandle >>= \case
+    -- We already closed the forker in the past, so do nothing.
+    Nothing -> pure ()
+    -- Release the read lock.
+    Just (Left (lock, _, _)) -> atomically $ unsafeReleaseReadAccess lock
+    -- Release the value handle
+    Just (Right (bsvh, _)) -> Monad.void $ release bsvh
 
 {-------------------------------------------------------------------------------
   Acquiring consistent views
@@ -110,6 +114,7 @@ getValueHandle ForkerEnv{foeBackingStoreValueHandle, foeChangelog} =
       dblogSlot <- getTipSlot . changelogLastFlushedState <$> readTVarIO foeChangelog
       if bsvhAtSlot bsvh == dblogSlot
         then do
+          -- Release the read lock acquired when opening the forker.
           atomically $ unsafeReleaseReadAccess l
           pure (Right (k, bsvh), bsvh)
         else

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Lock.hs

@@ -9,7 +9,7 @@
 module Ouroboros.Consensus.Storage.LedgerDB.V1.Lock
   ( -- * LedgerDB lock
     LedgerDBLock
-  , ReadLocked
+  , ReadLocked (..)
   , WriteLocked
   , mkLedgerDBLock
   , readLocked
@@ -59,7 +59,7 @@ mkLedgerDBLock :: IOLike m => m (LedgerDBLock m)
 mkLedgerDBLock = LedgerDBLock <$> Lock.new ()
 
 -- | An action in @m@ that has to hold the read lock. See @withReadLock@.
-newtype ReadLocked m a = ReadLocked {runReadLocked :: m a}
+newtype ReadLocked m a = ReadLocked {unsafeRunReadLocked :: m a}
   deriving newtype (Functor, Applicative, Monad)
 
 -- | Enforce that the action has to be run while holding the read lock.
@@ -69,7 +69,7 @@ readLocked = ReadLocked
 -- | Acquire the ledger DB read lock and hold it while performing an action
 withReadLock :: IOLike m => LedgerDBLock m -> ReadLocked m a -> m a
 withReadLock (LedgerDBLock lock) m =
-  Lock.withReadAccess lock (\() -> runReadLocked m)
+  Lock.withReadAccess lock (\() -> unsafeRunReadLocked m)
 
 -- | An action in @m@ that has to hold the write lock. See @withWriteLock@.
 newtype WriteLocked m a = WriteLocked {runWriteLocked :: m a}