diff --git a/ouroboros-consensus-test/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus-test/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index 06addef7303..d32d0ad25e1 100644 --- a/ouroboros-consensus-test/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/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 ()) 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 index 4d90d74430b..b0556542c9e 100644 --- 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 index 13243bc5c82..ae5fd0b9003 100644 --- 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 index ff341e89acb..f1240cab3c7 100644 --- 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 index 02af175245a..0599ab80926 100644 --- 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 index c0261e1252f..9d6c58d4c5b 100644 --- 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 index ae10a9c9543..a19dcf075f4 100644 --- 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 index ee44201e343..49b81431c60 100644 --- 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,18 +431,26 @@ 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 { @@ -448,7 +458,7 @@ ledgerDbSwitch cfg numRollbacks newBlocks db = , rollbackRequested = numRollbacks } Just db' -> - Right <$> ledgerDbPushMany cfg newBlocks db' + Right <$> ledgerDbPushMany trace cfg newBlocks db' {------------------------------------------------------------------------------- The LedgerDB itself behaves like a ledger @@ -516,7 +526,7 @@ 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 @@ -524,13 +534,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' diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/OnDisk.hs index d5e67edf560..ba5f1b328d9 100644 --- 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 new file mode 100644 index 00000000000..23294f4cd81 --- /dev/null +++ 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)