Cleanup ChainSelection and LedgerDB (#1880)

# Description

The ContT experiment showed some improvements that could be made for
clarity on both ChainSelection and the LedgerDB. The Changelog fragment
describes each cleanup.

Author: jasagredo

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs

@@ -436,11 +436,11 @@ storeLedgerStateAt slotNo ledgerAppMode env = do
   FromLedgerState initLedgerDB internal = startFrom
 
   process :: () -> blk -> IO (NextStep, ())
-  process _ blk = do
+  process _ blk = withRegistry $ \reg -> do
     let ledgerCfg = ExtLedgerCfg cfg
     oldLedger <- IOLike.atomically $ LedgerDB.getVolatileTip initLedgerDB
     frk <-
-      LedgerDB.getForkerAtTarget initLedgerDB registry VolatileTip >>= \case
+      LedgerDB.getForkerAtTarget initLedgerDB reg VolatileTip >>= \case
         Left{} -> error "Unreachable, volatile tip MUST be in the LedgerDB"
         Right f -> pure f
     tbs <- LedgerDB.forkerReadTables frk (getBlockKeySets blk)

ouroboros-consensus/changelog.d/20260216_123105_javier.sagredo_cleanup_chainsel.md

@@ -0,0 +1,41 @@
+<!--
+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
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Cleanup Chain selection:
+  - Removed `Ouroboros.Consensus.Fragment.Validated` as it was only an
+    indirection over `Ouroboros.Consensus.Fragment.ValidatedDiff`.
+  - Initial chain selection now also performs the commit on the forker and
+    returns only the selected fragment of headers.
+  - Deleted `ChainAndLedger` as it was an unnecessary indirection.
+  - Deleted `validateCandidate` as it was an unnecessary indirection to
+    `ledgerValidateCandidate` which was now renamed to `validatedCandidate`.
+- Cleanup LedgerDB:
+  - `validateFork` allows for `l` other than `ExtLedgerState`.
+  - `validateFork` expects a non-empty list of headers.
+  - `ValidateArgs` now expects an `l` that can be different to `ExtLedgerState`.
+  - `Ap` has been simplified to monomorphize the constraints. `applyBlock` and
+    related functions now run on an appropriate monad.
+  - Classes `ThrowsLedgerErrors` and `ResolvesBlocks` have been deletes as
+    unnecessary.
+  - `MonadBase` scattered constraints have been removed as unnecessary.
+  - `AnnLedgerError` carries a point to the latest valid block instead of a
+    forker.

ouroboros-consensus/ouroboros-consensus.cabal

@@ -98,7 +98,6 @@ library
     Ouroboros.Consensus.Config.SupportsNode
     Ouroboros.Consensus.Forecast
     Ouroboros.Consensus.Fragment.Diff
-    Ouroboros.Consensus.Fragment.Validated
     Ouroboros.Consensus.Fragment.ValidatedDiff
     Ouroboros.Consensus.Genesis.Governor
     Ouroboros.Consensus.HardFork.Abstract
@@ -371,7 +370,6 @@ library
     these ^>=1.2,
     time,
     transformers,
-    transformers-base,
     typed-protocols ^>=1.2,
     vector ^>=0.13,
 
@@ -567,7 +565,6 @@ library unstable-consensus-testlib
     temporary,
     text,
     time,
-    transformers-base,
     tree-diff,
     utf8-string,
     vector,
@@ -726,7 +723,6 @@ test-suite consensus-test
     tasty-quickcheck,
     time,
     transformers,
-    transformers-base,
     tree-diff,
     typed-protocols:{examples, stateful, typed-protocols} ^>=1.2,
     unstable-consensus-testlib,

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Validated.hs

@@ -12,21 +12,16 @@ module Ouroboros.Consensus.Fragment.ValidatedDiff
   ( ValidatedChainDiff (ValidatedChainDiff)
   , getChainDiff
   , getLedger
-  , new
-  , toValidatedFragment
 
     -- * Monadic
   , newM
-  , toValidatedFragmentM
   ) where
 
 import Control.Monad.Except (throwError)
 import GHC.Stack (HasCallStack)
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Fragment.Diff (ChainDiff)
 import qualified Ouroboros.Consensus.Fragment.Diff as Diff
-import Ouroboros.Consensus.Fragment.Validated (ValidatedFragment)
-import qualified Ouroboros.Consensus.Fragment.Validated as VF
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Util.Assert
 import Ouroboros.Consensus.Util.IOLike (MonadSTM (..))
@@ -52,21 +47,6 @@ pattern ValidatedChainDiff d l <- UnsafeValidatedChainDiff d l
 
 {-# COMPLETE ValidatedChainDiff #-}
 
--- | Create a 'ValidatedChainDiff'.
---
--- PRECONDITION:
---
--- > getTip chainDiff == ledgerTipPoint ledger
-new ::
-  forall b l mk.
-  (GetTip l, HasHeader b, HeaderHash l ~ HeaderHash b, HasCallStack) =>
-  ChainDiff b ->
-  l mk ->
-  ValidatedChainDiff b (l mk)
-new chainDiff ledger =
-  assertWithMsg (pointInvariant (getTip ledger) chainDiff) $
-    UnsafeValidatedChainDiff chainDiff ledger
-
 pointInvariant ::
   forall l b.
   (HeaderHash b ~ HeaderHash l, HasHeader b) =>
@@ -88,17 +68,15 @@ pointInvariant ledgerTip0 chainDiff = precondition
             <> " /= "
             <> show ledgerTip
 
-toValidatedFragment ::
-  (GetTip l, HasHeader b, HeaderHash l ~ HeaderHash b, HasCallStack) =>
-  ValidatedChainDiff b (l mk) ->
-  ValidatedFragment b (l mk)
-toValidatedFragment (UnsafeValidatedChainDiff cs l) =
-  VF.ValidatedFragment (Diff.getSuffix cs) l
-
 {-------------------------------------------------------------------------------
   Monadic
 -------------------------------------------------------------------------------}
 
+-- | Create a 'ValidatedChainDiff'.
+--
+-- PRECONDITION:
+--
+-- > getTip chainDiff == ledgerTipPoint ledger
 newM ::
   forall m b l.
   ( MonadSTM m
@@ -115,15 +93,3 @@ newM chainDiff ledger = do
   pure $
     assertWithMsg (pointInvariant ledgerTip chainDiff) $
       UnsafeValidatedChainDiff chainDiff ledger
-
-toValidatedFragmentM ::
-  ( MonadSTM m
-  , GetTipSTM m l
-  , HasHeader b
-  , HeaderHash l ~ HeaderHash b
-  , HasCallStack
-  ) =>
-  ValidatedChainDiff b l ->
-  m (ValidatedFragment b l)
-toValidatedFragmentM (UnsafeValidatedChainDiff cs l) =
-  VF.newM (Diff.getSuffix cs) l

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs

@@ -58,7 +58,6 @@ import GHC.Stack (HasCallStack)
 import NoThunks.Class
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
-import qualified Ouroboros.Consensus.Fragment.Validated as VF
 import Ouroboros.Consensus.HardFork.Abstract
 import Ouroboros.Consensus.HeaderValidation (mkHeaderWithTime)
 import Ouroboros.Consensus.Ledger.Extended (ledgerState)
@@ -185,26 +184,18 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
     traceWith initChainSelTracer StartedInitChainSelection
     initialLoE <- Args.cdbsLoE cdbSpecificArgs
     initialWeights <- atomically $ PerasCertDB.getWeightSnapshot perasCertDB
-    chain <- withRegistry $ \rr -> do
-      chainAndLedger <-
-        ChainSel.initialChainSelection
-          immutableDB
-          volatileDB
-          lgrDB
-          rr
-          initChainSelTracer
-          (Args.cdbsTopLevelConfig cdbSpecificArgs)
-          varInvalid
-          (void initialLoE)
-          (forgetFingerprint initialWeights)
-      traceWith initChainSelTracer InitialChainSelected
-
-      let chain = VF.validatedFragment chainAndLedger
-          ledger = VF.validatedLedger chainAndLedger
-
-      atomically $ LedgerDB.forkerCommit ledger
-      LedgerDB.forkerClose ledger
-      pure chain
+    chain <- withRegistry $ \rr ->
+      ChainSel.initialChainSelection
+        immutableDB
+        volatileDB
+        lgrDB
+        rr
+        initChainSelTracer
+        (Args.cdbsTopLevelConfig cdbSpecificArgs)
+        varInvalid
+        (void initialLoE)
+        (forgetFingerprint initialWeights)
+    traceWith initChainSelTracer InitialChainSelected
     LedgerDB.tryFlush lgrDB
 
     curLedger <- atomically $ LedgerDB.getVolatileTip lgrDB