Skip to content

Commit b76d77c

Browse files
dnadalesdnadales
committed
[TO DROP] WIP: attempt to change the type of getCurrentChain
From `STM m (AnchoredFragment (Header blk))` to `STM m (AnchoredFragment (HeaderWithTime blk))`. Problem: these changes seem to lead down a path where we need to introduce `HeaderWithTime` in the volatile DB, which we want to avoid.
1 parent 247bd80 commit b76d77c

File tree

7 files changed

+65
-30
lines changed

7 files changed

+65
-30
lines changed

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

+2-3
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,7 @@ 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 (HeaderWithTime blk))
5454
, getIsFetched :: STM m (Point blk -> Bool)
5555
, getMaxSlotNo :: STM m MaxSlotNo
5656
, addBlockWaitWrittenToDisk :: InvalidBlockPunishment m -> blk -> m Bool
@@ -206,8 +206,7 @@ mkBlockFetchConsensusInterface
206206
readCandidateChains = getCandidates
207207

208208
readCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk))
209-
-- FIXME: change the type once we adapt the code to the changes in BlockFetchConsensusInterface
210-
readCurrentChain = undefined (getCurrentChain chainDB)
209+
readCurrentChain = getCurrentChain chainDB
211210

212211
readFetchedBlocks :: STM m (Point blk -> Bool)
213212
readFetchedBlocks = getIsFetched chainDB

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs

+7-1
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)
3131
import Ouroboros.Network.Block (ChainUpdate (..), Serialised,
3232
Tip (..))
3333
import Ouroboros.Network.Protocol.ChainSync.Server
34+
import Data.Typeable (Typeable)
3435

3536

3637
chainSyncHeaderServerFollower ::
@@ -57,6 +58,7 @@ chainSyncHeadersServer ::
5758
forall m blk.
5859
( IOLike m
5960
, HasHeader (Header blk)
61+
, Typeable blk
6062
)
6163
=> Tracer m (TraceChainSyncServerEvent blk)
6264
-> ChainDB m blk
@@ -71,7 +73,11 @@ chainSyncHeadersServer tracer chainDB flr =
7173
-- chains of full blocks (rather than a header \/ body split).
7274
--
7375
chainSyncBlocksServer ::
74-
forall m blk. (IOLike m, HasHeader (Header blk))
76+
forall m blk.
77+
( IOLike m
78+
, HasHeader (Header blk)
79+
, Typeable blk
80+
)
7581
=> Tracer m (TraceChainSyncServerEvent blk)
7682
-> ChainDB m blk
7783
-> Follower m blk (WithPoint blk (Serialised blk))

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

+4-3
Original file line numberDiff line numberDiff line change
@@ -96,6 +96,7 @@ import qualified Ouroboros.Network.Block as Network
9696
import Ouroboros.Network.Mock.Chain (Chain (..))
9797
import qualified Ouroboros.Network.Mock.Chain as Chain
9898
import System.FS.API.Types (FsError)
99+
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime)
99100

100101
-- | The chain database
101102
--
@@ -168,7 +169,7 @@ data ChainDB m blk = ChainDB {
168169
--
169170
-- NOTE: A direct consequence of this guarantee is that the anchor of the
170171
-- fragment will move as the chain grows.
171-
, getCurrentChain :: STM m (AnchoredFragment (Header blk))
172+
, getCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk))
172173

173174
-- | Return the LedgerDB containing the last @k@ ledger states.
174175
, getLedgerDB :: STM m (LedgerDB' blk)
@@ -348,11 +349,11 @@ data ChainDB m blk = ChainDB {
348349
, isOpen :: STM m Bool
349350
}
350351

351-
getCurrentTip :: (Monad (STM m), HasHeader (Header blk))
352+
getCurrentTip :: (Typeable blk, Monad (STM m), HasHeader (Header blk))
352353
=> ChainDB m blk -> STM m (Network.Tip blk)
353354
getCurrentTip = fmap (AF.anchorToTip . AF.headAnchor) . getCurrentChain
354355

355-
getTipBlockNo :: (Monad (STM m), HasHeader (Header blk))
356+
getTipBlockNo :: (Typeable blk, Monad (STM m), HasHeader (Header blk))
356357
=> ChainDB m blk -> STM m (WithOrigin BlockNo)
357358
getTipBlockNo = fmap Network.getTipBlockNo . getCurrentTip
358359

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

+8-2
Original file line numberDiff line numberDiff line change
@@ -86,6 +86,7 @@ import Ouroboros.Network.AnchoredFragment (Anchor, AnchoredFragment,
8686
AnchoredSeq (..))
8787
import qualified Ouroboros.Network.AnchoredFragment as AF
8888
import qualified Ouroboros.Network.AnchoredSeq as AS
89+
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime, projectHeader)
8990

9091
-- | Perform the initial chain selection based on the tip of the ImmutableDB
9192
-- and the contents of the VolatileDB.
@@ -307,20 +308,24 @@ chainSelSync cdb@CDB{..} (ChainSelReprocessLoEBlocks varProcessed) = do
307308
lift cdbLoE >>= \case
308309
LoEDisabled -> pure ()
309310
LoEEnabled _ -> do
310-
(succsOf, chain) <- lift $ atomically $ do
311+
(succsOf, chain :: AnchoredFragment (HeaderWithTime blk)) <- lift $ atomically $ do
311312
invalid <- forgetFingerprint <$> readTVar cdbInvalid
312313
(,)
313314
<$> (ignoreInvalidSuc cdbVolatileDB invalid <$>
314315
VolatileDB.filterByPredecessor cdbVolatileDB)
315316
<*> Query.getCurrentChain cdb
316317
let
318+
succsOf' :: Point (HeaderWithTime blk) -> [HeaderHash blk]
317319
succsOf' = Set.toList . succsOf . pointHash . castPoint
320+
loeHashes :: [HeaderHash blk]
318321
loeHashes = succsOf' (AF.anchorPoint chain)
319322
firstHeader = either (const Nothing) Just $ AF.last chain
320323
-- We avoid the VolatileDB for the headers we already have in the chain
324+
getHeaderFromHash :: HeaderHash blk -> m (Header blk)
321325
getHeaderFromHash hash =
322326
case firstHeader of
323-
Just header | headerHash header == hash -> pure header
327+
-- REVIEW: rewrite this!
328+
Just headerWithTime | headerHash (projectHeader headerWithTime) == hash -> pure (projectHeader headerWithTime)
324329
_ -> VolatileDB.getKnownBlockComponent cdbVolatileDB GetHeader hash
325330
loeHeaders <- lift (mapM getHeaderFromHash loeHashes)
326331
for_ loeHeaders $ \hdr ->
@@ -857,6 +862,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ do
857862
-- us, as we cannot roll back more than @k@ headers anyway.
858863
switchTo
859864
:: HasCallStack
865+
-- REVIEW: If we change the type of getCurrentChain (and therefore of cdbChain) it seems the type of `ValidatedChainDiff` will change. I wonder if this is ok. Alternatively we can generalize this to any 'ProjectHeader' instance.
860866
=> ValidatedChainDiff (Header blk) (LedgerDB' blk)
861867
-- ^ Chain and ledger to switch to
862868
-> StrictTVar m (StrictMaybe (Header blk))

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

+34-14
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,11 @@
77
{-# LANGUAGE TupleSections #-}
88
{-# LANGUAGE TypeApplications #-}
99

10+
-- REVIEW: required by constraint 'HeaderHash blk ~ HeaderHash (t blk)'
11+
--
12+
-- ... to suppress warning 'The use of ‘~’ without TypeOperators will become an error in a future GHC release.'
13+
{-# LANGUAGE TypeOperators #-}
14+
1015
-- | Followers
1116
module Ouroboros.Consensus.Storage.ChainDB.Impl.Follower (
1217
closeAllFollowers
@@ -40,6 +45,7 @@ import Ouroboros.Consensus.Util.STM (blockUntilJust)
4045
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
4146
import qualified Ouroboros.Network.AnchoredFragment as AF
4247
import Ouroboros.Network.Block (ChainUpdate (..))
48+
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime, ProjectHeader(..))
4349

4450
{-------------------------------------------------------------------------------
4551
Accessing the environment
@@ -203,14 +209,15 @@ instructionHelper ::
203209
, GetHeader blk
204210
, HasNestedContent Header blk
205211
, EncodeDiskDep (NestedCtxt Header) blk
206-
, Traversable f, Applicative f
212+
, Traversable f
213+
, Applicative f
207214
)
208215
=> ResourceRegistry m
209216
-> StrictTVar m (FollowerState m blk b)
210217
-> ChainType
211218
-> BlockComponent blk b
212-
-> ( STM m (Maybe (ChainUpdate blk (Header blk)))
213-
-> STM m (f (ChainUpdate blk (Header blk))))
219+
-> ( STM m (Maybe (ChainUpdate blk (HeaderWithTime blk)))
220+
-> STM m (f (ChainUpdate blk (HeaderWithTime blk))))
214221
-- ^ How to turn a transaction that may or may not result in a new
215222
-- 'ChainUpdate' in one that returns the right return type: use @fmap
216223
-- Identity . 'blockUntilJust'@ to block or 'id' to just return the
@@ -271,6 +278,8 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB
271278
where
272279
trace = traceWith (contramap TraceFollowerEvent cdbTracer)
273280

281+
-- REVIEW: we read from 'cdbChain', so we can't generalize this.
282+
getCurrentChainByType :: STM m (AnchoredFragment (HeaderWithTime blk))
274283
getCurrentChainByType = do
275284
curChain <- readTVar cdbChain
276285
case chainType of
@@ -283,16 +292,16 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB
283292
codecConfig = configCodec cdbTopLevelConfig
284293

285294
headerUpdateToBlockComponentUpdate
286-
:: f (ChainUpdate blk (Header blk)) -> m (f (ChainUpdate blk b))
295+
:: ProjectHeader t blk => f (ChainUpdate blk (t blk)) -> m (f (ChainUpdate blk b))
287296
headerUpdateToBlockComponentUpdate =
288297
traverse (traverse (`getBlockComponentFromHeader` blockComponent))
289298

290299
-- | We only got the header for the in-memory chain fragment, so depending
291300
-- on the 'BlockComponent' that's requested, we might have to read the
292301
-- whole block.
293302
getBlockComponentFromHeader
294-
:: forall b'. Header blk -> BlockComponent blk b' -> m b'
295-
getBlockComponentFromHeader hdr = \case
303+
:: forall b' t. ProjectHeader t blk => t blk -> BlockComponent blk b' -> m b'
304+
getBlockComponentFromHeader t = \case
296305
GetVerifiedBlock -> getBlockComponent GetVerifiedBlock
297306
GetBlock -> getBlockComponent GetBlock
298307
GetRawBlock -> getBlockComponent GetRawBlock
@@ -313,6 +322,8 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB
313322
getBlockComponentFromHeader hdr f <*>
314323
getBlockComponentFromHeader hdr bc
315324
where
325+
hdr = projectHeader t
326+
316327
-- | Use the 'ImmutableDB' and 'VolatileDB' to read the 'BlockComponent' from
317328
-- disk (or memory).
318329
getBlockComponent :: forall c. BlockComponent blk c -> m c
@@ -364,15 +375,16 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB
364375
EQ | pt == pointAtImmutableDBTip
365376
-> do
366377
trace $ FollowerSwitchToMem pt slotNoAtImmutableDBTip
367-
fupdate <- atomically $ fromMaybeSTM $ do
378+
(fupdate ::f (ChainUpdate blk (HeaderWithTime blk))) <- atomically $ (fromMaybeSTM) $ do
368379
curChain <- getCurrentChainByType
369380
instructionSTM
370381
(RollForwardFrom pt)
371382
curChain
372383
(writeTVar varFollower . FollowerInMem)
373384
-- We only got the header, we must first convert it to the right
374385
-- block component.
375-
headerUpdateToBlockComponentUpdate fupdate
386+
(headerUpdateToBlockComponentUpdate :: f (ChainUpdate blk (HeaderWithTime blk)) -> m (f (ChainUpdate blk b)))
387+
fupdate
376388

377389
-- Two possibilities:
378390
--
@@ -391,27 +403,31 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB
391403

392404
-- | 'followerInstruction' for when the follower is in the 'FollowerInMem' state.
393405
instructionSTM ::
394-
forall m blk. (MonadSTM m, HasHeader (Header blk))
406+
forall m blk t. (MonadSTM m, HasHeader (t blk), ProjectHeader t blk
407+
, HeaderHash blk ~ HeaderHash (t blk)
408+
, HasHeader (Header blk)
409+
)
395410
=> FollowerRollState blk
396411
-- ^ The current 'FollowerRollState' of the follower
397-
-> AnchoredFragment (Header blk)
412+
-> AnchoredFragment (t blk)
398413
-- ^ The current chain fragment
399414
-> (FollowerRollState blk -> STM m ())
400415
-- ^ How to save the updated 'FollowerRollState'
401-
-> STM m (Maybe (ChainUpdate blk (Header blk)))
416+
-> STM m (Maybe (ChainUpdate blk (t blk)))
402417
instructionSTM rollState curChain saveRollState =
403418
assert (invariant curChain) $ case rollState of
404419
RollForwardFrom pt ->
405420
case AF.successorBlock (castPoint pt) curChain of
406421
-- There is no successor block because the follower is at the head
407422
Nothing -> return Nothing
408423
Just hdr -> do
409-
saveRollState $ RollForwardFrom $ headerPoint hdr
424+
saveRollState $ RollForwardFrom $ headerPoint $ projectHeader hdr
410425
return $ Just $ AddBlock hdr
411426
RollBackTo pt -> do
412427
saveRollState $ RollForwardFrom pt
413428
return $ Just $ RollBack pt
414429
where
430+
invariant :: AnchoredFragment (t blk) -> Bool
415431
invariant =
416432
AF.withinFragmentBounds (castPoint (followerRollStatePoint rollState))
417433

@@ -440,8 +456,12 @@ forward registry varFollower blockComponent CDB{..} = \pts -> do
440456
<*> pure pts
441457
where
442458
findFirstPointOnChain ::
443-
HasCallStack
444-
=> AnchoredFragment (Header blk)
459+
forall t.
460+
( HasCallStack
461+
, HeaderHash blk ~ HeaderHash (t blk)
462+
, HasHeader (t blk)
463+
)
464+
=> AnchoredFragment (t blk)
445465
-> FollowerState m blk b
446466
-> WithOrigin SlotNo
447467
-> [Point blk]

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

+7-5
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,7 @@ import Ouroboros.Consensus.Config
3131
import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..))
3232
import Ouroboros.Consensus.HeaderStateHistory
3333
(HeaderStateHistory (..), mkHeaderStateWithTimeFromSummary)
34-
import Ouroboros.Consensus.HeaderValidation (HasAnnTip)
34+
import Ouroboros.Consensus.HeaderValidation (HasAnnTip, HeaderWithTime, hwtHeader)
3535
import Ouroboros.Consensus.Ledger.Abstract (IsLedger, LedgerState)
3636
import Ouroboros.Consensus.Ledger.Extended
3737
import Ouroboros.Consensus.Protocol.Abstract
@@ -50,6 +50,7 @@ import Ouroboros.Consensus.Util.STM (WithFingerprint (..))
5050
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
5151
import qualified Ouroboros.Network.AnchoredFragment as AF
5252
import Ouroboros.Network.Block (MaxSlotNo, maxSlotNoFromWithOrigin)
53+
import Data.Typeable (Typeable)
5354

5455
-- | Return the last @k@ headers.
5556
--
@@ -71,9 +72,10 @@ getCurrentChain ::
7172
( IOLike m
7273
, HasHeader (Header blk)
7374
, ConsensusProtocol (BlockProtocol blk)
75+
, Typeable blk
7476
)
7577
=> ChainDbEnv m blk
76-
-> STM m (AnchoredFragment (Header blk))
78+
-> STM m (AnchoredFragment (HeaderWithTime blk))
7779
getCurrentChain CDB{..} =
7880
AF.anchorNewest k <$> readTVar cdbChain
7981
where
@@ -134,7 +136,7 @@ getTipHeader ::
134136
getTipHeader CDB{..} = do
135137
anchorOrHdr <- AF.head <$> atomically (readTVar cdbChain)
136138
case anchorOrHdr of
137-
Right hdr -> return $ Just hdr
139+
Right hdr -> return $ Just (hwtHeader hdr)
138140
Left anchor ->
139141
case pointToWithOriginRealPoint (castPoint (AF.anchorToPoint anchor)) of
140142
Origin -> return Nothing
@@ -148,7 +150,7 @@ getTipHeader CDB{..} = do
148150
Just <$> ImmutableDB.getKnownBlockComponent cdbImmutableDB GetHeader p
149151

150152
getTipPoint ::
151-
forall m blk. (IOLike m, HasHeader (Header blk))
153+
forall m blk. (IOLike m, HasHeader (Header blk), Typeable blk)
152154
=> ChainDbEnv m blk -> STM m (Point blk)
153155
getTipPoint CDB{..} =
154156
(castPoint . AF.headPoint) <$> readTVar cdbChain
@@ -198,7 +200,7 @@ getIsValid CDB{..} = do
198200
| otherwise -> Nothing
199201

200202
getMaxSlotNo ::
201-
forall m blk. (IOLike m, HasHeader (Header blk))
203+
forall m blk. (IOLike m, HasHeader (Header blk), Typeable blk)
202204
=> ChainDbEnv m blk -> STM m MaxSlotNo
203205
getMaxSlotNo CDB{..} = do
204206
-- Note that we need to look at both the current chain and the VolatileDB

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

+3-2
Original file line numberDiff line numberDiff line change
@@ -108,6 +108,7 @@ import Ouroboros.Consensus.Util.ResourceRegistry
108108
import Ouroboros.Consensus.Util.STM (WithFingerprint)
109109
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
110110
import Ouroboros.Network.Block (MaxSlotNo)
111+
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime)
111112

112113
-- | All the serialisation related constraints needed by the ChainDB.
113114
class ( ImmutableDbSerialiseConstraints blk
@@ -173,7 +174,7 @@ data ChainDbEnv m blk = CDB
173174
{ cdbImmutableDB :: !(ImmutableDB m blk)
174175
, cdbVolatileDB :: !(VolatileDB m blk)
175176
, cdbLgrDB :: !(LgrDB m blk)
176-
, cdbChain :: !(StrictTVar m (AnchoredFragment (Header blk)))
177+
, cdbChain :: !(StrictTVar m (AnchoredFragment (HeaderWithTime blk)))
177178
-- ^ Contains the current chain fragment.
178179
--
179180
-- INVARIANT: the anchor point of this fragment is the tip of the
@@ -205,7 +206,7 @@ data ChainDbEnv m blk = CDB
205206
-- Note that the \"immutable\" block will /never/ be /more/ than @k@
206207
-- blocks back, as opposed to the anchor point of 'cdbChain'.
207208
, cdbTentativeState :: !(StrictTVar m (TentativeHeaderState blk))
208-
, cdbTentativeHeader :: !(StrictTVar m (StrictMaybe (Header blk)))
209+
, cdbTentativeHeader :: !(StrictTVar m (StrictMaybe (HeaderWithTime blk)))
209210
-- ^ The tentative header, for diffusion pipelining.
210211
--
211212
-- INVARIANT: It fits on top of the current chain, and its body is not known

0 commit comments

Comments
 (0)