consensus: integrate HeaderWithTime

cabal.project

@@ -90,3 +90,13 @@ if impl (ghc >= 9.12)
     -- https://github.com/haskell-servant/servant/pull/1810
     , servant:base
     , servant-server:base
+
+
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/ouroboros-consensus.git
+  tag: abe2ef2b9
+  subdir:
+    ouroboros-consensus
+    ouroboros-consensus-diffusion
+  --sha256: sha256-D1oxLyKk+HfpBjaakTmzzSYRJrPT9U0LEtFPsPXCAb4=

cardano-node/cardano-node.cabal

@@ -190,7 +190,7 @@ library
                       , network-mux >= 0.5
                       , nothunks
                       , optparse-applicative-fork >= 0.18.1
-                      , ouroboros-consensus ^>= 0.26.0.1
+                      , ouroboros-consensus ^>= 0.26
                       , ouroboros-consensus-cardano ^>= 0.25
                       , ouroboros-consensus-diffusion ^>= 0.22
                       , ouroboros-consensus-protocol

cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Cardano.Node.Tracing.Tracers.Peer
   ( PeerT (..)
@@ -14,6 +16,7 @@ import           Cardano.Logging hiding (traceWith)
 import           Cardano.Node.Orphans ()
 import           Cardano.Node.Queries
 import           Ouroboros.Consensus.Block (Header)
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientHandle,
                    csCandidate, cschcMap, viewChainSyncState)
 import           Ouroboros.Consensus.Util.Orphans ()
@@ -49,7 +52,8 @@ import           Text.Printf (printf)
 -- The thread is linked to the parent thread for proper error propagation
 -- and labeled for easier debugging and identification.
 startPeerTracer
-  :: Tracer IO [PeerT blk]  -- ^ Tracer for the peer list
+  :: forall blk. Net.HasHeader (Header blk)
+  => Tracer IO [PeerT blk]  -- ^ Tracer for the peer list
   -> NodeKernelData blk     -- ^ Node kernel containing peer data
   -> Int                    -- ^ Delay in milliseconds between traces
   -> IO ()
@@ -104,18 +108,31 @@ ppStatus = \case
   PeerFetchStatusReady {} -> "ready"
 
 getCurrentPeers
-  :: NodeKernelData blk
+  :: forall blk. Net.HasHeader (Header blk)
+  => NodeKernelData blk
   -> IO [PeerT blk]
 getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd
                       <&> fromSMaybe mempty
  where
   tuple3pop :: (a, b, c) -> (a, b)
   tuple3pop (a, b, _) = (a, b)
 
+  peerFetchStatusForgetTime :: PeerFetchStatus (HeaderWithTime blk) -> PeerFetchStatus (Header blk)
+  peerFetchStatusForgetTime = \case
+      PeerFetchStatusShutdown          -> PeerFetchStatusShutdown
+      PeerFetchStatusStarting          -> PeerFetchStatusStarting
+      PeerFetchStatusAberrant          -> PeerFetchStatusAberrant
+      PeerFetchStatusBusy              -> PeerFetchStatusBusy
+      PeerFetchStatusReady points idle -> PeerFetchStatusReady (Set.mapMonotonic Net.castPoint points) idle
+
+  peerFetchInFlightForgetTime :: PeerFetchInFlight (HeaderWithTime blk) -> PeerFetchInFlight (Header blk)
+  peerFetchInFlightForgetTime inflight =
+    inflight {peerFetchBlocksInFlight = Set.mapMonotonic Net.castPoint (peerFetchBlocksInFlight inflight)}
+
   getCandidates
     :: STM.STM IO (Map peer (ChainSyncClientHandle IO blk))
     -> STM.STM IO (Map peer (Net.AnchoredFragment (Header blk)))
-  getCandidates handle = viewChainSyncState handle csCandidate
+  getCandidates handle = viewChainSyncState handle (Net.mapAnchoredFragment hwtHeader . csCandidate)
 
   extractPeers :: NodeKernel IO RemoteAddress LocalConnectionId blk
                 -> IO [PeerT blk]
@@ -129,7 +146,7 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd
 
     let peers = flip Map.mapMaybeWithKey candidates $ \cid af ->
                   maybe Nothing
-                        (\(status, inflight) -> Just $ PeerT cid af status inflight)
+                        (\(status, inflight) -> Just $ PeerT cid af (peerFetchStatusForgetTime status) (peerFetchInFlightForgetTime inflight))
                         $ Map.lookup cid peerStates
     pure . Map.elems $ peers
 

cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs

@@ -21,7 +21,7 @@ module Cardano.Tracing.OrphanInstances.Consensus () where
 
 import           Cardano.Node.Tracing.Tracers.ConsensusStartupException
                    (ConsensusStartupException (..))
-import           Cardano.Prelude (maximumDef)
+import           Cardano.Prelude (Typeable, maximumDef)
 import           Cardano.Slotting.Slot (fromWithOrigin)
 import           Cardano.Tracing.OrphanInstances.Common
 import           Cardano.Tracing.OrphanInstances.Network ()
@@ -74,8 +74,8 @@ import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.Enclose
 import           Ouroboros.Consensus.Util.Orphans ()
 import qualified Ouroboros.Network.AnchoredFragment as AF
-import           Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), MaxSlotNo(..), SlotNo (..), StandardHash,
-                   Tip (..), blockHash, pointSlot, tipFromHeader)
+import           Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), MaxSlotNo (..),
+                   SlotNo (..), StandardHash, Tip (..), blockHash, pointSlot, tipFromHeader)
 import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
 import           Ouroboros.Network.Point (withOrigin)
 import           Ouroboros.Network.SizeInBytes (SizeInBytes (..))
@@ -133,6 +133,12 @@ instance ConvertRawHash blk => ConvertRawHash (Header blk) where
   hashSize :: proxy (Header blk) -> Word32
   hashSize _ = hashSize (Proxy @blk)
 
+instance ConvertRawHash blk => ConvertRawHash (HeaderWithTime blk) where
+  toShortRawHash _ = toShortRawHash (Proxy @blk)
+  fromShortRawHash _ = fromShortRawHash (Proxy @blk)
+  hashSize :: proxy (HeaderWithTime blk) -> Word32
+  hashSize _ = hashSize (Proxy @blk)
+
 --
 -- * instances of @HasPrivacyAnnotation@ and @HasSeverityAnnotation@
 --
@@ -1779,10 +1785,10 @@ instance ToObject selection => ToObject (TraceGsmEvent selection) where
 instance HasPrivacyAnnotation (TraceGDDEvent peer blk) where
 instance HasSeverityAnnotation (TraceGDDEvent peer blk) where
   getSeverityAnnotation _ = Debug
-instance (ToObject peer, ConvertRawHash blk, GetHeader blk) => Transformable Text IO (TraceGDDEvent peer blk) where
+instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk) => Transformable Text IO (TraceGDDEvent peer blk) where
   trTransformer = trStructured
 
-instance (ToObject peer, ConvertRawHash blk, GetHeader blk) => ToObject (TraceGDDEvent peer blk) where
+instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk) => ToObject (TraceGDDEvent peer blk) where
   toObject verb (TraceGDDDebug (GDDDebugInfo {..})) = mconcat $
     [ "kind" .= String "TraceGDDEvent"
     , "losingPeers".= toJSON (map (toObject verb) losingPeers)
@@ -1828,7 +1834,7 @@ instance (ToObject peer, ConvertRawHash blk, GetHeader blk) => ToObject (TraceGD
     , "peer" .= toJSON (map (toObject verb) $ toList peer)
     ]
 
-instance (ConvertRawHash blk, GetHeader blk) => ToObject (DensityBounds blk) where
+instance (Typeable blk, ConvertRawHash blk, GetHeader blk) => ToObject (DensityBounds blk) where
   toObject verb DensityBounds {..} = mconcat
     [ "kind" .= String "DensityBounds"
     , "clippedFragment" .= toObject verb clippedFragment

cardano-node/src/Cardano/Tracing/Peer.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Cardano.Tracing.Peer
   ( Peer (..)
@@ -17,6 +19,7 @@ import           Cardano.BM.Tracing
 import           Cardano.Node.Orphans ()
 import           Cardano.Node.Queries
 import           Ouroboros.Consensus.Block (Header)
+import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientHandle,
                    csCandidate, cschcMap, viewChainSyncState)
 import           Ouroboros.Consensus.Util.Orphans ()
@@ -87,18 +90,31 @@ ppStatus = \case
   PeerFetchStatusStarting -> "starting"
 
 getCurrentPeers
-  :: NodeKernelData blk
+  :: forall blk. Net.HasHeader (Header blk)
+  => NodeKernelData blk
   -> IO [Peer blk]
 getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd
                       <&> fromSMaybe mempty
  where
   tuple3pop :: (a, b, c) -> (a, b)
   tuple3pop (a, b, _) = (a, b)
 
+  peerFetchStatusForgetTime :: PeerFetchStatus (HeaderWithTime blk) -> PeerFetchStatus (Header blk)
+  peerFetchStatusForgetTime = \case
+      PeerFetchStatusShutdown          -> PeerFetchStatusShutdown
+      PeerFetchStatusStarting          -> PeerFetchStatusStarting
+      PeerFetchStatusAberrant          -> PeerFetchStatusAberrant
+      PeerFetchStatusBusy              -> PeerFetchStatusBusy
+      PeerFetchStatusReady points idle -> PeerFetchStatusReady (Set.mapMonotonic Net.castPoint points) idle
+
+  peerFetchInFlightForgetTime :: PeerFetchInFlight (HeaderWithTime blk) -> PeerFetchInFlight (Header blk)
+  peerFetchInFlightForgetTime inflight =
+    inflight {peerFetchBlocksInFlight = Set.mapMonotonic Net.castPoint (peerFetchBlocksInFlight inflight)}
+
   getCandidates
     :: STM.STM IO (Map peer (ChainSyncClientHandle IO blk))
     -> STM.STM IO (Map peer (Net.AnchoredFragment (Header blk)))
-  getCandidates handle = viewChainSyncState handle csCandidate
+  getCandidates handle = viewChainSyncState handle (Net.mapAnchoredFragment hwtHeader . csCandidate)
 
   extractPeers :: NodeKernel IO RemoteAddress LocalConnectionId blk
                 -> IO [Peer blk]
@@ -112,7 +128,7 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd
 
     let peers = flip Map.mapMaybeWithKey candidates $ \cid af ->
                   maybe Nothing
-                        (\(status, inflight) -> Just $ Peer cid af status inflight)
+                        (\(status, inflight) -> Just $ Peer cid af (peerFetchStatusForgetTime status) (peerFetchInFlightForgetTime inflight))
                         $ Map.lookup cid peerStates
     pure . Map.elems $ peers