diff --git a/cabal.project b/cabal.project index ebe3111cf13..f764c4acf6a 100644 --- a/cabal.project +++ b/cabal.project @@ -15,11 +15,19 @@ 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 +-- `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 @@ -32,6 +40,7 @@ packages: ./cardano-ping ./ntp-client ./cardano-client ./decentralized-message-queue + ./quickcheck-monoids tests: True benchmarks: True @@ -53,7 +62,3 @@ package network-mux package ouroboros-network flags: +asserts +cddl - -allow-newer: aeson:QuickCheck, - tree-diff:QuickCheck, - quickcheck-instances:QuickCheck 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/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/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/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/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/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"] + ] + 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-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-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 4dd4e270a51..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,47 +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" -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 2 - <> toCBOR (WithOriginCoded wOrigin, pools') + <> Codec.encodeWord8 1 -- internal version + <> Codec.encodeListLen 2 + <> encodeWithOrigin wOrigin + <> toCBOR pools' where pools' = [(AccPoolStakeCoded accPoolStake, (PoolStakeCoded relStake, relays)) | (accPoolStake, (relStake, relays)) <- pools ] -instance FromCBOR LedgerPeerSnapshot where - fromCBOR = do +decodeLedgerPeerSnapshot :: LedgerPeerSnapshotSRVSupport -> Codec.Decoder s LedgerPeerSnapshot +decodeLedgerPeerSnapshot _ = do Codec.decodeListLenOf 2 version <- Codec.decodeWord8 case version of - 2 -> LedgerPeerSnapshotV2 <$> do - (WithOriginCoded wOrigin, pools) <- fromCBOR + 1 -> LedgerPeerSnapshotV2 <$> do + Codec.decodeListLenOf 2 + wOrigin <- decodeWithOrigin + pools <- fromCBOR let pools' = [(accStake, (relStake, relays)) | (AccPoolStakeCoded accStake, (PoolStakeCoded relStake, relays)) <- pools ] @@ -266,7 +296,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-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 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 f6a2430eae6..ca936fd693e 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 @@ -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, @@ -101,7 +101,33 @@ library -Widentities -Wredundant-constraints -Wno-unticked-promoted-constructors - -Wunused-packages + +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 @@ -116,7 +142,7 @@ library testlib other-modules: build-depends: - QuickCheck >=2.16, + QuickCheck, base >=4.14 && <4.22, bytestring, cborg, @@ -129,6 +155,7 @@ library testlib ouroboros-network-api, ouroboros-network-framework, ouroboros-network-testing, + quickcheck-monoids, random, serialise, typed-protocols:{typed-protocols, examples}, @@ -144,7 +171,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 +184,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 +205,7 @@ test-suite sim-tests pretty-simple, psqueues, quickcheck-instances, + quickcheck-monoids, quiet, random, serialise, @@ -197,7 +228,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 +244,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-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"] + ] + 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-protocols/ouroboros-network-protocols.cabal b/ouroboros-network-protocols/ouroboros-network-protocols.cabal index ecfc5d02ff9..c04bec968b5 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, @@ -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 ba404b15091..72598e3a09b 100644 --- a/ouroboros-network/CHANGELOG.md +++ b/ouroboros-network/CHANGELOG.md @@ -1,13 +1,30 @@ # Revision history for ouroboros-network -## next release +## 0.22.3.0 -- 27.08.2025 -### Breaking changes +* Compatible with `QuickCheck < 2.16` + +## 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 +- 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 +### Non-breaking changes + +* Fixed CBOR encoding of the `LedgerPeerSnapshot`. + ### Breaking changes - Removed `TraceLedgerPeersResult` and `TraceLedgerPeersFailure` @@ -51,6 +68,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 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/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..e0590c6993f 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.3.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, @@ -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 @@ -224,7 +245,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 +310,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, @@ -303,18 +324,20 @@ 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, bytestring, - cardano-binary, cardano-slotting, cborg, containers, @@ -341,6 +364,7 @@ library testlib pipes, pretty-simple, psqueues, + quickcheck-monoids, random, serialise, tasty, @@ -385,6 +409,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 @@ -426,7 +453,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/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. -- 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..e9f7f336cee 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. @@ -950,7 +985,8 @@ withPeerStateActions PeerStateActionsArguments { pchConnectionId, pchPeerStatus, pchMux, - pchAppHandles + pchAppHandles, + pchPromotedHotVar } = do wasCold <- atomically $ do notCold <- isNotCoolingOrCold pchPeerStatus @@ -969,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 @@ -1207,4 +1251,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..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) @@ -1259,6 +1263,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 +3885,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 +3908,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 +3975,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 ) 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 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/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"] + ] + 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 224d2b32083..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,10 +10,18 @@ -- `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 -{-# DEPRECATED Test.QuickCheck.Monoids "Use QuickCheck >= 2.16" #-} import Data.List.NonEmpty as NonEmpty import Data.Semigroup (Semigroup (..)) @@ -21,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 @@ -41,7 +62,16 @@ instance Monoid All where -- existential variables. -- data Any = forall p. Testable p => Any { getAny :: p } -{-# DEPRECATED All "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 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