Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[CAD-3723] Add progress to initial chain selection #3518

Merged
merged 7 commits into from
Dec 6, 2021
Merged

[CAD-3723] Add progress to initial chain selection #3518

Show file tree
Hide file tree
Changes from 5 commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
b3902e5
Move dedicated initChainSelTracer tracer to initialChainSelection
EncodePanda Nov 25, 2021
8be9a23
Added StartedInitChainSelection and InitialChainSelected
EncodePanda Nov 25, 2021
eee455c
Add UpdateLedgerDbTraceEvent events
EncodePanda Dec 1, 2021
d2f234d
Add RealPoint to the StartedPushingBlockToTheLedgerDb
EncodePanda Dec 2, 2021
5c59ed7
Add progress to UpdateLedgerDbTraceEvent
EncodePanda Dec 3, 2021
68b9a6c
Capitalize comments
EncodePanda Dec 6, 2021
4a5633a
Simplify the pushAndTrace
EncodePanda Dec 6, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 4 additions & 1 deletion ...boros-consensus-test/test-consensus/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Expand All @@ -208,6 +208,9 @@ initLgrDB k chain = do

genesisLedgerDB = LgrDB.ledgerDbWithAnchor testInitExtLedger

noopTrace :: blk -> m ()
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We have other uses of const $ pure (). Don't we want to replace these with noopTrace? Or just use const $ pure ()

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

hmm.. good question, i think it's better if we replace with noop helper function, otherwise someone who will read the code will have to check each time to understand "wtf is const pure unit"

noopTrace = const $ pure ()

args = LgrDbArgs
{ lgrTopLevelConfig = cfg
, lgrHasFS = SomeHasFS (error "lgrHasFS" :: HasFS m ())
Expand Down
2 changes: 2 additions & 0 deletions ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/ChainDB/StateMachine.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions ouroboros-consensus-test/test-storage/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -593,6 +593,7 @@ runDB standalone@DB{..} cmd =
ledgerDbSwitch
dbLedgerDbCfg
n
(const $ pure ())
(map ApplyVal bs)
db
go hasFS Snap = do
Expand Down
1 change: 1 addition & 0 deletions ouroboros-consensus/ouroboros-consensus.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
5 changes: 4 additions & 1 deletion ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
8 changes: 5 additions & 3 deletions ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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/.
Expand Down Expand Up @@ -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
Expand All @@ -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

Expand Down
7 changes: 6 additions & 1 deletion ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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 (..))
Expand Down Expand Up @@ -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 $
Expand Down
12 changes: 10 additions & 2 deletions ouroboros-consensus/src/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand Down
39 changes: 31 additions & 8 deletions ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/InMemory.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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.
Expand Down Expand Up @@ -428,27 +437,40 @@ 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
EncodePanda marked this conversation as resolved.
Show resolved Hide resolved
where
pushAndTrace ap db = do
traceStep $ StartedPushingBlockToTheLedgerDb (Pushing $ toRealPoint ap)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

What about something more direct (with the use of auxiliary mk functions)?

trace $ tartedPushingBlockToTheLedgerDb $ (mkPushing ap ) (mkPushGoal aps)

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I like it

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)
=> LedgerDbCfg l
-> Word64 -- ^ How many blocks to roll back
-> (UpdateLedgerDbTraceEvent blk -> m ())
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

In principle, this could be any action. I wonder if we want to be more specific and declare that this should actually be a tracer.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Good question, but at least debatable. Even though I follow your line of thought and you are right, in principle this could be any hook but:
a) this could be a slipper slope to messy code in a future, because it is so easy to just "add one more thing" to a hook.
b) I've followed existing convention in our code were we pass trace functions as arguments

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more. 

data ChainSelEnv m blk = ChainSelEnv
    { lgrDB             :: LgrDB m blk
    , trace             :: TraceValidationEvent blk -> m ()

ChainSelEnv is using trace and that pollutes our design. I think I will change that to provide a tracer instead but in a follow up PR.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think it should be Tracer. Tracer is isomorphic to that type, and transparent, so there's no restriction gained by using either type. But Tracer is the tell-tale type throughout our codebase for this kind of concern.

Copy link
Contributor Author

@EncodePanda EncodePanda Dec 3, 2021 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@nfrisby are you ok with doing this in separate PR so this one does not get polluted with too many concerns?

Copy link
Contributor

@nfrisby nfrisby Dec 7, 2021 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think for the the new field it should just be Tracer, regardless of new code, but yeah no need to change existing code in this PR.

Edit: eg you could use nullTracer instead of const $ pure () etc. Tracer is the right API for this sort of thing.

-> [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
Expand Down Expand Up @@ -524,13 +546,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'

Expand Down
5 changes: 4 additions & 1 deletion ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/OnDisk.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -323,6 +325,7 @@ initStartingWith tracer cfg streamAPI initDb = do
(ledgerState (ledgerDbCurrent db))
(ledgerState (ledgerDbCurrent db'))


Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Style: undue newline

traceWith tracer (ReplayedBlock (blockRealPoint blk) events ())
return (db', replayed')

Expand Down Expand Up @@ -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.
Expand Down Expand Up @@ -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)
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Please add a Haddock comment on this one, describing the general meaning of the UpdateLedgerDbTraceEvent type/category.

deriving (Generic, Eq, Show, Functor, Foldable, Traversable)
30 changes: 30 additions & 0 deletions ouroboros-consensus/src/Ouroboros/Consensus/Storage/LedgerDB/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
EncodePanda marked this conversation as resolved.
Show resolved Hide resolved
(PushGoal blk)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is there a ! missing here?

-- ^ 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)