Skip to content

Commit f40c927

Browse files
nfrisbynfrisby
committed
WIP: add cdbChainWithTime
1 parent b08aa97 commit f40c927

File tree

13 files changed

+146
-38
lines changed

13 files changed

+146
-38
lines changed

‎cabal.project

-9
Original file line numberDiff line numberDiff line change
@@ -44,12 +44,3 @@ package ouroboros-network
4444
if(os(windows))
4545
constraints:
4646
bitvec -simd
47-
48-
source-repository-package
49-
type: git
50-
location: https://github.com/IntersectMBO/ouroboros-network
51-
tag: 947f9b8ad41775c9488127189216b76aaab3108a
52-
subdir:
53-
ouroboros-network-api
54-
ouroboros-network
55-
--sha256: sha256-tCmNw5L8w0zqizks7Fa8wlBbQYL4/nsoKDAWpbV+Qvw=

‎ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs

+4-4
Original file line numberDiff line numberDiff line change
@@ -250,8 +250,8 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
250250
, GSM.equivalent = (==) `on` (AF.headPoint . fst)
251251
, GSM.getChainSyncStates = fmap cschState <$> readTVar varChainSyncHandles
252252
, GSM.getCurrentSelection = do
253-
headers <- ChainDB.getCurrentChain chainDB
254-
extLedgerState <- ChainDB.getCurrentLedger chainDB
253+
headers <- ChainDB.getCurrentChainWithTime chainDB
254+
extLedgerState <- ChainDB.getCurrentLedger chainDB
255255
return (headers, ledgerState extLedgerState)
256256
, GSM.minCaughtUpDuration = gsmMinCaughtUpDuration
257257
, GSM.setCaughtUpPersistentMark = \upd ->
@@ -349,7 +349,7 @@ data InternalState m addrNTN addrNTC blk = IS {
349349
, registry :: ResourceRegistry m
350350
, btime :: BlockchainTime m
351351
, chainDB :: ChainDB m blk
352-
, blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) (HeaderWithTime blk) blk m
352+
, blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m
353353
, fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m
354354
, varChainSyncHandles :: StrictTVar m (Map (ConnectionId addrNTN) (ChainSyncClientHandle m blk))
355355
, varGsmState :: StrictTVar m GSM.GsmState
@@ -397,7 +397,7 @@ initInternalState NodeKernelArgs { tracers, chainDB, registry, cfg
397397
(ChainDB.getCurrentChain chainDB)
398398
getUseBootstrapPeers
399399
(GSM.gsmStateToLedgerJudgement <$> readTVar varGsmState)
400-
blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) (HeaderWithTime blk) blk m
400+
blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m
401401
blockFetchInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface
402402
(configBlock cfg)
403403
(BlockFetchClientInterface.defaultChainDbView chainDB)

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs

+13
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ module Ouroboros.Consensus.Fragment.Diff (
2121
-- * Application
2222
, apply
2323
-- * Manipulation
24+
, Ouroboros.Consensus.Fragment.Diff.map
2425
, append
2526
, mapM
2627
, takeWhileOldest
@@ -166,6 +167,18 @@ takeWhileOldest ::
166167
takeWhileOldest accept (ChainDiff nbRollback suffix) =
167168
ChainDiff nbRollback (AF.takeWhileOldest accept suffix)
168169

170+
map ::
171+
forall a b.
172+
( HasHeader b
173+
, HeaderHash a ~ HeaderHash b
174+
)
175+
=> (a -> b)
176+
-> ChainDiff a
177+
-> ChainDiff b
178+
map f (ChainDiff rollback suffix) =
179+
ChainDiff rollback
180+
$ AF.mapAnchoredFragment f suffix
181+
169182
mapM ::
170183
forall a b m.
171184
( HasHeader b

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderValidation.hs

+30
Original file line numberDiff line numberDiff line change
@@ -58,6 +58,7 @@ module Ouroboros.Consensus.HeaderValidation (
5858
, Ticked (..)
5959
-- * Header with time
6060
, HeaderWithTime (..)
61+
, mkHeaderWithTime
6162
) where
6263

6364
import Cardano.Binary (enforceSize)
@@ -79,6 +80,10 @@ import NoThunks.Class (NoThunks)
7980
import Ouroboros.Consensus.Block
8081
import Ouroboros.Consensus.BlockchainTime (RelativeTime)
8182
import Ouroboros.Consensus.Config
83+
import Ouroboros.Consensus.HardFork.Abstract
84+
(HasHardForkHistory (hardForkSummary))
85+
import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
86+
import Ouroboros.Consensus.Ledger.Basics
8287
import Ouroboros.Consensus.Protocol.Abstract
8388
import Ouroboros.Consensus.Ticked
8489
import Ouroboros.Consensus.Util (whenJust)
@@ -544,6 +549,31 @@ instance (Typeable blk, HasHeader (Header blk), Show (HeaderHash blk))
544549
instance HasHeader (Header blk) => GetHeader (HeaderWithTime blk) blk where
545550
getHeader = hwtHeader
546551

552+
-- | Convert 'Header' to 'HeaderWithTime'
553+
--
554+
-- PREREQ: The given ledger must be able to translate the slot of the given
555+
-- header.
556+
--
557+
-- This is INLINEed since the summary can usually be reused.
558+
mkHeaderWithTime ::
559+
( HasHardForkHistory blk
560+
, HasHeader (Header blk)
561+
)
562+
=> LedgerConfig blk
563+
-> LedgerState blk
564+
-> Header blk
565+
-> HeaderWithTime blk
566+
{-# INLINE mkHeaderWithTime #-}
567+
mkHeaderWithTime cfg lst = \hdr ->
568+
let summary = hardForkSummary cfg lst
569+
slot = fromWithOrigin 0 $ pointSlot $ headerPoint hdr
570+
qry = Qry.slotToWallclock slot
571+
(slotTime, _) = Qry.runQueryPure qry summary
572+
in HeaderWithTime {
573+
hwtHeader = hdr
574+
, hwtSlotRelativeTime = slotTime
575+
}
576+
547577
{-------------------------------------------------------------------------------
548578
Serialisation
549579
-------------------------------------------------------------------------------}

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs

+8-6
Original file line numberDiff line numberDiff line change
@@ -50,15 +50,17 @@ import Ouroboros.Network.SizeInBytes
5050

5151
-- | Abstract over the ChainDB
5252
data ChainDbView m blk = ChainDbView {
53-
getCurrentChain :: STM m (AnchoredFragment (Header blk))
53+
getCurrentChain :: STM m (AnchoredFragment (Header blk))
54+
, getCurrentChainWithTime :: STM m (AnchoredFragment (HeaderWithTime blk))
5455
, getIsFetched :: STM m (Point blk -> Bool)
5556
, getMaxSlotNo :: STM m MaxSlotNo
5657
, addBlockWaitWrittenToDisk :: InvalidBlockPunishment m -> blk -> m Bool
5758
}
5859

5960
defaultChainDbView :: IOLike m => ChainDB m blk -> ChainDbView m blk
6061
defaultChainDbView chainDB = ChainDbView {
61-
getCurrentChain = ChainDB.getCurrentChain chainDB
62+
getCurrentChain = ChainDB.getCurrentChain chainDB
63+
, getCurrentChainWithTime = ChainDB.getCurrentChainWithTime chainDB
6264
, getIsFetched = ChainDB.getIsFetched chainDB
6365
, getMaxSlotNo = ChainDB.getMaxSlotNo chainDB
6466
, addBlockWaitWrittenToDisk = ChainDB.addBlockWaitWrittenToDisk chainDB
@@ -182,7 +184,7 @@ mkBlockFetchConsensusInterface ::
182184
-- ^ Slot forge time, see 'headerForgeUTCTime' and 'blockForgeUTCTime'.
183185
-> STM m FetchMode
184186
-- ^ See 'readFetchMode'.
185-
-> BlockFetchConsensusInterface peer (Header blk) (HeaderWithTime blk) blk m
187+
-> BlockFetchConsensusInterface peer (HeaderWithTime blk) blk m
186188
mkBlockFetchConsensusInterface
187189
bcfg chainDB getCandidates blockFetchSize slotForgeTime readFetchMode =
188190
BlockFetchConsensusInterface {
@@ -206,8 +208,8 @@ mkBlockFetchConsensusInterface
206208
readCandidateChains :: STM m (Map peer (AnchoredFragment (HeaderWithTime blk)))
207209
readCandidateChains = getCandidates
208210

209-
readCurrentChain :: STM m (AnchoredFragment (Header blk))
210-
readCurrentChain = getCurrentChain chainDB
211+
readCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk))
212+
readCurrentChain = getCurrentChainWithTime chainDB
211213

212214
readFetchedBlocks :: STM m (Point blk -> Bool)
213215
readFetchedBlocks = getIsFetched chainDB
@@ -287,7 +289,7 @@ mkBlockFetchConsensusInterface
287289
-- fragment, by the time the block fetch download logic considers the
288290
-- fragment, our current chain might have changed.
289291
plausibleCandidateChain :: HasCallStack
290-
=> AnchoredFragment (Header blk)
292+
=> AnchoredFragment (HeaderWithTime blk)
291293
-> AnchoredFragment (HeaderWithTime blk)
292294
-> Bool
293295
plausibleCandidateChain ours cand

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs

+8
Original file line numberDiff line numberDiff line change
@@ -171,6 +171,14 @@ data ChainDB m blk = ChainDB {
171171
-- fragment will move as the chain grows.
172172
, getCurrentChain :: STM m (AnchoredFragment (Header blk))
173173

174+
-- | Exact same as 'getCurrentChain', except each header is annotated
175+
-- with the 'RelativeTime' of the onset of its slot (translated according
176+
-- to the chain it is on)
177+
--
178+
-- INVARIANT @'hwtHeader' <$> 'getCurrentChainWithTime' = 'getCurrentChain'@
179+
, getCurrentChainWithTime
180+
:: STM m (AnchoredFragment (HeaderWithTime blk))
181+
174182
-- | Return the LedgerDB containing the last @k@ ledger states.
175183
, getLedgerDB :: STM m (LedgerDB' blk)
176184

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

+19
Original file line numberDiff line numberDiff line change
@@ -44,8 +44,11 @@ import qualified Data.Map.Strict as Map
4444
import Data.Maybe.Strict (StrictMaybe (..))
4545
import GHC.Stack (HasCallStack)
4646
import Ouroboros.Consensus.Block
47+
import Ouroboros.Consensus.Config
4748
import qualified Ouroboros.Consensus.Fragment.Validated as VF
4849
import Ouroboros.Consensus.HardFork.Abstract
50+
import Ouroboros.Consensus.HeaderValidation (mkHeaderWithTime)
51+
import Ouroboros.Consensus.Ledger.Extended (ledgerState)
4952
import Ouroboros.Consensus.Ledger.Inspect
5053
import Ouroboros.Consensus.Ledger.SupportsProtocol
5154
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
@@ -165,8 +168,21 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
165168
let chain = VF.validatedFragment chainAndLedger
166169
ledger = VF.validatedLedger chainAndLedger
167170

171+
lcfg = configLedger (Args.cdbsTopLevelConfig cdbSpecificArgs)
172+
173+
-- the tip ledger state can translate the slots of the volatile
174+
-- headers
175+
chainWithTime =
176+
AF.mapAnchoredFragment
177+
(mkHeaderWithTime
178+
lcfg
179+
(ledgerState (LgrDB.ledgerDbCurrent ledger))
180+
)
181+
chain
182+
168183
atomically $ LgrDB.setCurrent lgrDB ledger
169184
varChain <- newTVarIO chain
185+
varChainWithTime <- newTVarIO chainWithTime
170186
varTentativeState <- newTVarIO $ initialTentativeHeaderState (Proxy @blk)
171187
varTentativeHeader <- newTVarIO SNothing
172188
varIterators <- newTVarIO Map.empty
@@ -182,6 +198,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
182198
, cdbVolatileDB = volatileDB
183199
, cdbLgrDB = lgrDB
184200
, cdbChain = varChain
201+
, cdbChainWithTime = varChainWithTime
185202
, cdbTentativeState = varTentativeState
186203
, cdbTentativeHeader = varTentativeHeader
187204
, cdbIterators = varIterators
@@ -207,6 +224,8 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
207224
{ addBlockAsync = getEnv2 h ChainSel.addBlockAsync
208225
, chainSelAsync = getEnv h ChainSel.triggerChainSelectionAsync
209226
, getCurrentChain = getEnvSTM h Query.getCurrentChain
227+
, getCurrentChainWithTime
228+
= getEnvSTM h Query.getCurrentChainWithTime
210229
, getLedgerDB = getEnvSTM h Query.getLedgerDB
211230
, getHeaderStateHistory = getEnvSTM h Query.getHeaderStateHistory
212231
, getTipBlock = getEnv h Query.getTipBlock

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

+8-5
Original file line numberDiff line numberDiff line change
@@ -178,12 +178,15 @@ copyToImmutableDB CDB{..} = electric $ do
178178
removeFromChain :: Point blk -> STM m ()
179179
removeFromChain pt = do
180180
-- The chain might have been extended in the meantime.
181-
curChain <- readTVar cdbChain
182-
case curChain of
183-
hdr :< curChain'
181+
curChain <- readTVar cdbChain
182+
curChainWithTime <- readTVar cdbChainWithTime
183+
case (curChain, curChainWithTime) of
184+
(hdr :< curChain', _hwt :< curChainWithTime')
184185
| headerPoint hdr == pt
185-
-> writeTVar cdbChain curChain'
186-
-- We're the only one removing things from 'curChain', so this cannot
186+
-> do
187+
writeTVar cdbChain curChain'
188+
writeTVar cdbChainWithTime curChainWithTime'
189+
-- We're the only one removing things from 'cdbChain', so this cannot
187190
-- happen if the precondition was satisfied.
188191
_ -> error "header to remove not on the current chain"
189192

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

+23-4
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,8 @@ import Ouroboros.Consensus.Fragment.ValidatedDiff
5353
import qualified Ouroboros.Consensus.Fragment.ValidatedDiff as ValidatedDiff
5454
import Ouroboros.Consensus.HardFork.Abstract
5555
import qualified Ouroboros.Consensus.HardFork.History as History
56-
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
56+
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..),
57+
mkHeaderWithTime)
5758
import Ouroboros.Consensus.Ledger.Abstract
5859
import Ouroboros.Consensus.Ledger.Extended
5960
import Ouroboros.Consensus.Ledger.Inspect
@@ -880,14 +881,32 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ do
880881
$ getSuffix
881882
$ getChainDiff vChainDiff
882883
(curChain, newChain, events, prevTentativeHeader) <- atomically $ do
883-
curChain <- readTVar cdbChain -- Not Query.getCurrentChain!
884-
curLedger <- LgrDB.getCurrent cdbLgrDB
884+
curChain <- readTVar cdbChain
885+
-- Not Query.getCurrentChain!
886+
curChainWithTime <- readTVar cdbChainWithTime
887+
curLedger <- LgrDB.getCurrent cdbLgrDB
885888
case Diff.apply curChain chainDiff of
886889
-- Impossible, as described in the docstring
887890
Nothing ->
888891
error "chainDiff doesn't fit onto current chain"
889892
Just newChain -> do
890-
writeTVar cdbChain newChain
893+
let lcfg = configLedger cdbTopLevelConfig
894+
diffWithTime =
895+
-- the new ledger state can translate the slots of the new
896+
-- headers
897+
Diff.map
898+
(mkHeaderWithTime
899+
lcfg
900+
(ledgerState (LgrDB.ledgerDbCurrent newLedger))
901+
)
902+
chainDiff
903+
newChainWithTime =
904+
case Diff.apply curChainWithTime diffWithTime of
905+
Nothing -> error "chainDiff failed for HeaderWithTime"
906+
Just x -> x
907+
908+
writeTVar cdbChain newChain
909+
writeTVar cdbChainWithTime newChainWithTime
891910
LgrDB.setCurrent cdbLgrDB newLedger
892911

893912
-- Inspect the new ledger for potential problems

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

+17-1
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query (
99
-- * Queries
1010
getBlockComponent
1111
, getCurrentChain
12+
, getCurrentChainWithTime
1213
, getHeaderStateHistory
1314
, getIsFetched
1415
, getIsInvalidBlock
@@ -31,7 +32,8 @@ import Ouroboros.Consensus.Config
3132
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..))
3233
import Ouroboros.Consensus.HeaderStateHistory
3334
(HeaderStateHistory (..), mkHeaderStateWithTimeFromSummary)
34-
import Ouroboros.Consensus.HeaderValidation (HasAnnTip)
35+
import Ouroboros.Consensus.HeaderValidation (HasAnnTip,
36+
HeaderWithTime)
3537
import Ouroboros.Consensus.Ledger.Abstract (IsLedger, LedgerState)
3638
import Ouroboros.Consensus.Ledger.Extended
3739
import Ouroboros.Consensus.Protocol.Abstract
@@ -79,6 +81,20 @@ getCurrentChain CDB{..} =
7981
where
8082
SecurityParam k = configSecurityParam cdbTopLevelConfig
8183

84+
-- | Same as 'getCurrentChain', /mutatis mutandi/.
85+
getCurrentChainWithTime ::
86+
forall m blk.
87+
( IOLike m
88+
, HasHeader (HeaderWithTime blk)
89+
, ConsensusProtocol (BlockProtocol blk)
90+
)
91+
=> ChainDbEnv m blk
92+
-> STM m (AnchoredFragment (HeaderWithTime blk))
93+
getCurrentChainWithTime CDB{..} =
94+
AF.anchorNewest k <$> readTVar cdbChainWithTime
95+
where
96+
SecurityParam k = configSecurityParam cdbTopLevelConfig
97+
8298
getLedgerDB ::
8399
IOLike m
84100
=> ChainDbEnv m blk -> STM m (LgrDB.LedgerDB' blk)

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

+9
Original file line numberDiff line numberDiff line change
@@ -205,6 +205,15 @@ data ChainDbEnv m blk = CDB
205205
--
206206
-- Note that the \"immutable\" block will /never/ be /more/ than @k@
207207
-- blocks back, as opposed to the anchor point of 'cdbChain'.
208+
, cdbChainWithTime :: !(StrictTVar m (AnchoredFragment (HeaderWithTime blk)))
209+
-- ^ INVARIANT @fmap 'hwtHeader' 'cdbChainWithTime' = 'chbChain'@
210+
--
211+
-- This mutable variable is maintained separately --- but exactly in
212+
-- parallel --- for performance reasons and modularity reasons, trading a
213+
-- few thousand pointers to avoid extra allocation per use, more granular
214+
-- interfaces (notably
215+
-- 'Ouroboros.Network.BlockFetch.ConsensusInterface.BlockFetchConsensusInterface'),
216+
-- etc.
208217
, cdbTentativeState :: !(StrictTVar m (TentativeHeaderState blk))
209218
, cdbTentativeHeader :: !(StrictTVar m (StrictMaybe (Header blk)))
210219
-- ^ The tentative header, for diffusion pipelining.

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs

+5-8
Original file line numberDiff line numberDiff line change
@@ -133,18 +133,15 @@ compareAnchoredFragments cfg frag1 frag2 =
133133
-- from our tip, although the exact distance does not matter for
134134
-- 'compareAnchoredFragments').
135135
preferAnchoredCandidate ::
136-
forall blk t t'.
136+
forall h blk.
137137
( BlockSupportsProtocol blk
138138
, HasCallStack
139-
, GetHeader (t blk) blk
140-
, HasHeader (t blk)
141-
, GetHeader (t' blk) blk
142-
, HasHeader (t' blk)
143-
, HeaderHash (t blk) ~ HeaderHash (t' blk)
139+
, GetHeader (h blk) blk
140+
, HasHeader (h blk)
144141
)
145142
=> BlockConfig blk
146-
-> AnchoredFragment (t blk) -- ^ Our chain
147-
-> AnchoredFragment (t' blk) -- ^ Candidate
143+
-> AnchoredFragment (h blk) -- ^ Our chain
144+
-> AnchoredFragment (h blk) -- ^ Candidate
148145
-> Bool
149146
preferAnchoredCandidate cfg ours cand =
150147
assertWithMsg (precondition ours cand) $

‎ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs

+2-1
Original file line numberDiff line numberDiff line change
@@ -267,6 +267,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do
267267
let -- Always return the empty chain such that the BlockFetch logic
268268
-- downloads all chains.
269269
getCurrentChain = pure $ AF.Empty AF.AnchorGenesis
270+
getCurrentChainWithTime = pure $ AF.Empty AF.AnchorGenesis
270271
getIsFetched = ChainDB.getIsFetched chainDB
271272
getMaxSlotNo = ChainDB.getMaxSlotNo chainDB
272273
addBlockWaitWrittenToDisk = ChainDB.addBlockWaitWrittenToDisk chainDB
@@ -280,7 +281,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do
280281
mkTestBlockFetchConsensusInterface ::
281282
STM m (Map PeerId (AnchoredFragment (HeaderWithTime TestBlock)))
282283
-> BlockFetchClientInterface.ChainDbView m TestBlock
283-
-> BlockFetchConsensusInterface PeerId (Header TestBlock) (HeaderWithTime TestBlock) TestBlock m
284+
-> BlockFetchConsensusInterface PeerId (HeaderWithTime TestBlock) TestBlock m
284285
mkTestBlockFetchConsensusInterface getCandidates chainDbView =
285286
BlockFetchClientInterface.mkBlockFetchConsensusInterface
286287
(TestBlockConfig numCoreNodes)

0 commit comments

Comments
 (0)