[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.

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

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

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
 

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

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,16 +292,16 @@ 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))
 
     -- | We only got the header for the in-memory chain fragment, so depending
     -- 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,15 +375,16 @@ 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)
                 curChain
                 (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,27 +403,31 @@ 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 ->
         case AF.successorBlock (castPoint pt) curChain of
           -- 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]

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

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