Skip to content

Commit fce8e47

Browse files
geo2ageo2a
committed
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.
1 parent be74c97 commit fce8e47

File tree

3 files changed

+52
-13
lines changed

3 files changed

+52
-13
lines changed

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

+21-4
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,10 @@
11
{-# LANGUAGE DerivingVia #-}
2+
{-# LANGUAGE FlexibleContexts #-}
23
{-# LANGUAGE FlexibleInstances #-}
34
{-# LANGUAGE LambdaCase #-}
45
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE PackageImports #-}
7+
{-# LANGUAGE ScopedTypeVariables #-}
68

79
module Cardano.Node.Tracing.Tracers.Peer
810
( PeerT (..)
@@ -14,6 +16,7 @@ import Cardano.Logging hiding (traceWith)
1416
import Cardano.Node.Orphans ()
1517
import Cardano.Node.Queries
1618
import Ouroboros.Consensus.Block (Header)
19+
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
1720
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientHandle,
1821
csCandidate, cschcMap, viewChainSyncState)
1922
import Ouroboros.Consensus.Util.Orphans ()
@@ -49,7 +52,8 @@ import Text.Printf (printf)
4952
-- The thread is linked to the parent thread for proper error propagation
5053
-- and labeled for easier debugging and identification.
5154
startPeerTracer
52-
:: Tracer IO [PeerT blk] -- ^ Tracer for the peer list
55+
:: forall blk. Net.HasHeader (Header blk)
56+
=> Tracer IO [PeerT blk] -- ^ Tracer for the peer list
5357
-> NodeKernelData blk -- ^ Node kernel containing peer data
5458
-> Int -- ^ Delay in milliseconds between traces
5559
-> IO ()
@@ -104,18 +108,31 @@ ppStatus = \case
104108
PeerFetchStatusReady {} -> "ready"
105109

106110
getCurrentPeers
107-
:: NodeKernelData blk
111+
:: forall blk. Net.HasHeader (Header blk)
112+
=> NodeKernelData blk
108113
-> IO [PeerT blk]
109114
getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd
110115
<&> fromSMaybe mempty
111116
where
112117
tuple3pop :: (a, b, c) -> (a, b)
113118
tuple3pop (a, b, _) = (a, b)
114119

120+
peerFetchStatusForgetTime :: PeerFetchStatus (HeaderWithTime blk) -> PeerFetchStatus (Header blk)
121+
peerFetchStatusForgetTime = \case
122+
PeerFetchStatusShutdown -> PeerFetchStatusShutdown
123+
PeerFetchStatusStarting -> PeerFetchStatusStarting
124+
PeerFetchStatusAberrant -> PeerFetchStatusAberrant
125+
PeerFetchStatusBusy -> PeerFetchStatusBusy
126+
PeerFetchStatusReady points idle -> PeerFetchStatusReady (Set.mapMonotonic Net.castPoint points) idle
127+
128+
peerFetchInFlightForgetTime :: PeerFetchInFlight (HeaderWithTime blk) -> PeerFetchInFlight (Header blk)
129+
peerFetchInFlightForgetTime inflight =
130+
inflight {peerFetchBlocksInFlight = Set.mapMonotonic Net.castPoint (peerFetchBlocksInFlight inflight)}
131+
115132
getCandidates
116133
:: STM.STM IO (Map peer (ChainSyncClientHandle IO blk))
117134
-> STM.STM IO (Map peer (Net.AnchoredFragment (Header blk)))
118-
getCandidates handle = viewChainSyncState handle csCandidate
135+
getCandidates handle = viewChainSyncState handle (Net.mapAnchoredFragment hwtHeader . csCandidate)
119136

120137
extractPeers :: NodeKernel IO RemoteAddress LocalConnectionId blk
121138
-> IO [PeerT blk]
@@ -129,7 +146,7 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd
129146

130147
let peers = flip Map.mapMaybeWithKey candidates $ \cid af ->
131148
maybe Nothing
132-
(\(status, inflight) -> Just $ PeerT cid af status inflight)
149+
(\(status, inflight) -> Just $ PeerT cid af (peerFetchStatusForgetTime status) (peerFetchInFlightForgetTime inflight))
133150
$ Map.lookup cid peerStates
134151
pure . Map.elems $ peers
135152

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

+12-6
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,7 @@ module Cardano.Tracing.OrphanInstances.Consensus () where
2121

2222
import Cardano.Node.Tracing.Tracers.ConsensusStartupException
2323
(ConsensusStartupException (..))
24-
import Cardano.Prelude (maximumDef)
24+
import Cardano.Prelude (Typeable, maximumDef)
2525
import Cardano.Slotting.Slot (fromWithOrigin)
2626
import Cardano.Tracing.OrphanInstances.Common
2727
import Cardano.Tracing.OrphanInstances.Network ()
@@ -74,8 +74,8 @@ import Ouroboros.Consensus.Util.Condense
7474
import Ouroboros.Consensus.Util.Enclose
7575
import Ouroboros.Consensus.Util.Orphans ()
7676
import qualified Ouroboros.Network.AnchoredFragment as AF
77-
import Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), MaxSlotNo(..), SlotNo (..), StandardHash,
78-
Tip (..), blockHash, pointSlot, tipFromHeader)
77+
import Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), MaxSlotNo (..),
78+
SlotNo (..), StandardHash, Tip (..), blockHash, pointSlot, tipFromHeader)
7979
import Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
8080
import Ouroboros.Network.Point (withOrigin)
8181
import Ouroboros.Network.SizeInBytes (SizeInBytes (..))
@@ -133,6 +133,12 @@ instance ConvertRawHash blk => ConvertRawHash (Header blk) where
133133
hashSize :: proxy (Header blk) -> Word32
134134
hashSize _ = hashSize (Proxy @blk)
135135

136+
instance ConvertRawHash blk => ConvertRawHash (HeaderWithTime blk) where
137+
toShortRawHash _ = toShortRawHash (Proxy @blk)
138+
fromShortRawHash _ = fromShortRawHash (Proxy @blk)
139+
hashSize :: proxy (HeaderWithTime blk) -> Word32
140+
hashSize _ = hashSize (Proxy @blk)
141+
136142
--
137143
-- * instances of @HasPrivacyAnnotation@ and @HasSeverityAnnotation@
138144
--
@@ -1779,10 +1785,10 @@ instance ToObject selection => ToObject (TraceGsmEvent selection) where
17791785
instance HasPrivacyAnnotation (TraceGDDEvent peer blk) where
17801786
instance HasSeverityAnnotation (TraceGDDEvent peer blk) where
17811787
getSeverityAnnotation _ = Debug
1782-
instance (ToObject peer, ConvertRawHash blk, GetHeader blk) => Transformable Text IO (TraceGDDEvent peer blk) where
1788+
instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk) => Transformable Text IO (TraceGDDEvent peer blk) where
17831789
trTransformer = trStructured
17841790

1785-
instance (ToObject peer, ConvertRawHash blk, GetHeader blk) => ToObject (TraceGDDEvent peer blk) where
1791+
instance (Typeable blk, ToObject peer, ConvertRawHash blk, GetHeader blk) => ToObject (TraceGDDEvent peer blk) where
17861792
toObject verb (TraceGDDDebug (GDDDebugInfo {..})) = mconcat $
17871793
[ "kind" .= String "TraceGDDEvent"
17881794
, "losingPeers".= toJSON (map (toObject verb) losingPeers)
@@ -1828,7 +1834,7 @@ instance (ToObject peer, ConvertRawHash blk, GetHeader blk) => ToObject (TraceGD
18281834
, "peer" .= toJSON (map (toObject verb) $ toList peer)
18291835
]
18301836

1831-
instance (ConvertRawHash blk, GetHeader blk) => ToObject (DensityBounds blk) where
1837+
instance (Typeable blk, ConvertRawHash blk, GetHeader blk) => ToObject (DensityBounds blk) where
18321838
toObject verb DensityBounds {..} = mconcat
18331839
[ "kind" .= String "DensityBounds"
18341840
, "clippedFragment" .= toObject verb clippedFragment

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

+19-3
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,10 @@
11
{-# LANGUAGE DeriveGeneric #-}
22
{-# LANGUAGE DerivingVia #-}
3+
{-# LANGUAGE FlexibleContexts #-}
34
{-# LANGUAGE FlexibleInstances #-}
45
{-# LANGUAGE LambdaCase #-}
56
{-# LANGUAGE OverloadedStrings #-}
7+
{-# LANGUAGE ScopedTypeVariables #-}
68

79
module Cardano.Tracing.Peer
810
( Peer (..)
@@ -17,6 +19,7 @@ import Cardano.BM.Tracing
1719
import Cardano.Node.Orphans ()
1820
import Cardano.Node.Queries
1921
import Ouroboros.Consensus.Block (Header)
22+
import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
2023
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainSyncClientHandle,
2124
csCandidate, cschcMap, viewChainSyncState)
2225
import Ouroboros.Consensus.Util.Orphans ()
@@ -87,18 +90,31 @@ ppStatus = \case
8790
PeerFetchStatusStarting -> "starting"
8891

8992
getCurrentPeers
90-
:: NodeKernelData blk
93+
:: forall blk. Net.HasHeader (Header blk)
94+
=> NodeKernelData blk
9195
-> IO [Peer blk]
9296
getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd
9397
<&> fromSMaybe mempty
9498
where
9599
tuple3pop :: (a, b, c) -> (a, b)
96100
tuple3pop (a, b, _) = (a, b)
97101

102+
peerFetchStatusForgetTime :: PeerFetchStatus (HeaderWithTime blk) -> PeerFetchStatus (Header blk)
103+
peerFetchStatusForgetTime = \case
104+
PeerFetchStatusShutdown -> PeerFetchStatusShutdown
105+
PeerFetchStatusStarting -> PeerFetchStatusStarting
106+
PeerFetchStatusAberrant -> PeerFetchStatusAberrant
107+
PeerFetchStatusBusy -> PeerFetchStatusBusy
108+
PeerFetchStatusReady points idle -> PeerFetchStatusReady (Set.mapMonotonic Net.castPoint points) idle
109+
110+
peerFetchInFlightForgetTime :: PeerFetchInFlight (HeaderWithTime blk) -> PeerFetchInFlight (Header blk)
111+
peerFetchInFlightForgetTime inflight =
112+
inflight {peerFetchBlocksInFlight = Set.mapMonotonic Net.castPoint (peerFetchBlocksInFlight inflight)}
113+
98114
getCandidates
99115
:: STM.STM IO (Map peer (ChainSyncClientHandle IO blk))
100116
-> STM.STM IO (Map peer (Net.AnchoredFragment (Header blk)))
101-
getCandidates handle = viewChainSyncState handle csCandidate
117+
getCandidates handle = viewChainSyncState handle (Net.mapAnchoredFragment hwtHeader . csCandidate)
102118

103119
extractPeers :: NodeKernel IO RemoteAddress LocalConnectionId blk
104120
-> IO [Peer blk]
@@ -112,7 +128,7 @@ getCurrentPeers nkd = mapNodeKernelDataIO extractPeers nkd
112128

113129
let peers = flip Map.mapMaybeWithKey candidates $ \cid af ->
114130
maybe Nothing
115-
(\(status, inflight) -> Just $ Peer cid af status inflight)
131+
(\(status, inflight) -> Just $ Peer cid af (peerFetchStatusForgetTime status) (peerFetchInFlightForgetTime inflight))
116132
$ Map.lookup cid peerStates
117133
pure . Map.elems $ peers
118134

0 commit comments

Comments
 (0)