[CAD-3723] Add progress to initial chain selection

ouroboros-consensus-test/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs

@@ -187,7 +187,7 @@ initLgrDB k chain = do
     varDB          <- newTVarIO genesisLedgerDB
     varPrevApplied <- newTVarIO mempty
     let lgrDB = mkLgrDB varDB varPrevApplied resolve args
-    LgrDB.validate lgrDB genesisLedgerDB BlockCache.empty 0
+    LgrDB.validate lgrDB genesisLedgerDB BlockCache.empty 0 noopTrace
       (map getHeader (Chain.toOldestFirst chain)) >>= \case
         LgrDB.ValidateExceededRollBack _ ->
           error "impossible: rollback was 0"
@@ -208,6 +208,9 @@ initLgrDB k chain = do
 
     genesisLedgerDB = LgrDB.ledgerDbWithAnchor testInitExtLedger
 
+    noopTrace :: blk -> m ()
+    noopTrace = const $ pure ()
+
     args = LgrDbArgs
       { lgrTopLevelConfig       = cfg
       , lgrHasFS                = SomeHasFS (error "lgrHasFS" :: HasFS m ())

ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs

@@ -1598,6 +1598,8 @@ traceEventName = \case
     TraceCopyToImmutableDBEvent ev    -> "CopyToImmutableDB." <> constrName ev
     TraceInitChainSelEvent      ev    -> "InitChainSel."      <> case ev of
       InitChainSelValidation    ev' -> constrName ev'
+      StartedInitChainSelection     -> "StartedInitChainSelection"
+      InitalChainSelected           -> "InitalChainSelected"
     TraceOpenEvent              ev    -> "Open."              <> constrName ev
     TraceGCEvent                ev    -> "GC."                <> constrName ev
     TraceIteratorEvent          ev    -> "Iterator."          <> constrName ev

ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs

@@ -593,6 +593,7 @@ runDB standalone@DB{..} cmd =
               ledgerDbSwitch
                 dbLedgerDbCfg
                 n
+                (const $ pure ())
                 (map ApplyVal bs)
                 db
     go hasFS Snap = do

ouroboros-consensus/ouroboros-consensus.cabal

@@ -230,6 +230,7 @@ library
                        Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
                        Ouroboros.Consensus.Storage.LedgerDB.InMemory
                        Ouroboros.Consensus.Storage.LedgerDB.OnDisk
+                       Ouroboros.Consensus.Storage.LedgerDB.Types
                        Ouroboros.Consensus.Storage.Serialisation
                        Ouroboros.Consensus.Storage.VolatileDB
                        Ouroboros.Consensus.Storage.VolatileDB.API

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

@@ -144,16 +144,19 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
       varInvalid      <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0))
       varFutureBlocks <- newTVarIO Map.empty
 
+      let initChainSelTracer = contramap TraceInitChainSelEvent tracer
 
+      traceWith initChainSelTracer StartedInitChainSelection
       chainAndLedger <- ChainSel.initialChainSelection
                           immutableDB
                           volatileDB
                           lgrDB
-                          tracer
+                          initChainSelTracer
                           (Args.cdbTopLevelConfig args)
                           varInvalid
                           varFutureBlocks
                           (Args.cdbCheckInFuture args)
+      traceWith initChainSelTracer InitalChainSelected
 
       let chain  = VF.validatedFragment chainAndLedger
           ledger = VF.validatedLedger   chainAndLedger

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

@@ -90,7 +90,7 @@ initialChainSelection
   => ImmutableDB m blk
   -> VolatileDB m blk
   -> LgrDB m blk
-  -> Tracer m (TraceEvent blk)
+  -> Tracer m (TraceInitChainSelEvent blk)
   -> TopLevelConfig blk
   -> StrictTVar m (WithFingerprint (InvalidBlocks blk))
   -> StrictTVar m (FutureBlocks blk)
@@ -194,7 +194,7 @@ initialChainSelection immutableDB volatileDB lgrDB tracer cfg varInvalid
           , blockCache = BlockCache.empty
           , curChainAndLedger
           , trace = traceWith
-              (contramap (TraceInitChainSelEvent . InitChainSelValidation) tracer)
+              (contramap (InitChainSelValidation) tracer)
           }
 
 -- | Add a block to the ChainDB, /asynchronously/.
@@ -911,7 +911,7 @@ ledgerValidateCandidate
   -> ChainDiff (Header blk)
   -> m (ValidatedChainDiff (Header blk) (LedgerDB' blk))
 ledgerValidateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) =
-    LgrDB.validate lgrDB curLedger blockCache rollback newBlocks >>= \case
+    LgrDB.validate lgrDB curLedger blockCache rollback traceUpdate newBlocks >>= \case
       LgrDB.ValidateExceededRollBack {} ->
         -- Impossible: we asked the LgrDB to roll back past the immutable tip,
         -- which is impossible, since the candidates we construct must connect
@@ -933,6 +933,8 @@ ledgerValidateCandidate chainSelEnv chainDiff@(ChainDiff rollback suffix) =
     ChainSelEnv { lgrDB, trace, curChainAndLedger, blockCache, varInvalid } =
       chainSelEnv
 
+    traceUpdate = trace . UpdateLedgerDbTraceEvent
+
     curLedger :: LedgerDB' blk
     curLedger = VF.validatedLedger curChainAndLedger
 

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

@@ -51,6 +51,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB (
 import           Codec.CBOR.Decoding (Decoder)
 import           Codec.CBOR.Encoding (Encoding)
 import           Codec.Serialise (Serialise (decode))
+import           Control.Monad.Trans.Class
 import           Control.Tracer
 import           Data.Foldable (foldl')
 import           Data.Set (Set)
@@ -75,6 +76,8 @@ import           Ouroboros.Consensus.Storage.Common
 import           Ouroboros.Consensus.Storage.FS.API (SomeHasFS (..),
                      createDirectoryIfMissing)
 import           Ouroboros.Consensus.Storage.FS.API.Types (FsError, mkFsPath)
+import           Ouroboros.Consensus.Storage.LedgerDB.Types
+                     (UpdateLedgerDbTraceEvent (..))
 
 import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
                      (DiskPolicy (..))
@@ -366,14 +369,16 @@ validate :: forall m blk. (IOLike m, LedgerSupportsProtocol blk, HasCallStack)
             -- in the 'LgrDB'.
          -> BlockCache blk
          -> Word64  -- ^ How many blocks to roll back
+         -> (UpdateLedgerDbTraceEvent blk -> m ())
          -> [Header blk]
          -> m (ValidateResult blk)
-validate LgrDB{..} ledgerDB blockCache numRollbacks = \hdrs -> do
+validate LgrDB{..} ledgerDB blockCache numRollbacks trace = \hdrs -> do
     aps <- mkAps hdrs <$> atomically (readTVar varPrevApplied)
     res <- fmap rewrap $ LedgerDB.defaultResolveWithErrors resolveBlock $
              LedgerDB.ledgerDbSwitch
                (configLedgerDb cfg)
                numRollbacks
+               (lift . lift . trace)
                aps
                ledgerDB
     atomically $ modifyTVar varPrevApplied $

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

@@ -78,6 +78,8 @@ import           Ouroboros.Consensus.Fragment.InFuture (CheckInFuture)
 import           Ouroboros.Consensus.Ledger.Extended (ExtValidationError)
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
+import           Ouroboros.Consensus.Storage.LedgerDB.Types
+                     (UpdateLedgerDbTraceEvent)
 import           Ouroboros.Consensus.Util.CallStack
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Consensus.Util.ResourceRegistry
@@ -668,6 +670,7 @@ data TraceValidationEvent blk =
       -- ^ Candidate chain containing headers from the future
       [Header blk]
       -- ^ Headers from the future, exceeding clock skew
+  | UpdateLedgerDbTraceEvent (UpdateLedgerDbTraceEvent blk)
   deriving (Generic)
 
 deriving instance
@@ -680,8 +683,13 @@ deriving instance
   , LedgerSupportsProtocol blk
   ) => Show (TraceValidationEvent blk)
 
-data TraceInitChainSelEvent blk
-  = InitChainSelValidation (TraceValidationEvent blk)
+data TraceInitChainSelEvent blk =
+    StartedInitChainSelection
+    -- ^ An event traced when inital chain selection has started during the
+    -- initialization of ChainDB
+  | InitalChainSelected
+    -- ^ An event traced when inital chain has been selected
+  | InitChainSelValidation (TraceValidationEvent blk)
     -- ^ An event traced during validation performed while performing initial
     -- chain selection.
   deriving (Generic)

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

@@ -76,6 +76,8 @@ import qualified Ouroboros.Network.AnchoredSeq as AS
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Ledger.Abstract
+import           Ouroboros.Consensus.Storage.LedgerDB.Types (PushGoal (..),
+                     Pushing (..), UpdateLedgerDbTraceEvent (..))
 import           Ouroboros.Consensus.Ticked
 import           Ouroboros.Consensus.Util
 import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin)
@@ -265,6 +267,13 @@ data Ap :: (Type -> Type) -> Type -> Type -> Constraint -> Type where
   Internal utilities for 'Ap'
 -------------------------------------------------------------------------------}
 
+toRealPoint :: HasHeader blk => Ap m l blk c -> RealPoint blk
+toRealPoint (ReapplyVal blk) = blockRealPoint blk
+toRealPoint (ApplyVal blk)   = blockRealPoint blk
+toRealPoint (ReapplyRef rp)  = rp
+toRealPoint (ApplyRef rp)    = rp
+toRealPoint (Weaken ap)      = toRealPoint ap
+
 -- | Apply block to the current ledger state
 --
 -- We take in the entire 'LedgerDB' because we record that as part of errors.
@@ -428,27 +437,36 @@ ledgerDbPush cfg ap db =
       applyBlock (ledgerDbCfg cfg) ap db
 
 -- | Push a bunch of blocks (oldest first)
-ledgerDbPushMany :: (ApplyBlock l blk, Monad m, c)
-                 => LedgerDbCfg l
-                 -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
-ledgerDbPushMany = repeatedlyM . ledgerDbPush
+ledgerDbPushMany ::
+     forall m c l blk . (ApplyBlock l blk, Monad m, c)
+  => (UpdateLedgerDbTraceEvent blk -> m ())
+  -> LedgerDbCfg l
+  -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
+ledgerDbPushMany trace cfg aps initDb = (repeatedlyM pushAndTrace) aps initDb
+  where
+    pushAndTrace ap db = do
+      let pushing = Pushing . toRealPoint $ ap
+          goal    = PushGoal . toRealPoint . last $ aps
+      trace $ StartedPushingBlockToTheLedgerDb pushing goal
+      ledgerDbPush cfg ap db
 
 -- | Switch to a fork
 ledgerDbSwitch :: (ApplyBlock l blk, Monad m, c)
                => LedgerDbCfg l
                -> Word64          -- ^ How many blocks to roll back
+               -> (UpdateLedgerDbTraceEvent blk -> m ())
                -> [Ap m l blk c]  -- ^ New blocks to apply
                -> LedgerDB l
                -> m (Either ExceededRollback (LedgerDB l))
-ledgerDbSwitch cfg numRollbacks newBlocks db =
+ledgerDbSwitch cfg numRollbacks trace newBlocks db =
     case rollback numRollbacks db of
       Nothing ->
         return $ Left $ ExceededRollback {
             rollbackMaximum   = ledgerDbMaxRollback db
           , rollbackRequested = numRollbacks
           }
       Just db' ->
-        Right <$> ledgerDbPushMany cfg newBlocks db'
+        Right <$> ledgerDbPushMany trace cfg newBlocks db'
 
 {-------------------------------------------------------------------------------
   The LedgerDB itself behaves like a ledger
@@ -524,13 +542,14 @@ ledgerDbPush' cfg b = runIdentity . ledgerDbPush cfg (pureBlock b)
 
 ledgerDbPushMany' :: ApplyBlock l blk
                   => LedgerDbCfg l -> [blk] -> LedgerDB l -> LedgerDB l
-ledgerDbPushMany' cfg bs = runIdentity . ledgerDbPushMany cfg (map pureBlock bs)
+ledgerDbPushMany' cfg bs =
+  runIdentity . ledgerDbPushMany (const $ pure ()) cfg (map pureBlock bs)
 
 ledgerDbSwitch' :: forall l blk. ApplyBlock l blk
                 => LedgerDbCfg l
                 -> Word64 -> [blk] -> LedgerDB l -> Maybe (LedgerDB l)
 ledgerDbSwitch' cfg n bs db =
-    case runIdentity $ ledgerDbSwitch cfg n (map pureBlock bs) db of
+    case runIdentity $ ledgerDbSwitch cfg n (const $ pure ()) (map pureBlock bs) db of
       Left  ExceededRollback{} -> Nothing
       Right db'                -> Just db'
 

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

@@ -60,6 +60,8 @@ import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
+import           Ouroboros.Consensus.Storage.LedgerDB.Types
+                     (UpdateLedgerDbTraceEvent (..))
 import           Ouroboros.Consensus.Util.CBOR (ReadIncrementalErr,
                      readIncremental)
 import           Ouroboros.Consensus.Util.IOLike
@@ -323,6 +325,7 @@ initStartingWith tracer cfg streamAPI initDb = do
                        (ledgerState (ledgerDbCurrent db))
                        (ledgerState (ledgerDbCurrent db'))
 
+
         traceWith tracer (ReplayedBlock (blockRealPoint blk) events ())
         return (db', replayed')
 
@@ -496,7 +499,6 @@ snapshotFromPath fileName = do
 {-------------------------------------------------------------------------------
   Trace events
 -------------------------------------------------------------------------------}
-
 data TraceEvent blk
   = InvalidSnapshot DiskSnapshot (InitFailure blk)
     -- ^ An on disk snapshot was skipped because it was invalid.
@@ -533,4 +535,5 @@ data TraceReplayEvent blk replayTo
     -- The @blockInfo@ parameter corresponds replayed block and the @replayTo@
     -- parameter corresponds to the block at the tip of the ImmutableDB, i.e.,
     -- the last block to replay.
+  | UpdateLedgerDbTraceEvent (UpdateLedgerDbTraceEvent blk)
   deriving (Generic, Eq, Show, Functor, Foldable, Traversable)

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

@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveGeneric #-}
+module Ouroboros.Consensus.Storage.LedgerDB.Types (
+    PushGoal (..)
+  , Pushing (..)
+  , UpdateLedgerDbTraceEvent (..)
+  ) where
+
+
+import           GHC.Generics (Generic)
+import           Ouroboros.Consensus.Block.RealPoint (RealPoint)
+
+{-------------------------------------------------------------------------------
+  Trace events
+-------------------------------------------------------------------------------}
+newtype PushGoal blk = PushGoal { unPushGoal :: RealPoint blk }
+  deriving (Show, Eq)
+
+newtype Pushing blk = Pushing { unPushing :: RealPoint blk }
+  deriving (Show, Eq)
+
+data UpdateLedgerDbTraceEvent blk =
+    -- | Event fired when we are about to push a block to the LedgerDB
+      StartedPushingBlockToTheLedgerDb
+        !(Pushing blk)
+        -- ^ Point which block we are about to push
+        (PushGoal blk)
+        -- ^ Point to which we are updating the ledger, the last event
+        -- StartedPushingBlockToTheLedgerDb will have Pushing and PushGoal
+        -- wrapping over the same RealPoint
+  deriving (Show, Eq, Generic)