From fce8e471d389f081fd439f9cf24a6fdc1d90de7d Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 7 May 2025 12:01:36 +0200 Subject: [PATCH 1/2] consensus: integrate `HeaderWithTime` The tracing system is modified to effectively ignore `HeaderWithTime` by dropping the time annotations and using the underlying `Header`, keeping the old behaviour. --- .../src/Cardano/Node/Tracing/Tracers/Peer.hs | 25 ++++++++++++++++--- .../Tracing/OrphanInstances/Consensus.hs | 18 ++++++++----- cardano-node/src/Cardano/Tracing/Peer.hs | 22 +++++++++++++--- 3 files changed, 52 insertions(+), 13 deletions(-) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs index e751a067f3e..238b2917fe2 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Peer.hs +++ b/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,7 +108,8 @@ 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 @@ -112,10 +117,22 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd 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 diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs index 3dfaef1be66..64432738d6b 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/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 diff --git a/cardano-node/src/Cardano/Tracing/Peer.hs b/cardano-node/src/Cardano/Tracing/Peer.hs index d7caff501b0..8c40e04f94d 100644 --- a/cardano-node/src/Cardano/Tracing/Peer.hs +++ b/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,7 +90,8 @@ 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 @@ -95,10 +99,22 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd 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 From ff6ac6f687af1ea2205f8aff9818f271d7be18bf Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 7 May 2025 13:18:52 +0200 Subject: [PATCH 2/2] TEMP add s-r-p on consensus packages, relax versions --- cabal.project | 10 ++++++++++ cardano-node/cardano-node.cabal | 2 +- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/cabal.project b/cabal.project index 35af620d187..471e3e44bbd 100644 --- a/cabal.project +++ b/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= diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 5ff4ea57334..6e76f98adb6 100644 --- a/cardano-node/cardano-node.cabal +++ b/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