Add UpdateLedgerDbTraceEvent events

Those events tracks changes done to LedgerDB each time block is added/applied to it. User gets notiftied twice: once the block is about to be applied and the moment after it got applied
IntersectMBO · Dec 1, 2021 · f1e6637 · f1e6637
1 parent 19c0f02
commit f1e6637
Show file tree

Hide file tree

Showing 10 changed files with 56 additions and 11 deletions.
diff --git a/...boros-consensus-test/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/...boros-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 ())

diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/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

diff --git a/ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs b/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

diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/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

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
@@ -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
 

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/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 $

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/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

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/InMemory.hs b/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
+                     (UpdateLedgerDbTraceEvent (..))
 import           Ouroboros.Consensus.Ticked
 import           Ouroboros.Consensus.Util
 import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin)
@@ -429,26 +431,34 @@ ledgerDbPush cfg ap db =
 
 -- | Push a bunch of blocks (oldest first)
 ledgerDbPushMany :: (ApplyBlock l blk, Monad m, c)
-                 => LedgerDbCfg l
+                 => (UpdateLedgerDbTraceEvent blk -> m ())
+                 -> LedgerDbCfg l
                  -> [Ap m l blk c] -> LedgerDB l -> m (LedgerDB l)
-ledgerDbPushMany = repeatedlyM . ledgerDbPush
+ledgerDbPushMany trace = repeatedlyM . pushAndTrace
+  where
+    pushAndTrace cfg ap db = do
+      trace StartedPushingBlockToTheLedgerDb
+      res <- ledgerDbPush cfg ap db
+      trace PushedBlockToTheLedgerDb
+      return res
 
 -- | 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
@@ -516,21 +526,22 @@ instance ApplyBlock l blk => ApplyBlock (LedgerDB l) blk where
 -------------------------------------------------------------------------------}
 
 pureBlock :: blk -> Ap m l blk ()
-pureBlock = ReapplyVal
+pureBlock blk = ReapplyVal blk
 
 ledgerDbPush' :: ApplyBlock l blk
               => LedgerDbCfg l -> blk -> LedgerDB l -> LedgerDB l
 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'
 

diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/OnDisk.hs b/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)
diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/Types.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/Types.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DeriveGeneric #-}
+module Ouroboros.Consensus.Storage.LedgerDB.Types (UpdateLedgerDbTraceEvent (..)) where
+
+import           GHC.Generics (Generic)
+
+{-------------------------------------------------------------------------------
+  Trace events
+-------------------------------------------------------------------------------}
+data UpdateLedgerDbTraceEvent blk =
+    -- | Event fired when we are about to push a block to the LedgerDB
+      StartedPushingBlockToTheLedgerDb
+    -- | Event fired when we successfully pushed a block to the LedgerDB
+    | PushedBlockToTheLedgerDb
+  deriving (Show, Eq, Generic)