[CAD-3723] Add progress to initial chain selection

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

@@ -76,8 +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
-                     (UpdateLedgerDbTraceEvent (..))
+import           Ouroboros.Consensus.Storage.LedgerDB.Types (PushGoal (..),
+                     Pushing (..), UpdateLedgerDbTraceEvent (..))
 import           Ouroboros.Consensus.Ticked
 import           Ouroboros.Consensus.Util
 import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin)
@@ -437,16 +437,22 @@ ledgerDbPush cfg ap db =
       applyBlock (ledgerDbCfg cfg) ap db
 
 -- | Push a bunch of blocks (oldest first)
-ledgerDbPushMany :: (ApplyBlock l blk, Monad m, c)
-                 => (UpdateLedgerDbTraceEvent blk -> m ())
-                 -> LedgerDbCfg l
-                 -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
-ledgerDbPushMany trace = repeatedlyM . pushAndTrace
+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 cfg ap db = do
-      trace $ StartedPushingBlockToTheLedgerDb $ toRealPoint ap
-      res <- ledgerDbPush cfg ap db
-      return res
+    pushAndTrace ap db = do
+      traceStep $ StartedPushingBlockToTheLedgerDb (Pushing $ toRealPoint ap)
+      ledgerDbPush cfg ap db
+
+    traceStep :: (PushGoal blk -> UpdateLedgerDbTraceEvent blk) -> m ()
+    traceStep step =
+      let goal = PushGoal . toRealPoint . last $ aps
+          event = step goal
+      in  trace event
 
 -- | Switch to a fork
 ledgerDbSwitch :: (ApplyBlock l blk, Monad m, c)

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

@@ -1,5 +1,9 @@
 {-# LANGUAGE DeriveGeneric #-}
-module Ouroboros.Consensus.Storage.LedgerDB.Types (UpdateLedgerDbTraceEvent (..)) where
+module Ouroboros.Consensus.Storage.LedgerDB.Types (
+    PushGoal (..)
+  , Pushing (..)
+  , UpdateLedgerDbTraceEvent (..)
+  ) where
 
 
 import           GHC.Generics (Generic)
@@ -8,7 +12,19 @@ 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 !(RealPoint blk)
+      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)