From 71fdf5b5a64efac5cc400ec97593e4704576ae8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 24 Jul 2025 11:41:27 +0200 Subject: [PATCH 01/14] Hot connection durations A trace is emitted whenever a hot outbound peer is demoted or closed (possibly due to an error), giving the duration in seconds of how long the peer has been in hot mode. Added hot connection durations to peer selection debug state, which traces durations upon receiving sigusr1 interrupt. --- .../Network/PeerSelection/LedgerPeers/Type.hs | 2 +- .../Cardano/Network/Diffusion.hs | 4 +- .../Cardano/Network/Diffusion/Handlers.hs | 11 ++-- .../Network/PeerSelection/Governor/Types.hs | 25 ++++++-- .../Network/PeerSelection/PeerStateActions.hs | 58 +++++++++++++++---- .../Network/Diffusion/Testnet/Cardano.hs | 9 ++- 6 files changed, 85 insertions(+), 24 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs index 4dd4e270a51..01bc005ec82 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -266,7 +266,7 @@ data IsLedgerPeer = IsLedgerPeer data IsBigLedgerPeer = IsBigLedgerPeer | IsNotBigLedgerPeer - deriving Eq + deriving (Eq, Show) -- | Return ledger state information and ledger peers. -- diff --git a/ouroboros-network/cardano-diffusion/Cardano/Network/Diffusion.hs b/ouroboros-network/cardano-diffusion/Cardano/Network/Diffusion.hs index af6ed0938a3..2fa56c6cb46 100644 --- a/ouroboros-network/cardano-diffusion/Cardano/Network/Diffusion.hs +++ b/ouroboros-network/cardano-diffusion/Cardano/Network/Diffusion.hs @@ -41,6 +41,7 @@ import Ouroboros.Network.NodeToNode (NodeToNodeVersionData (..), RemoteAddress, import Ouroboros.Network.NodeToNode qualified as NodeToNode import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeersConsensusInterface (..)) +import Ouroboros.Network.PeerSelection.PeerStateActions import Ouroboros.Network.Protocol.Handshake -- | Main entry point for Cardano data diffusion service. It allows to: @@ -138,7 +139,8 @@ run CardanoNodeArguments { (Diffusion.dcPeerSharing config) readUseBootstrapPeers (Cardano.getLedgerStateJudgement (lpExtraAPI ledgerPeersAPI)) - churnMetrics, + churnMetrics + getPromotedHotTime, daPeerSelectionGovernorArgs = Cardano.Types.cardanoPeerSelectionGovernorArgs Cardano.ExtraPeerSelectionActions { diff --git a/ouroboros-network/cardano-diffusion/Cardano/Network/Diffusion/Handlers.hs b/ouroboros-network/cardano-diffusion/Cardano/Network/Diffusion/Handlers.hs index abe2eae3694..8376c3c7f54 100644 --- a/ouroboros-network/cardano-diffusion/Cardano/Network/Diffusion/Handlers.hs +++ b/ouroboros-network/cardano-diffusion/Cardano/Network/Diffusion/Handlers.hs @@ -8,6 +8,8 @@ module Cardano.Network.Diffusion.Handlers where +import Control.Monad.Class.MonadTime.SI + import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers) import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Cardano import Cardano.Network.Types (LedgerStateJudgement) @@ -19,7 +21,6 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers) import Ouroboros.Network.PeerSelection.PeerMetric import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) #ifdef POSIX -import Control.Monad.Class.MonadTime.SI import Control.Tracer (traceWith) import Ouroboros.Network.ConnectionManager.Core (Trace (..)) import Ouroboros.Network.PeerSelection.Governor.Types @@ -40,6 +41,8 @@ sigUSR1Handler -> STM IO UseBootstrapPeers -> STM IO LedgerStateJudgement -> PeerMetrics IO ntnAddr + -> (peerconn -> STM IO (Maybe Time)) + -- ^ return time when an active peer was promoted to a hot peer. -> ConnectionManager muxMode socket ntnAddr handle handleError IO -> StrictTVar IO (PeerSelectionState @@ -49,7 +52,7 @@ sigUSR1Handler -> IO () #ifdef POSIX sigUSR1Handler tracersExtra getUseLedgerPeers ownPeerSharing getBootstrapPeers - getLedgerStateJudgement metrics connectionManager dbgStateVar = do + getLedgerStateJudgement metrics getPromotedHotTime connectionManager dbgStateVar = do _ <- Signals.installHandler Signals.sigUSR1 (Signals.Catch @@ -66,7 +69,7 @@ sigUSR1Handler tracersExtra getUseLedgerPeers ownPeerSharing getBootstrapPeers useBootstrapPeers <*> readTVar dbgStateVar - let dbgState = makeDebugPeerSelectionState ps up bp lsj am + dbgState <- makeDebugPeerSelectionState ps up bp lsj am getPromotedHotTime now traceWith (dtConnectionManagerTracer tracersExtra) (TrState state) @@ -77,5 +80,5 @@ sigUSR1Handler tracersExtra getUseLedgerPeers ownPeerSharing getBootstrapPeers Nothing return () #else -sigUSR1Handler _ _ _ _ _ _ _ _ = pure () +sigUSR1Handler _ _ _ _ _ _ _ _ _ = pure () #endif diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index 7d806467ce9..7e0cb3f75df 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -769,18 +769,24 @@ data DebugPeerSelectionState extraState extraFlags extraPeers peeraddr = dpssUpstreamyness :: !(Map peeraddr Int), dpssFetchynessBlocks :: !(Map peeraddr Int), dpssAssociationMode :: !AssociationMode, + dpssHotDurations :: !(Map peeraddr (IsBigLedgerPeer, DiffTime)), dpssExtraState :: !extraState } deriving Show makeDebugPeerSelectionState - :: PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn + :: (Ord peeraddr, MonadSTM m) + => PeerSelectionState extraState extraFlags extraPeers peeraddr peerconn -> Map peeraddr Int -> Map peeraddr Int -> extraDebugState -> AssociationMode - -> DebugPeerSelectionState extraDebugState extraFlags extraPeers peeraddr -makeDebugPeerSelectionState PeerSelectionState {..} up bp es am = - DebugPeerSelectionState { + -> (peerconn -> STM m (Maybe Time)) + -> Time + -> m (DebugPeerSelectionState extraDebugState extraFlags extraPeers peeraddr) +makeDebugPeerSelectionState PeerSelectionState {..} up bp es am getPromotedHotTime now = do + let activeMap = EstablishedPeers.toMap establishedPeers `Map.restrictKeys` activePeers + dpssHotDurations <- Map.traverseMaybeWithKey getDiffTimes activeMap + return DebugPeerSelectionState { dpssTargets = targets , dpssLocalRootPeers = localRootPeers , dpssPublicRootPeers = publicRootPeers @@ -802,8 +808,19 @@ makeDebugPeerSelectionState PeerSelectionState {..} up bp es am = , dpssUpstreamyness = up , dpssFetchynessBlocks = bp , dpssAssociationMode = am + , dpssHotDurations , dpssExtraState = es } + where + getDiffTimes peeraddr peerconn = do + t1 <- atomically $ getPromotedHotTime peerconn + case t1 of + Nothing -> return Nothing + Just t1' -> + let !dt = now `diffTime` t1' + in if Set.member peeraddr (PublicRootPeers.getBigLedgerPeers publicRootPeers) + then return . Just $ (IsBigLedgerPeer, dt) + else return . Just $ (IsNotBigLedgerPeer, dt) -- | Public 'PeerSelectionState' that can be accessed by Peer Sharing -- mechanisms without any problem. diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs index f9a91386fbe..6b522464312 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -18,6 +20,7 @@ module Ouroboros.Network.PeerSelection.PeerStateActions -- * Create PeerStateActions PeerStateActionsArguments (..) , PeerConnectionHandle + , getPromotedHotTime , withPeerStateActions , pchPeerSharing -- * Exceptions @@ -38,6 +41,7 @@ import Control.Monad (when, (<=<)) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Concurrent.JobPool (Job (..), JobPool) @@ -428,13 +432,23 @@ awaitAllResults tok bundle = do -- together with their state 'StrictTVar's. -- data PeerConnectionHandle (muxMode :: Mux.Mode) responderCtx peerAddr versionData bytes m a b = PeerConnectionHandle { - pchConnectionId :: ConnectionId peerAddr, - pchPeerStatus :: StrictTVar m PeerStatus, - pchMux :: Mux.Mux muxMode m, - pchAppHandles :: TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b), - pchVersionData :: !versionData + pchConnectionId :: !(ConnectionId peerAddr), + pchPeerStatus :: !(StrictTVar m PeerStatus), + pchMux :: !(Mux.Mux muxMode m), + pchAppHandles :: !(TemperatureBundle (ApplicationHandle muxMode responderCtx peerAddr bytes m a b)), + pchVersionData :: !versionData, + pchPromotedHotVar :: !(StrictTVar m (Maybe Time)) } +-- | Retrieve the time the remote peer has been promoted to hot state +-- or Nothing if either the peer was not promoted or is being currently demoted +-- +getPromotedHotTime :: (MonadSTM m) + => PeerConnectionHandle muxMode responderCtx peerAddr versionData bytes m a b + -> STM m (Maybe Time) +getPromotedHotTime PeerConnectionHandle { pchPromotedHotVar } = + readTVar pchPromotedHotVar + mkInitiatorContext :: MonadSTM m => SingProtocolTemperature pt -> IsBigLedgerPeer @@ -627,7 +641,12 @@ withPeerStateActions PeerStateActionsArguments { peerMonitoringLoop :: PeerConnectionHandle muxMode responderCtx peerAddr versionData ByteString m a b -> m () - peerMonitoringLoop pch@PeerConnectionHandle { pchConnectionId, pchPeerStatus, pchAppHandles } = do + peerMonitoringLoop pch@PeerConnectionHandle { + pchConnectionId, + pchPeerStatus, + pchAppHandles, + pchPromotedHotVar + } = do -- A first-to-finish synchronisation on all the bundles; As a result -- this is a first-to-finish synchronisation between all the -- mini-protocols runs toward the given peer. @@ -731,7 +750,13 @@ withPeerStateActions PeerStateActionsArguments { -- peerMonitingLoop exit -- - Nothing -> + Nothing -> do + pchPromotedHot <- atomically $ stateTVar pchPromotedHotVar (, Nothing) + case pchPromotedHot of + Just t1 -> do + dt <- diffTime <$> getMonotonicTime <*> pure t1 + traceWith spsTracer (PeerHotDuration pchConnectionId dt) + Nothing -> pure () traceWith spsTracer (PeerStatusChanged (CoolingToCold pchConnectionId)) establishPeerConnection :: JobPool () m (Maybe SomeException) @@ -768,7 +793,8 @@ withPeerStateActions PeerStateActionsArguments { writeTVar (projectBundle SingWarm controlMessageBundle) Continue writeTVar (projectBundle SingEstablished controlMessageBundle) Continue - awaitVarBundle <- atomically $ mkAwaitVars muxBundle + awaitVarBundle <- atomically $ mkAwaitVars muxBundle + pchPromotedHotVar <- newTVarIO Nothing let connHandle = PeerConnectionHandle { @@ -779,7 +805,8 @@ withPeerStateActions PeerStateActionsArguments { muxBundle controlMessageBundle awaitVarBundle, - pchVersionData = versionData + pchVersionData = versionData, + pchPromotedHotVar } startProtocols SingWarm isBigLedgerPeer connHandle @@ -796,9 +823,15 @@ withPeerStateActions PeerStateActionsArguments { Just SomeAsyncException {} -> Nothing Nothing -> Just e) (\e -> do - atomically $ do + promotedHot <- atomically $ do waitForOutboundDemotion spsConnectionManager connId writeTVar peerStateVar PeerCold + stateTVar pchPromotedHotVar (, Nothing) + case promotedHot of + Just t1 -> do + dt <- diffTime <$> getMonotonicTime <*> pure t1 + traceWith spsTracer (PeerHotDuration connId dt) + Nothing -> pure () traceWith spsTracer (PeerMonitoringError connId e) throwIO e) (peerMonitoringLoop connHandle $> Nothing)) @@ -913,7 +946,8 @@ withPeerStateActions PeerStateActionsArguments { connHandle@PeerConnectionHandle { pchConnectionId, pchPeerStatus, - pchAppHandles } = do + pchAppHandles, + pchPromotedHotVar } = do -- quiesce warm peer protocols and set hot ones in 'Continue' mode. wasWarm <- atomically $ do -- if the peer is cold we can't activate it. @@ -930,6 +964,7 @@ withPeerStateActions PeerStateActionsArguments { -- start hot peer protocols startProtocols SingHot isBigLedgerPeer connHandle + atomically . writeTVar pchPromotedHotVar . (Just $!) =<< getMonotonicTime -- Only set the status to PeerHot if the peer isn't PeerCold. -- This can happen asynchronously between the check above and now. @@ -1207,4 +1242,5 @@ data PeerSelectionActionsTrace peerAddr vNumber = | PeerMonitoringError (ConnectionId peerAddr) SomeException | PeerMonitoringResult (ConnectionId peerAddr) (Maybe (WithSomeProtocolTemperature FirstToFinishResult)) | AcquireConnectionError SomeException + | PeerHotDuration (ConnectionId peerAddr) DiffTime deriving Show diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs index f29c11470ce..07d55fe2bc7 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -1259,6 +1259,8 @@ prop_peer_selection_action_trace_coverage defaultBearerInfo diffScript = = "AcquireConnectionError: " ++ show (ioe_type ioe) | otherwise = "AcquireConnectionError: " ++ show e + peerSelectionActionsTraceMap (PeerHotDuration _id _dt) = + "PeerHotDuration" eventsSeenNames = map peerSelectionActionsTraceMap events @@ -3879,7 +3881,7 @@ prop_diffusion_peer_selection_actions_no_dodgy_traces ioSimTrace traceNumber = $ evs' numOfActiveColdErrors = length . filter (\case - (PeerStatusChangeFailure HotToWarm{} ActiveCold) + (PeerStatusChangeFailure HotToWarm{} ActiveCold{}) -> True _ -> False) $ evs' @@ -3902,7 +3904,7 @@ prop_diffusion_peer_selection_actions_no_dodgy_traces ioSimTrace traceNumber = in conjoin (zipWith (curry (\case ev@( WithTime _ (PeerStatusChangeFailure (HotToWarm _) TimeoutError) - , WithTime _ (PeerStatusChangeFailure (HotToWarm _) ActiveCold) + , WithTime _ (PeerStatusChangeFailure (HotToWarm _) ActiveCold{}) ) -> counterexample (show ev) $ counterexample (unlines $ map show peerSelectionActionsEvents) @@ -3969,7 +3971,8 @@ prop_diffusion_peer_selection_actions_no_dodgy_traces ioSimTrace traceNumber = WithTime _ (PeerStatusChangeFailure type_ _) -> getConnId type_ WithTime _ (PeerMonitoringError connId _) -> Just connId WithTime _ (PeerMonitoringResult connId _) -> Just connId - WithTime _ (AcquireConnectionError _) -> Nothing) + WithTime _ (AcquireConnectionError _) -> Nothing + WithTime _ (PeerHotDuration connId _) -> Just connId) $ peerSelectionActionsEvents ) From 1d0e44cf64bbd2d3ba20c1588e3da91c94d5bd8b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Thu, 24 Jul 2025 11:42:17 +0200 Subject: [PATCH 02/14] changelog --- ouroboros-network/CHANGELOG.md | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index ba404b15091..e05af2ee3c7 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -1,11 +1,15 @@ # Revision history for ouroboros-network -## next release +## 0.22.1.0 -- 2025-07- ### Breaking changes ### Non-breaking changes +- Added `pchPromotedHotVar` to `PeerConnectionHandle` to track when a peer has been promoted to hot +- Added tag `PeerHotDuration` to `PeerSelectionActionsTrace` to indicate how long a remote + peer has been in hot mode until it was either demoted or closed. + ## 0.22.0.0 -- 28.06.2025 ### Breaking changes @@ -51,6 +55,10 @@ * Added `dispatchLookupWithTTL` * Lower the time to cache DNS errors to at most 15min. +## 0.21.3.0 + +Consult changelog on main + ## 0.21.2.0 -- 2025-06-02 ### Breaking changes From c7a45c7af37179e41955539816edaf4860e4d943 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Marcin=20W=C3=B3jtowicz?= Date: Fri, 25 Jul 2025 09:27:54 +0200 Subject: [PATCH 03/14] Restore tracking of 'PeerHotDuration' when demoting a peer --- .../Network/PeerSelection/PeerStateActions.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs index 6b522464312..e9f7f336cee 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs @@ -985,7 +985,8 @@ withPeerStateActions PeerStateActionsArguments { pchConnectionId, pchPeerStatus, pchMux, - pchAppHandles + pchAppHandles, + pchPromotedHotVar } = do wasCold <- atomically $ do notCold <- isNotCoolingOrCold pchPeerStatus @@ -1004,7 +1005,15 @@ withPeerStateActions PeerStateActionsArguments { -- Hot protocols should stop within 'spsDeactivateTimeout'. res <- timeout spsDeactivateTimeout - (atomically $ awaitAllResults SingHot pchAppHandles) + do + (res, pchPromotedHot) <- + atomically $ (,) <$> awaitAllResults SingHot pchAppHandles + <*> stateTVar pchPromotedHotVar (, Nothing) + res <$ case pchPromotedHot of + Just t1 -> do + dt <- diffTime <$> getMonotonicTime <*> pure t1 + traceWith spsTracer (PeerHotDuration pchConnectionId dt) + Nothing -> pure () case res of Nothing -> do Mux.stop pchMux From 82df769f3b916e6dd9465505081628dea7fc78d8 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 21 Jul 2025 15:26:43 +0200 Subject: [PATCH 04/14] Retain original CBOR encoding of {Ledger}RelayAccessPoint --- .../Network/PeerSelection/LedgerPeers/Type.hs | 16 +++++++- .../Network/PeerSelection/RelayAccessPoint.hs | 40 +++++++++++-------- .../Network/PeerSelection/RelayAccessPoint.hs | 4 +- 3 files changed, 40 insertions(+), 20 deletions(-) diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs index 01bc005ec82..cda909457fc 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -184,10 +184,18 @@ instance FromCBOR WithOriginCoded where (2, _) -> fail "LedgerPeers.Type: Expected tag for At constructor" _ -> fail "LedgerPeers.Type: Unrecognized list length while decoding WithOrigin SlotNo" + +-- TODO: don't use `ToCBOR` type class but a function: +-- ``` +-- encodeLedgerPeerSnapshot :: NodeToClientVersion -> Encoding +-- ``` +-- Also note that if we use `NodeToClientVersion` we don't need to encode the +-- version of the `LedgerPeerSnapshot` encoding (e.g. the internal version below). +-- instance ToCBOR LedgerPeerSnapshot where toCBOR (LedgerPeerSnapshotV2 (wOrigin, pools)) = Codec.encodeListLen 2 - <> Codec.encodeWord8 2 + <> Codec.encodeWord8 1 -- internal version <> toCBOR (WithOriginCoded wOrigin, pools') where pools' = @@ -195,12 +203,16 @@ instance ToCBOR LedgerPeerSnapshot where | (accPoolStake, (relStake, relays)) <- pools ] +-- TODO: don't use `FromCBOR` type class but a function: +-- ``` +-- decodeLedgerPeerSnapshot :: NodeToClientVersion -> Decoder s LedgerPeerSnapshot +-- ``` instance FromCBOR LedgerPeerSnapshot where fromCBOR = do Codec.decodeListLenOf 2 version <- Codec.decodeWord8 case version of - 2 -> LedgerPeerSnapshotV2 <$> do + 1 -> LedgerPeerSnapshotV2 <$> do (WithOriginCoded wOrigin, pools) <- fromCBOR let pools' = [(accStake, (relStake, relays)) | (AccPoolStakeCoded accStake, (PoolStakeCoded relStake, relays)) <- pools diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs index 6b12e43fa32..a714720d3ab 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs @@ -100,18 +100,18 @@ instance ToCBOR RelayAccessPoint where RelayAccessDomain domain port -> Codec.encodeListLen 3 <> Codec.encodeWord8 0 - <> toCBOR domain <> serialise' port + <> toCBOR domain RelayAccessAddress (IP.IPv4 ipv4) port -> Codec.encodeListLen 3 <> Codec.encodeWord8 1 - <> toCBOR (IP.fromIPv4 ipv4) <> serialise' port + <> toCBOR (IP.fromIPv4 ipv4) RelayAccessAddress (IP.IPv6 ip6) port -> Codec.encodeListLen 3 <> Codec.encodeWord8 2 - <> toCBOR (IP.fromIPv6 ip6) <> serialise' port + <> toCBOR (IP.fromIPv6 ip6) RelayAccessSRVDomain domain -> Codec.encodeListLen 2 <> Codec.encodeWord8 3 @@ -130,13 +130,17 @@ instance FromCBOR RelayAccessPoint where <> show constructorTag case constructorTag of 0 -> do - RelayAccessDomain <$> fromCBOR <*> decodePort + port <- decodePort + domain <- fromCBOR + return $ RelayAccessDomain domain port 1 -> do - let ip4 = IP.IPv4 . IP.toIPv4 <$> fromCBOR - RelayAccessAddress <$> ip4 <*> decodePort + port <- decodePort + ip <- IP.IPv4 . IP.toIPv4 <$> fromCBOR + return $ RelayAccessAddress ip port 2 -> do - let ip6 = IP.IPv6 . IP.toIPv6 <$> fromCBOR - RelayAccessAddress <$> ip6 <*> decodePort + port <- decodePort + ip <- IP.IPv6 . IP.toIPv6 <$> fromCBOR + return $ RelayAccessAddress ip port 3 -> do RelayAccessSRVDomain <$> fromCBOR _ -> fail $ "Unrecognized RelayAccessPoint tag: " <> show constructorTag @@ -216,18 +220,18 @@ instance ToCBOR LedgerRelayAccessPoint where LedgerRelayAccessDomain domain port -> Codec.encodeListLen 3 <> Codec.encodeWord8 0 - <> toCBOR domain <> serialise' port + <> toCBOR domain LedgerRelayAccessAddress (IP.IPv4 ipv4) port -> Codec.encodeListLen 3 <> Codec.encodeWord8 1 - <> toCBOR (IP.fromIPv4 ipv4) <> serialise' port + <> toCBOR (IP.fromIPv4 ipv4) LedgerRelayAccessAddress (IP.IPv6 ip6) port -> Codec.encodeListLen 3 <> Codec.encodeWord8 2 - <> toCBOR (IP.fromIPv6 ip6) <> serialise' port + <> toCBOR (IP.fromIPv6 ip6) LedgerRelayAccessSRVDomain domain -> Codec.encodeListLen 2 <> Codec.encodeWord8 3 @@ -246,13 +250,17 @@ instance FromCBOR LedgerRelayAccessPoint where <> show constructorTag case constructorTag of 0 -> do - LedgerRelayAccessDomain <$> fromCBOR <*> decodePort + port <- decodePort + domain <- fromCBOR + return $ LedgerRelayAccessDomain domain port 1 -> do - let ip4 = IP.IPv4 . IP.toIPv4 <$> fromCBOR - LedgerRelayAccessAddress <$> ip4 <*> decodePort + port <- decodePort + ip <- IP.IPv4 . IP.toIPv4 <$> fromCBOR + return $ LedgerRelayAccessAddress ip port 2 -> do - let ip6 = IP.IPv6 . IP.toIPv6 <$> fromCBOR - LedgerRelayAccessAddress <$> ip6 <*> decodePort + port <- decodePort + ip <- IP.IPv6 . IP.toIPv6 <$> fromCBOR + return $ LedgerRelayAccessAddress ip port 3 -> do LedgerRelayAccessSRVDomain <$> fromCBOR _ -> fail $ "Unrecognized LedgerRelayAccessPoint tag: " <> show constructorTag diff --git a/ouroboros-network-api/test/Test/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs b/ouroboros-network-api/test/Test/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs index f9ed8e3bab5..cda9f8f0c81 100644 --- a/ouroboros-network-api/test/Test/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs +++ b/ouroboros-network-api/test/Test/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs @@ -23,8 +23,8 @@ import Test.Tasty.QuickCheck (testProperty) tests :: TestTree tests = testGroup "Ouroboros.Network.PeerSelection" [ testGroup "cbor" - [ testProperty "LedgeRelayAccessPoint" prop_cbor_LedgerRelayAccessPoint - , testProperty "RelayAccessPoint" prop_cbor_RelayAccessPoint + [ testProperty "LedgerRelayAccessPoint" prop_cbor_LedgerRelayAccessPoint + , testProperty "RelayAccessPoint" prop_cbor_RelayAccessPoint ] , testGroup "json" [ testProperty "RelayAccessPoint" prop_json_RelayAccessPoint From 604013cf4775707084c7a7dcc8c1b6e99c986dfa Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 21 Jul 2025 17:18:00 +0200 Subject: [PATCH 05/14] NodeToClientV_22: support SRV in GetLedgerPeerSnapshot --- cardano-ping/src/Cardano/Network/Ping.hs | 8 ++ .../Ouroboros/Network/NodeToClient/Version.hs | 4 + .../Network/PeerSelection/LedgerPeers/Type.hs | 82 +++++++++++-------- .../cddl/specs/handshake-node-to-client.cddl | 4 +- .../Ouroboros/Network/OrphanInstances.hs | 2 + ouroboros-network/ouroboros-network.cabal | 1 - .../Test/Ouroboros/Network/LedgerPeers.hs | 40 +++++++-- 7 files changed, 100 insertions(+), 41 deletions(-) diff --git a/cardano-ping/src/Cardano/Network/Ping.hs b/cardano-ping/src/Cardano/Network/Ping.hs index cf5142dfec4..ae723af712b 100644 --- a/cardano-ping/src/Cardano/Network/Ping.hs +++ b/cardano-ping/src/Cardano/Network/Ping.hs @@ -153,6 +153,7 @@ supportedNodeToClientVersions magic = , NodeToClientVersionV19 magic , NodeToClientVersionV20 magic , NodeToClientVersionV21 magic + , NodeToClientVersionV22 magic ] data InitiatorOnly = InitiatorOnly | InitiatorAndResponder @@ -191,6 +192,7 @@ data NodeVersion | NodeToClientVersionV19 Word32 | NodeToClientVersionV20 Word32 | NodeToClientVersionV21 Word32 + | NodeToClientVersionV22 Word32 | NodeToNodeVersionV1 Word32 | NodeToNodeVersionV2 Word32 | NodeToNodeVersionV3 Word32 @@ -223,6 +225,7 @@ instance ToJSON NodeVersion where NodeToClientVersionV19 m -> go2 "NodeToClientVersionV19" m NodeToClientVersionV20 m -> go2 "NodeToClientVersionV20" m NodeToClientVersionV21 m -> go2 "NodeToClientVersionV21" m + NodeToClientVersionV22 m -> go2 "NodeToClientVersionV22" m NodeToNodeVersionV1 m -> go2 "NodeToNodeVersionV1" m NodeToNodeVersionV2 m -> go2 "NodeToNodeVersionV2" m NodeToNodeVersionV3 m -> go2 "NodeToNodeVersionV3" m @@ -371,6 +374,9 @@ handshakeReqEnc versions query = encodeVersion (NodeToClientVersionV21 magic) = CBOR.encodeWord (21 `setBit` nodeToClientVersionBit) <> nodeToClientDataWithQuery magic + encodeVersion (NodeToClientVersionV22 magic) = + CBOR.encodeWord (22 `setBit` nodeToClientVersionBit) + <> nodeToClientDataWithQuery magic -- node-to-node encodeVersion (NodeToNodeVersionV1 magic) = @@ -521,6 +527,7 @@ handshakeDec = do (19, True) -> Right . NodeToClientVersionV19 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) (20, True) -> Right . NodeToClientVersionV20 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) (21, True) -> Right . NodeToClientVersionV21 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) + (22, True) -> Right . NodeToClientVersionV22 <$> (CBOR.decodeListLen *> CBOR.decodeWord32 <* (modeFromBool <$> CBOR.decodeBool)) _ -> return $ Left $ UnknownVersionInRsp version decodeWithMode :: (Word32 -> InitiatorOnly -> NodeVersion) -> CBOR.Decoder s (Either HandshakeFailure NodeVersion) @@ -845,6 +852,7 @@ isSameVersionAndMagic v1 v2 = extract v1 == extract v2 extract (NodeToClientVersionV19 m) = (-19, m) extract (NodeToClientVersionV20 m) = (-20, m) extract (NodeToClientVersionV21 m) = (-21, m) + extract (NodeToClientVersionV22 m) = (-22, m) extract (NodeToNodeVersionV1 m) = (1, m) extract (NodeToNodeVersionV2 m) = (2, m) extract (NodeToNodeVersionV3 m) = (3, m) diff --git a/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs b/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs index d2222653ded..a3aaeb8de9f 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/NodeToClient/Version.hs @@ -54,6 +54,8 @@ data NodeToClientVersion -- added @MsgGetMeasures@ and @MsgReplyGetMeasures@ to @LocalTxMonitor@ | NodeToClientV_21 -- ^ new codecs for @PParams@ and @CompactGenesis@ + | NodeToClientV_22 + -- ^ support SRV records in @GetBigLedgerPeerSnapshot@ query deriving (Eq, Ord, Enum, Bounded, Show, Generic, NFData) -- | We set 16ths bit to distinguish `NodeToNodeVersion` and @@ -73,6 +75,7 @@ nodeToClientVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } NodeToClientV_19 -> enc 19 NodeToClientV_20 -> enc 20 NodeToClientV_21 -> enc 21 + NodeToClientV_22 -> enc 22 where enc :: Int -> CBOR.Term enc = CBOR.TInt . (`setBit` nodeToClientVersionBit) @@ -85,6 +88,7 @@ nodeToClientVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm } 19 -> Right NodeToClientV_19 20 -> Right NodeToClientV_20 21 -> Right NodeToClientV_21 + 22 -> Right NodeToClientV_22 n -> Left (unknownTag n) where dec :: CBOR.Term -> Either (Text, Maybe Int) Int diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs index cda909457fc..ca92eecdff4 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -27,6 +28,9 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type , AfterSlot (..) , LedgerPeersKind (..) , LedgerPeerSnapshot (.., LedgerPeerSnapshot) + , LedgerPeerSnapshotSRVSupport (..) + , encodeLedgerPeerSnapshot + , decodeLedgerPeerSnapshot , getRelayAccessPointsFromLedgerPeerSnapshot , isLedgerPeersEnabled , compareLedgerPeerSnapshotApproximate @@ -39,6 +43,7 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type import GHC.Generics (Generic) +-- TODO: remove `FromCBOR` and `ToCBOR` type classes import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Binary qualified as Codec import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) @@ -46,8 +51,9 @@ import Control.Concurrent.Class.MonadSTM import Control.DeepSeq (NFData (..)) import Control.Monad (forM) import Data.Aeson -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NonEmpty import NoThunks.Class import Ouroboros.Network.PeerSelection.RelayAccessPoint @@ -161,59 +167,71 @@ instance FromJSON LedgerPeerSnapshot where Just ledgerPeerSnapshot' -> return ledgerPeerSnapshot' Nothing -> fail "Network.LedgerPeers.Type: parseJSON: failed to migrate big ledger peer snapshot" --- | cardano-slotting provides its own {To,From}CBOR instances for WithOrigin a --- but to pin down the encoding for CDDL we provide a wrapper with custom --- instances --- -newtype WithOriginCoded = WithOriginCoded (WithOrigin SlotNo) --- | Hand cranked CBOR instances to facilitate CDDL spec --- -instance ToCBOR WithOriginCoded where - toCBOR (WithOriginCoded Origin) = Codec.encodeListLen 1 <> Codec.encodeWord8 0 - toCBOR (WithOriginCoded (At slotNo)) = Codec.encodeListLen 2 <> Codec.encodeWord8 1 <> toCBOR slotNo +encodeWithOrigin :: WithOrigin SlotNo -> Codec.Encoding +encodeWithOrigin Origin = Codec.encodeListLen 1 <> Codec.encodeWord8 0 +encodeWithOrigin (At slotNo) = Codec.encodeListLen 2 <> Codec.encodeWord8 1 <> toCBOR slotNo -instance FromCBOR WithOriginCoded where - fromCBOR = do +decodeWithOrigin :: Codec.Decoder s (WithOrigin SlotNo) +decodeWithOrigin = do listLen <- Codec.decodeListLen tag <- Codec.decodeWord8 case (listLen, tag) of - (1, 0) -> pure $ WithOriginCoded Origin + (1, 0) -> pure $ Origin (1, _) -> fail "LedgerPeers.Type: Expected tag for Origin constructor" - (2, 1) -> WithOriginCoded . At <$> fromCBOR + (2, 1) -> At <$> fromCBOR (2, _) -> fail "LedgerPeers.Type: Expected tag for At constructor" _ -> fail "LedgerPeers.Type: Unrecognized list length while decoding WithOrigin SlotNo" --- TODO: don't use `ToCBOR` type class but a function: --- ``` --- encodeLedgerPeerSnapshot :: NodeToClientVersion -> Encoding --- ``` --- Also note that if we use `NodeToClientVersion` we don't need to encode the --- version of the `LedgerPeerSnapshot` encoding (e.g. the internal version below). --- -instance ToCBOR LedgerPeerSnapshot where - toCBOR (LedgerPeerSnapshotV2 (wOrigin, pools)) = +data LedgerPeerSnapshotSRVSupport + = LedgerPeerSnapshotSupportsSRV + -- ^ since `NodeToClientV_22` + | LedgerPeerSnapshotDoesntSupportSRV + deriving (Show, Eq) + +encodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> LedgerPeerSnapshot -> Codec.Encoding +encodeLedgerPeerSnapshot LedgerPeerSnapshotDoesntSupportSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = + Codec.encodeListLen 2 + <> Codec.encodeWord8 1 -- internal version + <> Codec.encodeListLen 2 + <> encodeWithOrigin wOrigin + <> toCBOR pools' + where + pools' = + [(AccPoolStakeCoded accPoolStake, (PoolStakeCoded relStake, relays)) + | (accPoolStake, (relStake, relays)) <- + -- filter out SRV domains, not supported by `< NodeToClientV_22` + map + (second $ second $ NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> False + _ -> True) + ) + pools + , not (null relays) + ] +encodeLedgerPeerSnapshot LedgerPeerSnapshotSupportsSRV (LedgerPeerSnapshotV2 (wOrigin, pools)) = Codec.encodeListLen 2 <> Codec.encodeWord8 1 -- internal version - <> toCBOR (WithOriginCoded wOrigin, pools') + <> Codec.encodeListLen 2 + <> encodeWithOrigin wOrigin + <> toCBOR pools' where pools' = [(AccPoolStakeCoded accPoolStake, (PoolStakeCoded relStake, relays)) | (accPoolStake, (relStake, relays)) <- pools ] --- TODO: don't use `FromCBOR` type class but a function: --- ``` --- decodeLedgerPeerSnapshot :: NodeToClientVersion -> Decoder s LedgerPeerSnapshot --- ``` -instance FromCBOR LedgerPeerSnapshot where - fromCBOR = do +decodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> Codec.Decoder s LedgerPeerSnapshot +decodeLedgerPeerSnapshot _ = do Codec.decodeListLenOf 2 version <- Codec.decodeWord8 case version of 1 -> LedgerPeerSnapshotV2 <$> do - (WithOriginCoded wOrigin, pools) <- fromCBOR + Codec.decodeListLenOf 2 + wOrigin <- decodeWithOrigin + pools <- fromCBOR let pools' = [(accStake, (relStake, relays)) | (AccPoolStakeCoded accStake, (PoolStakeCoded relStake, relays)) <- pools ] diff --git a/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl b/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl index f9ea3f06991..afee197d68b 100644 --- a/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl +++ b/ouroboros-network-protocols/cddl/specs/handshake-node-to-client.cddl @@ -19,8 +19,8 @@ versionTable = { * versionNumber => nodeToClientVersionData } ; as of version 2 (which is no longer supported) we set 16th bit to 1 -; 16 / 17 / 18 / 19 / 20 / 21 -versionNumber = 32784 / 32785 / 32786 / 32787 / 32788 / 32789 +; 16 / 17 / 18 / 19 / 20 / 21 / 22 +versionNumber = 32784 / 32785 / 32786 / 32787 / 32788 / 32789 / 32790 ; As of version 15 and higher nodeToClientVersionData = [networkMagic, query] diff --git a/ouroboros-network/orphan-instances/Ouroboros/Network/OrphanInstances.hs b/ouroboros-network/orphan-instances/Ouroboros/Network/OrphanInstances.hs index b2df39c9f9b..b2cf19c51af 100644 --- a/ouroboros-network/orphan-instances/Ouroboros/Network/OrphanInstances.hs +++ b/ouroboros-network/orphan-instances/Ouroboros/Network/OrphanInstances.hs @@ -242,6 +242,7 @@ instance FromJSON NodeToClientVersion where Number 19 -> pure NodeToClientV_19 Number 20 -> pure NodeToClientV_20 Number 21 -> pure NodeToClientV_21 + Number 22 -> pure NodeToClientV_22 Number x -> fail $ "FromJSON.NodeToClientVersion: unsupported node-to-client protocol version " ++ show x x -> fail $ "FromJSON.NodeToClientVersion: error parsing NodeToClientVersion: " ++ show x @@ -253,6 +254,7 @@ instance ToJSON NodeToClientVersion where NodeToClientV_19 -> Number 19 NodeToClientV_20 -> Number 20 NodeToClientV_21 -> Number 21 + NodeToClientV_22 -> Number 22 instance ToJSON NodeToNodeVersionData where toJSON (NodeToNodeVersionData (NetworkMagic m) dm ps q) = object diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index fbd8f8eb29c..62e4089e61b 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -314,7 +314,6 @@ library testlib array, base >=4.14 && <4.22, bytestring, - cardano-binary, cardano-slotting, cborg, containers, diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/LedgerPeers.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/LedgerPeers.hs index 84c9e02badd..619ac0795d6 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/LedgerPeers.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/LedgerPeers.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} @@ -41,7 +42,6 @@ import System.Random import Network.DNS (Domain) -import Cardano.Binary import Cardano.Network.Diffusion.Configuration qualified as Cardano (srvPrefix) import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) import Ouroboros.Network.PeerSelection.LedgerPeers @@ -498,27 +498,55 @@ prop_getLedgerPeers curSlot (pure (Map.elems (accPoolStake lps))) () +instance Arbitrary LedgerPeerSnapshotSRVSupport where + arbitrary = elements [ LedgerPeerSnapshotSupportsSRV + , LedgerPeerSnapshotDoesntSupportSRV + ] + -- | Checks validity of LedgerPeerSnapshot CBOR encoding, and whether -- round trip cycle is the identity function -- -prop_ledgerPeerSnapshotCBORV2 :: SlotNo +-- TODO: move to `ouroboros-network-api:test` +prop_ledgerPeerSnapshotCBORV2 :: LedgerPeerSnapshotSRVSupport + -> SlotNo -> LedgerPools -> Property -prop_ledgerPeerSnapshotCBORV2 slotNo +prop_ledgerPeerSnapshotCBORV2 srvSupport slotNo ledgerPools = counterexample (show snapshot) $ counterexample ("Invalid CBOR encoding" <> show encoded) (validFlatTerm encoded) .&&. either ((`counterexample` False) . ("CBOR decode failed: " <>)) - (counterexample . ("CBOR round trip failed: " <>) . show <*> (snapshot ==)) + (counterexample . ("CBOR round trip failed: " <>) . show <*> (result ==)) decoded where snapshot = snapshotV2 slotNo ledgerPools - encoded = toFlatTerm . toCBOR $ snapshot - decoded = fromFlatTerm fromCBOR encoded + encoded = toFlatTerm . encodeLedgerPeerSnapshot srvSupport $ snapshot + decoded = fromFlatTerm (decodeLedgerPeerSnapshot srvSupport) encoded + + result = case srvSupport of + LedgerPeerSnapshotSupportsSRV -> snapshot + LedgerPeerSnapshotDoesntSupportSRV -> + -- filter out SRV records + LedgerPeerSnapshotV2 + ( slotNo' + , [ (accStake, (stake, NonEmpty.fromList relays')) + | (accStake, (stake, relays)) <- peers + , let relays' = NonEmpty.filter + (\case + LedgerRelayAccessSRVDomain {} -> False + _ -> True + ) + relays + , not (null relays') + ] + ) + where + LedgerPeerSnapshotV2 (slotNo', peers) = snapshot -- | Tests if LedgerPeerSnapshot JSON round trip is the identity function -- +-- TODO: move to `ouroboros-network-api:test` prop_ledgerPeerSnapshotJSONV2 :: SlotNo -> LedgerPools -> Property From 83005203f17a26664d49fa63c142f1cd46dc9257 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 21 Jul 2025 15:51:21 +0200 Subject: [PATCH 06/14] ouroboros-network-0.22.1 --- cardano-client/cardano-client.cabal | 2 +- .../decentralized-message-queue.cabal | 2 +- ouroboros-network-api/CHANGELOG.md | 5 ++++- ouroboros-network-api/ouroboros-network-api.cabal | 2 +- .../ouroboros-network-framework.cabal | 2 +- .../ouroboros-network-protocols.cabal | 2 +- ouroboros-network/CHANGELOG.md | 8 +++++--- ouroboros-network/ouroboros-network.cabal | 8 ++++---- 8 files changed, 18 insertions(+), 13 deletions(-) diff --git a/cardano-client/cardano-client.cabal b/cardano-client/cardano-client.cabal index abb5640a063..fb1e9ac1f15 100644 --- a/cardano-client/cardano-client.cabal +++ b/cardano-client/cardano-client.cabal @@ -29,7 +29,7 @@ library io-classes:si-timers ^>=1.8.0.1, network-mux ^>=0.9, ouroboros-network ^>=0.22, - ouroboros-network-api ^>=0.15, + ouroboros-network-api ^>=0.16, ouroboros-network-framework ^>=0.19, ghc-options: diff --git a/decentralized-message-queue/decentralized-message-queue.cabal b/decentralized-message-queue/decentralized-message-queue.cabal index 7a286c590e7..be9b6e032e5 100644 --- a/decentralized-message-queue/decentralized-message-queue.cabal +++ b/decentralized-message-queue/decentralized-message-queue.cabal @@ -89,7 +89,7 @@ library nothunks ^>=0.1.4 || ^>=0.2, optparse-applicative ^>=0.18, ouroboros-network:{ouroboros-network, orphan-instances} ^>=0.22, - ouroboros-network-api ^>=0.15, + ouroboros-network-api ^>=0.16, ouroboros-network-framework ^>=0.19, ouroboros-network-protocols ^>=0.15, random ^>=1.2, diff --git a/ouroboros-network-api/CHANGELOG.md b/ouroboros-network-api/CHANGELOG.md index e776d642d43..9d73efd27d7 100644 --- a/ouroboros-network-api/CHANGELOG.md +++ b/ouroboros-network-api/CHANGELOG.md @@ -2,9 +2,12 @@ ## next release +## 0.16.0.0 -- 2025-07-21 + ### Breaking changes -### Non-breaking changes +* Added `encodeLedgerPeerSnapshot` and `decodeLedgerPeerSnapshot`; removed + `{To,From}CBOR` instances for `LedgerPeerSnapshot`. ## 0.15.0.0 -- 2025-06-28 diff --git a/ouroboros-network-api/ouroboros-network-api.cabal b/ouroboros-network-api/ouroboros-network-api.cabal index d2e08926c98..e3586bb7d39 100644 --- a/ouroboros-network-api/ouroboros-network-api.cabal +++ b/ouroboros-network-api/ouroboros-network-api.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ouroboros-network-api -version: 0.15.0.0 +version: 0.16.0.0 synopsis: A networking api shared with ouroboros-consensus description: A networking api shared with ouroboros-consensus. license: Apache-2.0 diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index f6a2430eae6..cd375c0a15a 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -79,7 +79,7 @@ library network-mux ^>=0.9, nothunks, nothunks ^>=0.1.4 || ^>=0.2, - ouroboros-network-api ^>=0.15, + ouroboros-network-api ^>=0.16, ouroboros-network-testing, psqueues, quiet, diff --git a/ouroboros-network-protocols/ouroboros-network-protocols.cabal b/ouroboros-network-protocols/ouroboros-network-protocols.cabal index ecfc5d02ff9..a704c3db5c7 100644 --- a/ouroboros-network-protocols/ouroboros-network-protocols.cabal +++ b/ouroboros-network-protocols/ouroboros-network-protocols.cabal @@ -104,7 +104,7 @@ library deepseq, io-classes:{io-classes, si-timers} ^>=1.8.0.1, nothunks, - ouroboros-network-api ^>=0.15, + ouroboros-network-api ^>=0.16, quiet, random, serialise, diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index e05af2ee3c7..0b13ef6fd47 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -1,8 +1,6 @@ # Revision history for ouroboros-network -## 0.22.1.0 -- 2025-07- - -### Breaking changes +## 0.22.1.0 -- 28.07.2025 ### Non-breaking changes @@ -12,6 +10,10 @@ ## 0.22.0.0 -- 28.06.2025 +### Non-breaking changes + +* Fixed CBOR encoding of the `LedgerPeerSnapshot`. + ### Breaking changes - Removed `TraceLedgerPeersResult` and `TraceLedgerPeersFailure` diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 62e4089e61b..a3d6544cb06 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: ouroboros-network -version: 0.22.0.0 +version: 0.22.1.0 synopsis: A networking layer for the Ouroboros blockchain protocol description: A networking layer for the Ouroboros blockchain protocol. license: Apache-2.0 @@ -161,7 +161,7 @@ library network ^>=3.2.7, network-mux, nothunks, - ouroboros-network-api ^>=0.15, + ouroboros-network-api ^>=0.16, ouroboros-network-framework ^>=0.19, ouroboros-network-protocols ^>=0.15, psqueues >=0.2.3 && <0.3, @@ -224,7 +224,7 @@ library orphan-instances network, network-mux, ouroboros-network:{ouroboros-network, cardano-diffusion}, - ouroboros-network-api ^>=0.15, + ouroboros-network-api ^>=0.16, ouroboros-network-framework ^>=0.19, text, @@ -289,7 +289,7 @@ library cardano-diffusion monoidal-synchronisation, network ^>=3.2.7, ouroboros-network, - ouroboros-network-api ^>=0.15, + ouroboros-network-api ^>=0.16, ouroboros-network-framework ^>=0.19, ouroboros-network-protocols ^>=0.15, random, From e79d6afd85f3b802c5e48d232d63aaf600dff413 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 28 Jul 2025 15:31:18 +0200 Subject: [PATCH 07/14] quickcheck-monoids: fixed a build error --- quickcheck-monoids/src/Test/QuickCheck/Monoids.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs index 224d2b32083..16d79544579 100644 --- a/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs +++ b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs @@ -9,7 +9,6 @@ module Test.QuickCheck.Monoids ( All (..) , Any (..) ) where -{-# DEPRECATED Test.QuickCheck.Monoids "Use QuickCheck >= 2.16" #-} import Data.List.NonEmpty as NonEmpty import Data.Semigroup (Semigroup (..)) From 98ee8d177bc67d26c44a866c7fbf0bfdc403dac9 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 2 Jul 2025 18:01:37 +0200 Subject: [PATCH 08/14] Fixed quickcheck-monoids --- cabal.project | 1 + quickcheck-monoids/src/Test/QuickCheck/Monoids.hs | 2 +- quickcheck-monoids/test/Main.hs | 5 ++++- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index ebe3111cf13..43c3dbf5a6a 100644 --- a/cabal.project +++ b/cabal.project @@ -32,6 +32,7 @@ packages: ./cardano-ping ./ntp-client ./cardano-client ./decentralized-message-queue + ./quickcheck-monoids tests: True benchmarks: True diff --git a/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs index 16d79544579..2cb6a0f6892 100644 --- a/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs +++ b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs @@ -40,7 +40,7 @@ instance Monoid All where -- existential variables. -- data Any = forall p. Testable p => Any { getAny :: p } -{-# DEPRECATED All "Use 'Some' from QuickCheck >= 2.16" #-} +{-# DEPRECATED Any "Use 'Some' from QuickCheck >= 2.16" #-} instance Testable Any where property (Any p) = property p diff --git a/quickcheck-monoids/test/Main.hs b/quickcheck-monoids/test/Main.hs index 48d47f8a82f..ea77e737453 100644 --- a/quickcheck-monoids/test/Main.hs +++ b/quickcheck-monoids/test/Main.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeApplications #-} + {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Main (main) where @@ -7,7 +10,7 @@ import Data.List.NonEmpty import Data.Semigroup (Semigroup (..)) import Test.QuickCheck -import Test.QuickCheck.Monoids +import "quickcheck-monoids" Test.QuickCheck.Monoids import Test.Tasty import Test.Tasty.QuickCheck From 198e84e9147efb669a4bf380597183cfee1b2a14 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 18 Jul 2025 11:06:53 +0200 Subject: [PATCH 09/14] Default values that depend on node role (BP/Relay) --- .../src/DMQ/Configuration.hs | 101 +++++++++--------- ouroboros-network/CHANGELOG.md | 7 ++ ouroboros-network/ouroboros-network.cabal | 2 +- .../Network/Diffusion/Configuration.hs | 25 +++-- 4 files changed, 79 insertions(+), 56 deletions(-) diff --git a/decentralized-message-queue/src/DMQ/Configuration.hs b/decentralized-message-queue/src/DMQ/Configuration.hs index 09d11e352d9..96477f0e67a 100644 --- a/decentralized-message-queue/src/DMQ/Configuration.hs +++ b/decentralized-message-queue/src/DMQ/Configuration.hs @@ -22,8 +22,8 @@ import GHC.Generics (Generic) import Network.Socket (AddrInfo (..), AddrInfoFlag (..), SockAddr, SocketType (..), defaultHints, getAddrInfo) -import Ouroboros.Network.Diffusion.Configuration - (defaultAcceptedConnectionsLimit, defaultDeadlineChurnInterval, +import Ouroboros.Network.Diffusion.Configuration (BlockProducerOrRelay (..), + defaultAcceptedConnectionsLimit, defaultDeadlineChurnInterval, defaultDeadlineTargets, defaultProtocolIdleTimeout, defaultTimeWaitTimeout) import Ouroboros.Network.Diffusion.Topology (NetworkTopology (..), @@ -59,53 +59,56 @@ data Configuration ntnFd ntnAddr ntcFd ntcAddr = instance FromJSON (Configuration ntnFd ntnAddr ntcFd ntcAddr) where parseJSON = withObject "DMQConfiguration" $ \v -> do - dmqcAcceptedConnectionsLimit <- v .:? "AcceptedConnectionsLimit" - .!= defaultAcceptedConnectionsLimit - - dmqcDiffusionMode <- v .:? "DiffusionMode" - .!= InitiatorAndResponderDiffusionMode - - dmqcTargetOfRootPeers <- v .:? "TargetNumberOfRootPeers" - .!= targetNumberOfRootPeers defaultDeadlineTargets - dmqcTargetOfKnownPeers <- v .:? "TargetNumberOfKnownPeers" - .!= targetNumberOfKnownPeers defaultDeadlineTargets - dmqcTargetOfEstablishedPeers <- v .:? "TargetNumberOfEstablishedPeers" - .!= targetNumberOfEstablishedPeers defaultDeadlineTargets - dmqcTargetOfActivePeers <- v .:? "TargetNumberOfActivePeers" - .!= targetNumberOfActivePeers defaultDeadlineTargets - dmqcTargetOfKnownBigLedgerPeers <- v .:? "TargetNumberOfKnownBigLedgerPeers" - .!= targetNumberOfKnownBigLedgerPeers defaultDeadlineTargets - dmqcTargetOfEstablishedBigLedgerPeers <- v .:? "TargetNumberOfEstablishedBigLedgerPeers" - .!= targetNumberOfEstablishedBigLedgerPeers defaultDeadlineTargets - dmqcTargetOfActiveBigLedgerPeers <- v .:? "TargetNumberOfActiveBigLedgerPeers" - .!= targetNumberOfActiveBigLedgerPeers defaultDeadlineTargets - - dmqcProtocolIdleTimeout <- v .:? "ProtocolIdleTimeout" - .!= defaultProtocolIdleTimeout - - dmqcChurnInterval <- v .:? "ChurnInterval" - .!= defaultDeadlineChurnInterval - - dmqcPeerSharing <- v .:? "PeerSharing" - .!= PeerSharingEnabled - networkMagic <- v .: "NetworkMagic" - - pure $ - Configuration - { dmqcAcceptedConnectionsLimit - , dmqcDiffusionMode - , dmqcTargetOfRootPeers - , dmqcTargetOfKnownPeers - , dmqcTargetOfEstablishedPeers - , dmqcTargetOfActivePeers - , dmqcTargetOfKnownBigLedgerPeers - , dmqcTargetOfEstablishedBigLedgerPeers - , dmqcTargetOfActiveBigLedgerPeers - , dmqcProtocolIdleTimeout - , dmqcChurnInterval - , dmqcPeerSharing - , dmqcNetworkMagic = NetworkMagic networkMagic - } + dmqcAcceptedConnectionsLimit <- v .:? "AcceptedConnectionsLimit" + .!= defaultAcceptedConnectionsLimit + + dmqcDiffusionMode <- v .:? "DiffusionMode" + .!= InitiatorAndResponderDiffusionMode + + dmqcTargetOfRootPeers <- v .:? "TargetNumberOfRootPeers" + .!= targetNumberOfRootPeers deadlineTargets + dmqcTargetOfKnownPeers <- v .:? "TargetNumberOfKnownPeers" + .!= targetNumberOfKnownPeers deadlineTargets + dmqcTargetOfEstablishedPeers <- v .:? "TargetNumberOfEstablishedPeers" + .!= targetNumberOfEstablishedPeers deadlineTargets + dmqcTargetOfActivePeers <- v .:? "TargetNumberOfActivePeers" + .!= targetNumberOfActivePeers deadlineTargets + dmqcTargetOfKnownBigLedgerPeers <- v .:? "TargetNumberOfKnownBigLedgerPeers" + .!= targetNumberOfKnownBigLedgerPeers deadlineTargets + dmqcTargetOfEstablishedBigLedgerPeers <- v .:? "TargetNumberOfEstablishedBigLedgerPeers" + .!= targetNumberOfEstablishedBigLedgerPeers deadlineTargets + dmqcTargetOfActiveBigLedgerPeers <- v .:? "TargetNumberOfActiveBigLedgerPeers" + .!= targetNumberOfActiveBigLedgerPeers deadlineTargets + + dmqcProtocolIdleTimeout <- v .:? "ProtocolIdleTimeout" + .!= defaultProtocolIdleTimeout + + dmqcChurnInterval <- v .:? "ChurnInterval" + .!= defaultDeadlineChurnInterval + + dmqcPeerSharing <- v .:? "PeerSharing" + .!= PeerSharingEnabled + networkMagic <- v .: "NetworkMagic" + + pure $ + Configuration + { dmqcAcceptedConnectionsLimit + , dmqcDiffusionMode + , dmqcTargetOfRootPeers + , dmqcTargetOfKnownPeers + , dmqcTargetOfEstablishedPeers + , dmqcTargetOfActivePeers + , dmqcTargetOfKnownBigLedgerPeers + , dmqcTargetOfEstablishedBigLedgerPeers + , dmqcTargetOfActiveBigLedgerPeers + , dmqcProtocolIdleTimeout + , dmqcChurnInterval + , dmqcPeerSharing + , dmqcNetworkMagic = NetworkMagic networkMagic + } + where + -- TODO: use DMQ's own default values + deadlineTargets = defaultDeadlineTargets Relay -- | Read the `DMQConfiguration` from the specified file. -- diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index 0b13ef6fd47..abb7d043c65 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for ouroboros-network +## 0.22.2.0 -- 05.08.2025 + +NOTE: morally this ought to be a major release. + +* Type of `defaultSyncTargets` changed. +* Type of `defaultPeerSharing` changed. + ## 0.22.1.0 -- 28.07.2025 ### Non-breaking changes diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index a3d6544cb06..72be2a3cb54 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: ouroboros-network -version: 0.22.1.0 +version: 0.22.2.0 synopsis: A networking layer for the Ouroboros blockchain protocol description: A networking layer for the Ouroboros blockchain protocol. license: Apache-2.0 diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index 7e8903750e3..fe75baecfb5 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -10,6 +10,7 @@ module Ouroboros.Network.Diffusion.Configuration , defaultDeadlineTargets , defaultDeadlineChurnInterval , defaultBulkChurnInterval + , BlockProducerOrRelay (..) -- re-exports , AcceptedConnectionsLimit (..) , BlockFetchConfiguration (..) @@ -57,13 +58,23 @@ import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -- Targets may vary depending on whether a node is operating in -- Genesis mode. + +-- | A Boolean like type to differentiate between a node which is configured as +-- a block producer and a relay. Some default options depend on that value. +-- +data BlockProducerOrRelay = BlockProducer | Relay + deriving Show + + -- | Default peer targets in Praos mode -- -defaultDeadlineTargets :: PeerSelectionTargets -defaultDeadlineTargets = +defaultDeadlineTargets :: BlockProducerOrRelay + -- ^ block producer or relay node + -> PeerSelectionTargets +defaultDeadlineTargets bp = PeerSelectionTargets { - targetNumberOfRootPeers = 60, - targetNumberOfKnownPeers = 150, + targetNumberOfRootPeers = case bp of { BlockProducer -> 100; Relay -> 60 }, + targetNumberOfKnownPeers = case bp of { BlockProducer -> 100; Relay -> 150 }, targetNumberOfEstablishedPeers = 30, targetNumberOfActivePeers = 20, targetNumberOfKnownBigLedgerPeers = 15, @@ -81,8 +92,10 @@ defaultAcceptedConnectionsLimit = -- | Node's peer sharing participation flag -- -defaultPeerSharing :: PeerSharing -defaultPeerSharing = PeerSharingEnabled +defaultPeerSharing :: BlockProducerOrRelay + -> PeerSharing +defaultPeerSharing BlockProducer = PeerSharingDisabled +defaultPeerSharing Relay = PeerSharingEnabled -- | Configuration for FetchDecisionPolicy. -- From 751aaae0a002b05531ef27c0d87720d9547340af Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 27 Aug 2025 11:17:20 +0200 Subject: [PATCH 10/14] quickcheck-monoids: compatibility with QuickCheck-2.16 --- cabal.project | 6 +-- flake.lock | 47 +++++++++++++------ nix/ouroboros-network.nix | 4 +- ouroboros-network-framework/CHANGELOG.md | 4 ++ .../ouroboros-network-framework.cabal | 18 ++++--- .../Test/Ouroboros/Network/Server/Sim.hs | 3 ++ .../Network/ConnectionManager/Timeouts.hs | 5 ++ .../Network/ConnectionManager/Utils.hs | 5 ++ .../Network/InboundGovernor/Utils.hs | 5 ++ .../ouroboros-network-protocols.cabal | 2 +- .../Network/Protocol/LocalStateQuery/Test.hs | 9 ++-- ouroboros-network/CHANGELOG.md | 4 ++ ouroboros-network/ouroboros-network.cabal | 13 +++-- .../Network/Diffusion/Testnet/Cardano.hs | 4 ++ .../Test/Ouroboros/Network/PeerSelection.hs | 1 + .../Network/PeerSelection/PeerMetric.hs | 4 ++ quickcheck-monoids/CHANGELOG.md | 5 ++ quickcheck-monoids/quickcheck-monoids.cabal | 2 +- .../src/Test/QuickCheck/Monoids.hs | 35 +++++++++++++- 19 files changed, 136 insertions(+), 40 deletions(-) diff --git a/cabal.project b/cabal.project index 43c3dbf5a6a..318bc076106 100644 --- a/cabal.project +++ b/cabal.project @@ -15,7 +15,7 @@ repository cardano-haskell-packages -- repeat the index-state for hackage to work around haskell.nix parsing limitation index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2025-06-17T07:53:04Z + , hackage.haskell.org 2025-07-16T09:24:19Z -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2025-02-15T18:39:38Z @@ -54,7 +54,3 @@ package network-mux package ouroboros-network flags: +asserts +cddl - -allow-newer: aeson:QuickCheck, - tree-diff:QuickCheck, - quickcheck-instances:QuickCheck diff --git a/flake.lock b/flake.lock index 0518d2dc710..539dc0cf3e5 100644 --- a/flake.lock +++ b/flake.lock @@ -173,11 +173,11 @@ "hackage-for-stackage": { "flake": false, "locked": { - "lastModified": 1750206390, - "narHash": "sha256-oQP8Nt2+ZvMPzGVSiGDEW7ODlAYbtpjvpLJcqbUVy/8=", + "lastModified": 1756254358, + "narHash": "sha256-ByfkTCjd06Fn5MfCW0mIo0W0udiIyvJ6KBEthn9L12c=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "089c6a92fc4e53f868503afea683bc6185d9c5a3", + "rev": "7fbc57bfa6164026ec9f0af9eae45970c9757ddd", "type": "github" }, "original": { @@ -187,14 +187,30 @@ "type": "github" } }, + "hackage-internal": { + "flake": false, + "locked": { + "lastModified": 1750307553, + "narHash": "sha256-iiafNoeLHwlSLQTyvy8nPe2t6g5AV4PPcpMeH/2/DLs=", + "owner": "input-output-hk", + "repo": "hackage.nix", + "rev": "f7867baa8817fab296528f4a4ec39d1c7c4da4f3", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "hackage.nix", + "type": "github" + } + }, "hackageNix": { "flake": false, "locked": { - "lastModified": 1749687976, - "narHash": "sha256-CIy7o8PDJObfuBc0UTUXGpySA1cxPFp46A8Bi/fWzh4=", + "lastModified": 1756254358, + "narHash": "sha256-ByfkTCjd06Fn5MfCW0mIo0W0udiIyvJ6KBEthn9L12c=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "c0ec5d2de9aed5d63ee86d5c9c753d62f860d362", + "rev": "7fbc57bfa6164026ec9f0af9eae45970c9757ddd", "type": "github" }, "original": { @@ -217,6 +233,7 @@ "hackageNix" ], "hackage-for-stackage": "hackage-for-stackage", + "hackage-internal": "hackage-internal", "hls": "hls", "hls-1.10": "hls-1.10", "hls-2.0": "hls-2.0", @@ -245,11 +262,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1750245982, - "narHash": "sha256-o84Xdk0o+l/PIsRI0ECU/a7tdNQaiGJ/Fz3mE91pIbM=", + "lastModified": 1756255926, + "narHash": "sha256-KsVNKJIKuWItwazbPfTwV2xq0/zqzBfVs4ZHrCrKq9s=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "75098f8e585ae3db165e0b7b6d4ed5caaebe0047", + "rev": "340eecb704a4b484bee871b6aa25eb51c304d0db", "type": "github" }, "original": { @@ -518,11 +535,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1749443511, - "narHash": "sha256-asfdanBoIUcJ9XQWB3a/5wQGFG/6Uq6l2s9r8OuamkY=", + "lastModified": 1755040634, + "narHash": "sha256-8W7uHpAIG8HhO3ig5OGHqvwduoye6q6dlrea1IrP2eI=", "owner": "stable-haskell", "repo": "iserv-proxy", - "rev": "e40eddb1ca1e3e906e018c7e6b0d1e51c930ec9d", + "rev": "1383d199a2c64f522979005d112b4fbdee38dd92", "type": "github" }, "original": { @@ -711,11 +728,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1750119212, - "narHash": "sha256-TsW+cHOQTUnOYdoldr+Cnk6hjDF+Ph050+uihGL3rgw=", + "lastModified": 1756253589, + "narHash": "sha256-HaIEVY8W2GWaYEJQkuxLcIXssz96EkLN7UosnXH+8Ps=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "01f8e0f3049d543b330de39278bb42ecb6c87599", + "rev": "52026ed0525ab2266d24664b6a0163c7a8225abc", "type": "github" }, "original": { diff --git a/nix/ouroboros-network.nix b/nix/ouroboros-network.nix index af7ba718d9c..11fbac9f638 100644 --- a/nix/ouroboros-network.nix +++ b/nix/ouroboros-network.nix @@ -42,9 +42,9 @@ let # pkgs - nixpkgs instatiated for cross compilation, so # stdenv.hostPlatform.isWindows will work as expected src = ./..; - index-state = "2025-06-17T07:53:04Z"; - index-sha256 = "sha256-/9/Z6Fpdzil6tDmMrKMKKVcnXksfIpLOQ/2drHo1Rts="; name = "ouroboros-network"; + index-state = "2025-07-16T09:24:19Z"; + index-sha256 = "sha256-fmnSRF68/UIQYzzdmNs3UT0cbYhn9d5nlhb3BnVXe48="; compiler-nix-name = lib.mkDefault defaultCompiler; cabalProjectLocal = if pkgs.stdenv.hostPlatform.isWindows diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index 0aae3b9cfbe..a28f55a7fb4 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -6,6 +6,10 @@ ### Non-breaking changes +## 0.19.1.0 -- 27.08.2025 + +* Compatible with `QuickCheck < 2.16` + ## 0.19.0.0 -- 28.06.2025 ### Breaking changes diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index cd375c0a15a..37a88c16b9a 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ouroboros-network-framework -version: 0.19.0.0 +version: 0.19.1.0 synopsis: Ouroboros network framework description: Ouroboros network framework. license: Apache-2.0 @@ -101,7 +101,6 @@ library -Widentities -Wredundant-constraints -Wno-unticked-promoted-constructors - -Wunused-packages library testlib visibility: public @@ -116,7 +115,7 @@ library testlib other-modules: build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, cborg, @@ -129,6 +128,7 @@ library testlib ouroboros-network-api, ouroboros-network-framework, ouroboros-network-testing, + quickcheck-monoids, random, serialise, typed-protocols:{typed-protocols, examples}, @@ -144,7 +144,7 @@ library testlib -Widentities -Wredundant-constraints -Wno-unticked-promoted-constructors - -Wunused-packages + -Wno-unused-packages test-suite sim-tests type: exitcode-stdio-1.0 @@ -157,8 +157,11 @@ test-suite sim-tests Test.Ouroboros.Network.Server.Sim Test.Simulation.Network.Snocket + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, cborg, @@ -175,6 +178,7 @@ test-suite sim-tests pretty-simple, psqueues, quickcheck-instances, + quickcheck-monoids, quiet, random, serialise, @@ -197,7 +201,7 @@ test-suite sim-tests -Widentities -Wredundant-constraints -Wno-unticked-promoted-constructors - -Wunused-packages + -Wno-unused-packages if flag(ipv6) cpp-options: -DOUROBOROS_NETWORK_IPV6 @@ -213,7 +217,7 @@ test-suite io-tests Test.Ouroboros.Network.Socket build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, contra-tracer, diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index 939b520ea83..5d22674ced0 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -64,6 +64,9 @@ import System.Random (StdGen, mkStdGen, split) import Text.Printf import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs index 22d07e6a33f..d13a22a8da3 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} module Test.Ouroboros.Network.ConnectionManager.Timeouts ( verifyAllTimeouts @@ -39,6 +41,9 @@ import Data.Monoid (Sum (Sum)) import Text.Printf (printf) import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) import Ouroboros.Network.ConnectionManager.Core qualified as CM diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Utils.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Utils.hs index 573ce87ba89..3a02bcd677f 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Utils.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Utils.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Ouroboros.Network.ConnectionManager.Utils where @@ -10,6 +12,9 @@ import Ouroboros.Network.ConnectionManager.Core as CM import Ouroboros.Network.ConnectionManager.Types import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif verifyAbstractTransition :: AbstractTransition diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs index 171674153d2..57d24434483 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/InboundGovernor/Utils.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} module Test.Ouroboros.Network.InboundGovernor.Utils where import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.InboundGovernor (RemoteSt (..)) diff --git a/ouroboros-network-protocols/ouroboros-network-protocols.cabal b/ouroboros-network-protocols/ouroboros-network-protocols.cabal index a704c3db5c7..c04bec968b5 100644 --- a/ouroboros-network-protocols/ouroboros-network-protocols.cabal +++ b/ouroboros-network-protocols/ouroboros-network-protocols.cabal @@ -217,7 +217,7 @@ test-suite test default-language: Haskell2010 default-extensions: ImportQualifiedPost build-depends: - QuickCheck ^>=2.16, + QuickCheck, base >=4.14 && <4.22, ouroboros-network-api, ouroboros-network-mock, diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs index fa8e83a8d94..1848f7e7420 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/LocalStateQuery/Test.hs @@ -44,7 +44,8 @@ import Ouroboros.Network.Mock.Chain (Point) import Ouroboros.Network.Mock.ConcreteBlock (Block) import Ouroboros.Network.Protocol.LocalStateQuery.Client -import Ouroboros.Network.Protocol.LocalStateQuery.Codec +import Ouroboros.Network.Protocol.LocalStateQuery.Codec hiding (Some (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Codec qualified as LocalStateQuery import Ouroboros.Network.Protocol.LocalStateQuery.Direct import Ouroboros.Network.Protocol.LocalStateQuery.Examples import Ouroboros.Network.Protocol.LocalStateQuery.Server @@ -53,7 +54,7 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type import Test.ChainGenerators () import Test.Ouroboros.Network.Protocol.Utils -import Test.QuickCheck as QC hiding (Result, Some (Some)) +import Test.QuickCheck as QC hiding (Result) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) import Text.Show.Functions () @@ -386,10 +387,10 @@ codec = encodeQuery :: Query result -> CBOR.Encoding encodeQuery GetTheLedgerState = Serialise.encode () - decodeQuery :: forall s . CBOR.Decoder s (Some Query) + decodeQuery :: forall s . CBOR.Decoder s (LocalStateQuery.Some Query) decodeQuery = do () <- Serialise.decode - return $ Some GetTheLedgerState + return $ LocalStateQuery.Some GetTheLedgerState encodeResult :: Query result -> result -> CBOR.Encoding encodeResult GetTheLedgerState = Serialise.encode diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md index abb7d043c65..72598e3a09b 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for ouroboros-network +## 0.22.3.0 -- 27.08.2025 + +* Compatible with `QuickCheck < 2.16` + ## 0.22.2.0 -- 05.08.2025 NOTE: morally this ought to be a major release. diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 72be2a3cb54..b43adca3d18 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: ouroboros-network -version: 0.22.2.0 +version: 0.22.3.0 synopsis: A networking layer for the Ouroboros blockchain protocol description: A networking layer for the Ouroboros blockchain protocol. license: Apache-2.0 @@ -303,13 +303,16 @@ library cardano-diffusion -- Simulation Test Library library testlib + mixins: + QuickCheck hiding (Test.QuickCheck.Monoids) + import: ghc-options-tests default-language: Haskell2010 default-extensions: ImportQualifiedPost visibility: public hs-source-dirs: testlib build-depends: - QuickCheck >=2.16, + QuickCheck, aeson, array, base >=4.14 && <4.22, @@ -340,6 +343,7 @@ library testlib pipes, pretty-simple, psqueues, + quickcheck-monoids, random, serialise, tasty, @@ -384,6 +388,9 @@ library testlib Test.Ouroboros.Network.TxSubmission Test.Ouroboros.Network.Version + ghc-options: + -Wno-unused-packages + -- Simulation tests, and IO tests which don't require native system calls. -- (i.e. they don't require system call API provided by `Win32-network` or -- `network` dependency). test-suite sim-tests @@ -425,7 +432,7 @@ test-suite io-tests default-language: Haskell2010 default-extensions: ImportQualifiedPost build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, contra-tracer, diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs index 07d55fe2bc7..27148469fea 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/Diffusion/Testnet/Cardano.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -100,6 +101,9 @@ import Simulation.Network.Snocket (BearerInfo (..)) import Cardano.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty import Test.Tasty.QuickCheck (testProperty) diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs index 79e2fd5b3e8..f6ee70b8b7b 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs @@ -105,6 +105,7 @@ import Cardano.Network.Types (LedgerStateJudgement (..), NumberOfBigLedgerPeers (..)) import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..)) import Test.QuickCheck +import Test.QuickCheck.Monoids import Test.Tasty import Test.Tasty.QuickCheck import Text.Pretty.Simple diff --git a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs index 8da417642b3..b5741fc93c0 100644 --- a/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 908 @@ -46,6 +47,9 @@ import NoThunks.Class import Test.Ouroboros.Network.Data.Script import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,16,0) +import "quickcheck-monoids" Test.QuickCheck.Monoids +#endif import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) diff --git a/quickcheck-monoids/CHANGELOG.md b/quickcheck-monoids/CHANGELOG.md index c162a689b6f..faa779ee3aa 100644 --- a/quickcheck-monoids/CHANGELOG.md +++ b/quickcheck-monoids/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for quickcheck-monoids +## 0.1.0.3 -- 2025-08-27 + +* Somewhat compatible with `QuickCheck-2.16`: `QuickCheck` is also defining + `Test.QuickCheck.Monoids` module. + ## 0.1.0.2 -- 2025-06-28 * Package is deprecated, use `QuickCheck >= 2.16` which provides `Every` and diff --git a/quickcheck-monoids/quickcheck-monoids.cabal b/quickcheck-monoids/quickcheck-monoids.cabal index 8a78a6c9b89..d0e4f45495d 100644 --- a/quickcheck-monoids/quickcheck-monoids.cabal +++ b/quickcheck-monoids/quickcheck-monoids.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: quickcheck-monoids -version: 0.1.0.2 +version: 0.1.0.3 synopsis: QuickCheck monoids description: All and Any monoids for `Testable` instances based on `.&&.` and `.||.`. license: Apache-2.0 diff --git a/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs index 2cb6a0f6892..fb6abf8b467 100644 --- a/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs +++ b/quickcheck-monoids/src/Test/QuickCheck/Monoids.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} -- | Monoids using `.&&.` and `.||.`. -- @@ -6,8 +10,17 @@ -- `checkCoverage` (see test for a counterexample). -- module Test.QuickCheck.Monoids +#if !MIN_VERSION_QuickCheck(2,16,0) + ( type Every + , All(Every, getEvery, ..) + , type Some + , Any(Some, getSome, ..) +#else ( All (..) , Any (..) + , Every (..) + , Some (..) +#endif ) where import Data.List.NonEmpty as NonEmpty @@ -20,7 +33,16 @@ import Test.QuickCheck -- existential variables. -- data All = forall p. Testable p => All { getAll :: p } -{-# DEPRECATED All "Use 'Every' from QuickCheck >= 2.16" #-} + +#if !MIN_VERSION_QuickCheck(2,16,0) +type Every = All + +pattern Every :: () + => Testable p + => p + -> All +pattern Every { getEvery } = All getEvery +#endif instance Testable All where property (All p) = property p @@ -40,7 +62,16 @@ instance Monoid All where -- existential variables. -- data Any = forall p. Testable p => Any { getAny :: p } -{-# DEPRECATED Any "Use 'Some' from QuickCheck >= 2.16" #-} + +#if !MIN_VERSION_QuickCheck(2,16,0) +type Some = Any + +pattern Some :: () + => Testable p + => p + -> Any +pattern Some { getSome } = Any getSome +#endif instance Testable Any where property (Any p) = property p From ed9f0e39fb3635c7a5fe03ef3ba438c911ea2931 Mon Sep 17 00:00:00 2001 From: Federico Mastellone Date: Mon, 27 Oct 2025 16:58:02 +0000 Subject: [PATCH 11/14] REMOVE ME --- cabal.project | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/cabal.project b/cabal.project index 318bc076106..f764c4acf6a 100644 --- a/cabal.project +++ b/cabal.project @@ -20,6 +20,14 @@ index-state: -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2025-02-15T18:39:38Z +-- `trace-dispatcher` from repo "cardano-node" branch "fmaste/dmq-node". +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-node.git + subdir: trace-dispatcher + tag: 9d25e72454269ecca5f138ee2abf3cbbfa619428 + --sha256: 1asb9gx7w50p31wv6hnac7hcmvs3h2m5zrm57p1dpmb70h38xz74 + packages: ./cardano-ping ./monoidal-synchronisation ./network-mux From a3d81a113247d0addf603db1e188e5023b678c36 Mon Sep 17 00:00:00 2001 From: Federico Mastellone Date: Mon, 27 Oct 2025 16:27:43 +0000 Subject: [PATCH 12/14] network-mux:traces --- network-mux/network-mux.cabal | 24 ++ network-mux/traces/Network/Mux/Traces.hs | 501 +++++++++++++++++++++++ 2 files changed, 525 insertions(+) create mode 100644 network-mux/traces/Network/Mux/Traces.hs diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 96c28b067af..df2eb707e5d 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -112,6 +112,30 @@ library -Wredundant-constraints -Wunused-packages +library traces + build-depends: + aeson, + base >=4.14 && <4.22, + formatting, + network-mux, + trace-dispatcher ^>= 2.10.0 + hs-source-dirs: traces + visibility: public + exposed-modules: + Network.Mux.Traces + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wno-unticked-promoted-constructors + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test diff --git a/network-mux/traces/Network/Mux/Traces.hs b/network-mux/traces/Network/Mux/Traces.hs new file mode 100644 index 00000000000..bede3b0c951 --- /dev/null +++ b/network-mux/traces/Network/Mux/Traces.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- From: `Cardano.Node.Tracing.Tracers.Diffusion` +-- Branch "ana/10.6-final-integration-mix" + +module Network.Mux.Traces () where + +import Cardano.Logging +-- import Cardano.Node.Configuration.TopologyP2P () + +import qualified Network.Mux as Mux +#ifdef linux_HOST_OS +import Network.Mux.TCPInfo (StructTCPInfo (..)) +#endif +import Network.Mux.Types (SDUHeader (..), unRemoteClockModel) + +-- types-protocols ??? +-- import Network.TypedProtocol.Codec (AnyMessage (AnyMessageAndAgency)) + +import Data.Aeson (Value (String), (.=)) +import Data.Typeable +import Formatting + +-------------------------------------------------------------------------------- +-- Mux Tracer +-------------------------------------------------------------------------------- + +instance (LogFormatting peer, LogFormatting tr, Typeable tr) => + LogFormatting (Mux.WithBearer peer tr) where + forMachine dtal (Mux.WithBearer b ev) = + mconcat [ "kind" .= (show . typeOf $ ev) + , "bearer" .= forMachine dtal b + , "event" .= forMachine dtal ev ] + forHuman (Mux.WithBearer b ev) = "With mux bearer " <> forHumanOrMachine b + <> ". " <> forHumanOrMachine ev + +instance MetaTrace tr => MetaTrace (Mux.WithBearer peer tr) where + namespaceFor (Mux.WithBearer _peer obj) = (nsCast . namespaceFor) obj + severityFor ns Nothing = severityFor (nsCast ns :: Namespace tr) Nothing + severityFor ns (Just (Mux.WithBearer _peer obj)) = + severityFor (nsCast ns) (Just obj) + privacyFor ns Nothing = privacyFor (nsCast ns :: Namespace tr) Nothing + privacyFor ns (Just (Mux.WithBearer _peer obj)) = + privacyFor (nsCast ns) (Just obj) + detailsFor ns Nothing = detailsFor (nsCast ns :: Namespace tr) Nothing + detailsFor ns (Just (Mux.WithBearer _peer obj)) = + detailsFor (nsCast ns) (Just obj) + documentFor ns = documentFor (nsCast ns :: Namespace tr) + metricsDocFor ns = metricsDocFor (nsCast ns :: Namespace tr) + allNamespaces = map nsCast (allNamespaces :: [Namespace tr]) + +instance LogFormatting Mux.BearerTrace where + forMachine _dtal Mux.TraceRecvHeaderStart = mconcat + [ "kind" .= String "Mux.TraceRecvHeaderStart" + , "msg" .= String "Bearer Receive Header Start" + ] + forMachine _dtal (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + [ "kind" .= String "Mux.TraceRecvHeaderStart" + , "msg" .= String "Bearer Receive Header End" + , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "miniProtocolNum" .= String (showT mhNum) + , "miniProtocolDir" .= String (showT mhDir) + , "length" .= String (showT mhLength) + ] + forMachine _dtal (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = mconcat + [ "kind" .= String "Mux.TraceRecvDeltaQObservation" + , "msg" .= String "Bearer DeltaQ observation" + , "timeRemote" .= String (showT ts) + , "timeLocal" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "length" .= String (showT mhLength) + ] + forMachine _dtal (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = mconcat + [ "kind" .= String "Mux.TraceRecvDeltaQSample" + , "msg" .= String "Bearer DeltaQ Sample" + , "duration" .= String (showT d) + , "packets" .= String (showT sp) + , "sumBytes" .= String (showT so) + , "DeltaQ_S" .= String (showT dqs) + , "DeltaQ_VMean" .= String (showT dqvm) + , "DeltaQ_VVar" .= String (showT dqvs) + , "DeltaQ_estR" .= String (showT estR) + , "sizeDist" .= String (showT sdud) + ] + forMachine _dtal (Mux.TraceRecvStart len) = mconcat + [ "kind" .= String "Mux.TraceRecvStart" + , "msg" .= String "Bearer Receive Start" + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceRecvRaw len) = mconcat + [ "kind" .= String "Mux.TraceRecvRaw" + , "msg" .= String "Bearer Receive Raw" + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceRecvEnd len) = mconcat + [ "kind" .= String "Mux.TraceRecvEnd" + , "msg" .= String "Bearer Receive End" + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = mconcat + [ "kind" .= String "Mux.TraceSendStart" + , "msg" .= String "Bearer Send Start" + , "timestamp" .= String (showTHex (unRemoteClockModel mhTimestamp)) + , "miniProtocolNum" .= String (showT mhNum) + , "miniProtocolDir" .= String (showT mhDir) + , "length" .= String (showT mhLength) + ] + forMachine _dtal Mux.TraceSendEnd = mconcat + [ "kind" .= String "Mux.TraceSendEnd" + , "msg" .= String "Bearer Send End" + ] + forMachine _dtal Mux.TraceSDUReadTimeoutException = mconcat + [ "kind" .= String "Mux.TraceSDUReadTimeoutException" + , "msg" .= String "Timed out reading SDU" + ] + forMachine _dtal Mux.TraceSDUWriteTimeoutException = mconcat + [ "kind" .= String "Mux.TraceSDUWriteTimeoutException" + , "msg" .= String "Timed out writing SDU" + ] + forMachine _dtal Mux.TraceEmitDeltaQ = mempty +#ifdef linux_HOST_OS + forMachine _dtal (Mux.TraceTCPInfo StructTCPInfo + { tcpi_snd_mss, tcpi_rcv_mss, tcpi_lost, tcpi_retrans + , tcpi_rtt, tcpi_rttvar, tcpi_snd_cwnd } + len) = mconcat + [ "kind" .= String "Mux.TraceTCPInfo" + , "msg" .= String "TCPInfo" + , "rtt" .= (fromIntegral tcpi_rtt :: Word) + , "rttvar" .= (fromIntegral tcpi_rttvar :: Word) + , "snd_cwnd" .= (fromIntegral tcpi_snd_cwnd :: Word) + , "snd_mss" .= (fromIntegral tcpi_snd_mss :: Word) + , "rcv_mss" .= (fromIntegral tcpi_rcv_mss :: Word) + , "lost" .= (fromIntegral tcpi_lost :: Word) + , "retrans" .= (fromIntegral tcpi_retrans :: Word) + , "length" .= len + ] +#else + forMachine _dtal (Mux.TraceTCPInfo _ len) = mconcat + [ "kind" .= String "Mux.TraceTCPInfo" + , "msg" .= String "TCPInfo" + , "len" .= String (showT len) + ] +#endif + + forHuman Mux.TraceRecvHeaderStart = + "Bearer Receive Header Start" + forHuman (Mux.TraceRecvHeaderEnd SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = + sformat ("Bearer Receive Header End: ts:" % prefixHex % "(" % shown % ") " % shown % " len " % int) + (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength + forHuman (Mux.TraceRecvDeltaQObservation SDUHeader { mhTimestamp, mhLength } ts) = + sformat ("Bearer DeltaQ observation: remote ts" % int % " local ts " % shown % " length " % int) + (unRemoteClockModel mhTimestamp) ts mhLength + forHuman (Mux.TraceRecvDeltaQSample d sp so dqs dqvm dqvs estR sdud) = + sformat ("Bearer DeltaQ Sample: duration " % fixed 3 % " packets " % int % " sumBytes " + % int % " DeltaQ_S " % fixed 3 % " DeltaQ_VMean " % fixed 3 % "DeltaQ_VVar " % fixed 3 + % " DeltaQ_estR " % fixed 3 % " sizeDist " % string) + d sp so dqs dqvm dqvs estR sdud + forHuman (Mux.TraceRecvStart len) = + sformat ("Bearer Receive Start: length " % int) len + forHuman (Mux.TraceRecvRaw len) = + sformat ("Bearer Receive Raw: length " % int) len + forHuman (Mux.TraceRecvEnd len) = + sformat ("Bearer Receive End: length " % int) len + forHuman (Mux.TraceSendStart SDUHeader { mhTimestamp, mhNum, mhDir, mhLength }) = + sformat ("Bearer Send Start: ts: " % prefixHex % " (" % shown % ") " % shown % " length " % int) + (unRemoteClockModel mhTimestamp) mhNum mhDir mhLength + forHuman Mux.TraceSendEnd = + "Bearer Send End" + forHuman Mux.TraceSDUReadTimeoutException = + "Timed out reading SDU" + forHuman Mux.TraceSDUWriteTimeoutException = + "Timed out writing SDU" + forHuman Mux.TraceEmitDeltaQ = mempty +#ifdef linux_HOST_OS + forHuman (Mux.TraceTCPInfo StructTCPInfo + { tcpi_snd_mss, tcpi_rcv_mss, tcpi_lost, tcpi_retrans + , tcpi_rtt, tcpi_rttvar, tcpi_snd_cwnd } + len) = + sformat ("TCPInfo rtt " % int % " rttvar " % int % " snd_cwnd " % int % + " snd_mss " % int % " rcv_mss " % int % " lost " % int % + " retrans " % int % " len " % int) + (fromIntegral tcpi_rtt :: Word) + (fromIntegral tcpi_rttvar :: Word) + (fromIntegral tcpi_snd_cwnd :: Word) + (fromIntegral tcpi_snd_mss :: Word) + (fromIntegral tcpi_rcv_mss :: Word) + (fromIntegral tcpi_lost :: Word) + (fromIntegral tcpi_retrans :: Word) + len +#else + forHuman (Mux.TraceTCPInfo _ len) = sformat ("TCPInfo len " % int) len +#endif + +instance MetaTrace Mux.BearerTrace where + namespaceFor Mux.TraceRecvHeaderStart {} = + Namespace [] ["RecvHeaderStart"] + namespaceFor Mux.TraceRecvHeaderEnd {} = + Namespace [] ["RecvHeaderEnd"] + namespaceFor Mux.TraceRecvStart {} = + Namespace [] ["RecvStart"] + namespaceFor Mux.TraceRecvRaw {} = + Namespace [] ["RecvRaw"] + namespaceFor Mux.TraceRecvEnd {} = + Namespace [] ["RecvEnd"] + namespaceFor Mux.TraceSendStart {} = + Namespace [] ["SendStart"] + namespaceFor Mux.TraceSendEnd = + Namespace [] ["SendEnd"] + namespaceFor Mux.TraceRecvDeltaQObservation {} = + Namespace [] ["RecvDeltaQObservation"] + namespaceFor Mux.TraceRecvDeltaQSample {} = + Namespace [] ["RecvDeltaQSample"] + namespaceFor Mux.TraceSDUReadTimeoutException = + Namespace [] ["SDUReadTimeoutException"] + namespaceFor Mux.TraceSDUWriteTimeoutException = + Namespace [] ["SDUWriteTimeoutException"] + namespaceFor Mux.TraceEmitDeltaQ = + Namespace [] ["TraceEmitDeltaQ"] + namespaceFor Mux.TraceTCPInfo {} = + Namespace [] ["TCPInfo"] + + severityFor (Namespace _ ["RecvHeaderStart"]) _ = Just Debug + severityFor (Namespace _ ["RecvRaw"]) _ = Just Debug + severityFor (Namespace _ ["RecvHeaderEnd"]) _ = Just Debug + severityFor (Namespace _ ["RecvStart"]) _ = Just Debug + severityFor (Namespace _ ["RecvEnd"]) _ = Just Debug + severityFor (Namespace _ ["SendStart"]) _ = Just Debug + severityFor (Namespace _ ["SendEnd"]) _ = Just Debug + severityFor (Namespace _ ["RecvDeltaQObservation"]) _ = Just Debug + severityFor (Namespace _ ["RecvDeltaQSample"]) _ = Just Debug + severityFor (Namespace _ ["SDUReadTimeoutException"]) _ = Just Notice + severityFor (Namespace _ ["SDUWriteTimeoutException"]) _ = Just Notice + severityFor (Namespace _ ["TCPInfo"]) _ = Just Debug + severityFor (Namespace _ ["TraceEmitDeltaQ"]) _ = Nothing + severityFor _ _ = Nothing + + documentFor (Namespace _ ["RecvHeaderStart"]) = Just + "Bearer receive header start." + documentFor (Namespace _ ["RecvRaw"]) = Just + "Bearer receive raw." + documentFor (Namespace _ ["RecvHeaderEnd"]) = Just + "Bearer receive header end." + documentFor (Namespace _ ["RecvStart"]) = Just + "Bearer receive start." + documentFor (Namespace _ ["RecvEnd"]) = Just + "Bearer receive end." + documentFor (Namespace _ ["SendStart"]) = Just + "Bearer send start." + documentFor (Namespace _ ["SendEnd"]) = Just + "Bearer send end." + documentFor (Namespace _ ["RecvDeltaQObservation"]) = Just + "Bearer DeltaQ observation." + documentFor (Namespace _ ["RecvDeltaQSample"]) = Just + "Bearer DeltaQ sample." + documentFor (Namespace _ ["SDUReadTimeoutException"]) = Just + "Timed out reading SDU." + documentFor (Namespace _ ["SDUWriteTimeoutException"]) = Just + "Timed out writing SDU." + documentFor (Namespace _ ["TraceEmitDeltaQ"]) = Nothing + documentFor (Namespace _ ["TCPInfo"]) = Just + "TCPInfo." + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["RecvHeaderStart"] + , Namespace [] ["RecvRaw"] + , Namespace [] ["RecvHeaderEnd"] + , Namespace [] ["RecvStart"] + , Namespace [] ["RecvEnd"] + , Namespace [] ["SendStart"] + , Namespace [] ["SendEnd"] + , Namespace [] ["RecvDeltaQObservation"] + , Namespace [] ["RecvDeltaQSample"] + , Namespace [] ["SDUReadTimeoutException"] + , Namespace [] ["SDUWriteTimeoutException"] + , Namespace [] ["TraceEmitDeltaQ"] + , Namespace [] ["TCPInfo"] + ] + +instance LogFormatting Mux.ChannelTrace where + forMachine _dtal (Mux.TraceChannelRecvStart mid) = mconcat + [ "kind" .= String "Mux.TraceChannelRecvStart" + , "msg" .= String "Channel Receive Start" + , "miniProtocolNum" .= String (showT mid) + ] + forMachine _dtal (Mux.TraceChannelRecvEnd mid len) = mconcat + [ "kind" .= String "Mux.TraceChannelRecvEnd" + , "msg" .= String "Channel Receive End" + , "miniProtocolNum" .= String (showT mid) + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceChannelSendStart mid len) = mconcat + [ "kind" .= String "Mux.TraceChannelSendStart" + , "msg" .= String "Channel Send Start" + , "miniProtocolNum" .= String (showT mid) + , "length" .= String (showT len) + ] + forMachine _dtal (Mux.TraceChannelSendEnd mid) = mconcat + [ "kind" .= String "Mux.TraceChannelSendEnd" + , "msg" .= String "Channel Send End" + , "miniProtocolNum" .= String (showT mid) + ] + + forHuman (Mux.TraceChannelRecvStart mid) = + sformat ("Channel Receive Start on " % shown) mid + forHuman (Mux.TraceChannelRecvEnd mid len) = + sformat ("Channel Receive End on (" % shown % ") " % int) mid len + forHuman (Mux.TraceChannelSendStart mid len) = + sformat ("Channel Send Start on (" % shown % ") " % int) mid len + forHuman (Mux.TraceChannelSendEnd mid) = + sformat ("Channel Send End on " % shown) mid + +instance MetaTrace Mux.ChannelTrace where + namespaceFor Mux.TraceChannelRecvStart {} = + Namespace [] ["ChannelRecvStart"] + namespaceFor Mux.TraceChannelRecvEnd {} = + Namespace [] ["ChannelRecvEnd"] + namespaceFor Mux.TraceChannelSendStart {} = + Namespace [] ["ChannelSendStart"] + namespaceFor Mux.TraceChannelSendEnd {} = + Namespace [] ["ChannelSendEnd"] + + severityFor (Namespace _ ["ChannelRecvStart"]) _ = Just Debug + severityFor (Namespace _ ["ChannelRecvEnd"]) _ = Just Debug + severityFor (Namespace _ ["ChannelSendStart"]) _ = Just Debug + severityFor (Namespace _ ["ChannelSendEnd"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["ChannelRecvStart"]) = Just + "Channel receive start." + documentFor (Namespace _ ["ChannelRecvEnd"]) = Just + "Channel receive end." + documentFor (Namespace _ ["ChannelSendStart"]) = Just + "Channel send start." + documentFor (Namespace _ ["ChannelSendEnd"]) = Just + "Channel send end." + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["ChannelRecvStart"] + , Namespace [] ["ChannelRecvEnd"] + , Namespace [] ["ChannelSendStart"] + , Namespace [] ["ChannelSendEnd"] + ] + +instance LogFormatting Mux.Trace where + forMachine _dtal (Mux.TraceState new) = mconcat + [ "kind" .= String "Mux.TraceState" + , "msg" .= String "MuxState" + , "state" .= String (showT new) + ] + forMachine _dtal (Mux.TraceCleanExit mid dir) = mconcat + [ "kind" .= String "Mux.TraceCleanExit" + , "msg" .= String "Miniprotocol terminated cleanly" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceExceptionExit mid dir exc) = mconcat + [ "kind" .= String "Mux.TraceExceptionExit" + , "msg" .= String "Miniprotocol terminated with exception" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + , "exception" .= String (showT exc) + ] + forMachine _dtal (Mux.TraceStartEagerly mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartEagerly" + , "msg" .= String "Eagerly started" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceStartOnDemand mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartOnDemand" + , "msg" .= String "Preparing to start" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceStartOnDemandAny mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartOnDemandAny" + , "msg" .= String "Preparing to start" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceStartedOnDemand mid dir) = mconcat + [ "kind" .= String "Mux.TraceStartedOnDemand" + , "msg" .= String "Started on demand" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal (Mux.TraceTerminating mid dir) = mconcat + [ "kind" .= String "Mux.TraceTerminating" + , "msg" .= String "Terminating" + , "miniProtocolNum" .= String (showT mid) + , "miniProtocolDir" .= String (showT dir) + ] + forMachine _dtal Mux.TraceStopping = mconcat + [ "kind" .= String "Mux.TraceStopping" + , "msg" .= String "Mux stopping" + ] + forMachine _dtal Mux.TraceStopped = mconcat + [ "kind" .= String "Mux.TraceStopped" + , "msg" .= String "Mux stoppped" + ] + + forHuman (Mux.TraceState new) = + sformat ("State: " % shown) new + forHuman (Mux.TraceCleanExit mid dir) = + sformat ("Miniprotocol (" % shown % ") " % shown % " terminated cleanly") + mid dir + forHuman (Mux.TraceExceptionExit mid dir e) = + sformat ("Miniprotocol (" % shown % ") " % shown % + " terminated with exception " % shown) mid dir e + forHuman (Mux.TraceStartEagerly mid dir) = + sformat ("Eagerly started (" % shown % ") in " % shown) mid dir + forHuman (Mux.TraceStartOnDemand mid dir) = + sformat ("Preparing to start (" % shown % ") in " % shown) mid dir + forHuman (Mux.TraceStartOnDemandAny mid dir) = + sformat ("Preparing to start (" % shown % ") in " % shown) mid dir + forHuman (Mux.TraceStartedOnDemand mid dir) = + sformat ("Started on demand (" % shown % ") in " % shown) mid dir + forHuman (Mux.TraceTerminating mid dir) = + sformat ("Terminating (" % shown % ") in " % shown) mid dir + forHuman Mux.TraceStopping = "Mux stopping" + forHuman Mux.TraceStopped = "Mux stoppped" + +instance MetaTrace Mux.Trace where + namespaceFor Mux.TraceState {} = + Namespace [] ["State"] + namespaceFor Mux.TraceCleanExit {} = + Namespace [] ["CleanExit"] + namespaceFor Mux.TraceExceptionExit {} = + Namespace [] ["ExceptionExit"] + namespaceFor Mux.TraceStartEagerly {} = + Namespace [] ["StartEagerly"] + namespaceFor Mux.TraceStartOnDemand {} = + Namespace [] ["StartOnDemand"] + namespaceFor Mux.TraceStartOnDemandAny {} = + Namespace [] ["StartOnDemandAny"] + namespaceFor Mux.TraceStartedOnDemand {} = + Namespace [] ["StartedOnDemand"] + namespaceFor Mux.TraceTerminating {} = + Namespace [] ["Terminating"] + namespaceFor Mux.TraceStopping = + Namespace [] ["Stopping"] + namespaceFor Mux.TraceStopped = + Namespace [] ["Stopped"] + + severityFor (Namespace _ ["State"]) _ = Just Info + severityFor (Namespace _ ["CleanExit"]) _ = Just Notice + severityFor (Namespace _ ["ExceptionExit"]) _ = Just Notice + severityFor (Namespace _ ["StartEagerly"]) _ = Just Debug + severityFor (Namespace _ ["StartOnDemand"]) _ = Just Debug + severityFor (Namespace _ ["StartOnDemandAny"]) _ = Just Debug + severityFor (Namespace _ ["StartedOnDemand"]) _ = Just Debug + severityFor (Namespace _ ["Terminating"]) _ = Just Debug + severityFor (Namespace _ ["Stopping"]) _ = Just Debug + severityFor (Namespace _ ["Stopped"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["State"]) = Just + "State." + documentFor (Namespace _ ["CleanExit"]) = Just + "Miniprotocol terminated cleanly." + documentFor (Namespace _ ["ExceptionExit"]) = Just + "Miniprotocol terminated with exception." + documentFor (Namespace _ ["StartEagerly"]) = Just + "Eagerly started." + documentFor (Namespace _ ["StartOnDemand"]) = Just + "Preparing to start." + documentFor (Namespace _ ["StartedOnDemand"]) = Just + "Started on demand." + documentFor (Namespace _ ["StartOnDemandAny"]) = Just + "Start whenever any other protocol has started." + documentFor (Namespace _ ["Terminating"]) = Just + "Terminating." + documentFor (Namespace _ ["Stopping"]) = Just + "Mux shutdown." + documentFor (Namespace _ ["Stopped"]) = Just + "Mux shutdown." + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["State"] + , Namespace [] ["CleanExit"] + , Namespace [] ["ExceptionExit"] + , Namespace [] ["StartEagerly"] + , Namespace [] ["StartOnDemand"] + , Namespace [] ["StartOnDemandAny"] + , Namespace [] ["StartedOnDemand"] + , Namespace [] ["Terminating"] + , Namespace [] ["Stopping"] + , Namespace [] ["Stopped"] + ] + From 817dbff482e754405ae3437f53b281e0aa3edbaf Mon Sep 17 00:00:00 2001 From: Federico Mastellone Date: Mon, 27 Oct 2025 19:24:39 +0000 Subject: [PATCH 13/14] ouroboros-network:traces --- ouroboros-network/ouroboros-network.cabal | 21 + .../traces/Ouroboros/Network/Traces.hs | 385 ++++++++++++++++++ 2 files changed, 406 insertions(+) create mode 100644 ouroboros-network/traces/Ouroboros/Network/Traces.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index b43adca3d18..e0590c6993f 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -180,6 +180,27 @@ library if flag(txsubmission-delay) cpp-options: -DTXSUBMISSION_DELAY +library traces + import: ghc-options + visibility: public + hs-source-dirs: traces + exposed-modules: + Ouroboros.Network.Traces + other-modules: + reexported-modules: + default-language: Haskell2010 + other-extensions: + build-depends: + aeson, + base >=4.14 && <4.22, + ouroboros-network, + -- Needs: `instance ToJSON UseLedgerPeers` + ouroboros-network:orphan-instances, + text, + trace-dispatcher ^>= 2.10.0 + if flag(asserts) + ghc-options: -fno-ignore-asserts + library orphan-instances import: ghc-options visibility: public diff --git a/ouroboros-network/traces/Ouroboros/Network/Traces.hs b/ouroboros-network/traces/Ouroboros/Network/Traces.hs new file mode 100644 index 00000000000..d051d3ea071 --- /dev/null +++ b/ouroboros-network/traces/Ouroboros/Network/Traces.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- From `Cardano.Node.Tracing.Tracers.Diffusion` +-- Branch "ana/10.6-final-integration-mix" + +module Ouroboros.Network.Traces () where + +import Cardano.Logging + +import qualified Ouroboros.Network.Diffusion.Types as Diff +-- Needs: `instance ToJSON UseLedgerPeers` +import Ouroboros.Network.OrphanInstances () +import Ouroboros.Network.PeerSelection.LedgerPeers ( + NumberOfPeers (..) + , PoolStake (..) + , TraceLedgerPeers (..) + ) +import Data.Aeson (Value (String), (.=)) +import qualified Data.List as List +import Data.Text (pack) + +-------------------------------------------------------------------------------- +-- DiffusionInit Tracer +-------------------------------------------------------------------------------- + +instance (Show ntnAddr, Show ntcAddr) => + LogFormatting (Diff.DiffusionTracer ntnAddr ntcAddr) where + forMachine _dtal (Diff.RunServer sockAddr) = mconcat + [ "kind" .= String "RunServer" + , "socketAddress" .= String (pack (show sockAddr)) + ] + + forMachine _dtal (Diff.RunLocalServer localAddress) = mconcat + [ "kind" .= String "RunLocalServer" + , "localAddress" .= String (pack (show localAddress)) + ] + forMachine _dtal (Diff.UsingSystemdSocket localAddress) = mconcat + [ "kind" .= String "UsingSystemdSocket" + , "path" .= String (pack . show $ localAddress) + ] + + forMachine _dtal (Diff.CreateSystemdSocketForSnocketPath localAddress) = mconcat + [ "kind" .= String "CreateSystemdSocketForSnocketPath" + , "path" .= String (pack . show $ localAddress) + ] + forMachine _dtal (Diff.CreatedLocalSocket localAddress) = mconcat + [ "kind" .= String "CreatedLocalSocket" + , "path" .= String (pack . show $ localAddress) + ] + forMachine _dtal (Diff.ConfiguringLocalSocket localAddress socket) = mconcat + [ "kind" .= String "ConfiguringLocalSocket" + , "path" .= String (pack . show $ localAddress) + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.ListeningLocalSocket localAddress socket) = mconcat + [ "kind" .= String "ListeningLocalSocket" + , "path" .= String (pack . show $ localAddress) + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.LocalSocketUp localAddress fd) = mconcat + [ "kind" .= String "LocalSocketUp" + , "path" .= String (pack . show $ localAddress) + , "socket" .= String (pack (show fd)) + ] + forMachine _dtal (Diff.CreatingServerSocket socket) = mconcat + [ "kind" .= String "CreatingServerSocket" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.ListeningServerSocket socket) = mconcat + [ "kind" .= String "ListeningServerSocket" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.ServerSocketUp socket) = mconcat + [ "kind" .= String "ServerSocketUp" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.ConfiguringServerSocket socket) = mconcat + [ "kind" .= String "ConfiguringServerSocket" + , "socket" .= String (pack (show socket)) + ] + forMachine _dtal (Diff.UnsupportedLocalSystemdSocket path) = mconcat + [ "kind" .= String "UnsupportedLocalSystemdSocket" + , "path" .= String (pack (show path)) + ] + forMachine _dtal Diff.UnsupportedReadySocketCase = mconcat + [ "kind" .= String "UnsupportedReadySocketCase" + ] + forMachine _dtal (Diff.DiffusionErrored exception) = mconcat + [ "kind" .= String "DiffusionErrored" + , "error" .= String (pack (show exception)) + ] + forMachine _dtal (Diff.SystemdSocketConfiguration config) = mconcat + [ "kind" .= String "SystemdSocketConfiguration" + , "path" .= String (pack (show config)) + ] + +instance MetaTrace (Diff.DiffusionTracer ntnAddr ntcAddr) where + namespaceFor Diff.RunServer {} = + Namespace [] ["RunServer"] + namespaceFor Diff.RunLocalServer {} = + Namespace [] ["RunLocalServer"] + namespaceFor Diff.UsingSystemdSocket {} = + Namespace [] ["UsingSystemdSocket"] + namespaceFor Diff.CreateSystemdSocketForSnocketPath {} = + Namespace [] ["CreateSystemdSocketForSnocketPath"] + namespaceFor Diff.CreatedLocalSocket {} = + Namespace [] ["CreatedLocalSocket"] + namespaceFor Diff.ConfiguringLocalSocket {} = + Namespace [] ["ConfiguringLocalSocket"] + namespaceFor Diff.ListeningLocalSocket {} = + Namespace [] ["ListeningLocalSocket"] + namespaceFor Diff.LocalSocketUp {} = + Namespace [] ["LocalSocketUp"] + namespaceFor Diff.CreatingServerSocket {} = + Namespace [] ["CreatingServerSocket"] + namespaceFor Diff.ListeningServerSocket {} = + Namespace [] ["ListeningServerSocket"] + namespaceFor Diff.ServerSocketUp {} = + Namespace [] ["ServerSocketUp"] + namespaceFor Diff.ConfiguringServerSocket {} = + Namespace [] ["ConfiguringServerSocket"] + namespaceFor Diff.UnsupportedLocalSystemdSocket {} = + Namespace [] ["UnsupportedLocalSystemdSocket"] + namespaceFor Diff.UnsupportedReadySocketCase {} = + Namespace [] ["UnsupportedReadySocketCase"] + namespaceFor Diff.DiffusionErrored {} = + Namespace [] ["DiffusionErrored"] + namespaceFor Diff.SystemdSocketConfiguration {} = + Namespace [] ["SystemdSocketConfiguration"] + + severityFor (Namespace _ ["RunServer"]) _ = Just Info + severityFor (Namespace _ ["RunLocalServer"]) _ = Just Info + severityFor (Namespace _ ["UsingSystemdSocket"]) _ = Just Info + severityFor (Namespace _ ["CreateSystemdSocketForSnocketPath"]) _ = Just Info + severityFor (Namespace _ ["CreatedLocalSocket"]) _ = Just Info + severityFor (Namespace _ ["ConfiguringLocalSocket"]) _ = Just Info + severityFor (Namespace _ ["ListeningLocalSocket"]) _ = Just Info + severityFor (Namespace _ ["LocalSocketUp"]) _ = Just Info + severityFor (Namespace _ ["CreatingServerSocket"]) _ = Just Info + severityFor (Namespace _ ["ListeningServerSocket"]) _ = Just Info + severityFor (Namespace _ ["ServerSocketUp"]) _ = Just Info + severityFor (Namespace _ ["ConfiguringServerSocket"]) _ = Just Info + severityFor (Namespace _ ["UnsupportedLocalSystemdSocket"]) _ = Just Warning + severityFor (Namespace _ ["UnsupportedReadySocketCase"]) _ = Just Info + severityFor (Namespace _ ["DiffusionErrored"]) _ = Just Critical + severityFor (Namespace _ ["SystemdSocketConfiguration"]) _ = Just Warning + severityFor _ _ = Nothing + + documentFor (Namespace _ ["RunServer"]) = Just + "RunServer" + documentFor (Namespace _ ["RunLocalServer"]) = Just + "RunLocalServer" + documentFor (Namespace _ ["UsingSystemdSocket"]) = Just + "UsingSystemdSocket" + documentFor (Namespace _ ["CreateSystemdSocketForSnocketPath"]) = Just + "CreateSystemdSocketForSnocketPath" + documentFor (Namespace _ ["CreatedLocalSocket"]) = Just + "CreatedLocalSocket" + documentFor (Namespace _ ["ConfiguringLocalSocket"]) = Just + "ConfiguringLocalSocket" + documentFor (Namespace _ ["ListeningLocalSocket"]) = Just + "ListeningLocalSocket" + documentFor (Namespace _ ["LocalSocketUp"]) = Just + "LocalSocketUp" + documentFor (Namespace _ ["CreatingServerSocket"]) = Just + "CreatingServerSocket" + documentFor (Namespace _ ["ListeningServerSocket"]) = Just + "ListeningServerSocket" + documentFor (Namespace _ ["ServerSocketUp"]) = Just + "ServerSocketUp" + documentFor (Namespace _ ["ConfiguringServerSocket"]) = Just + "ConfiguringServerSocket" + documentFor (Namespace _ ["UnsupportedLocalSystemdSocket"]) = Just + "UnsupportedLocalSystemdSocket" + documentFor (Namespace _ ["UnsupportedReadySocketCase"]) = Just + "UnsupportedReadySocketCase" + documentFor (Namespace _ ["DiffusionErrored"]) = Just + "DiffusionErrored" + documentFor (Namespace _ ["SystemdSocketConfiguration"]) = Just + "SystemdSocketConfiguration" + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["RunServer"] + , Namespace [] ["RunLocalServer"] + , Namespace [] ["UsingSystemdSocket"] + , Namespace [] ["CreateSystemdSocketForSnocketPath"] + , Namespace [] ["CreatedLocalSocket"] + , Namespace [] ["ConfiguringLocalSocket"] + , Namespace [] ["ListeningLocalSocket"] + , Namespace [] ["LocalSocketUp"] + , Namespace [] ["CreatingServerSocket"] + , Namespace [] ["ListeningServerSocket"] + , Namespace [] ["ServerSocketUp"] + , Namespace [] ["ConfiguringServerSocket"] + , Namespace [] ["UnsupportedLocalSystemdSocket"] + , Namespace [] ["UnsupportedReadySocketCase"] + , Namespace [] ["DiffusionErrored"] + , Namespace [] ["SystemdSocketConfiguration"] + ] + +-------------------------------------------------------------------------------- +-- LedgerPeers Tracer +-------------------------------------------------------------------------------- + +instance LogFormatting TraceLedgerPeers where + forMachine _dtal (PickedLedgerPeer addr _ackStake stake) = + mconcat + [ "kind" .= String "PickedLedgerPeer" + , "address" .= show addr + , "relativeStake" .= (realToFrac (unPoolStake stake) :: Double) + ] + forMachine _dtal (PickedLedgerPeers (NumberOfPeers n) addrs) = + mconcat + [ "kind" .= String "PickedLedgerPeers" + , "desiredCount" .= n + , "count" .= List.length addrs + , "addresses" .= show addrs + ] + forMachine _dtal (PickedBigLedgerPeer addr _ackStake stake) = + mconcat + [ "kind" .= String "PickedBigLedgerPeer" + , "address" .= show addr + , "relativeStake" .= (realToFrac (unPoolStake stake) :: Double) + ] + forMachine _dtal (PickedBigLedgerPeers (NumberOfPeers n) addrs) = + mconcat + [ "kind" .= String "PickedBigLedgerPeers" + , "desiredCount" .= n + , "count" .= List.length addrs + , "addresses" .= show addrs + ] + forMachine _dtal (FetchingNewLedgerState cnt bigCnt) = + mconcat + [ "kind" .= String "FetchingNewLedgerState" + , "numberOfLedgerPeers" .= cnt + , "numberOfBigLedgerPeers" .= bigCnt + ] + forMachine _dtal DisabledLedgerPeers = + mconcat + [ "kind" .= String "DisabledLedgerPeers" + ] + forMachine _dtal (TraceUseLedgerPeers ulp) = + mconcat + [ "kind" .= String "UseLedgerPeers" + , "useLedgerPeers" .= ulp + ] + forMachine _dtal WaitingOnRequest = + mconcat + [ "kind" .= String "WaitingOnRequest" + ] + forMachine _dtal (RequestForPeers (NumberOfPeers np)) = + mconcat + [ "kind" .= String "RequestForPeers" + , "numberOfPeers" .= np + ] + forMachine _dtal (ReusingLedgerState cnt age) = + mconcat + [ "kind" .= String "ReusingLedgerState" + , "numberOfPools" .= cnt + , "ledgerStateAge" .= age + ] + forMachine _dtal FallingBackToPublicRootPeers = + mconcat + [ "kind" .= String "FallingBackToPublicRootPeers" + ] + forMachine _dtal (NotEnoughLedgerPeers (NumberOfPeers target) numOfLedgerPeers) = + mconcat + [ "kind" .= String "NotEnoughLedgerPeers" + , "target" .= target + , "numOfLedgerPeers" .= numOfLedgerPeers + ] + forMachine _dtal (NotEnoughBigLedgerPeers (NumberOfPeers target) numOfBigLedgerPeers) = + mconcat + [ "kind" .= String "NotEnoughBigLedgerPeers" + , "target" .= target + , "numOfBigLedgerPeers" .= numOfBigLedgerPeers + ] + forMachine _dtal (TraceLedgerPeersDomains daps) = + mconcat + [ "kind" .= String "TraceLedgerPeersDomains" + , "domainAccessPoints" .= daps + ] + forMachine _dtal UsingBigLedgerPeerSnapshot = + mconcat + [ "kind" .= String "UsingBigLedgerPeerSnapshot" + ] + +instance MetaTrace TraceLedgerPeers where + namespaceFor PickedLedgerPeer {} = + Namespace [] ["PickedLedgerPeer"] + namespaceFor PickedLedgerPeers {} = + Namespace [] ["PickedLedgerPeers"] + namespaceFor PickedBigLedgerPeer {} = + Namespace [] ["PickedBigLedgerPeer"] + namespaceFor PickedBigLedgerPeers {} = + Namespace [] ["PickedBigLedgerPeers"] + namespaceFor FetchingNewLedgerState {} = + Namespace [] ["FetchingNewLedgerState"] + namespaceFor DisabledLedgerPeers {} = + Namespace [] ["DisabledLedgerPeers"] + namespaceFor TraceUseLedgerPeers {} = + Namespace [] ["TraceUseLedgerPeers"] + namespaceFor WaitingOnRequest {} = + Namespace [] ["WaitingOnRequest"] + namespaceFor RequestForPeers {} = + Namespace [] ["RequestForPeers"] + namespaceFor ReusingLedgerState {} = + Namespace [] ["ReusingLedgerState"] + namespaceFor FallingBackToPublicRootPeers {} = + Namespace [] ["FallingBackToPublicRootPeers"] + namespaceFor NotEnoughLedgerPeers {} = + Namespace [] ["NotEnoughLedgerPeers"] + namespaceFor NotEnoughBigLedgerPeers {} = + Namespace [] ["NotEnoughBigLedgerPeers"] + namespaceFor TraceLedgerPeersDomains {} = + Namespace [] ["TraceLedgerPeersDomains"] + namespaceFor UsingBigLedgerPeerSnapshot {} = + Namespace [] ["UsingBigLedgerPeerSnapshot"] + + severityFor (Namespace _ ["PickedPeer"]) _ = Just Debug + severityFor (Namespace _ ["PickedPeers"]) _ = Just Info + severityFor (Namespace _ ["FetchingNewLedgerState"]) _ = Just Info + severityFor (Namespace _ ["DisabledLedgerPeers"]) _ = Just Info + severityFor (Namespace _ ["TraceUseLedgerAfter"]) _ = Just Info + severityFor (Namespace _ ["WaitingOnRequest"]) _ = Just Debug + severityFor (Namespace _ ["RequestForPeers"]) _ = Just Debug + severityFor (Namespace _ ["ReusingLedgerState"]) _ = Just Debug + severityFor (Namespace _ ["FallingBackToPublicRootPeers"]) _ = Just Info + severityFor (Namespace _ ["NotEnoughLedgerPeers"]) _ = Just Warning + severityFor (Namespace _ ["NotEnoughBigLedgerPeers"]) _ = Just Warning + severityFor (Namespace _ ["TraceLedgerPeersDomains"]) _ = Just Debug + severityFor (Namespace _ ["TraceLedgerPeersResult"]) _ = Just Debug + severityFor (Namespace _ ["TraceLedgerPeersFailure"]) _ = Just Debug + severityFor (Namespace _ ["UsingBigLedgerPeerSnapshot"]) _ = Just Debug + severityFor _ _ = Nothing + + documentFor (Namespace _ ["PickedPeer"]) = Just + "Trace for a peer picked with accumulated and relative stake of its pool." + documentFor (Namespace _ ["PickedPeers"]) = Just + "Trace for the number of peers we wanted to pick and the list of peers picked." + documentFor (Namespace _ ["FetchingNewLedgerState"]) = Just $ mconcat + [ "Trace for fetching a new list of peers from the ledger. Int is the number of peers" + , " returned." + ] + documentFor (Namespace _ ["DisabledLedgerPeers"]) = Just + "Trace for when getting peers from the ledger is disabled, that is DontUseLedger." + documentFor (Namespace _ ["TraceUseLedgerAfter"]) = Just + "Trace UseLedgerAfter value." + documentFor (Namespace _ ["WaitingOnRequest"]) = Just + "" + documentFor (Namespace _ ["RequestForPeers"]) = Just + "RequestForPeers (NumberOfPeers 1)" + documentFor (Namespace _ ["ReusingLedgerState"]) = Just + "" + documentFor (Namespace _ ["FallingBackToPublicRootPeers"]) = Just + "" + documentFor (Namespace _ ["TraceLedgerPeersDomains"]) = Just + "" + documentFor (Namespace _ ["TraceLedgerPeersResult"]) = Just + "" + documentFor (Namespace _ ["TraceLedgerPeersFailure"]) = Just + "" + documentFor (Namespace _ ["UsingBigLedgerPeerSnapshot"]) = Just $ mconcat + [ "Trace for when a request for big ledger peers is fulfilled from the snapshot file" + , " defined in the topology configuration file."] + documentFor _ = Nothing + + allNamespaces = [ + Namespace [] ["PickedPeer"] + , Namespace [] ["PickedPeers"] + , Namespace [] ["FetchingNewLedgerState"] + , Namespace [] ["DisabledLedgerPeers"] + , Namespace [] ["TraceUseLedgerAfter"] + , Namespace [] ["WaitingOnRequest"] + , Namespace [] ["RequestForPeers"] + , Namespace [] ["ReusingLedgerState"] + , Namespace [] ["FallingBackToPublicRootPeers"] + , Namespace [] ["TraceLedgerPeersDomains"] + , Namespace [] ["TraceLedgerPeersResult"] + , Namespace [] ["TraceLedgerPeersFailure"] + , Namespace [] ["UsingBigLedgerPeerSnapshot"] + ] + From 3e27ce88bf55484a460a417e379f25f9fdf22b9e Mon Sep 17 00:00:00 2001 From: Federico Mastellone Date: Mon, 27 Oct 2025 21:13:01 +0000 Subject: [PATCH 14/14] ouroboros-network-framework:traces --- .../ouroboros-network-framework.cabal | 27 ++++++ .../Network/Protocol/Handshake/Traces.hs | 89 +++++++++++++++++++ 2 files changed, 116 insertions(+) create mode 100644 ouroboros-network-framework/traces/Ouroboros/Network/Protocol/Handshake/Traces.hs diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index 37a88c16b9a..ca936fd693e 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -102,6 +102,33 @@ library -Wredundant-constraints -Wno-unticked-promoted-constructors +library traces + visibility: public + hs-source-dirs: traces + exposed-modules: + Ouroboros.Network.Protocol.Handshake.Traces + other-modules: + build-depends: + aeson, + base >=4.14 && <4.22, + ouroboros-network-framework, + text, + trace-dispatcher ^>= 2.10.0, + typed-protocols >= 1.0 + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + ghc-options: + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wno-unticked-promoted-constructors + -Wno-unused-packages + + library testlib visibility: public hs-source-dirs: testlib diff --git a/ouroboros-network-framework/traces/Ouroboros/Network/Protocol/Handshake/Traces.hs b/ouroboros-network-framework/traces/Ouroboros/Network/Protocol/Handshake/Traces.hs new file mode 100644 index 00000000000..b2a0f86c2ac --- /dev/null +++ b/ouroboros-network-framework/traces/Ouroboros/Network/Protocol/Handshake/Traces.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ouroboros.Network.Protocol.Handshake.Traces () where + +import Cardano.Logging + +import qualified Ouroboros.Network.Protocol.Handshake.Type as HS +import Network.TypedProtocol.Codec (AnyMessage (..)) + +import Data.Aeson (Value (String), (.=)) +import Data.Text (Text, pack) + +-------------------------------------------------------------------------------- +-- Handshake Tracer +-------------------------------------------------------------------------------- + +instance (Show term, Show ntcVersion) => + LogFormatting (AnyMessage (HS.Handshake ntcVersion term)) where + forMachine _dtal (AnyMessageAndAgency stok msg) = + mconcat [ "kind" .= String kind + , "msg" .= (String . showT $ msg) + , "agency" .= String (pack $ show stok) + ] + where + kind = case msg of + HS.MsgProposeVersions {} -> "ProposeVersions" + HS.MsgReplyVersions {} -> "ReplyVersions" + HS.MsgQueryReply {} -> "QueryReply" + HS.MsgAcceptVersion {} -> "AcceptVersion" + HS.MsgRefuse {} -> "Refuse" + + forHuman (AnyMessageAndAgency stok msg) = + "Handshake (agency, message) = " <> "(" <> showT stok <> "," <> showT msg <> ")" + +instance MetaTrace (AnyMessage (HS.Handshake a b)) where + namespaceFor (AnyMessage msg) = Namespace [] $ case msg of + HS.MsgProposeVersions {} -> ["ProposeVersions"] + HS.MsgReplyVersions {} -> ["ReplyVersions"] + HS.MsgQueryReply {} -> ["QueryReply"] + HS.MsgAcceptVersion {} -> ["AcceptVersion"] + HS.MsgRefuse {} -> ["Refuse"] + + severityFor (Namespace _ [sym]) _ = case sym of + "ProposeVersions" -> Just Info + "ReplyVersions" -> Just Info + "QueryReply" -> Just Info + "AcceptVersion" -> Just Info + "Refuse" -> Just Info + _otherwise -> Nothing + severityFor _ _ = Nothing + + documentFor (Namespace _ sym) = wrap . mconcat $ case sym of + ["ProposeVersions"] -> + [ "Propose versions together with version parameters. It must be" + , " encoded to a sorted list.." + ] + ["ReplyVersions"] -> + [ "`MsgReplyVersions` received as a response to 'MsgProposeVersions'. It" + , " is not supported to explicitly send this message. It can only be" + , " received as a copy of 'MsgProposeVersions' in a simultaneous open" + , " scenario." + ] + ["QueryReply"] -> + [ "`MsgQueryReply` received as a response to a handshake query in " + , " 'MsgProposeVersions' and lists the supported versions." + ] + ["AcceptVersion"] -> + [ "The remote end decides which version to use and sends chosen version." + , "The server is allowed to modify version parameters." + ] + ["Refuse"] -> ["It refuses to run any version."] + _otherwise -> [] :: [Text] + where + wrap it = case it of + "" -> Nothing + it' -> Just it' + + allNamespaces = [ + Namespace [] ["ProposeVersions"] + , Namespace [] ["ReplyVersions"] + , Namespace [] ["QueryReply"] + , Namespace [] ["AcceptVersion"] + , Namespace [] ["Refuse"] + ] +