consensus: annotate headers with their slot's RelativeTime

ouroboros-consensus-diffusion/changelog.d/20241218_095040_nick.frisby_annotate_headers_with_time.md

@@ -0,0 +1,22 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Use `HeaderWithTime` for the ChainSync candidates

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -56,6 +56,7 @@ import qualified Network.Mux as Mux
 import           Network.TypedProtocol.Codec
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config (DiffusionPipeliningSupport (..))
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime)
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
@@ -152,7 +153,7 @@ data Handlers m addr blk = Handlers {
         :: NodeToNodeVersion
         -> ControlMessageSTM m
         -> FetchedMetricsTracer m
-        -> BlockFetchClient (Header blk) blk m ()
+        -> BlockFetchClient (HeaderWithTime blk) blk m ()
 
     , hBlockFetchServer
         :: ConnectionId addr

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Genesis.hs

@@ -26,8 +26,10 @@ module Ouroboros.Consensus.Node.Genesis (
 import           Control.Monad (join)
 import           Data.Maybe (fromMaybe)
 import           Data.Traversable (for)
+import           Data.Typeable (Typeable)
 import           GHC.Generics (Generic)
 import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (CSJConfig (..), CSJEnabledConfig (..),
                      ChainSyncLoPBucketConfig (..),
@@ -194,7 +196,7 @@ data LoEAndGDDNodeKernelArgs m blk = LoEAndGDDNodeKernelArgs {
 -- 'ChainDB.GetLoEFragment' that will be replaced via 'setGetLoEFragment') and a
 -- function to update the 'ChainDbArgs' accordingly.
 mkGenesisNodeKernelArgs ::
-     forall m blk. (IOLike m, GetHeader blk)
+     forall m blk. (IOLike m, GetHeader blk, Typeable blk)
   => GenesisConfig
   -> m ( GenesisNodeKernelArgs m blk
        , Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk
@@ -222,9 +224,9 @@ mkGenesisNodeKernelArgs gcfg = do
 -- | Set 'gnkaGetLoEFragment' to the actual logic for determining the current
 -- LoE fragment.
 setGetLoEFragment ::
-     forall m blk. (IOLike m, GetHeader blk)
+     forall m blk. (IOLike m, GetHeader blk, Typeable blk)
   => STM m GSM.GsmState
-  -> STM m (AnchoredFragment (Header blk))
+  -> STM m (AnchoredFragment (HeaderWithTime blk))
      -- ^ The LoE fragment.
   -> StrictTVar m (ChainDB.GetLoEFragment m blk)
   -> m ()

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

@@ -100,6 +100,10 @@ import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (castTip, tipFromHeader)
 import           Ouroboros.Network.BlockFetch
+import           Ouroboros.Network.BlockFetch.ClientState
+                     (mapTraceFetchClientState)
+import           Ouroboros.Network.BlockFetch.Decision.Trace
+                     (TraceDecisionEvent (..))
 import           Ouroboros.Network.NodeToNode (ConnectionId,
                      MiniProtocolParameters (..))
 import           Ouroboros.Network.PeerSelection.Governor.Types
@@ -133,7 +137,7 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel {
     , getTopLevelConfig       :: TopLevelConfig blk
 
       -- | The fetch client registry, used for the block fetch clients.
-    , getFetchClientRegistry  :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
+    , getFetchClientRegistry  :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m
 
       -- | The fetch mode, used by diffusion.
       --
@@ -258,8 +262,8 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
               , GSM.equivalent                = (==) `on` (AF.headPoint . fst)
               , GSM.getChainSyncStates        = fmap cschState <$> cschcMap varChainSyncHandles
               , GSM.getCurrentSelection       = do
-                  headers        <- ChainDB.getCurrentChain  chainDB
-                  extLedgerState <- ChainDB.getCurrentLedger chainDB
+                  headers        <- ChainDB.getCurrentChainWithTime chainDB
+                  extLedgerState <- ChainDB.getCurrentLedger        chainDB
                   return (headers, ledgerState extLedgerState)
               , GSM.minCaughtUpDuration       = gsmMinCaughtUpDuration
               , GSM.setCaughtUpPersistentMark = \upd ->
@@ -314,8 +318,8 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
     -- 'addFetchedBlock' whenever a new block is downloaded.
     void $ forkLinkedThread registry "NodeKernel.blockFetchLogic" $
       blockFetchLogic
-        (blockFetchDecisionTracer tracers)
-        (blockFetchClientTracer   tracers)
+        (contramap castTraceFetchDecision $ blockFetchDecisionTracer tracers)
+        (contramap (fmap castTraceFetchClientState) $ blockFetchClientTracer tracers)
         blockFetchInterface
         fetchClientRegistry
         blockFetchConfiguration
@@ -350,6 +354,18 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
           blockForging' <- traverse (forkBlockForging st) blockForging
           go blockForging'
 
+castTraceFetchDecision ::
+     forall remotePeer blk.
+     TraceDecisionEvent remotePeer (HeaderWithTime blk) -> TraceDecisionEvent remotePeer (Header blk)
+castTraceFetchDecision = \case
+      PeersFetch xs -> PeersFetch (map (fmap (second (map castPoint))) xs) -- [TraceLabelPeer peer (FetchDecision [Point header])]
+      PeerStarvedUs peer -> PeerStarvedUs peer
+
+castTraceFetchClientState ::
+     forall blk. HasHeader (Header blk)
+  => TraceFetchClientState (HeaderWithTime blk) -> TraceFetchClientState (Header blk)
+castTraceFetchClientState = mapTraceFetchClientState hwtHeader
+
 {-------------------------------------------------------------------------------
   Internal node components
 -------------------------------------------------------------------------------}
@@ -360,8 +376,8 @@ data InternalState m addrNTN addrNTC blk = IS {
     , registry            :: ResourceRegistry m
     , btime               :: BlockchainTime m
     , chainDB             :: ChainDB m blk
-    , blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) blk m
-    , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (Header blk) blk m
+    , blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m
+    , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m
     , varChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk
     , varGsmState         :: StrictTVar m GSM.GsmState
     , mempool             :: Mempool m blk
@@ -408,7 +424,7 @@ initInternalState NodeKernelArgs { tracers, chainDB, registry, cfg
           (ChainDB.getCurrentChain chainDB)
           getUseBootstrapPeers
           (GSM.gsmStateToLedgerJudgement <$> readTVar varGsmState)
-        blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (Header blk) blk m
+        blockFetchInterface :: BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m
         blockFetchInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface
           (dbfTracer tracers)
           (configBlock cfg)

ouroboros-consensus-diffusion/src/unstable-mock-testlib/Test/ThreadNet/Util/SimpleBlock.hs

@@ -2,7 +2,7 @@
 
 module Test.ThreadNet.Util.SimpleBlock (prop_validSimpleBlock) where
 
-import           Data.Typeable
+import           Data.Typeable (Typeable)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Mock.Ledger
 import           Ouroboros.Consensus.Util.Condense (condense)

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs

@@ -31,6 +31,7 @@ import           Ouroboros.Consensus.Config.SecurityParam
                      (SecurityParam (SecurityParam), maxRollbacks)
 import           Ouroboros.Consensus.Genesis.Governor (DensityBounds,
                      densityDisconnect, sharedCandidatePrefix)
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime)
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (ChainSyncClientException (..), ChainSyncState (..))
 import           Ouroboros.Consensus.Util.Condense (condense)
@@ -59,13 +60,16 @@ import           Test.QuickCheck
 import           Test.QuickCheck.Extras (unsafeMapSuchThatJust)
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
+import           Test.Util.HeaderValidation (attachSlotTimeToFragment)
 import           Test.Util.Orphans.IOLike ()
 import           Test.Util.PartialAccessors
-import           Test.Util.TersePrinting (terseHFragment, terseHeader)
-import           Test.Util.TestBlock (TestBlock)
+import           Test.Util.TersePrinting (terseHFragment, terseHWTFragment,
+                     terseHeader)
+import           Test.Util.TestBlock (TestBlock, singleNodeTestConfig)
 import           Test.Util.TestEnv (adjustQuickCheckMaxSize,
                      adjustQuickCheckTests)
 
+
 tests :: TestTree
 tests =
   adjustQuickCheckTests (* 10) $
@@ -87,9 +91,9 @@ data StaticCandidates =
   StaticCandidates {
     k        :: SecurityParam,
     sgen     :: GenesisWindow,
-    suffixes :: [(PeerId, AnchoredFragment (Header TestBlock))],
+    suffixes :: [(PeerId, AnchoredFragment (HeaderWithTime TestBlock))],
     tips     :: Map PeerId (Tip TestBlock),
-    loeFrag  :: AnchoredFragment (Header TestBlock)
+    loeFrag  :: AnchoredFragment (HeaderWithTime TestBlock)
   }
   deriving Show
 
@@ -100,7 +104,7 @@ data StaticCandidates =
 -- 'sharedCandidatePrefix' from the selection.
 staticCandidates :: GenesisTest TestBlock s -> [StaticCandidates]
 staticCandidates GenesisTest {gtSecurityParam, gtGenesisWindow, gtBlockTree} =
-  one . toHeaders <$> selections
+ one . attachTimeUsingTestConfig . toHeaders <$> selections
   where
     one curChain =
       StaticCandidates {
@@ -112,7 +116,11 @@ staticCandidates GenesisTest {gtSecurityParam, gtGenesisWindow, gtBlockTree} =
       }
       where
         (loeFrag, suffixes) =
-          sharedCandidatePrefix curChain (second toHeaders <$> candidates)
+          sharedCandidatePrefix
+              curChain
+              (second (attachTimeUsingTestConfig . toHeaders)
+                <$> candidates
+              )
 
     selections = selection <$> branches
 
@@ -128,6 +136,15 @@ staticCandidates GenesisTest {gtSecurityParam, gtGenesisWindow, gtBlockTree} =
 
     branches = btBranches gtBlockTree
 
+-- | Attach a relative slot time to a fragment of headers using the
+-- 'singleNodeTestConfig'. Since 'k' is not used for time conversions,
+-- it is safe to use this configuration even if other 'k' values are
+-- used in the tests that call this function.
+attachTimeUsingTestConfig ::
+  AnchoredFragment (Header TestBlock) ->
+  AnchoredFragment (HeaderWithTime TestBlock)
+attachTimeUsingTestConfig = attachSlotTimeToFragment singleNodeTestConfig
+
 -- | Check that the GDD disconnects from some peers for each full Genesis window starting at any of a block tree's
 -- intersections, and that it's not the honest peer.
 prop_densityDisconnectStatic :: Property
@@ -139,7 +156,7 @@ prop_densityDisconnectStatic =
      counterexample "it should not disconnect the honest peers"
        (not $ any isHonestPeerId disconnect)
   where
-    mkState :: AnchoredFragment (Header TestBlock) -> ChainSyncState TestBlock
+    mkState :: AnchoredFragment (HeaderWithTime TestBlock) -> ChainSyncState TestBlock
     mkState frag =
       ChainSyncState {
         csCandidate = frag,
@@ -167,7 +184,7 @@ data EvolvingPeers =
     k        :: SecurityParam,
     sgen     :: GenesisWindow,
     peers    :: Peers EvolvingPeer,
-    loeFrag  :: AnchoredFragment (Header TestBlock),
+    loeFrag  :: AnchoredFragment (HeaderWithTime TestBlock),
     fullTree :: BlockTree TestBlock
   }
   deriving Show
@@ -227,7 +244,7 @@ data UpdateEvent = UpdateEvent {
   , bounds   :: [(PeerId, DensityBounds TestBlock)]
     -- | The current chains
   , tree     :: BlockTree (Header TestBlock)
-  , loeFrag  :: AnchoredFragment (Header TestBlock)
+  , loeFrag  :: AnchoredFragment (HeaderWithTime TestBlock)
   , curChain :: AnchoredFragment (Header TestBlock)
   }
 
@@ -240,7 +257,7 @@ prettyUpdateEvent UpdateEvent {target, added, killed, bounds, tree, loeFrag, cur
   [
     "Extended " ++ condense target ++ " with " ++ terseHeader added,
     "        disconnect: " ++ show killed,
-    "        LoE frag: " ++ terseHFragment loeFrag,
+    "        LoE frag: " ++ terseHWTFragment loeFrag,
     "        selection: " ++ terseHFragment curChain
   ]
   ++ prettyDensityBounds bounds
@@ -377,12 +394,17 @@ evolveBranches EvolvingPeers {k, sgen, peers = initialPeers, fullTree} =
         states =
           candidates <&> \ csCandidate ->
             ChainSyncState {
-              csCandidate,
+              csCandidate = attachTimeUsingTestConfig csCandidate,
               csIdling = False,
               csLatestSlot = SJust (AF.headSlot csCandidate)
             }
         -- Run GDD.
-        (loeFrag, suffixes) = sharedCandidatePrefix curChain (Map.toList candidates)
+        (loeFrag, suffixes) =
+          sharedCandidatePrefix
+             (attachTimeUsingTestConfig curChain)
+             (Map.toList $
+               fmap attachTimeUsingTestConfig candidates
+             )
         (killedNow, bounds) = first Set.fromList $ densityDisconnect sgen k states suffixes loeFrag
         event = UpdateEvent {
           target,
@@ -415,7 +437,7 @@ peerInfo EvolvingPeers {k = SecurityParam k, sgen = GenesisWindow sgen, loeFrag}
   [
     "k: " <> show k,
     "sgen: " <> show sgen,
-    "loeFrag: " <> terseHFragment loeFrag
+    "loeFrag: " <> terseHWTFragment loeFrag
   ]
 
 -- | Tests that when GDD disconnects a peer, it continues to disconnect it when

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs

@@ -26,6 +26,7 @@ import           Network.TypedProtocol.Codec (ActiveState, AnyMessage,
 import           Ouroboros.Consensus.Block (HasHeader)
 import           Ouroboros.Consensus.Block.Abstract (Header, Point (..))
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (ChainSyncClientHandleCollection)
@@ -78,7 +79,7 @@ startBlockFetchLogic ::
   -> ResourceRegistry m
   -> Tracer m (TraceEvent TestBlock)
   -> ChainDB m TestBlock
-  -> FetchClientRegistry PeerId (Header TestBlock) TestBlock m
+  -> FetchClientRegistry PeerId (HeaderWithTime TestBlock) TestBlock m
   -> ChainSyncClientHandleCollection PeerId m TestBlock
   -> m ()
 startBlockFetchLogic enableChainSelStarvation registry tracer chainDb fetchClientRegistry csHandlesCol = do
@@ -132,10 +133,10 @@ startBlockFetchLogic enableChainSelStarvation registry tracer chainDb fetchClien
     decisionTracer = TraceOther . ("BlockFetchLogic | " ++) . show >$< tracer
 
 startKeepAliveThread ::
-     forall m peer blk.
+     forall m peer blk hdr.
      (Ord peer, IOLike m)
   => ResourceRegistry m
-  -> FetchClientRegistry peer (Header blk) blk m
+  -> FetchClientRegistry peer hdr blk m
   -> peer
   -> m ()
 startKeepAliveThread registry fetchClientRegistry peerId =
@@ -149,7 +150,7 @@ runBlockFetchClient ::
   -> PeerId
   -> BlockFetchTimeout
   -> StateViewTracers blk m
-  -> FetchClientRegistry PeerId (Header blk) blk m
+  -> FetchClientRegistry PeerId (HeaderWithTime blk) blk m
   -> ControlMessageSTM m
   -> Channel m (AnyMessage (BlockFetch blk (Point blk)))
      -- ^ Send and receive message via the given 'Channel'.

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs

@@ -18,8 +18,10 @@ import           Control.Tracer (Tracer (..), traceWith)
 import           Data.Functor (void)
 import           Data.Set (Set)
 import qualified Data.Set as Set
+import           Data.Typeable (Typeable)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config (TopLevelConfig (..))
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (ChainSyncClientHandleCollection (..))
 import           Ouroboros.Consensus.Storage.ChainDB.API
@@ -90,7 +92,7 @@ data LiveResources blk m = LiveResources {
   , lrCdb      :: NodeDBs (StrictTMVar m MockFS)
 
     -- | The LoE fragment must be reset for each live interval.
-  , lrLoEVar   :: LoE (StrictTVar m (AnchoredFragment (Header blk)))
+  , lrLoEVar   :: LoE (StrictTVar m (AnchoredFragment (HeaderWithTime blk)))
   }
 
 data LiveInterval blk m = LiveInterval {
@@ -190,7 +192,7 @@ lifecycleStart start liResources liResult = do
 -- | Shut down the node by killing all its threads after extracting the
 -- persistent state used to restart the node later.
 lifecycleStop ::
-  (IOLike m, GetHeader blk) =>
+  (IOLike m, GetHeader blk, Typeable blk) =>
   LiveResources blk m ->
   LiveNode blk m ->
   m (LiveIntervalResult blk)