From 94aadc44d41fdc46f422b1b2c44aafff58dda8fa Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 30 Jun 2025 10:59:08 +0200 Subject: [PATCH 1/4] threadnet: fixed rng for GSM --- .../src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 5b252b2c29..843a3b1f8e 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -1035,7 +1035,8 @@ runThreadNetwork let rng = case seed of Seed s -> mkStdGen s - (kaRng, psRng) = split rng + (kaRng, rng') = split rng + (gsmRng, psRng) = split rng' publicPeerSelectionStateVar <- makePublicPeerSelectionStateVar let nodeKernelArgs = NodeKernelArgs @@ -1074,7 +1075,7 @@ runThreadNetwork } , gsmArgs = GSM.GsmNodeKernelArgs - { gsmAntiThunderingHerd = kaRng + { gsmAntiThunderingHerd = gsmRng , gsmDurationUntilTooOld = Nothing , gsmMarkerFileView = GSM.MarkerFileView From bca716e1155745a3839e8c81d2e5deb31825a642 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 30 Jun 2025 11:17:18 +0200 Subject: [PATCH 2/4] ouroboros-consensus-diffusion integrated with cardano-diffusion --- cabal.project | 32 +- flake.lock | 12 +- .../ouroboros-consensus-cardano.cabal | 8 +- .../Ouroboros/Consensus/Cardano/Node.hs | 6 +- .../Shelley/Ledger/NetworkProtocolVersion.hs | 1 + .../Consensus/Shelley/Ledger/PeerSelection.hs | 34 +- .../Cardano/Tools/ImmDBServer/Diffusion.hs | 47 +- .../Test/Consensus/Shelley/Examples.hs | 4 +- .../ouroboros-consensus-diffusion.cabal | 35 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 24 +- .../Ouroboros/Consensus/Node.hs | 518 ++++-------------- .../Ouroboros/Consensus/Node/ErrorPolicy.hs | 139 ----- .../Ouroboros/Consensus/NodeKernel.hs | 21 +- .../Test/ThreadNet/Network.hs | 16 +- .../Test/Consensus/Genesis/Setup/GenChains.hs | 3 - .../Test/Consensus/Genesis/Tests/CSJ.hs | 4 - .../Test/Consensus/Genesis/Tests/Uniform.hs | 3 - .../Test/Consensus/PeerSimulator/ChainSync.hs | 5 +- .../Test/Consensus/PeerSimulator/Run.hs | 2 +- .../PeerSimulator/Tests/LinkedThreads.hs | 1 - .../Consensus/PeerSimulator/Tests/Timeouts.hs | 1 - .../Test/Consensus/PointSchedule.hs | 78 ++- ouroboros-consensus/ouroboros-consensus.cabal | 45 +- .../Consensus/Ledger/SupportsPeerSelection.hs | 14 +- .../Storage/ImmutableDB/Impl/Index/Cache.hs | 1 + .../Storage/ImmutableDB/Impl/Index/Primary.hs | 7 + .../Ouroboros/Consensus/Util/EarlyExit.hs | 11 +- .../Test/Util/HardFork/OracularClock.hs | 6 +- .../Test/Util/LogicalClock.hs | 4 +- .../Test/Consensus/BlockchainTime/Simple.hs | 2 +- .../Test/Consensus/Mempool/StateMachine.hs | 2 +- 31 files changed, 346 insertions(+), 740 deletions(-) delete mode 100644 ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs diff --git a/cabal.project b/cabal.project index de98dab224..637a19fdfc 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- update either of these. index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2025-06-03T21:29:34Z + , hackage.haskell.org 2025-06-17T07:53:04Z -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2025-06-03T13:42:38Z @@ -57,14 +57,6 @@ if impl (ghc >= 9.12) -- https://github.com/kapralVV/Unique/issues/11 , Unique:hashable -source-repository-package - type: git - location: https://github.com/IntersectMBO/ouroboros-network - tag: 3e8d3b4b8c87ead794876c62d7fe25f32efb5142 - --sha256: 08fpkx3iagj83nn413h9a865zjcj3lrf7017a756qd2wg2jg3amq - subdir: - ouroboros-network-api - source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger @@ -97,3 +89,25 @@ source-repository-package libs/set-algebra libs/small-steps libs/vector-map + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: 06d72973b3187758dd57d8f1e2c48c53f23aae1c + --sha256: sha256-i574WLPFteQjyxhogejbNyhQt2E0A0cDmNqWDOfkAw0= + subdir: + network-mux + ouroboros-network + ouroboros-network-api + ouroboros-network-framework + ouroboros-network-mock + ouroboros-network-protocols + ouroboros-network-testing + +source-repository-package + type: git + location: https://github.com/input-output-hk/fs-sim + tag: ee0b75bee5bcd426cfc5433b6c69c67fe6319c1b + --sha256: 0ss4n302khl13fj5f4l6cxfj5vn558s2wk533ikmxhgigf9qas0q + subdir: fs-api + fs-sim diff --git a/flake.lock b/flake.lock index 8cc47e8ac7..b966f3fc42 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1749025734, - "narHash": "sha256-Gcnpwo+Yp5I+HwQjm7jWAVleHsYhzP34oX/1xJmkgpI=", + "lastModified": 1750632370, + "narHash": "sha256-tg2brm14jly5TLAIgSSYw3Z+ktagPWFTYzuWjukS8+M=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "3d1d71d40bf3dcd129ba0e3fdce7904a4f04b57c", + "rev": "95b0fc262496bd5f85e9686231e497e47657fdff", "type": "github" }, "original": { @@ -254,11 +254,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1749428898, - "narHash": "sha256-IUKLK2emvXkyLIPG7QFZYXgUjy8fjikJ8Hf6KJg/Ck0=", + "lastModified": 1750777164, + "narHash": "sha256-Fg+IpsuF+z/I/5QcCDFbKc6VVzvmWZzUE6ddySuqwqw=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "74c08c2338088dc27041cd9a851ece70accc2d07", + "rev": "e1c181c71d166437e1c09950b1b80a5cd9f9b3b3", "type": "github" }, "original": { diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 2615cd7183..d2f9e63917 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -161,7 +161,7 @@ library nothunks, ouroboros-consensus ^>=0.27, ouroboros-consensus-protocol ^>=0.12, - ouroboros-network-api ^>=0.14, + ouroboros-network-api ^>=0.15, serialise ^>=0.2, singletons ^>=3.0, small-steps, @@ -484,7 +484,7 @@ test-suite cardano-test tasty, tasty-hunit, tasty-quickcheck, - typed-protocols ^>=0.3, + typed-protocols ^>=1.0, unstable-byron-testlib, unstable-cardano-testlib, unstable-shelley-testlib, @@ -566,7 +566,7 @@ library unstable-cardano-tools directory, dot, filepath, - fs-api ^>=0.3, + fs-api ^>=0.4, githash, microlens, mtl, @@ -579,7 +579,7 @@ library unstable-cardano-tools ouroboros-consensus-protocol:{ouroboros-consensus-protocol, unstable-protocol-testlib} ^>=0.12, ouroboros-network, ouroboros-network-api, - ouroboros-network-framework ^>=0.18, + ouroboros-network-framework ^>=0.19, ouroboros-network-protocols, resource-registry, singletons, diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index 33b8a12dde..cdf25e2641 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -379,6 +379,7 @@ instance supportedNodeToNodeVersions _ = Map.fromList $ [ (NodeToNodeV_14, CardanoNodeToNodeVersion2) + , (NodeToNodeV_15, CardanoNodeToNodeVersion2) ] supportedNodeToClientVersions _ = @@ -391,10 +392,7 @@ instance , (NodeToClientV_21, CardanoNodeToClientVersion17) ] - -- This is not set to NodeToClientV_21 on purpose because that one is just a - -- stub. Once we have a proper ouroboros-network to integrate that comes with - -- said version and we remove the SRP then we can bump this value. - latestReleasedNodeVersion _prx = (Just NodeToNodeV_14, Just NodeToClientV_20) + latestReleasedNodeVersion _prx = (Just NodeToNodeV_15, Just NodeToClientV_21) {------------------------------------------------------------------------------- ProtocolInfo diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs index ea7cc2e5a4..210c9d82a1 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs @@ -38,6 +38,7 @@ instance SupportedNetworkProtocolVersion (ShelleyBlock proto era) where supportedNodeToNodeVersions _ = Map.fromList [ (NodeToNodeV_14, ShelleyNodeToNodeVersion1) + , (NodeToNodeV_15, ShelleyNodeToNodeVersion1) ] supportedNodeToClientVersions _ = Map.fromList diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs index f8c1d45be0..2ce71d90b3 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -29,7 +29,7 @@ import Ouroboros.Consensus.Shelley.Ledger.Ledger instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto era) where getPeers ShelleyLedgerState{shelleyLedgerState} = catMaybes - [ (poolStake,) <$> Map.lookup stakePool poolRelayAccessPoints + [ (poolStake,) <$> Map.lookup stakePool poolLedgerRelayAccessPoints | (stakePool, poolStake) <- orderByStake poolDistr ] where @@ -60,41 +60,41 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto . SL.nesEs $ shelleyLedgerState - relayToRelayAccessPoint :: SL.StakePoolRelay -> Maybe RelayAccessPoint - relayToRelayAccessPoint (SL.SingleHostAddr (SJust (Port port)) (SJust ipv4) _) = - Just $ RelayAccessAddress (IPv4 ipv4) (fromIntegral port) - relayToRelayAccessPoint + relayToLedgerRelayAccessPoint :: SL.StakePoolRelay -> Maybe LedgerRelayAccessPoint + relayToLedgerRelayAccessPoint (SL.SingleHostAddr (SJust (Port port)) (SJust ipv4) _) = + Just $ LedgerRelayAccessAddress (IPv4 ipv4) (fromIntegral port) + relayToLedgerRelayAccessPoint ( SL.SingleHostAddr (SJust (Port port)) SNothing (SJust ipv6) ) = - Just $ RelayAccessAddress (IPv6 ipv6) (fromIntegral port) - relayToRelayAccessPoint (SL.SingleHostName (SJust (Port port)) dnsName) = - Just $ RelayAccessDomain (encodeUtf8 $ dnsToText dnsName) (fromIntegral port) - relayToRelayAccessPoint _ = + Just $ LedgerRelayAccessAddress (IPv6 ipv6) (fromIntegral port) + relayToLedgerRelayAccessPoint (SL.SingleHostName (SJust (Port port)) dnsName) = + Just $ LedgerRelayAccessDomain (encodeUtf8 $ dnsToText dnsName) (fromIntegral port) + relayToLedgerRelayAccessPoint _ = -- This could be an unsupported relay (SRV records) or an unusable -- relay such as a relay with an IP address but without a port number. Nothing -- \| Note that a stake pool can have multiple registered relays - pparamsRelayAccessPoints :: - (RelayAccessPoint -> StakePoolRelay) -> + pparamsLedgerRelayAccessPoints :: + (LedgerRelayAccessPoint -> StakePoolRelay) -> SL.PoolParams -> Maybe (NonEmpty StakePoolRelay) - pparamsRelayAccessPoints injStakePoolRelay = + pparamsLedgerRelayAccessPoints injStakePoolRelay = NE.nonEmpty . force - . mapMaybe (fmap injStakePoolRelay . relayToRelayAccessPoint) + . mapMaybe (fmap injStakePoolRelay . relayToLedgerRelayAccessPoint) . toList . SL.ppRelays -- \| Combine the stake pools registered in the future and the current pool -- parameters, and remove duplicates. - poolRelayAccessPoints :: + poolLedgerRelayAccessPoints :: Map (SL.KeyHash 'SL.StakePool) (NonEmpty StakePoolRelay) - poolRelayAccessPoints = + poolLedgerRelayAccessPoints = Map.unionWith (\futureRelays currentRelays -> NE.nub (futureRelays <> currentRelays)) - (Map.mapMaybe (pparamsRelayAccessPoints FutureRelay) futurePoolParams) - (Map.mapMaybe (pparamsRelayAccessPoints CurrentRelay) poolParams) + (Map.mapMaybe (pparamsLedgerRelayAccessPoints FutureRelay) futurePoolParams) + (Map.mapMaybe (pparamsLedgerRelayAccessPoints CurrentRelay) poolParams) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs index fa281c9083..1934876474 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs @@ -25,7 +25,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDbArgs (..)) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) import Ouroboros.Network.IOManager (withIOManager) import Ouroboros.Network.Mux import qualified Ouroboros.Network.NodeToNode as N2N @@ -33,8 +32,11 @@ import Ouroboros.Network.PeerSelection.PeerSharing.Codec ( decodeRemoteAddress , encodeRemoteAddress ) +import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) +import qualified Ouroboros.Network.Protocol.Handshake as Handshake +import qualified Ouroboros.Network.Server.Simple as Server import qualified Ouroboros.Network.Snocket as Snocket -import Ouroboros.Network.Socket (configureSocket) +import Ouroboros.Network.Socket (SomeResponderApplication (..), configureSocket) import System.FS.API (SomeHasFS (..)) import System.FS.API.Types (MountPoint (MountPoint)) import System.FS.IO (ioHasFS) @@ -48,32 +50,23 @@ serve :: N2N.NodeToNodeVersionData (OuroborosApplicationWithMinimalCtx 'Mux.ResponderMode SockAddr BL.ByteString IO Void ()) -> IO Void -serve sockAddr application = withIOManager \iocp -> do - let sn = Snocket.socketSnocket iocp - family = Snocket.addrFamily sn sockAddr - bracket (Snocket.open sn family) (Snocket.close sn) \socket -> do - networkMutableState <- N2N.newNetworkMutableState - configureSocket socket (Just sockAddr) - Snocket.bind sn socket sockAddr - Snocket.listen sn socket - N2N.withServer - sn - N2N.nullNetworkServerTracers - { N2N.nstHandshakeTracer = show >$< stdoutTracer - , N2N.nstErrorPolicyTracer = show >$< stdoutTracer - } - networkMutableState - acceptedConnectionsLimit - socket - application - nullErrorPolicies - where - acceptedConnectionsLimit = - N2N.AcceptedConnectionsLimit - { N2N.acceptedConnectionsHardLimit = maxBound - , N2N.acceptedConnectionsSoftLimit = maxBound - , N2N.acceptedConnectionsDelay = 0 +serve sockAddr application = withIOManager \iocp -> + Server.with + (Snocket.socketSnocket iocp) + Snocket.makeSocketBearer + (\sock addr -> configureSocket sock (Just addr)) + sockAddr + HandshakeArguments + { haHandshakeTracer = show >$< stdoutTracer + , haBearerTracer = show >$< stdoutTracer + , haHandshakeCodec = Handshake.nodeToNodeHandshakeCodec + , haVersionDataCodec = Handshake.cborTermVersionDataCodec N2N.nodeToNodeCodecCBORTerm + , haAcceptVersion = Handshake.acceptableVersion + , haQueryVersion = Handshake.queryVersion + , haTimeLimits = Handshake.timeLimitsHandshake } + (SomeResponderApplication <$> application) + (\_ serverAsync -> wait serverAsync) run :: forall blk. diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index e33c77309b..797d1da8ac 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -199,7 +199,7 @@ fromShelleyLedgerExamples ( AccPoolStake 0.9 , ( PoolStake 0.9 - , RelayAccessAddress (IPv4 "1.1.1.1") 1234 :| [] + , LedgerRelayAccessAddress (IPv4 "1.1.1.1") 1234 :| [] ) ) ] @@ -335,7 +335,7 @@ fromShelleyLedgerExamplesPraos ( AccPoolStake 0.9 , ( PoolStake 0.9 - , RelayAccessAddress (IPv4 "1.1.1.1") 1234 :| [] + , LedgerRelayAccessAddress (IPv4 "1.1.1.1") 1234 :| [] ) ) ] diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 257e13a8f7..04e6f7ec4d 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -60,7 +60,6 @@ library Ouroboros.Consensus.Node Ouroboros.Consensus.Node.DbLock Ouroboros.Consensus.Node.DbMarker - Ouroboros.Consensus.Node.ErrorPolicy Ouroboros.Consensus.Node.Exit Ouroboros.Consensus.Node.ExitPolicy Ouroboros.Consensus.Node.GSM @@ -83,29 +82,25 @@ library containers >=0.5 && <0.8, contra-tracer, deepseq, - dns, filepath, - fs-api ^>=0.3, + fs-api ^>=0.4, hashable, - io-classes ^>=1.5, + io-classes:{io-classes, si-timers, strict-stm} ^>=1.8, mtl, - network-mux ^>=0.8, + network-mux ^>=0.9, ouroboros-consensus ^>=0.27, - ouroboros-network ^>=0.21, - ouroboros-network-api ^>=0.14, - ouroboros-network-framework ^>=0.18, - ouroboros-network-protocols ^>=0.14, + ouroboros-network:{cardano-diffusion, ouroboros-network} ^>=0.22, + ouroboros-network-api ^>=0.15, + ouroboros-network-framework ^>=0.19, + ouroboros-network-protocols ^>=0.15, random, resource-registry ^>=0.1, safe-wild-cards ^>=1.0, serialise ^>=0.2, - si-timers ^>=1.5, - strict-stm ^>=1.5, text, time, transformers, - typed-protocols, - typed-protocols-stateful, + typed-protocols:{stateful, typed-protocols}, library unstable-diffusion-testlib import: common-lib @@ -135,9 +130,9 @@ library unstable-diffusion-testlib containers, contra-tracer, fgl, - fs-sim ^>=0.3, + fs-sim ^>=0.4, graphviz >=2999.20.1.0, - io-classes, + io-classes:{io-classes, si-timers, strict-stm}, io-sim, mtl, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, @@ -150,11 +145,9 @@ library unstable-diffusion-testlib quiet ^>=0.2, random, resource-registry, - si-timers, sop-core ^>=0.5, sop-extras ^>=0.4, strict-sop-core ^>=0.1, - strict-stm, text, typed-protocols, @@ -289,10 +282,10 @@ test-suite consensus-test containers, contra-tracer, directory, - fs-api ^>=0.3, - fs-sim ^>=0.3, + fs-api ^>=0.4, + fs-sim ^>=0.4, hashable, - io-classes, + io-classes:{io-classes, si-timers, strict-stm}, io-sim, mempack, mtl, @@ -310,12 +303,10 @@ test-suite consensus-test random, resource-registry, serialise, - si-timers, sop-core, sop-extras, strict-checked-vars, strict-sop-core, - strict-stm, tasty, tasty-hunit, tasty-quickcheck, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 701d0c9a91..85c4109a52 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -37,9 +37,6 @@ module Ouroboros.Consensus.Network.NodeToNode -- ** Projections , initiator , initiatorAndResponder - - -- * Re-exports - , ChainSyncTimeout (..) ) where import Codec.CBOR.Decoding (Decoder) @@ -151,6 +148,7 @@ import Ouroboros.Network.TxSubmission.Mempool.Reader ( mapTxSubmissionMempoolReader ) import Ouroboros.Network.TxSubmission.Outbound +import System.Random (StdGen, split) {------------------------------------------------------------------------------- Handlers @@ -602,18 +600,22 @@ mkApps :: ) => -- | Needed for bracketing only NodeKernel m addrNTN addrNTC blk -> + StdGen -> Tracers m addrNTN blk e -> (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS) -> ByteLimits bCS bBF bTX bKA -> - m ChainSyncTimeout -> + -- Chain-Sync timeouts for chain-sync client (using `Header blk`) as well as + -- the server (`SerialisedHeader blk`). + (forall header. ProtocolTimeLimitsWithRnd (ChainSync header (Point blk) (Tip blk))) -> CsClient.ChainSyncLoPBucketConfig -> CsClient.CSJConfig -> ReportPeerMetrics m (ConnectionId addrNTN) -> Handlers m addrNTN blk -> Apps m addrNTN bCS bBF bTX bKA bPS NodeToNodeInitiatorResult () -mkApps kernel Tracers{..} mkCodecs ByteLimits{..} genChainSyncTimeout lopBucketConfig csjConfig ReportPeerMetrics{..} Handlers{..} = +mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucketConfig csjConfig ReportPeerMetrics{..} Handlers{..} = Apps{..} where + (chainSyncRng, chainSyncRng') = split rng NodeKernel{getDiffusionPipeliningSupport} = kernel aChainSyncClient :: @@ -650,13 +652,13 @@ mkApps kernel Tracers{..} mkCodecs ByteLimits{..} genChainSyncTimeout lopBucketC csjConfig getDiffusionPipeliningSupport $ \csState -> do - chainSyncTimeout <- genChainSyncTimeout (r, trailing) <- - runPipelinedPeerWithLimits + runPipelinedPeerWithLimitsRnd (contramap (TraceLabelPeer them) tChainSyncTracer) + chainSyncRng (cChainSyncCodec (mkCodecs version)) blChainSync - (timeLimitsChainSync chainSyncTimeout) + chainSyncTimeouts channel $ chainSyncClientPeerPipelined $ hChainSyncClient @@ -681,7 +683,6 @@ mkApps kernel Tracers{..} mkCodecs ByteLimits{..} genChainSyncTimeout lopBucketC m ((), Maybe bCS) aChainSyncServer version ResponderContext{rcConnectionId = them} channel = do labelThisThread "ChainSyncServer" - chainSyncTimeout <- genChainSyncTimeout bracketWithPrivateRegistry ( chainSyncHeaderServerFollower (getChainDB kernel) @@ -692,11 +693,12 @@ mkApps kernel Tracers{..} mkCodecs ByteLimits{..} genChainSyncTimeout lopBucketC ) ChainDB.followerClose $ \flr -> - runPeerWithLimits + runPeerWithLimitsRnd (contramap (TraceLabelPeer them) tChainSyncSerialisedTracer) + chainSyncRng' (cChainSyncCodecSerialised (mkCodecs version)) blChainSync - (timeLimitsChainSync chainSyncTimeout) + chainSyncTimeouts channel $ chainSyncServerPeer $ hChainSyncServer them version flr diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index c233ee9241..7c0535c1bd 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -26,8 +26,6 @@ module Ouroboros.Consensus.Node -- * Standard arguments , StdRunNodeArgs (..) , stdBfcSaltIO - , stdGsmAntiThunderingHerdIO - , stdKeepAliveRngIO , stdLowLevelRunNodeArgsIO , stdMkChainDbHasFS , stdRunDataDiffusion @@ -35,9 +33,6 @@ module Ouroboros.Consensus.Node , stdVersionDataNTN , stdWithCheckedDB - -- ** P2P Switch - , NetworkP2PMode (..) - -- * Exposed by 'run' et al , ChainDB.RelativeMountPoint (..) , ChainDB.TraceEvent (..) @@ -57,6 +52,7 @@ module Ouroboros.Consensus.Node , Tracers' (..) , pattern DoDiskSnapshotChecksum , pattern NoDoDiskSnapshotChecksum + , ChainSyncIdleTimeout (..) -- * Internal helpers , mkNodeKernelArgs @@ -64,22 +60,24 @@ module Ouroboros.Consensus.Node , openChainDB ) where -import Cardano.Network.PeerSelection.Bootstrap - ( UseBootstrapPeers (..) - ) -import Cardano.Network.Types (LedgerStateJudgement (..)) +import qualified Cardano.Network.Diffusion as Cardano.Diffusion +import Cardano.Network.Diffusion.Configuration (ChainSyncIdleTimeout (..)) +import qualified Cardano.Network.Diffusion.Policies as Cardano.Diffusion +import qualified Cardano.Network.LedgerPeerConsensusInterface as Cardano +import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) +import Cardano.Network.PeerSelection.Churn (ChurnMode (..)) import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (DeserialiseFailure) import qualified Control.Concurrent.Class.MonadSTM.Strict as StrictSTM import Control.DeepSeq (NFData) -import Control.Exception (IOException) import Control.Monad (forM_, when) import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.ResourceRegistry import Control.Tracer (Tracer, contramap, traceWith) import Data.ByteString.Lazy (ByteString) +import Data.Functor (void) import Data.Functor.Contravariant (Predicate (..)) import Data.Hashable (Hashable) import Data.Kind (Type) @@ -88,11 +86,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isNothing) import Data.Time (NominalDiffTime) import Data.Typeable (Typeable) -import Network.DNS.Resolver (Resolver) -import Network.Mux.Types -import qualified Ouroboros.Cardano.Network.ArgumentsExtra as Cardano -import qualified Ouroboros.Cardano.Network.LedgerPeerConsensusInterface as Cardano -import qualified Ouroboros.Cardano.Network.PeerSelection.Governor.PeerSelectionState as Cardano import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime hiding (getSystemStart) import Ouroboros.Consensus.Config @@ -108,13 +101,12 @@ import qualified Ouroboros.Consensus.Network.NodeToClient as NTC import qualified Ouroboros.Consensus.Network.NodeToNode as NTN import Ouroboros.Consensus.Node.DbLock import Ouroboros.Consensus.Node.DbMarker -import Ouroboros.Consensus.Node.ErrorPolicy import Ouroboros.Consensus.Node.ExitPolicy import Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..)) import qualified Ouroboros.Consensus.Node.GSM as GSM import Ouroboros.Consensus.Node.Genesis ( GenesisConfig (..) - , GenesisNodeKernelArgs + , GenesisNodeKernelArgs (..) , mkGenesisNodeKernelArgs ) import Ouroboros.Consensus.Node.InitStorage @@ -140,18 +132,14 @@ import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) import Ouroboros.Network.BlockFetch ( BlockFetchConfiguration (..) - , FetchMode ) import qualified Ouroboros.Network.Diffusion as Diffusion -import qualified Ouroboros.Network.Diffusion.Common as Diffusion import qualified Ouroboros.Network.Diffusion.Configuration as Diffusion -import qualified Ouroboros.Network.Diffusion.NonP2P as NonP2P -import qualified Ouroboros.Network.Diffusion.P2P as Diffusion.P2P +import qualified Ouroboros.Network.Diffusion.Policies as Diffusion import Ouroboros.Network.Magic import Ouroboros.Network.NodeToClient ( ConnectionId , LocalAddress - , LocalSocket , NodeToClientVersionData (..) , combineVersions , simpleSingletonVersions @@ -162,17 +150,14 @@ import Ouroboros.Network.NodeToNode , MiniProtocolParameters , NodeToNodeVersionData (..) , RemoteAddress - , Socket , blockFetchPipeliningMax , defaultMiniProtocolParameters ) import Ouroboros.Network.PeerSelection.Governor.Types - ( PeerSelectionState - , PublicPeerSelectionState + ( PublicPeerSelectionState ) import Ouroboros.Network.PeerSelection.LedgerPeers ( LedgerPeersConsensusInterface (..) - , UseLedgerPeers (..) ) import Ouroboros.Network.PeerSelection.PeerMetric ( PeerMetrics @@ -184,9 +169,7 @@ import Ouroboros.Network.PeerSelection.PeerSharing.Codec ( decodeRemoteAddress , encodeRemoteAddress ) -import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers - ( TracePublicRootPeers - ) +import Ouroboros.Network.Protocol.ChainSync.Codec (timeLimitsChainSync) import Ouroboros.Network.RethrowPolicy import qualified SafeWildCards import System.Exit (ExitCode (..)) @@ -227,9 +210,8 @@ type RunNodeArgs :: Type -> Type -> Type -> - Diffusion.P2P -> Type -data RunNodeArgs m addrNTN addrNTC blk p2p = RunNodeArgs +data RunNodeArgs m addrNTN addrNTC blk = RunNodeArgs { rnTraceConsensus :: Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -- ^ Consensus tracers , rnTraceNTN :: NTN.Tracers m addrNTN blk DeserialiseFailure @@ -246,8 +228,6 @@ data RunNodeArgs m addrNTN addrNTC blk p2p = RunNodeArgs -- -- Called on the 'NodeKernel' after creating it, but before the network -- layer is initialised. - , rnEnableP2P :: NetworkP2PMode p2p - -- ^ Network P2P Mode switch , rnPeerSharing :: PeerSharing -- ^ Network PeerSharing miniprotocol willingness flag , rnGetUseBootstrapPeers :: STM m UseBootstrapPeers @@ -265,10 +245,8 @@ type LowLevelRunNodeArgs :: Type -> Type -> Type -> - Diffusion.P2P -> - Type -> Type -data LowLevelRunNodeArgs m addrNTN addrNTC blk p2p extraAPI +data LowLevelRunNodeArgs m addrNTN addrNTC blk = LowLevelRunNodeArgs { llrnWithCheckedDB :: forall a. @@ -301,30 +279,28 @@ data LowLevelRunNodeArgs m addrNTN addrNTC blk p2p extraAPI -- ^ Customise the 'NodeArgs' , llrnBfcSalt :: Int -- ^ Ie 'bfcSalt' - , llrnGsmAntiThunderingHerd :: StdGen - -- ^ Ie 'gsmAntiThunderingHerd' - , llrnKeepAliveRng :: StdGen - -- ^ Ie 'keepAliveRng' + , llrnRng :: StdGen + -- ^ StdGen for various applications, e.g. keep-alive, chain-sync, gsm anti + -- thundering herd , llrnCustomiseHardForkBlockchainTimeArgs :: HardForkBlockchainTimeArgs m blk -> HardForkBlockchainTimeArgs m blk -- ^ Customise the 'HardForkBlockchainTimeArgs' - , llrnChainSyncTimeout :: m NTN.ChainSyncTimeout - -- ^ See 'NTN.ChainSyncTimeout' + , llrnChainSyncIdleTimeout :: ChainSyncIdleTimeout + -- ^ custom Chain-Sync idle timeout , llrnGenesisConfig :: GenesisConfig , llrnRunDataDiffusion :: NodeKernel m addrNTN (ConnectionId addrNTC) blk -> - Diffusion.Applications + Cardano.Diffusion.CardanoConsensusArguments addrNTN m -> + Cardano.Diffusion.Applications addrNTN NodeToNodeVersion NodeToNodeVersionData addrNTC NodeToClientVersion NodeToClientVersionData - extraAPI m NodeToNodeInitiatorResult -> - Diffusion.ApplicationsExtra p2p addrNTN m NodeToNodeInitiatorResult -> m () -- ^ How to run the data diffusion applications -- @@ -377,17 +353,6 @@ data StdRunNodeArgs m blk - (p2p :: Diffusion.P2P) - extraArgs - extraState - extraDebugState - extraActions - extraAPI - extraPeers - extraFlags - extraChurnArgs - extraCounters - exception = StdRunNodeArgs { srnBfcMaxConcurrencyBulkSync :: Maybe Word , srnBfcMaxConcurrencyDeadline :: Maybe Word @@ -395,84 +360,9 @@ data -- ^ If @True@, validate the ChainDB on init no matter what , srnDatabasePath :: NodeDatabasePaths -- ^ Location of the DBs - , srnDiffusionArguments :: - Diffusion.Arguments - IO - Socket - RemoteAddress - LocalSocket - LocalAddress - , srnDiffusionArgumentsExtra :: - Diffusion.P2PDecision p2p (Tracer IO TracePublicRootPeers) () -> - Diffusion.P2PDecision p2p (STM IO FetchMode) () -> - Diffusion.P2PDecision p2p extraAPI () -> - Diffusion.ArgumentsExtra - p2p - extraArgs - extraState - extraDebugState - extraFlags - extraPeers - extraAPI - extraChurnArgs - extraCounters - exception - RemoteAddress - LocalAddress - Resolver - IOException - IO - , srnDiffusionTracers :: - Diffusion.Tracers - RemoteAddress - NodeToNodeVersion - LocalAddress - NodeToClientVersion - IO - , srnDiffusionTracersExtra :: - Diffusion.ExtraTracers p2p extraState extraDebugState extraFlags extraPeers extraCounters IO - , srnSigUSR1SignalHandler :: - ( forall (mode :: Mode) x y. - Diffusion.ExtraTracers - p2p - extraState - Cardano.DebugPeerSelectionState - extraFlags - extraPeers - extraCounters - IO -> - STM IO UseLedgerPeers -> - PeerSharing -> - STM IO UseBootstrapPeers -> - STM IO LedgerStateJudgement -> - Diffusion.P2P.NodeToNodeConnectionManager - mode - Socket - RemoteAddress - NodeToNodeVersionData - NodeToNodeVersion - IO - x - y -> - StrictSTM.StrictTVar - IO - ( PeerSelectionState - extraState - extraFlags - extraPeers - RemoteAddress - ( Diffusion.P2P.NodeToNodePeerConnectionHandle - mode - RemoteAddress - NodeToNodeVersionData - IO - x - y - ) - ) -> - PeerMetrics IO RemoteAddress -> - IO () - ) + , srnDiffusionArguments :: Cardano.Diffusion.CardanoNodeArguments m + , srnDiffusionConfiguration :: Cardano.Diffusion.CardanoConfiguration m + , srnDiffusionTracers :: Cardano.Diffusion.CardanoTracers m , srnEnableInDevelopmentVersions :: Bool -- ^ If @False@, then the node will limit the negotiated NTN and NTC -- versions to the latest " official " release (as chosen by Network and @@ -481,8 +371,7 @@ data , srnMaybeMempoolCapacityOverride :: Maybe MempoolCapacityBytesOverride -- ^ Determine whether to use the system default mempool capacity or explicitly set -- capacity of the mempool. - , srnChainSyncTimeout :: Maybe (m NTN.ChainSyncTimeout) - -- ^ A custom timeout for ChainSync. + , srnChainSyncIdleTimeout :: ChainSyncIdleTimeout , -- Ad hoc values to replace default ChainDB configurations srnSnapshotPolicyArgs :: SnapshotPolicyArgs , srnQueryBatchSize :: QueryBatchSize @@ -493,40 +382,14 @@ data Entrypoints to the Consensus Layer node functionality -------------------------------------------------------------------------------} --- | P2P Switch -data NetworkP2PMode (p2p :: Diffusion.P2P) where - EnabledP2PMode :: NetworkP2PMode 'Diffusion.P2P - DisabledP2PMode :: NetworkP2PMode 'Diffusion.NonP2P - -deriving instance Eq (NetworkP2PMode p2p) -deriving instance Show (NetworkP2PMode p2p) - pure [] -- | Combination of 'runWith' and 'stdLowLevelRunArgsIO' run :: - forall blk p2p extraState extraActions extraPeers extraFlags extraChurnArgs extraCounters exception. - ( RunNode blk - , Monoid extraPeers - , Eq extraCounters - , Eq extraFlags - , Exception exception - ) => - RunNodeArgs IO RemoteAddress LocalAddress blk p2p -> - StdRunNodeArgs - IO - blk - p2p - (Cardano.ExtraArguments IO) - extraState - Cardano.DebugPeerSelectionState - extraActions - (Cardano.LedgerPeersConsensusInterface IO) - extraPeers - extraFlags - extraChurnArgs - extraCounters - exception -> + forall blk. + RunNode blk => + RunNodeArgs IO RemoteAddress LocalAddress blk -> + StdRunNodeArgs IO blk -> IO () run args stdArgs = stdLowLevelRunNodeArgsIO args stdArgs @@ -596,17 +459,17 @@ type NetworkAddr addr = -- TODO: Ideally, the ChainDB and LedgerDB should follow a consistent -- approach to resource deallocation. runWith :: - forall m addrNTN addrNTC blk p2p. + forall m addrNTN addrNTC blk. ( RunNode blk , IOLike m , Hashable addrNTN -- the constraint comes from `initNodeKernel` , NetworkIO m , NetworkAddr addrNTN ) => - RunNodeArgs m addrNTN addrNTC blk p2p -> + RunNodeArgs m addrNTN addrNTC blk -> (NodeToNodeVersion -> addrNTN -> CBOR.Encoding) -> (NodeToNodeVersion -> forall s. CBOR.Decoder s addrNTN) -> - LowLevelRunNodeArgs m addrNTN addrNTC blk p2p (Cardano.LedgerPeersConsensusInterface m) -> + LowLevelRunNodeArgs m addrNTN addrNTC blk -> m () runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = llrnWithCheckedDB $ \(LastShutDownWasClean lastShutDownWasClean) continueWithCleanChainDB -> @@ -704,8 +567,8 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = mkNodeKernelArgs registry llrnBfcSalt - llrnGsmAntiThunderingHerd - llrnKeepAliveRng + gsmAntiThunderingHerd + keepAliveRng cfg rnTraceConsensus btime @@ -721,21 +584,48 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = DiffusionPipeliningOn nodeKernel <- initNodeKernel nodeKernelArgs rnNodeKernelHook registry nodeKernel + churnModeVar <- StrictSTM.newTVarIO ChurnModeNormal + churnMetrics <- newPeerMetric Diffusion.peerMetricsConfiguration + let consensusDiffusionArgs = + Cardano.Diffusion.CardanoConsensusArguments + { Cardano.Diffusion.churnModeVar + , Cardano.Diffusion.churnMetrics + , Cardano.Diffusion.ledgerPeersAPI = + LedgerPeersConsensusInterface + { lpGetLatestSlot = getImmTipSlot nodeKernel + , lpGetLedgerPeers = fromMaybe [] <$> getPeersFromCurrentLedger nodeKernel (const True) + , lpExtraAPI = + Cardano.LedgerPeersConsensusInterface + { Cardano.readFetchMode = getFetchMode nodeKernel + , Cardano.getLedgerStateJudgement = GSM.gsmStateToLedgerJudgement <$> getGsmState nodeKernel + , Cardano.updateOutboundConnectionsState = + let varOcs = getOutboundConnectionsState nodeKernel + in \newOcs -> do + oldOcs <- readTVar varOcs + when (newOcs /= oldOcs) $ writeTVar varOcs newOcs + } + } + , Cardano.Diffusion.readUseBootstrapPeers = rnGetUseBootstrapPeers + } - peerMetrics <- newPeerMetric Diffusion.peerMetricsConfiguration - let ntnApps = mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNtN decAddrNtN + stdGen <- StrictSTM.newTVarIO peerSelectionRng + let ntnApps = mkNodeToNodeApps nodeKernelArgs nodeKernel churnMetrics encAddrNtN decAddrNtN ntcApps = mkNodeToClientApps nodeKernelArgs nodeKernel - (apps, appsExtra) = + apps = mkDiffusionApplications - rnEnableP2P + stdGen + consensusDiffusionArgs (miniProtocolParameters nodeKernelArgs) ntnApps ntcApps nodeKernel - peerMetrics - llrnRunDataDiffusion nodeKernel apps appsExtra + llrnRunDataDiffusion nodeKernel consensusDiffusionArgs apps where + (gsmAntiThunderingHerd, rng') = split llrnRng + (peerSelectionRng, rng'') = split rng' + (keepAliveRng, ntnAppsRng) = split rng'' + ProtocolInfo { pInfoConfig = cfg , pInfoInitLedger = initLedger @@ -764,10 +654,11 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNTN decAddrNTN version = NTN.mkApps nodeKernel + ntnAppsRng rnTraceNTN (NTN.defaultCodecs codecConfig version encAddrNTN decAddrNTN) NTN.byteLimits - llrnChainSyncTimeout + (timeLimitsChainSync llrnChainSyncIdleTimeout) (gcChainSyncLoPBucketConfig llrnGenesisConfig) (gcCSJConfig llrnGenesisConfig) (reportMetric Diffusion.peerMetricsConfiguration peerMetrics) @@ -787,7 +678,8 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = (NTC.mkHandlers nodeKernelArgs nodeKernel) mkDiffusionApplications :: - NetworkP2PMode p2p -> + StrictSTM.StrictTVar m StdGen -> + Cardano.Diffusion.CardanoConsensusArguments addrNTN m -> MiniProtocolParameters -> ( BlockNodeToNodeVersion blk -> NTN.Apps @@ -813,45 +705,23 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = () ) -> NodeKernel m addrNTN (ConnectionId addrNTC) blk -> - PeerMetrics m addrNTN -> - ( Diffusion.Applications - addrNTN - NodeToNodeVersion - NodeToNodeVersionData - addrNTC - NodeToClientVersion - NodeToClientVersionData - (Cardano.LedgerPeersConsensusInterface m) - m - NodeToNodeInitiatorResult - , Diffusion.ApplicationsExtra p2p addrNTN m NodeToNodeInitiatorResult - ) + Cardano.Diffusion.Applications + addrNTN + NodeToNodeVersion + NodeToNodeVersionData + addrNTC + NodeToClientVersion + NodeToClientVersionData + m + NodeToNodeInitiatorResult mkDiffusionApplications - enP2P + stdGenVar + consensusDiffusionArgs miniProtocolParams ntnApps ntcApps - kernel - peerMetrics = - case enP2P of - EnabledP2PMode -> - ( apps - , Diffusion.P2PApplicationsExtra - Diffusion.P2P.ApplicationsExtra - { Diffusion.P2P.daRethrowPolicy = consensusRethrowPolicy (Proxy @blk) - , Diffusion.P2P.daReturnPolicy = returnPolicy - , Diffusion.P2P.daLocalRethrowPolicy = localRethrowPolicy - , Diffusion.P2P.daPeerMetrics = peerMetrics - , Diffusion.P2P.daPeerSharingRegistry = getPeerSharingRegistry kernel - } - ) - DisabledP2PMode -> - ( apps - , Diffusion.NonP2PApplicationsExtra - NonP2P.ApplicationsExtra - { NonP2P.daErrorPolicies = consensusErrorPolicy (Proxy @blk) - } - ) + kernel = + apps where apps = Diffusion.Applications @@ -889,20 +759,16 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = (\versionData -> NTC.responder version versionData $ ntcApps blockVersion version) | (version, blockVersion) <- Map.toList llrnNodeToClientVersions ] - , Diffusion.daLedgerPeersCtx = - LedgerPeersConsensusInterface - { lpGetLatestSlot = getImmTipSlot kernel - , lpGetLedgerPeers = fromMaybe [] <$> getPeersFromCurrentLedger kernel (const True) - , lpExtraAPI = - Cardano.LedgerPeersConsensusInterface - { Cardano.getLedgerStateJudgement = GSM.gsmStateToLedgerJudgement <$> getGsmState kernel - , Cardano.updateOutboundConnectionsState = - let varOcs = getOutboundConnectionsState kernel - in \newOcs -> do - oldOcs <- readTVar varOcs - when (newOcs /= oldOcs) $ writeTVar varOcs newOcs - } - } + , Diffusion.daRethrowPolicy = consensusRethrowPolicy (Proxy @blk) + , Diffusion.daReturnPolicy = returnPolicy + , Diffusion.daRepromoteErrorDelay = Diffusion.repromoteErrorDelay + , Diffusion.daLocalRethrowPolicy = localRethrowPolicy + , daPeerSelectionPolicy = + Cardano.Diffusion.simpleChurnModePeerSelectionPolicy + stdGenVar + (StrictSTM.readTVar $ Cardano.Diffusion.churnModeVar consensusDiffusionArgs) + (Cardano.Diffusion.churnMetrics consensusDiffusionArgs) + , Diffusion.daPeerSharingRegistry = getPeerSharingRegistry kernel } localRethrowPolicy :: RethrowPolicy @@ -1086,12 +952,6 @@ stdMkChainDbHasFS rootPath (ChainDB.RelativeMountPoint relPath) = stdBfcSaltIO :: IO Int stdBfcSaltIO = randomIO -stdGsmAntiThunderingHerdIO :: IO StdGen -stdGsmAntiThunderingHerdIO = newStdGen - -stdKeepAliveRngIO :: IO StdGen -stdKeepAliveRngIO = newStdGen - stdVersionDataNTN :: NetworkMagic -> DiffusionMode -> @@ -1113,208 +973,64 @@ stdVersionDataNTC networkMagic = } stdRunDataDiffusion :: - ( Monoid extraPeers - , Eq extraCounters - , Eq extraFlags - , Exception exception - ) => - ( forall (mode :: Mode) x y. - Diffusion.P2P.NodeToNodeConnectionManager - mode - Socket - RemoteAddress - NodeToNodeVersionData - NodeToNodeVersion - IO - x - y -> - StrictSTM.StrictTVar - IO - ( PeerSelectionState - extraState - extraFlags - extraPeers - RemoteAddress - ( Diffusion.P2P.NodeToNodePeerConnectionHandle - mode - RemoteAddress - NodeToNodeVersionData - IO - x - y - ) - ) -> - PeerMetrics IO RemoteAddress -> - IO () - ) -> - Diffusion.Tracers - RemoteAddress - NodeToNodeVersion - LocalAddress - NodeToClientVersion - IO -> - Diffusion.ExtraTracers - p2p - extraState - extraDebugState - extraFlags - extraPeers - extraCounters - IO -> - Diffusion.Arguments - IO - Socket - RemoteAddress - LocalSocket - LocalAddress -> - Diffusion.ArgumentsExtra - p2p - extraArgs - extraState - extraDebugState - extraFlags - extraPeers - extraAPI - extraChurnArgs - extraCounters - exception - RemoteAddress - LocalAddress - Resolver - IOException - IO -> - Diffusion.Applications - RemoteAddress - NodeToNodeVersion - NodeToNodeVersionData - LocalAddress - NodeToClientVersion - NodeToClientVersionData - extraAPI - IO - a -> - Diffusion.ApplicationsExtra p2p RemoteAddress IO a -> + Cardano.Diffusion.CardanoNodeArguments IO -> + Cardano.Diffusion.CardanoConsensusArguments RemoteAddress IO -> + Cardano.Diffusion.CardanoTracers IO -> + Cardano.Diffusion.CardanoConfiguration IO -> + Cardano.Diffusion.CardanoApplications IO a -> IO () -stdRunDataDiffusion = Diffusion.run +stdRunDataDiffusion = \nodeArgs consensusArgs tracers config apps -> + void $ Cardano.Diffusion.run nodeArgs consensusArgs tracers config apps -- | Conveniently packaged 'LowLevelRunNodeArgs' arguments from a standard -- non-testing invocation. stdLowLevelRunNodeArgsIO :: - forall blk p2p extraState extraActions extraPeers extraFlags extraChurnArgs extraCounters exception. - ( RunNode blk - , Monoid extraPeers - , Eq extraCounters - , Eq extraFlags - , Exception exception - ) => - RunNodeArgs IO RemoteAddress LocalAddress blk p2p -> - StdRunNodeArgs - IO - blk - p2p - (Cardano.ExtraArguments IO) - extraState - Cardano.DebugPeerSelectionState - extraActions - (Cardano.LedgerPeersConsensusInterface IO) - extraPeers - extraFlags - extraChurnArgs - extraCounters - exception -> + forall blk. + RunNode blk => + RunNodeArgs IO RemoteAddress LocalAddress blk -> + StdRunNodeArgs IO blk -> IO ( LowLevelRunNodeArgs IO RemoteAddress LocalAddress blk - p2p - (Cardano.LedgerPeersConsensusInterface IO) ) stdLowLevelRunNodeArgsIO RunNodeArgs { rnProtocolInfo - , rnEnableP2P , rnPeerSharing , rnGenesisConfig - , rnGetUseBootstrapPeers } $(SafeWildCards.fields 'StdRunNodeArgs) = do llrnBfcSalt <- stdBfcSaltIO - llrnGsmAntiThunderingHerd <- stdGsmAntiThunderingHerdIO - llrnKeepAliveRng <- stdKeepAliveRngIO + llrnRng <- newStdGen pure LowLevelRunNodeArgs { llrnBfcSalt - , llrnChainSyncTimeout = fromMaybe Diffusion.defaultChainSyncTimeout srnChainSyncTimeout + , llrnChainSyncIdleTimeout = srnChainSyncIdleTimeout , llrnGenesisConfig = rnGenesisConfig , llrnCustomiseHardForkBlockchainTimeArgs = id - , llrnGsmAntiThunderingHerd - , llrnKeepAliveRng + , llrnRng , llrnMkImmutableHasFS = stdMkChainDbHasFS $ immutableDbPath srnDatabasePath , llrnMkVolatileHasFS = stdMkChainDbHasFS $ nonImmutableDbPath srnDatabasePath , llrnChainDbArgsDefaults = updateChainDbDefaults ChainDB.defaultArgs , llrnCustomiseChainDbArgs = id , llrnCustomiseNodeKernelArgs , llrnRunDataDiffusion = - \kernel apps extraApps -> do - case rnEnableP2P of - EnabledP2PMode -> - case srnDiffusionTracersExtra of - Diffusion.P2PTracers extraTracers -> do - let srnDiffusionArgumentsExtra' = - srnDiffusionArgumentsExtra - (Diffusion.P2PDecision (Diffusion.P2P.dtTracePublicRootPeersTracer extraTracers)) - (Diffusion.P2PDecision (getFetchMode kernel)) - (Diffusion.P2PDecision (lpExtraAPI (Diffusion.daLedgerPeersCtx apps))) - case srnDiffusionArgumentsExtra' of - Diffusion.P2PArguments extraArgs -> - stdRunDataDiffusion - ( srnSigUSR1SignalHandler - srnDiffusionTracersExtra - (Diffusion.P2P.daReadUseLedgerPeers extraArgs) - rnPeerSharing - rnGetUseBootstrapPeers - (GSM.gsmStateToLedgerJudgement <$> getGsmState kernel) - ) - srnDiffusionTracers - srnDiffusionTracersExtra - srnDiffusionArguments - srnDiffusionArgumentsExtra' - apps - extraApps - DisabledP2PMode -> - stdRunDataDiffusion - ( srnSigUSR1SignalHandler - (Diffusion.NonP2PTracers NonP2P.nullTracers) - (pure DontUseLedgerPeers) - rnPeerSharing - (pure DontUseBootstrapPeers) - (pure TooOld) - ) - srnDiffusionTracers - srnDiffusionTracersExtra - srnDiffusionArguments - ( srnDiffusionArgumentsExtra - (Diffusion.NonP2PDecision ()) - (Diffusion.NonP2PDecision ()) - (Diffusion.NonP2PDecision ()) - ) - apps - extraApps + \_kernel cardanoConsensusDiffusionArgs apps -> + stdRunDataDiffusion + srnDiffusionArguments + cardanoConsensusDiffusionArgs + srnDiffusionTracers + srnDiffusionConfiguration + apps , llrnVersionDataNTC = stdVersionDataNTC networkMagic , llrnVersionDataNTN = stdVersionDataNTN networkMagic - ( case rnEnableP2P of - EnabledP2PMode -> Diffusion.daMode srnDiffusionArguments - -- Every connection in non-p2p mode is unidirectional; We connect - -- from an ephemeral port. We still pass `srnDiffusionArguments` - -- to the diffusion layer, so the server side will be run also in - -- `InitiatorAndResponderDiffusionMode`. - DisabledP2PMode -> InitiatorOnlyDiffusionMode - ) + (Diffusion.dcMode srnDiffusionConfiguration) rnPeerSharing , llrnNodeToNodeVersions = limitToLatestReleasedVersion @@ -1332,7 +1048,7 @@ stdLowLevelRunNodeArgsIO , llrnMaxClockSkew = InFutureCheck.defaultClockSkew , llrnPublicPeerSelectionStateVar = - Diffusion.daPublicPeerSelectionVar srnDiffusionArguments + Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration , llrnLdbFlavorArgs = srnLdbFlavorArgs } diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs deleted file mode 100644 index bbc3bc3f57..0000000000 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Ouroboros.Consensus.Node.ErrorPolicy (consensusErrorPolicy) where - -import Control.Monad.Class.MonadAsync (ExceptionInLinkedThread (..)) -import Control.ResourceRegistry - ( RegistryClosedException - , ResourceRegistryThreadException - , TempRegistryException - ) -import Data.Proxy (Proxy) -import Data.Time.Clock (DiffTime) -import Data.Typeable (Typeable) -import Ouroboros.Consensus.Block (StandardHash) -import Ouroboros.Consensus.BlockchainTime -import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server - ( BlockFetchServerException - ) -import Ouroboros.Consensus.MiniProtocol.ChainSync.Client - ( ChainSyncClientException - ) -import Ouroboros.Consensus.Node.DbLock -import Ouroboros.Consensus.Node.DbMarker (DbMarkerError) -import Ouroboros.Consensus.Storage.ChainDB.API - ( ChainDbError (..) - , ChainDbFailure - ) -import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDBError) -import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB -import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError) -import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB -import Ouroboros.Network.ErrorPolicy -import System.FS.API.Types (FsError) - -consensusErrorPolicy :: - forall blk. - (Typeable blk, StandardHash blk) => - Proxy blk -> - ErrorPolicies -consensusErrorPolicy pb = - ErrorPolicies - { -- Exception raised during connect - -- - -- This is entirely a network-side concern. - epConErrorPolicies = [] - , -- Exception raised during interaction with the peer - -- - -- The list below should contain an entry for every type declared as an - -- instance of 'Exception' within ouroboros-consensus. - -- - -- If a particular exception is not handled by any policy, a default - -- kicks in, which currently means logging the exception and disconnecting - -- from the peer (in both directions), but allowing an immediate - -- reconnect. This is fine for exceptions that only affect that peer. - -- It is however essential that we handle exceptions here that /must/ - -- shut down the node (mainly storage layer errors). - -- - -- TODO: Talk to devops about what they should do when the node does - -- terminate with a storage layer exception (restart with full recovery). - epAppErrorPolicies = - [ -- Any exceptions in the storage layer should terminate the node - -- - -- NOTE: We do not catch IOExceptions here; they /ought/ to be caught - -- by the FS layer (and turn into FsError). If we do want to catch - -- them, we'd somehow have to distinguish between IO exceptions - -- arising from disk I/O (shutdownNode) and those arising from - -- network failures (SuspendConsumer). - ErrorPolicy $ \(_ :: DbMarkerError) -> Just shutdownNode - , ErrorPolicy $ \(_ :: DbLocked) -> Just shutdownNode - , ErrorPolicy $ \(_ :: ChainDbFailure blk) -> Just shutdownNode - , ErrorPolicy $ \(e :: VolatileDBError blk) -> - case e of - VolatileDB.ApiMisuse{} -> Just ourBug - VolatileDB.UnexpectedFailure{} -> Just shutdownNode - , ErrorPolicy $ \(e :: ImmutableDBError blk) -> - case e of - ImmutableDB.ApiMisuse{} -> Just ourBug - ImmutableDB.UnexpectedFailure{} -> Just shutdownNode - , ErrorPolicy $ \(_ :: FsError) -> Just shutdownNode - , -- When the system clock moved back, we have to restart the node. - ErrorPolicy $ \(_ :: SystemClockMovedBackException) -> Just shutdownNode - , -- Some chain DB errors are indicative of a bug in our code, others - -- indicate an invalid request from the peer. If the DB is closed - -- entirely, it will only be reopened after a node restart. - ErrorPolicy $ \(e :: ChainDbError blk) -> - case e of - ClosedDBError{} -> Just shutdownNode - ClosedFollowerError{} -> Just ourBug - InvalidIteratorRange{} -> Just theyBuggyOrEvil - , -- We have some resource registries that are used per-connection, - -- and so if we have ResourceRegistry related exception, we close - -- the connection but leave the rest of the node running. - ErrorPolicy $ \(_ :: RegistryClosedException) -> Just ourBug - , ErrorPolicy $ \(_ :: ResourceRegistryThreadException) -> Just ourBug - , ErrorPolicy $ \(_ :: TempRegistryException) -> Just ourBug - , -- An exception in the block fetch server meant the client asked - -- for some blocks we used to have but got GCed. This means the - -- peer is on a chain that forks off more than @k@ blocks away. - ErrorPolicy $ \(_ :: BlockFetchServerException) -> Just distantPeer - , -- Chain sync client exceptions indicate malicious behaviour. When we - -- have diverged too much from a client, making it no longer - -- interesting to us, we terminate with a result. - ErrorPolicy $ \(_ :: ChainSyncClientException) -> Just theyBuggyOrEvil - , -- Dispatch on nested exception - ErrorPolicy $ \(ExceptionInLinkedThread _ e) -> - evalErrorPolicies e (epAppErrorPolicies (consensusErrorPolicy pb)) - ] - } - where - -- Shutdown the node. If we have a storage layer failure, the node /must/ - -- be restarted (triggering recovery). - shutdownNode :: SuspendDecision DiffTime - shutdownNode = Throw - - -- Peer is either on a distant chain (one that forks more than k blocks ago) - -- or else is just too far behind; the chain sync client doesn't really have - -- any way of distinguishing between these two cases. If they are merely - -- far behind, we might want to reconnect to them later. - distantPeer :: SuspendDecision DiffTime - distantPeer = SuspendConsumer defaultDelay - - -- The peer sent us some data that they could have known was invalid. - -- This can only be due to a bug or malice. - theyBuggyOrEvil :: SuspendDecision DiffTime - theyBuggyOrEvil = SuspendPeer defaultDelay defaultDelay - - -- Something went wrong due to a bug in our code. We disconnect from the - -- peer, but allow to try again later in the hope the bug was transient. - -- We do not close the connection in the other direction; if the bug was - -- indeed local, it might not affect communication in the other direction. - ourBug :: SuspendDecision DiffTime - ourBug = SuspendConsumer defaultDelay - - -- Default delay - -- - -- We might want to tweak the delays for the various different kinds of - -- problems, but we'd need to establish a policy on how to set them. - defaultDelay :: DiffTime - defaultDelay = 200 -- seconds diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index a7aa8be583..b9c53da498 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -24,6 +24,7 @@ module Ouroboros.Consensus.NodeKernel , getPeersFromCurrentLedger , getPeersFromCurrentLedgerAfterSlot , initNodeKernel + , toConsensusMode ) where import Cardano.Network.ConsensusMode (ConsensusMode (..)) @@ -482,11 +483,11 @@ initInternalState peerSharingRegistry <- newPeerSharingRegistry return IS{..} - where - toConsensusMode :: forall a. LoEAndGDDConfig a -> ConsensusMode - toConsensusMode = \case - LoEAndGDDDisabled -> PraosMode - LoEAndGDDEnabled _ -> GenesisMode + +toConsensusMode :: forall a. LoEAndGDDConfig a -> ConsensusMode +toConsensusMode = \case + LoEAndGDDDisabled -> PraosMode + LoEAndGDDEnabled _ -> GenesisMode forkBlockForging :: forall m addrNTN addrNTC blk. @@ -495,12 +496,12 @@ forkBlockForging :: BlockForging m blk -> m (Thread m Void) forkBlockForging IS{..} blockForging = - forkLinkedWatcher registry threadLabel $ + forkLinkedWatcher registry label $ knownSlotWatcher btime $ \currentSlot -> withRegistry (\rr -> withEarlyExit_ $ go rr currentSlot) where - threadLabel :: String - threadLabel = + label :: String + label = "NodeKernel.blockForging." <> Text.unpack (forgeLabel blockForging) go :: ResourceRegistry m -> SlotNo -> WithEarlyExit m () @@ -899,7 +900,7 @@ getPeersFromCurrentLedger :: (IOLike m, LedgerSupportsPeerSelection blk) => NodeKernel m addrNTN addrNTC blk -> (LedgerState blk EmptyMK -> Bool) -> - STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]) + STM m (Maybe [(PoolStake, NonEmpty LedgerRelayAccessPoint)]) getPeersFromCurrentLedger kernel p = do immutableLedger <- ledgerState <$> ChainDB.getImmutableLedger (getChainDB kernel) @@ -920,7 +921,7 @@ getPeersFromCurrentLedgerAfterSlot :: ) => NodeKernel m addrNTN addrNTC blk -> SlotNo -> - STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]) + STM m (Maybe [(PoolStake, NonEmpty LedgerRelayAccessPoint)]) getPeersFromCurrentLedgerAfterSlot kernel slotNo = getPeersFromCurrentLedger kernel afterSlotNo where diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 843a3b1f8e..8a278eb630 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -12,6 +12,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -132,7 +133,7 @@ import Ouroboros.Network.PeerSelection.PeerMetric (nullMetric) import Ouroboros.Network.Point (WithOrigin (..)) import qualified Ouroboros.Network.Protocol.ChainSync.Type as CS import Ouroboros.Network.Protocol.KeepAlive.Type -import Ouroboros.Network.Protocol.Limits (waitForever) +import Ouroboros.Network.Protocol.Limits (ProtocolTimeLimitsWithRnd (..), waitForever) import Ouroboros.Network.Protocol.LocalStateQuery.Type import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharing) import Ouroboros.Network.Protocol.TxSubmission2.Type @@ -1036,7 +1037,8 @@ runThreadNetwork let rng = case seed of Seed s -> mkStdGen s (kaRng, rng') = split rng - (gsmRng, psRng) = split rng' + (gsmRng, rng'') = split rng' + (psRng, chainSyncRng) = split rng'' publicPeerSelectionStateVar <- makePublicPeerSelectionStateVar let nodeKernelArgs = NodeKernelArgs @@ -1107,18 +1109,12 @@ runThreadNetwork nodeKernel -- these tracers report every message sent/received by this -- node + chainSyncRng nullDebugProtocolTracers (customNodeToNodeCodecs pInfoConfig) NTN.noByteLimits -- see #1882, tests that can't cope with timeouts. - ( pure $ - NTN.ChainSyncTimeout - { canAwaitTimeout = waitForever - , intersectTimeout = waitForever - , mustReplyTimeout = waitForever - , idleTimeout = waitForever - } - ) + (ProtocolTimeLimitsWithRnd $ \_state -> (waitForever,)) CSClient.ChainSyncLoPBucketDisabled CSClient.CSJDisabled nullMetric diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs index 1146c7ff73..3ce9dcd237 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs @@ -26,9 +26,6 @@ import Ouroboros.Consensus.Protocol.Abstract ) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Protocol.ChainSync.Codec - ( ChainSyncTimeout (..) - ) import Ouroboros.Network.Protocol.Limits (shortWait) import qualified Test.Consensus.BlockTree as BT import Test.Consensus.PointSchedule diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/CSJ.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/CSJ.hs index 5ac1e20ac6..c7a7e31115 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/CSJ.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/CSJ.hs @@ -20,10 +20,6 @@ import Ouroboros.Consensus.Util.Condense , condenseListWithPadding ) import qualified Ouroboros.Network.AnchoredFragment as AF -import Ouroboros.Network.Protocol.ChainSync.Codec - ( ChainSyncTimeout (mustReplyTimeout) - , idleTimeout - ) import Test.Consensus.BlockTree (BlockTree (..)) import Test.Consensus.Genesis.Setup import Test.Consensus.Genesis.Tests.Uniform (genUniformSchedulePoints) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs index 548aab7fa9..c90c0ee246 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs @@ -30,9 +30,6 @@ import Ouroboros.Consensus.Block.Abstract (WithOrigin (NotOrigin)) import Ouroboros.Consensus.Util.Condense (condense) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (blockNo, blockSlot, unBlockNo) -import Ouroboros.Network.Protocol.ChainSync.Codec - ( ChainSyncTimeout (..) - ) import Ouroboros.Network.Protocol.Limits (shortWait) import Test.Consensus.BlockTree (BlockTree (..), btbSuffix) import Test.Consensus.Genesis.Setup diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs index 3af2750702..054b2be6bf 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs @@ -63,10 +63,8 @@ import Ouroboros.Network.Protocol.ChainSync.ClientPipelined , chainSyncClientPeerPipelined ) import Ouroboros.Network.Protocol.ChainSync.Codec - ( ChainSyncTimeout (..) - , byteLimitsChainSync + ( byteLimitsChainSync , codecChainSyncId - , timeLimitsChainSync ) import Ouroboros.Network.Protocol.ChainSync.PipelineDecision ( pipelineDecisionLowHighMark @@ -86,6 +84,7 @@ import Test.Consensus.PeerSimulator.Trace ( TraceChainSyncClientTerminationEvent (..) , TraceEvent (..) ) +import Test.Consensus.PointSchedule (ChainSyncTimeout (..), timeLimitsChainSync) import Test.Consensus.PointSchedule.Peers (PeerId) import Test.Util.Orphans.IOLike () diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index d3f6a76ed8..2bb1c13a97 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -58,7 +58,6 @@ import Ouroboros.Network.ControlMessage ( ControlMessage (..) , ControlMessageSTM ) -import Ouroboros.Network.Protocol.ChainSync.Codec import Ouroboros.Network.Util.ShowProxy (ShowProxy) import qualified Test.Consensus.PeerSimulator.BlockFetch as BlockFetch import qualified Test.Consensus.PeerSimulator.CSJInvariants as CSJInvariants @@ -74,6 +73,7 @@ import Test.Consensus.PeerSimulator.Trace import Test.Consensus.PointSchedule ( BlockFetchTimeout , CSJParams (..) + , ChainSyncTimeout , GenesisTest (..) , GenesisTestFull , LoPBucketParams (..) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs index c16d826849..f1d8fcb2de 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/LinkedThreads.hs @@ -14,7 +14,6 @@ import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Driver.Limits ( ProtocolLimitFailure (ExceededTimeLimit) ) -import Ouroboros.Network.Protocol.ChainSync.Codec (mustReplyTimeout) import Test.Consensus.BlockTree (BlockTree (..)) import Test.Consensus.Genesis.Setup import Test.Consensus.PeerSimulator.Run diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs index 1efb0e5418..1a8d8744fe 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs @@ -15,7 +15,6 @@ import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Driver.Limits ( ProtocolLimitFailure (ExceededTimeLimit) ) -import Ouroboros.Network.Protocol.ChainSync.Codec (mustReplyTimeout) import Test.Consensus.BlockTree (btTrunk) import Test.Consensus.Genesis.Setup import Test.Consensus.PeerSimulator.Run diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs index 98eba03fbb..55a1a72999 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -45,6 +48,8 @@ module Test.Consensus.PointSchedule , prettyPointSchedule , stToGen , uniformPoints + , ChainSyncTimeout (..) + , timeLimitsChainSync ) where import Cardano.Ledger.BaseTypes (unNonZero) @@ -63,11 +68,11 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Time (DiffTime) import Data.Word (Word64) +import Network.TypedProtocol import Ouroboros.Consensus.Block.Abstract (withOriginToMaybe) import Ouroboros.Consensus.Ledger.SupportsProtocol ( GenesisWindow (..) ) -import Ouroboros.Consensus.Network.NodeToNode (ChainSyncTimeout (..)) import Ouroboros.Consensus.Protocol.Abstract ( SecurityParam (SecurityParam) , maxRollbacks @@ -79,7 +84,9 @@ import Ouroboros.Consensus.Util.Condense ) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (SlotNo (..), blockSlot) +import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits (..)) import Ouroboros.Network.Point (withOrigin) +import Ouroboros.Network.Protocol.ChainSync.Type import System.Random.Stateful (STGenM, StatefulGen, runSTGen_) import qualified System.Random.Stateful as Random import Test.Consensus.BlockTree @@ -555,6 +562,43 @@ data BlockFetchTimeout = BlockFetchTimeout , streamingTimeout :: Maybe DiffTime } +-- | Configurable chain-sync timeouts +data ChainSyncTimeout = ChainSyncTimeout + { canAwaitTimeout :: Maybe DiffTime + , intersectTimeout :: Maybe DiffTime + , mustReplyTimeout :: Maybe DiffTime + , idleTimeout :: Maybe DiffTime + } + +-- | Time Limits +-- +-- > 'TokIdle' 'waitForever' (ie never times out) +-- > 'TokNext TokCanAwait' the given 'canAwaitTimeout' +-- > 'TokNext TokMustReply' the given 'mustReplyTimeout' +-- > 'TokIntersect' the given 'intersectTimeout' +timeLimitsChainSync :: + forall header point tip. + ChainSyncTimeout -> + ProtocolTimeLimits (ChainSync header point tip) +timeLimitsChainSync csTimeouts = ProtocolTimeLimits stateToLimit + where + ChainSyncTimeout + { canAwaitTimeout + , intersectTimeout + , mustReplyTimeout + , idleTimeout + } = csTimeouts + + stateToLimit :: + forall (st :: ChainSync header point tip). + ActiveState st => + StateToken st -> Maybe DiffTime + stateToLimit SingIdle = idleTimeout + stateToLimit (SingNext SingCanAwait) = canAwaitTimeout + stateToLimit (SingNext SingMustReply) = mustReplyTimeout + stateToLimit SingIntersect = intersectTimeout + stateToLimit a@SingDone = notActiveState a + -- | All the data used by point schedule tests. data GenesisTest blk schedule = GenesisTest { gtSecurityParam :: SecurityParam @@ -654,20 +698,22 @@ ensureScheduleDuration gt PointSchedule{psSchedule, psStartOrder, psMinEndTime} } where endingDelay = - let cst = gtChainSyncTimeouts gt - bft = gtBlockFetchTimeouts gt - bfGracePeriodDelay = fromIntegral adversaryCount * 10 - in 1 - + bfGracePeriodDelay - + fromIntegral peerCount - * maximum - ( 0 - : catMaybes - [ canAwaitTimeout cst - , intersectTimeout cst - , busyTimeout bft - , streamingTimeout bft - ] - ) + let + -- cst = gtChainSyncTimeouts gt + bft = gtBlockFetchTimeouts gt + bfGracePeriodDelay = fromIntegral adversaryCount * 10 + in + 1 + + bfGracePeriodDelay + + fromIntegral peerCount + * maximum + ( 0 + : catMaybes + -- [ canAwaitTimeout cst + -- , intersectTimeout cst + [ busyTimeout bft + , streamingTimeout bft + ] + ) peerCount = length (peersList psSchedule) adversaryCount = Map.size (adversarialPeers psSchedule) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 0cada6966c..64c86c5f40 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -316,18 +316,18 @@ library diff-containers >=1.2, filelock, fingertree-rm >=1.0, - fs-api ^>=0.3, + fs-api ^>=0.4, hashable, - io-classes ^>=1.5, + io-classes:{io-classes, si-timers, strict-mvar, strict-stm} ^>=1.8.0.1, measures, mempack, monoid-subclasses, mtl, multiset ^>=0.3, nothunks ^>=0.2, - ouroboros-network-api ^>=0.14, + ouroboros-network-api ^>=0.15, ouroboros-network-mock ^>=0.1, - ouroboros-network-protocols ^>=0.14, + ouroboros-network-protocols ^>=0.15, primitive, psqueues ^>=0.2.3, quiet ^>=0.2, @@ -335,7 +335,6 @@ library resource-registry ^>=0.1, semialign >=1.1, serialise ^>=0.2, - si-timers ^>=1.5, singletons, small-steps ^>=1.1, sop-core ^>=0.5, @@ -343,15 +342,13 @@ library streaming, strict >=0.1 && <0.6, strict-checked-vars ^>=0.2, - strict-mvar ^>=1.5, strict-sop-core ^>=0.1, - strict-stm ^>=1.5, text, these ^>=1.2, time, transformers, transformers-base, - typed-protocols ^>=0.3, + typed-protocols ^>=1.0, vector ^>=0.13, x-docspec-extra-packages: @@ -445,10 +442,10 @@ library unstable-consensus-testlib directory, file-embed, filepath, - fs-api ^>=0.3, - fs-sim ^>=0.3, + fs-api ^>=0.4, + fs-sim ^>=0.4, generics-sop, - io-classes, + io-classes:{io-classes, si-timers, strict-mvar, strict-stm}, io-sim, mempack, mtl, @@ -464,12 +461,9 @@ library unstable-consensus-testlib random, resource-registry, serialise, - si-timers, sop-core, sop-extras, - strict-mvar, strict-sop-core, - strict-stm, tasty, tasty-golden, tasty-hunit, @@ -542,8 +536,8 @@ library unstable-mempool-test-utils base, contra-tracer, deepseq, + io-classes:strict-stm, ouroboros-consensus, - strict-stm, library unstable-tutorials import: common-lib @@ -607,10 +601,10 @@ test-suite consensus-test deepseq, diff-containers, fingertree-rm, - fs-api ^>=0.3, + fs-api ^>=0.4, fs-sim, hashable, - io-classes, + io-classes:{io-classes, si-timers, strict-mvar, strict-stm}, io-sim, measures, mtl, @@ -628,12 +622,9 @@ test-suite consensus-test random, resource-registry, serialise, - si-timers, sop-core, sop-extras, - strict-mvar, strict-sop-core, - strict-stm, tasty, tasty-hunit, tasty-quickcheck, @@ -641,9 +632,7 @@ test-suite consensus-test transformers, transformers-base, tree-diff, - typed-protocols ^>=0.3, - typed-protocols-examples, - typed-protocols-stateful, + typed-protocols:{examples, stateful, typed-protocols} ^>=1, unstable-consensus-testlib, unstable-mock-block, @@ -739,11 +728,11 @@ test-suite storage-test diff-containers, directory, filepath, - fs-api ^>=0.3, - fs-sim ^>=0.3, + fs-api ^>=0.4, + fs-sim ^>=0.4, generics-sop, hashable, - io-classes, + io-classes:{io-classes, strict-mvar, strict-stm}, io-sim, mempack, mtl, @@ -759,8 +748,6 @@ test-suite storage-test resource-registry, serialise, sop-core, - strict-mvar, - strict-stm, tasty, tasty-hunit, tasty-quickcheck, @@ -824,7 +811,7 @@ benchmark ChainSync-client-bench ouroboros-network-protocols, resource-registry, time, - typed-protocols-examples, + typed-protocols:examples, unstable-consensus-testlib, with-utf8, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs index 8edb3edd83..68483ded16 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsPeerSelection.hs @@ -5,10 +5,9 @@ module Ouroboros.Consensus.Ledger.SupportsPeerSelection , stakePoolRelayAccessPoint -- * Re-exports for convenience - , DomainAccessPoint (..) , IP (..) , PortNumber - , RelayAccessPoint (..) + , LedgerRelayAccessPoint (..) ) where import Control.DeepSeq (NFData (..)) @@ -18,25 +17,24 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type ( PoolStake (..) ) import Ouroboros.Network.PeerSelection.RelayAccessPoint - ( DomainAccessPoint (..) - , IP (..) + ( IP (..) + , LedgerRelayAccessPoint (..) , PortNumber - , RelayAccessPoint (..) ) -- | A relay registered for a stake pool data StakePoolRelay = -- | One of the current relays - CurrentRelay RelayAccessPoint + CurrentRelay LedgerRelayAccessPoint | -- | One of the future relays - FutureRelay RelayAccessPoint + FutureRelay LedgerRelayAccessPoint deriving (Show, Eq) instance NFData StakePoolRelay where rnf (CurrentRelay ra) = rnf ra rnf (FutureRelay ra) = rnf ra -stakePoolRelayAccessPoint :: StakePoolRelay -> RelayAccessPoint +stakePoolRelayAccessPoint :: StakePoolRelay -> LedgerRelayAccessPoint stakePoolRelayAccessPoint (CurrentRelay ra) = ra stakePoolRelayAccessPoint (FutureRelay ra) = ra diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs index 0235a8be6a..0c1308a55e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs @@ -804,6 +804,7 @@ openPrimaryIndex cacheEnv chunk allowExisting = do flip onException (hClose pHnd) $ do newCurrentChunkInfo <- case allowExisting of MustBeNew -> return $ emptyCurrentChunkInfo chunk + MustExist -> loadCurrentChunkInfo hasFS chunkInfo chunk AllowExisting -> loadCurrentChunkInfo hasFS chunkInfo chunk mbEvicted <- modifyMVar cacheVar $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs index 79ef405aa0..a4755b5aec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Primary.hs @@ -424,6 +424,13 @@ open hasFS@HasFS{hOpen, hClose} chunk allowExisting = do flip onException (hClose pHnd) $ do case allowExisting of AllowExisting -> return () + MustExist -> + -- create the file if it doesn't exist + void $ + hPut hasFS pHnd $ + Put.execPut $ + Put.putWord8 currentVersionNumber + <> putSecondaryOffset 0 -- If the file is new, write the version number and the first offset, -- i.e. 0. MustBeNew -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs index d6d1a80998..4eba0f7c8a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs @@ -265,11 +265,16 @@ instance MonadMask m => MonadMask (WithEarlyExit m) where unmask' = earlyExit . unmask . withEarlyExit in withEarlyExit (f unmask') + getMaskingState = lift getMaskingState + + interruptible f = earlyExit $ interruptible $ withEarlyExit f + instance MonadThread m => MonadThread (WithEarlyExit m) where type ThreadId (WithEarlyExit m) = ThreadId m myThreadId = lift myThreadId labelThread = lift .: labelThread + threadLabel = lift . threadLabel instance (MonadMask m, MonadAsync m, MonadCatch (STM m)) => @@ -318,6 +323,8 @@ instance MonadFork m => MonadFork (WithEarlyExit m) where throwTo = lift .: throwTo yield = lift yield + getNumCapabilities = lift getNumCapabilities + instance PrimMonad m => PrimMonad (WithEarlyExit m) where type PrimState (WithEarlyExit m) = PrimState m primitive = lift . primitive @@ -365,8 +372,8 @@ instance MonadLabelledSTM m => MonadLabelledSTM (WithEarlyExit m) where instance MonadSay m => MonadSay (WithEarlyExit m) where say = lift . say -instance (MonadInspectSTM m, Monad (InspectMonad m)) => MonadInspectSTM (WithEarlyExit m) where - type InspectMonad (WithEarlyExit m) = InspectMonad m +instance (MonadInspectSTM m, Monad (InspectMonadSTM m)) => MonadInspectSTM (WithEarlyExit m) where + type InspectMonadSTM (WithEarlyExit m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs index e0ad053148..d9e7d40258 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs @@ -132,15 +132,15 @@ mkOracularClock BTime.SystemTime{..} numSlots future = , getCurrentSlot = do (slot, _leftInSlot, _slotLength) <- getPresent pure slot - , forkEachSlot_ = \rr threadLabel action -> + , forkEachSlot_ = \rr label action -> fmap cancelThread $ - forkLinkedThread rr threadLabel $ + forkLinkedThread rr label $ fix $ \loop -> do -- INVARIANT the slot returned here ascends monotonically unless -- the underlying 'BTime.SystemTime' jumps backwards (slot, leftInSlot, _slotLength) <- getPresent - let lbl = threadLabel <> " [" <> show slot <> "]" + let lbl = label <> " [" <> show slot <> "]" -- fork the action, so it can't threadDelay us void $ forkLinkedThread rr lbl $ action slot diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs index 4fb64eab9f..f129474087 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs @@ -108,11 +108,11 @@ onTick :: Tick -> m () -> m () -onTick registry clock threadLabel tick action = do +onTick registry clock label tick action = do void $ forkLinkedThread registry - threadLabel + label (waitForTick clock tick >> action) -- | Block until the specified tick diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs index f5c72cb409..bbc24a81b5 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs @@ -578,7 +578,7 @@ instance MonadLabelledSTM m => MonadLabelledSTM (OverrideDelay m) where labelTBQueueIO v = OverrideDelay . lift . LazySTM.labelTBQueueIO v instance MonadInspectSTM m => MonadInspectSTM (OverrideDelay m) where - type InspectMonad (OverrideDelay m) = InspectMonad m + type InspectMonadSTM (OverrideDelay m) = InspectMonadSTM m inspectTVar _ = inspectTVar (Proxy :: Proxy m) inspectTMVar _ = inspectTMVar (Proxy :: Proxy m) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs index 33dfd05954..9321065a38 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs @@ -18,7 +18,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -#if __GLASGOW_HASKELL__ >= 910 +#if __GLASGOW_HASKELL__ >= 908 {-# OPTIONS_GHC -Wno-x-partial #-} #endif From 41232ead2299d022bd7b0f38a83f04ba598b80d6 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 12 Jun 2025 15:27:56 +0200 Subject: [PATCH 3/4] SRV support --- .../Consensus/Shelley/Ledger/PeerSelection.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs index 2ce71d90b3..fae846a943 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -70,12 +70,17 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto (SJust ipv6) ) = Just $ LedgerRelayAccessAddress (IPv6 ipv6) (fromIntegral port) + -- no IP address or no port number + relayToLedgerRelayAccessPoint (SL.SingleHostAddr SNothing _ _) = Nothing + relayToLedgerRelayAccessPoint (SL.SingleHostAddr _ SNothing _) = Nothing relayToLedgerRelayAccessPoint (SL.SingleHostName (SJust (Port port)) dnsName) = Just $ LedgerRelayAccessDomain (encodeUtf8 $ dnsToText dnsName) (fromIntegral port) - relayToLedgerRelayAccessPoint _ = - -- This could be an unsupported relay (SRV records) or an unusable - -- relay such as a relay with an IP address but without a port number. - Nothing + -- srv support: either `SingleHostName` without port number or + -- `MultiHostName` + relayToLedgerRelayAccessPoint (SL.SingleHostName SNothing dnsName) = + Just $ LedgerRelayAccessSRVDomain (encodeUtf8 $ dnsToText dnsName) + relayToLedgerRelayAccessPoint (SL.MultiHostName dnsName) = + Just $ LedgerRelayAccessSRVDomain (encodeUtf8 $ dnsToText dnsName) -- \| Note that a stake pool can have multiple registered relays pparamsLedgerRelayAccessPoints :: From d24a4aad3fb7ab3bb981635f78c62d9977330ff8 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 16 Jun 2025 12:12:52 +0200 Subject: [PATCH 4/4] Updated golden files for GetBigledgerPeerSnapshot --- .../Result_GetBigLedgerPeerSnapshot | 4 ++-- .../Result_GetBigLedgerPeerSnapshot | 4 ++-- .../Result_GetBigLedgerPeerSnapshot | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/ouroboros-consensus-cardano/golden/shelley/QueryVersion2/ShelleyNodeToClientVersion11/Result_GetBigLedgerPeerSnapshot b/ouroboros-consensus-cardano/golden/shelley/QueryVersion2/ShelleyNodeToClientVersion11/Result_GetBigLedgerPeerSnapshot index 9fdbcecb87..e7f9cd456b 100644 --- a/ouroboros-consensus-cardano/golden/shelley/QueryVersion2/ShelleyNodeToClientVersion11/Result_GetBigLedgerPeerSnapshot +++ b/ouroboros-consensus-cardano/golden/shelley/QueryVersion2/ShelleyNodeToClientVersion11/Result_GetBigLedgerPeerSnapshot @@ -1,3 +1,3 @@ -‚‚‚*Ÿ‚‚ +‚‚‚*Ÿ‚‚ ‚‚ -ŸƒÒŸÿÿÿ \ No newline at end of file +ŸƒŸÿÒÿÿ \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion12/Result_GetBigLedgerPeerSnapshot b/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion12/Result_GetBigLedgerPeerSnapshot index 9fdbcecb87..e7f9cd456b 100644 --- a/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion12/Result_GetBigLedgerPeerSnapshot +++ b/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion12/Result_GetBigLedgerPeerSnapshot @@ -1,3 +1,3 @@ -‚‚‚*Ÿ‚‚ +‚‚‚*Ÿ‚‚ ‚‚ -ŸƒÒŸÿÿÿ \ No newline at end of file +ŸƒŸÿÒÿÿ \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion13/Result_GetBigLedgerPeerSnapshot b/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion13/Result_GetBigLedgerPeerSnapshot index 9fdbcecb87..e7f9cd456b 100644 --- a/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion13/Result_GetBigLedgerPeerSnapshot +++ b/ouroboros-consensus-cardano/golden/shelley/QueryVersion3/ShelleyNodeToClientVersion13/Result_GetBigLedgerPeerSnapshot @@ -1,3 +1,3 @@ -‚‚‚*Ÿ‚‚ +‚‚‚*Ÿ‚‚ ‚‚ -ŸƒÒŸÿÿÿ \ No newline at end of file +ŸƒŸÿÒÿÿ \ No newline at end of file