[WIP] Annotate headers with time

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

@@ -230,6 +230,9 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
               , gsmTracer tracers
               )
 
+            -- TODO: this should be a library function if the idea of dropping time on the candidate fragment makes sense.
+            dropTime = undefined
+
         let gsm = GSM.realGsmEntryPoints gsmTracerArgs GSM.GsmView
               { GSM.antiThunderingHerd        = Just gsmAntiThunderingHerd
               , GSM.candidateOverSelection    = \(headers, _lst) state ->
@@ -241,7 +244,8 @@ initNodeKernel args@NodeKernelArgs { registry, cfg, tracers
                             preferAnchoredCandidate
                                 (configBlock cfg)
                                 headers
-                                (csCandidate state)
+                                -- REVIEW: is it ok to drop the times here because we're initializing the node kernel?
+                                (dropTime $ csCandidate state)
               , GSM.peerIsIdle                = csIdling
               , GSM.durationUntilTooOld       =
                       gsmDurationUntilTooOld
@@ -388,7 +392,7 @@ initInternalState NodeKernelArgs { tracers, chainDB, registry, cfg
 
     fetchClientRegistry <- newFetchClientRegistry
 
-    let getCandidates :: STM m (Map (ConnectionId addrNTN) (AnchoredFragment (Header blk)))
+    let getCandidates :: STM m (Map (ConnectionId addrNTN) (AnchoredFragment (HeaderWithTime blk)))
         getCandidates = viewChainSyncState varChainSyncHandles csCandidate
 
     slotForgeTimeOracle <- BlockFetchClientInterface.initSlotForgeTimeOracle cfg chainDB
@@ -401,7 +405,7 @@ initInternalState NodeKernelArgs { tracers, chainDB, registry, cfg
         blockFetchInterface = BlockFetchClientInterface.mkBlockFetchConsensusInterface
           (configBlock cfg)
           (BlockFetchClientInterface.defaultChainDbView chainDB)
-          getCandidates
+          getCandidates -- REVIEW: note for myself. This is what enables the use of 'HeaderWithTime' to obtain the time slot of the header, removing the need of using the HFC to compute the header time.
           blockFetchSize
           slotForgeTimeOracle
           readFetchMode

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

@@ -30,6 +30,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 (DensityTooLow),
                      ChainSyncState (..))
@@ -93,6 +94,16 @@ data StaticCandidates =
   }
   deriving Show
 
+addTime ::
+     AnchoredFragment (Header TestBlock)
+  -> AnchoredFragment (HeaderWithTime TestBlock)
+addTime = undefined
+
+dropTime ::
+     AnchoredFragment (HeaderWithTime blk)
+  -> AnchoredFragment (Header blk)
+dropTime = undefined
+
 -- | Define one selection for each branch of the given block tree, consisting of the first @k@ blocks (or what's
 -- available) of the branch's suffix.
 --
@@ -106,13 +117,13 @@ staticCandidates GenesisTest {gtSecurityParam, gtGenesisWindow, gtBlockTree} =
       StaticCandidates {
         k = gtSecurityParam,
         sgen = gtGenesisWindow,
-        suffixes,
+        suffixes = fmap (second dropTime) suffixes,
         tips,
-        loeFrag
+        loeFrag = dropTime loeFrag
       }
       where
         (loeFrag, suffixes) =
-          sharedCandidatePrefix curChain (second toHeaders <$> candidates)
+          sharedCandidatePrefix curChain (second (addTime . toHeaders) <$> candidates)
 
     selections = selection <$> branches
 
@@ -133,7 +144,7 @@ staticCandidates GenesisTest {gtSecurityParam, gtGenesisWindow, gtBlockTree} =
 prop_densityDisconnectStatic :: Property
 prop_densityDisconnectStatic =
   forAll gen $ \ StaticCandidates {k, sgen, suffixes, loeFrag} -> do
-    let (disconnect, _) = densityDisconnect sgen k (mkState <$> Map.fromList suffixes) suffixes loeFrag
+    let (disconnect, _) = densityDisconnect sgen k (mkState <$> Map.fromList suffixes) (fmap (second addTime) suffixes) (addTime loeFrag)
     counterexample "it should disconnect some node" (not (null disconnect))
       .&&.
      counterexample "it should not disconnect the honest peers"
@@ -142,7 +153,7 @@ prop_densityDisconnectStatic =
     mkState :: AnchoredFragment (Header TestBlock) -> ChainSyncState TestBlock
     mkState frag =
       ChainSyncState {
-        csCandidate = frag,
+        csCandidate = addTime frag,
         csLatestSlot = SJust (AF.headSlot frag),
         csIdling = False
       }
@@ -377,26 +388,26 @@ evolveBranches EvolvingPeers {k, sgen, peers = initialPeers, fullTree} =
         states =
           candidates <&> \ csCandidate ->
             ChainSyncState {
-              csCandidate,
+              csCandidate = addTime csCandidate,
               csIdling = False,
               csLatestSlot = SJust (AF.headSlot csCandidate)
             }
         -- Run GDD.
-        (loeFrag, suffixes) = sharedCandidatePrefix curChain (Map.toList candidates)
+        (loeFrag, suffixes) = sharedCandidatePrefix curChain (Map.toList $ fmap addTime candidates)
         (killedNow, bounds) = first Set.fromList $ densityDisconnect sgen k states suffixes loeFrag
         event = UpdateEvent {
           target,
           added,
           killed = killedNow,
           bounds,
           tree = snapshotTree nextPeers,
-          loeFrag,
+          loeFrag = dropTime loeFrag,
           curChain
           }
         newEvents = event : events
         -- Check the termination condition and remove exhausted peers.
         updated = updatePeers sgen nextPeers killedBefore event
-      either (pure . result newEvents loeFrag) (step newEvents) updated
+      either (pure . result newEvents (dropTime loeFrag)) (step newEvents) updated
       where
         result evs f (res, final) = (res, EvolvingPeers {k, sgen, peers = final, loeFrag = f, fullTree}, reverse evs)
 

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

@@ -28,6 +28,7 @@ import           Network.TypedProtocol.Codec (AnyMessage, PeerHasAgency (..),
                      PeerRole)
 import           Ouroboros.Consensus.Block (HasHeader)
 import           Ouroboros.Consensus.Block.Abstract (Header, Point (..))
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface
 import           Ouroboros.Consensus.Node.ProtocolInfo
                      (NumCoreNodes (NumCoreNodes))
@@ -78,7 +79,7 @@ startBlockFetchLogic ::
   -> Tracer m (TraceEvent TestBlock)
   -> ChainDB m TestBlock
   -> FetchClientRegistry PeerId (Header TestBlock) TestBlock m
-  -> STM m (Map PeerId (AnchoredFragment (Header TestBlock)))
+  -> STM m (Map PeerId (AnchoredFragment (HeaderWithTime TestBlock)))
   -> m ()
 startBlockFetchLogic registry tracer chainDb fetchClientRegistry getCandidates = do
     let slotForgeTime :: BlockFetchClientInterface.SlotForgeTimeOracle m blk

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

@@ -317,7 +317,8 @@ mkStateTracer schedulerConfig GenesisTest {gtBlockTree} PeerSimulatorResources {
   , let getCandidates = viewChainSyncState psrHandles CSClient.csCandidate
         getCurrentChain = ChainDB.getCurrentChain chainDb
         getPoints = traverse readTVar (srCurrentState . prShared <$> psrPeers)
-  = peerSimStateDiagramSTMTracerDebug gtBlockTree getCurrentChain getCandidates getPoints
+    -- REVIEW: is it ok to drop time here?
+  = peerSimStateDiagramSTMTracerDebug gtBlockTree getCurrentChain (undefined getCandidates) getPoints
   | otherwise
   = pure nullTracer
 

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

@@ -29,6 +29,7 @@ import           Ouroboros.Consensus.Block (GenesisWindow (..), Header, Point,
                      WithOrigin (NotOrigin, Origin), succWithOrigin)
 import           Ouroboros.Consensus.Genesis.Governor (DensityBounds (..),
                      GDDDebugInfo (..), TraceGDDEvent (..))
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (TraceChainSyncClientEvent (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping
@@ -52,8 +53,9 @@ import           Ouroboros.Network.Block (SlotNo (SlotNo), Tip, castPoint)
 import           Test.Consensus.PointSchedule.NodeState (NodeState)
 import           Test.Consensus.PointSchedule.Peers (Peer (Peer), PeerId)
 import           Test.Util.TersePrinting (terseAnchor, terseBlock,
-                     terseFragment, terseHFragment, terseHeader, tersePoint,
-                     terseRealPoint, terseTip, terseWithOrigin)
+                     terseFragment, terseHFragment, terseHWTFragment,
+                     terseHeader, tersePoint, terseRealPoint, terseTip,
+                     terseWithOrigin)
 import           Test.Util.TestBlock (TestBlock)
 import           Text.Printf (printf)
 
@@ -75,7 +77,7 @@ data TraceSchedulerEvent blk
       DiffTime
       (Peer (NodeState blk))
       (AnchoredFragment (Header blk))
-      (Maybe (AnchoredFragment (Header blk)))
+      (Maybe (AnchoredFragment (HeaderWithTime blk)))
       [(PeerId, ChainSyncJumpingState m blk)]
   | TraceNodeShutdownStart (WithOrigin SlotNo)
   | TraceNodeShutdownComplete
@@ -218,7 +220,7 @@ traceSchedulerEventTestBlockWith setTickTime tracer0 _tracer = \case
           "  peer: " ++ condense pid,
           "  state: " ++ condense state,
           "  current chain: " ++ terseHFragment currentChain,
-          "  candidate fragment: " ++ maybe "Nothing" terseHFragment mCandidateFrag,
+          "  candidate fragment: " ++ maybe "Nothing" terseHWTFragment mCandidateFrag,
           "  jumping states:\n" ++ traceJumpingStates jumpingStates
         ]
     TraceNodeShutdownStart immTip ->

ouroboros-consensus-diffusion/test/consensus-test/Test/Util/TersePrinting.hs

@@ -8,6 +8,7 @@ module Test.Util.TersePrinting (
   , terseBlock
   , terseFragment
   , terseHFragment
+  , terseHWTFragment
   , terseHeader
   , terseMaybe
   , tersePoint
@@ -24,12 +25,13 @@ import           Ouroboros.Consensus.Block (Header,
                      Point (BlockPoint, GenesisPoint), RealPoint,
                      SlotNo (SlotNo), blockHash, blockNo, blockSlot,
                      realPointToPoint)
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import           Ouroboros.Network.AnchoredFragment (Anchor, AnchoredFragment,
                      anchor, anchorToPoint, mapAnchoredFragment, toOldestFirst)
 import           Ouroboros.Network.Block (Tip (..))
 import           Ouroboros.Network.Point (WithOrigin (..))
-import           Test.Util.TestBlock (Header (TestHeader), TestBlock,
-                     TestHash (TestHash), unTestHash)
+import           Test.Util.TestBlock (Header (TestHeader, testHeader),
+                     TestBlock, TestHash (TestHash), unTestHash)
 
 -- | Run-length encoding of a list. This groups consecutive duplicate elements,
 -- counting them. Only the first element of the equality is kept. For instance:
@@ -118,6 +120,12 @@ terseFragment fragment =
 terseHFragment :: AnchoredFragment (Header TestBlock) -> String
 terseHFragment = terseFragment . mapAnchoredFragment (\(TestHeader block) -> block)
 
+-- | Same as 'terseFragment' for fragments of headers with time.
+--
+-- TOOD: factor out common functionality if this function will stay.
+terseHWTFragment :: AnchoredFragment (HeaderWithTime TestBlock) -> String
+terseHWTFragment = terseFragment . mapAnchoredFragment (testHeader . hwtHeader)
+
 -- | Same as 'terseWithOrigin' for 'Maybe'.
 terseMaybe :: (a -> String) -> Maybe a -> String
 terseMaybe _ Nothing       = "X"

ouroboros-consensus/bench/ChainSync-client-bench/Main.hs

@@ -70,7 +70,7 @@ main = withStdTerminalHandles $ mainWith $ \n -> do
 
 {-# INLINE oneBenchRun #-}
 oneBenchRun ::
-     StrictTVar IO (AnchoredFragment H)
+     StrictTVar IO (AnchoredFragment (HV.HeaderWithTime B))
   -> StrictTVar IO (Tip B)
   -> ChainDB.Follower IO B (ChainDB.WithPoint B H)
   -> Int

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs

@@ -45,6 +45,7 @@ import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (mapMaybe, maybeToList)
 import           Data.Maybe.Strict (StrictMaybe)
+import           Data.Typeable (Typeable)
 import           Data.Word (Word64)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config (TopLevelConfig, configLedger,
@@ -54,6 +55,7 @@ import           Ouroboros.Consensus.Config.SecurityParam
 import           Ouroboros.Consensus.HardFork.Abstract (HasHardForkHistory (..))
 import           Ouroboros.Consensus.HardFork.History.Qry (qryFromExpr,
                      runQuery, slotToGenesisWindow)
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState,
                      ledgerState)
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
@@ -216,7 +218,7 @@ evaluateGDD cfg tracer stateView = do
       let
         (losingPeers, bounds) =
           densityDisconnect sgen (configSecurityParam cfg) states candidateSuffixes loeFrag
-        loeHead = AF.headAnchor loeFrag
+        loeHead = AF.castAnchor $ AF.headAnchor loeFrag
 
       traceWith tracer $ TraceGDDDebug
         GDDDebugInfo {sgen, curChain, bounds, candidates, candidateSuffixes, losingPeers, loeHead}
@@ -225,7 +227,15 @@ evaluateGDD cfg tracer stateView = do
         for_ losingPeersNE $ \peer -> killActions Map.! peer
         traceWith tracer $ TraceGDDDisconnected losingPeersNE
 
-    pure loeFrag
+    -- REVIEW: we should avoid this linear computation, but I don't see an alternative to changing the type of the LoE fragment.
+    pure $ dropTime loeFrag
+
+
+-- REVIEW: If dropping time is correct, this function will go into HeaderValidation most likely.
+dropTime ::
+     AnchoredFragment (HeaderWithTime blk)
+  -> AnchoredFragment (Header blk)
+dropTime = undefined
 
 -- | Compute the fragment @loeFrag@ between the immutable tip and the
 -- earliest intersection between @curChain@ and any of the @candidates@.
@@ -235,14 +245,14 @@ evaluateGDD cfg tracer stateView = do
 -- The function also yields the suffixes of the intersection of @loeFrag@ with
 -- every candidate fragment.
 sharedCandidatePrefix ::
-  GetHeader blk =>
+  (Typeable blk, GetHeader blk) =>
   AnchoredFragment (Header blk) ->
-  [(peer, AnchoredFragment (Header blk))] ->
-  (AnchoredFragment (Header blk), [(peer, AnchoredFragment (Header blk))])
+  [(peer, AnchoredFragment (HeaderWithTime blk))] ->
+  (AnchoredFragment (HeaderWithTime blk), [(peer, AnchoredFragment (HeaderWithTime blk))])
 sharedCandidatePrefix curChain candidates =
   second getCompose $
-  stripCommonPrefix (AF.anchor curChain) $
-  Compose immutableTipSuffixes
+      stripCommonPrefix (AF.castAnchor $ AF.anchor curChain) $
+          Compose immutableTipSuffixes
   where
     immutableTip = AF.anchorPoint curChain
 
@@ -300,8 +310,8 @@ densityDisconnect ::
   => GenesisWindow
   -> SecurityParam
   -> Map peer (ChainSyncState blk)
-  -> [(peer, AnchoredFragment (Header blk))]
-  -> AnchoredFragment (Header blk)
+  -> [(peer, AnchoredFragment (HeaderWithTime blk))] -- REVIEW: add a comment here? (in addition to the haddock above)
+  -> AnchoredFragment (HeaderWithTime blk)           -- REVIEW: add a comment here?
   -> ([peer], [(peer, DensityBounds blk)])
 densityDisconnect (GenesisWindow sgen) (SecurityParam k) states candidateSuffixes loeFrag =
   (losingPeers, densityBounds)
@@ -349,7 +359,9 @@ densityDisconnect (GenesisWindow sgen) (SecurityParam k) states candidateSuffixe
           -- If not, it is not qualified to compete by density (yet).
           offersMoreThanK = totalBlockCount > k
 
-      pure (peer, DensityBounds {clippedFragment, offersMoreThanK, lowerBound, upperBound, hasBlockAfter, latestSlot, idling})
+      pure (peer, DensityBounds {
+               clippedFragment = (dropTime clippedFragment), -- REVIEW: should we change the type of the clipped fragment?
+               offersMoreThanK, lowerBound, upperBound, hasBlockAfter, latestSlot, idling})
 
     losingPeers = nubOrd $ densityBounds >>= \
       (peer0 , DensityBounds { clippedFragment = frag0
@@ -434,8 +446,8 @@ data GDDDebugInfo peer blk =
   GDDDebugInfo {
     bounds            :: [(peer, DensityBounds blk)],
     curChain          :: AnchoredFragment (Header blk),
-    candidates        :: [(peer, AnchoredFragment (Header blk))],
-    candidateSuffixes :: [(peer, AnchoredFragment (Header blk))],
+    candidates        :: [(peer, AnchoredFragment (HeaderWithTime blk))],
+    candidateSuffixes :: [(peer, AnchoredFragment (HeaderWithTime blk))],
     losingPeers       :: [peer],
     loeHead           :: AF.Anchor (Header blk),
     sgen              :: GenesisWindow