diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs index 4675503f28..c7fd96108d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs @@ -50,7 +50,7 @@ import Ouroboros.Network.SizeInBytes -- | Abstract over the ChainDB data ChainDbView m blk = ChainDbView { - getCurrentChain :: STM m (AnchoredFragment (Header blk)) + getCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk)) , getIsFetched :: STM m (Point blk -> Bool) , getMaxSlotNo :: STM m MaxSlotNo , addBlockWaitWrittenToDisk :: InvalidBlockPunishment m -> blk -> m Bool @@ -206,8 +206,7 @@ mkBlockFetchConsensusInterface readCandidateChains = getCandidates readCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk)) - -- FIXME: change the type once we adapt the code to the changes in BlockFetchConsensusInterface - readCurrentChain = undefined (getCurrentChain chainDB) + readCurrentChain = getCurrentChain chainDB readFetchedBlocks :: STM m (Point blk -> Bool) readFetchedBlocks = getIsFetched chainDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs index 5027c93680..e517f7be90 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs @@ -31,6 +31,7 @@ import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Network.Block (ChainUpdate (..), Serialised, Tip (..)) import Ouroboros.Network.Protocol.ChainSync.Server +import Data.Typeable (Typeable) chainSyncHeaderServerFollower :: @@ -57,6 +58,7 @@ chainSyncHeadersServer :: forall m blk. ( IOLike m , HasHeader (Header blk) + , Typeable blk ) => Tracer m (TraceChainSyncServerEvent blk) -> ChainDB m blk @@ -71,7 +73,11 @@ chainSyncHeadersServer tracer chainDB flr = -- chains of full blocks (rather than a header \/ body split). -- chainSyncBlocksServer :: - forall m blk. (IOLike m, HasHeader (Header blk)) + forall m blk. + ( IOLike m + , HasHeader (Header blk) + , Typeable blk + ) => Tracer m (TraceChainSyncServerEvent blk) -> ChainDB m blk -> Follower m blk (WithPoint blk (Serialised blk)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 1ed76832a5..66c251f83d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -96,6 +96,7 @@ import qualified Ouroboros.Network.Block as Network import Ouroboros.Network.Mock.Chain (Chain (..)) import qualified Ouroboros.Network.Mock.Chain as Chain import System.FS.API.Types (FsError) +import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) -- | The chain database -- @@ -168,7 +169,7 @@ data ChainDB m blk = ChainDB { -- -- NOTE: A direct consequence of this guarantee is that the anchor of the -- fragment will move as the chain grows. - , getCurrentChain :: STM m (AnchoredFragment (Header blk)) + , getCurrentChain :: STM m (AnchoredFragment (HeaderWithTime blk)) -- | Return the LedgerDB containing the last @k@ ledger states. , getLedgerDB :: STM m (LedgerDB' blk) @@ -348,11 +349,11 @@ data ChainDB m blk = ChainDB { , isOpen :: STM m Bool } -getCurrentTip :: (Monad (STM m), HasHeader (Header blk)) +getCurrentTip :: (Typeable blk, Monad (STM m), HasHeader (Header blk)) => ChainDB m blk -> STM m (Network.Tip blk) getCurrentTip = fmap (AF.anchorToTip . AF.headAnchor) . getCurrentChain -getTipBlockNo :: (Monad (STM m), HasHeader (Header blk)) +getTipBlockNo :: (Typeable blk, Monad (STM m), HasHeader (Header blk)) => ChainDB m blk -> STM m (WithOrigin BlockNo) getTipBlockNo = fmap Network.getTipBlockNo . getCurrentTip diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 66afcca5a4..ac3ae8e69a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -86,6 +86,7 @@ import Ouroboros.Network.AnchoredFragment (Anchor, AnchoredFragment, AnchoredSeq (..)) import qualified Ouroboros.Network.AnchoredFragment as AF import qualified Ouroboros.Network.AnchoredSeq as AS +import Ouroboros.Consensus.HeaderValidation (HeaderWithTime, projectHeader) -- | Perform the initial chain selection based on the tip of the ImmutableDB -- and the contents of the VolatileDB. @@ -307,20 +308,24 @@ chainSelSync cdb@CDB{..} (ChainSelReprocessLoEBlocks varProcessed) = do lift cdbLoE >>= \case LoEDisabled -> pure () LoEEnabled _ -> do - (succsOf, chain) <- lift $ atomically $ do + (succsOf, chain :: AnchoredFragment (HeaderWithTime blk)) <- lift $ atomically $ do invalid <- forgetFingerprint <$> readTVar cdbInvalid (,) <$> (ignoreInvalidSuc cdbVolatileDB invalid <$> VolatileDB.filterByPredecessor cdbVolatileDB) <*> Query.getCurrentChain cdb let + succsOf' :: Point (HeaderWithTime blk) -> [HeaderHash blk] succsOf' = Set.toList . succsOf . pointHash . castPoint + loeHashes :: [HeaderHash blk] loeHashes = succsOf' (AF.anchorPoint chain) firstHeader = either (const Nothing) Just $ AF.last chain -- We avoid the VolatileDB for the headers we already have in the chain + getHeaderFromHash :: HeaderHash blk -> m (Header blk) getHeaderFromHash hash = case firstHeader of - Just header | headerHash header == hash -> pure header + -- REVIEW: rewrite this! + Just headerWithTime | headerHash (projectHeader headerWithTime) == hash -> pure (projectHeader headerWithTime) _ -> VolatileDB.getKnownBlockComponent cdbVolatileDB GetHeader hash loeHeaders <- lift (mapM getHeaderFromHash loeHashes) for_ loeHeaders $ \hdr -> @@ -857,6 +862,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ do -- us, as we cannot roll back more than @k@ headers anyway. switchTo :: HasCallStack + -- 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. => ValidatedChainDiff (Header blk) (LedgerDB' blk) -- ^ Chain and ledger to switch to -> StrictTVar m (StrictMaybe (Header blk)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs index a54b02df94..35b5e04ef1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs @@ -7,6 +7,11 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +-- REVIEW: required by constraint 'HeaderHash blk ~ HeaderHash (t blk)' +-- +-- ... to suppress warning 'The use of ‘~’ without TypeOperators will become an error in a future GHC release.' +{-# LANGUAGE TypeOperators #-} + -- | Followers module Ouroboros.Consensus.Storage.ChainDB.Impl.Follower ( closeAllFollowers @@ -40,6 +45,7 @@ import Ouroboros.Consensus.Util.STM (blockUntilJust) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (ChainUpdate (..)) +import Ouroboros.Consensus.HeaderValidation (HeaderWithTime, ProjectHeader(..)) {------------------------------------------------------------------------------- Accessing the environment @@ -203,14 +209,15 @@ instructionHelper :: , GetHeader blk , HasNestedContent Header blk , EncodeDiskDep (NestedCtxt Header) blk - , Traversable f, Applicative f + , Traversable f + , Applicative f ) => ResourceRegistry m -> StrictTVar m (FollowerState m blk b) -> ChainType -> BlockComponent blk b - -> ( STM m (Maybe (ChainUpdate blk (Header blk))) - -> STM m (f (ChainUpdate blk (Header blk)))) + -> ( STM m (Maybe (ChainUpdate blk (HeaderWithTime blk))) + -> STM m (f (ChainUpdate blk (HeaderWithTime blk)))) -- ^ How to turn a transaction that may or may not result in a new -- 'ChainUpdate' in one that returns the right return type: use @fmap -- Identity . 'blockUntilJust'@ to block or 'id' to just return the @@ -271,6 +278,8 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB where trace = traceWith (contramap TraceFollowerEvent cdbTracer) + -- REVIEW: we read from 'cdbChain', so we can't generalize this. + getCurrentChainByType :: STM m (AnchoredFragment (HeaderWithTime blk)) getCurrentChainByType = do curChain <- readTVar cdbChain case chainType of @@ -283,7 +292,7 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB codecConfig = configCodec cdbTopLevelConfig headerUpdateToBlockComponentUpdate - :: f (ChainUpdate blk (Header blk)) -> m (f (ChainUpdate blk b)) + :: ProjectHeader t blk => f (ChainUpdate blk (t blk)) -> m (f (ChainUpdate blk b)) headerUpdateToBlockComponentUpdate = traverse (traverse (`getBlockComponentFromHeader` blockComponent)) @@ -291,8 +300,8 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB -- on the 'BlockComponent' that's requested, we might have to read the -- whole block. getBlockComponentFromHeader - :: forall b'. Header blk -> BlockComponent blk b' -> m b' - getBlockComponentFromHeader hdr = \case + :: forall b' t. ProjectHeader t blk => t blk -> BlockComponent blk b' -> m b' + getBlockComponentFromHeader t = \case GetVerifiedBlock -> getBlockComponent GetVerifiedBlock GetBlock -> getBlockComponent GetBlock GetRawBlock -> getBlockComponent GetRawBlock @@ -313,6 +322,8 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB getBlockComponentFromHeader hdr f <*> getBlockComponentFromHeader hdr bc where + hdr = projectHeader t + -- | Use the 'ImmutableDB' and 'VolatileDB' to read the 'BlockComponent' from -- disk (or memory). getBlockComponent :: forall c. BlockComponent blk c -> m c @@ -364,7 +375,7 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB EQ | pt == pointAtImmutableDBTip -> do trace $ FollowerSwitchToMem pt slotNoAtImmutableDBTip - fupdate <- atomically $ fromMaybeSTM $ do + (fupdate ::f (ChainUpdate blk (HeaderWithTime blk))) <- atomically $ (fromMaybeSTM) $ do curChain <- getCurrentChainByType instructionSTM (RollForwardFrom pt) @@ -372,7 +383,8 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB (writeTVar varFollower . FollowerInMem) -- We only got the header, we must first convert it to the right -- block component. - headerUpdateToBlockComponentUpdate fupdate + (headerUpdateToBlockComponentUpdate :: f (ChainUpdate blk (HeaderWithTime blk)) -> m (f (ChainUpdate blk b))) + fupdate -- Two possibilities: -- @@ -391,14 +403,17 @@ instructionHelper registry varFollower chainType blockComponent fromMaybeSTM CDB -- | 'followerInstruction' for when the follower is in the 'FollowerInMem' state. instructionSTM :: - forall m blk. (MonadSTM m, HasHeader (Header blk)) + forall m blk t. (MonadSTM m, HasHeader (t blk), ProjectHeader t blk + , HeaderHash blk ~ HeaderHash (t blk) + , HasHeader (Header blk) + ) => FollowerRollState blk -- ^ The current 'FollowerRollState' of the follower - -> AnchoredFragment (Header blk) + -> AnchoredFragment (t blk) -- ^ The current chain fragment -> (FollowerRollState blk -> STM m ()) -- ^ How to save the updated 'FollowerRollState' - -> STM m (Maybe (ChainUpdate blk (Header blk))) + -> STM m (Maybe (ChainUpdate blk (t blk))) instructionSTM rollState curChain saveRollState = assert (invariant curChain) $ case rollState of RollForwardFrom pt -> @@ -406,12 +421,13 @@ instructionSTM rollState curChain saveRollState = -- There is no successor block because the follower is at the head Nothing -> return Nothing Just hdr -> do - saveRollState $ RollForwardFrom $ headerPoint hdr + saveRollState $ RollForwardFrom $ headerPoint $ projectHeader hdr return $ Just $ AddBlock hdr RollBackTo pt -> do saveRollState $ RollForwardFrom pt return $ Just $ RollBack pt where + invariant :: AnchoredFragment (t blk) -> Bool invariant = AF.withinFragmentBounds (castPoint (followerRollStatePoint rollState)) @@ -440,8 +456,12 @@ forward registry varFollower blockComponent CDB{..} = \pts -> do <*> pure pts where findFirstPointOnChain :: - HasCallStack - => AnchoredFragment (Header blk) + forall t. + ( HasCallStack + , HeaderHash blk ~ HeaderHash (t blk) + , HasHeader (t blk) + ) + => AnchoredFragment (t blk) -> FollowerState m blk b -> WithOrigin SlotNo -> [Point blk] diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 934edfbae1..69ebb8eb03 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -31,7 +31,7 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..)) import Ouroboros.Consensus.HeaderStateHistory (HeaderStateHistory (..), mkHeaderStateWithTimeFromSummary) -import Ouroboros.Consensus.HeaderValidation (HasAnnTip) +import Ouroboros.Consensus.HeaderValidation (HasAnnTip, HeaderWithTime, hwtHeader) import Ouroboros.Consensus.Ledger.Abstract (IsLedger, LedgerState) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Protocol.Abstract @@ -50,6 +50,7 @@ import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (MaxSlotNo, maxSlotNoFromWithOrigin) +import Data.Typeable (Typeable) -- | Return the last @k@ headers. -- @@ -71,9 +72,10 @@ getCurrentChain :: ( IOLike m , HasHeader (Header blk) , ConsensusProtocol (BlockProtocol blk) + , Typeable blk ) => ChainDbEnv m blk - -> STM m (AnchoredFragment (Header blk)) + -> STM m (AnchoredFragment (HeaderWithTime blk)) getCurrentChain CDB{..} = AF.anchorNewest k <$> readTVar cdbChain where @@ -134,7 +136,7 @@ getTipHeader :: getTipHeader CDB{..} = do anchorOrHdr <- AF.head <$> atomically (readTVar cdbChain) case anchorOrHdr of - Right hdr -> return $ Just hdr + Right hdr -> return $ Just (hwtHeader hdr) Left anchor -> case pointToWithOriginRealPoint (castPoint (AF.anchorToPoint anchor)) of Origin -> return Nothing @@ -148,7 +150,7 @@ getTipHeader CDB{..} = do Just <$> ImmutableDB.getKnownBlockComponent cdbImmutableDB GetHeader p getTipPoint :: - forall m blk. (IOLike m, HasHeader (Header blk)) + forall m blk. (IOLike m, HasHeader (Header blk), Typeable blk) => ChainDbEnv m blk -> STM m (Point blk) getTipPoint CDB{..} = (castPoint . AF.headPoint) <$> readTVar cdbChain @@ -198,7 +200,7 @@ getIsValid CDB{..} = do | otherwise -> Nothing getMaxSlotNo :: - forall m blk. (IOLike m, HasHeader (Header blk)) + forall m blk. (IOLike m, HasHeader (Header blk), Typeable blk) => ChainDbEnv m blk -> STM m MaxSlotNo getMaxSlotNo CDB{..} = do -- Note that we need to look at both the current chain and the VolatileDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index f696a509e9..66973ea005 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -108,6 +108,7 @@ import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (WithFingerprint) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block (MaxSlotNo) +import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) -- | All the serialisation related constraints needed by the ChainDB. class ( ImmutableDbSerialiseConstraints blk @@ -173,7 +174,7 @@ data ChainDbEnv m blk = CDB { cdbImmutableDB :: !(ImmutableDB m blk) , cdbVolatileDB :: !(VolatileDB m blk) , cdbLgrDB :: !(LgrDB m blk) - , cdbChain :: !(StrictTVar m (AnchoredFragment (Header blk))) + , cdbChain :: !(StrictTVar m (AnchoredFragment (HeaderWithTime blk))) -- ^ Contains the current chain fragment. -- -- INVARIANT: the anchor point of this fragment is the tip of the @@ -205,7 +206,7 @@ data ChainDbEnv m blk = CDB -- Note that the \"immutable\" block will /never/ be /more/ than @k@ -- blocks back, as opposed to the anchor point of 'cdbChain'. , cdbTentativeState :: !(StrictTVar m (TentativeHeaderState blk)) - , cdbTentativeHeader :: !(StrictTVar m (StrictMaybe (Header blk))) + , cdbTentativeHeader :: !(StrictTVar m (StrictMaybe (HeaderWithTime blk))) -- ^ The tentative header, for diffusion pipelining. -- -- INVARIANT: It fits on top of the current chain, and its body is not known