LedgerDB: refactor acquireAtTarget

No behavioral change, just a refactoring by extracting common parts; convenient
for follow-up changes

Author: amesgen

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

@@ -23,6 +23,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1 (mkInitDb) where
 import Control.Arrow ((>>>))
 import Control.Monad
 import Control.Monad.Except
+import Control.Monad.Trans (lift)
 import Control.ResourceRegistry
 import Control.Tracer
 import Data.Bifunctor (first)
@@ -721,38 +722,30 @@ acquireAtTarget ::
   ResourceRegistry m ->
   Either Word64 (Target (Point blk)) ->
   ReadLocked m (Either GetForkerError (Resources m l))
-acquireAtTarget ldbEnv rr (Right VolatileTip) =
-  readLocked $ do
-    dblog <- readTVarIO (ldbChangelog ldbEnv)
-    Right . (,dblog) <$> acquire ldbEnv rr dblog
-acquireAtTarget ldbEnv rr (Right ImmutableTip) =
-  readLocked $ do
-    dblog <- readTVarIO (ldbChangelog ldbEnv)
-    Right . (,rollbackToAnchor dblog)
-      <$> acquire ldbEnv rr dblog
-acquireAtTarget ldbEnv rr (Right (SpecificPoint pt)) =
-  readLocked $ do
-    dblog <- readTVarIO (ldbChangelog ldbEnv)
-    let immTip = getTip $ anchor dblog
-    case rollback pt dblog of
-      Nothing
-        | pointSlot pt < pointSlot immTip -> pure $ Left $ PointTooOld Nothing
-        | otherwise -> pure $ Left PointNotOnChain
-      Just dblog' -> Right . (,dblog') <$> acquire ldbEnv rr dblog'
-acquireAtTarget ldbEnv rr (Left n) = readLocked $ do
-  dblog <- readTVarIO (ldbChangelog ldbEnv)
-  case rollbackN n dblog of
-    Nothing ->
-      return $
-        Left $
+acquireAtTarget ldbEnv rr target = readLocked $ runExceptT $ do
+  dblog <- lift $ readTVarIO (ldbChangelog ldbEnv)
+  -- Get the prefix of the dblog ending in the specified target.
+  dblog' <- case target of
+    Right VolatileTip -> pure dblog
+    Right ImmutableTip -> pure $ rollbackToAnchor dblog
+    Right (SpecificPoint pt) -> do
+      let immTip = getTip $ anchor dblog
+      case rollback pt dblog of
+        Nothing
+          | pointSlot pt < pointSlot immTip -> throwError $ PointTooOld Nothing
+          | otherwise -> throwError PointNotOnChain
+        Just dblog' -> pure dblog'
+    Left n -> case rollbackN n dblog of
+      Nothing ->
+        throwError $
           PointTooOld $
-            Just $
+            Just
               ExceededRollback
                 { rollbackMaximum = maxRollback dblog
                 , rollbackRequested = n
                 }
-    Just dblog' ->
-      Right . (,dblog') <$> acquire ldbEnv rr dblog'
+      Just dblog' -> pure dblog'
+  lift $ (,dblog') <$> acquire ldbEnv rr dblog'
 
 acquire ::
   (IOLike m, GetTip l) =>

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

@@ -20,6 +20,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2 (mkInitDb) where
 import Control.Arrow ((>>>))
 import qualified Control.Monad as Monad (void, (>=>))
 import Control.Monad.Except
+import Control.Monad.Trans (lift)
 import Control.RAWLock
 import qualified Control.RAWLock as RAWLock
 import Control.ResourceRegistry
@@ -563,39 +564,30 @@ acquireAtTarget ::
   Either Word64 (Target (Point blk)) ->
   LDBLock ->
   m (Either GetForkerError (StateRef m l))
-acquireAtTarget ldbEnv (Right VolatileTip) _ = do
-  l <- readTVarIO (ldbSeq ldbEnv)
-  let StateRef st tbs = currentHandle l
-  t <- duplicate tbs
-  pure $ Right $ StateRef st t
-acquireAtTarget ldbEnv (Right ImmutableTip) _ = do
-  l <- readTVarIO (ldbSeq ldbEnv)
-  let StateRef st tbs = anchorHandle l
-  t <- duplicate tbs
-  pure $ Right $ StateRef st t
-acquireAtTarget ldbEnv (Right (SpecificPoint pt)) _ = do
-  dblog <- readTVarIO (ldbSeq ldbEnv)
-  let immTip = getTip $ anchor dblog
-  case currentHandle <$> rollback pt dblog of
-    Nothing
-      | pointSlot pt < pointSlot immTip -> pure $ Left $ PointTooOld Nothing
-      | otherwise -> pure $ Left PointNotOnChain
-    Just (StateRef st tbs) ->
-      Right . StateRef st <$> duplicate tbs
-acquireAtTarget ldbEnv (Left n) _ = do
-  dblog <- readTVarIO (ldbSeq ldbEnv)
-  case currentHandle <$> rollbackN n dblog of
-    Nothing ->
-      return $
-        Left $
+acquireAtTarget ldbEnv target _ = runExceptT $ do
+  l <- lift $ readTVarIO (ldbSeq ldbEnv)
+  StateRef st tbs <- case target of
+    Right VolatileTip -> pure $ currentHandle l
+    Right ImmutableTip -> pure $ anchorHandle l
+    Right (SpecificPoint pt) -> do
+      let immTip = getTip $ anchor l
+      case rollback pt l of
+        Nothing
+          | pointSlot pt < pointSlot immTip -> throwError $ PointTooOld Nothing
+          | otherwise -> throwError PointNotOnChain
+        Just t' -> pure $ currentHandle t'
+    Left n -> case rollbackN n l of
+      Nothing ->
+        throwError $
           PointTooOld $
-            Just $
+            Just
               ExceededRollback
-                { rollbackMaximum = maxRollback dblog
+                { rollbackMaximum = maxRollback l
                 , rollbackRequested = n
                 }
-    Just (StateRef st tbs) ->
-      Right . StateRef st <$> duplicate tbs
+      Just l' -> pure $ currentHandle l'
+  tbs' <- lift $ duplicate tbs
+  pure $ StateRef st tbs'
 
 newForkerAtTarget ::
   ( HeaderHash l ~ HeaderHash blk