diff --git a/cabal.project b/cabal.project index a62572ae97..be4d540df6 100644 --- a/cabal.project +++ b/cabal.project @@ -14,9 +14,9 @@ repository cardano-haskell-packages -- update either of these. index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2024-08-27T14:57:57Z + , hackage.haskell.org 2024-09-16T12:20:25Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2024-10-11T13:55:09Z + , cardano-haskell-packages 2024-10-21T06:28:35Z packages: ouroboros-consensus diff --git a/flake.lock b/flake.lock index 88ea71aece..b95df39180 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1728663083, - "narHash": "sha256-ejmJzPYPKdIwN53Arz3ycNcMO1YnS4k4uSBC7XeBRsQ=", + "lastModified": 1729492933, + "narHash": "sha256-XuwElZKFRhXXuJtT7KUZcCb5QCr0cFQ60ukhPgX8N50=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "16d7391e69a69b9954acf097ffca3bda61a4faf0", + "rev": "a36ff9eec592a38e9a23521079dbe41684ff9b51", "type": "github" }, "original": { @@ -237,11 +237,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1725237437, - "narHash": "sha256-I0u6xOAf/KzbR/92iXtb3+G8CWSDg8VOEYW42MyZZR4=", + "lastModified": 1726636349, + "narHash": "sha256-Fh+GjlpDnWtUpc02zvjULcgHZQEHuHrfKviweM7U6UY=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "77bd0734b3506f33f6a066f2aaac38434f803018", + "rev": "1d222a41735184d1fb52fa6959516cb9bf7ea319", "type": "github" }, "original": { diff --git a/ouroboros-consensus-cardano/changelog.d/20241021_094824_coot_typed_protocols_new_api.md b/ouroboros-consensus-cardano/changelog.d/20241021_094824_coot_typed_protocols_new_api.md new file mode 100644 index 0000000000..8dd7a26b29 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20241021_094824_coot_typed_protocols_new_api.md @@ -0,0 +1,4 @@ +### Non-Breaking + +- Updated to `ouroboros-network-0.14`, and `typed-protocols-0.3.0.0` as a consequence. +- Updated to `ouroboros-network-api-0.11`, which introduced `NodeToClientV_19`. diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 7dfce765e0..8aa5bbd4e3 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -159,7 +159,7 @@ library nothunks, ouroboros-consensus ^>=0.21, ouroboros-consensus-protocol ^>=0.9, - ouroboros-network-api ^>=0.10, + ouroboros-network-api ^>=0.11, serialise ^>=0.2, small-steps, sop-core ^>=0.5, @@ -463,7 +463,7 @@ test-suite cardano-test tasty, tasty-hunit, tasty-quickcheck, - typed-protocols ^>=0.1.1, + typed-protocols ^>=0.3, unstable-byron-testlib, unstable-cardano-testlib, unstable-shelley-testlib, @@ -555,7 +555,7 @@ library unstable-cardano-tools ouroboros-consensus-protocol ^>=0.9, ouroboros-network, ouroboros-network-api, - ouroboros-network-framework ^>=0.13.2, + ouroboros-network-framework ^>=0.14, ouroboros-network-protocols, serialise ^>=0.2, 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 8124973887..7b03cef237 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 @@ -512,9 +512,10 @@ instance CardanoHardForkConstraints c , (NodeToClientV_16, CardanoNodeToClientVersion12) , (NodeToClientV_17, CardanoNodeToClientVersion13) , (NodeToClientV_18, CardanoNodeToClientVersion14) + , (NodeToClientV_19, CardanoNodeToClientVersion14) ] - latestReleasedNodeVersion _prx = (Just NodeToNodeV_14, Just NodeToClientV_18) + latestReleasedNodeVersion _prx = (Just NodeToNodeV_14, Just NodeToClientV_19) {------------------------------------------------------------------------------- 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 e478d4c877..e7e5b332ef 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 @@ -66,6 +66,7 @@ instance SupportedNetworkProtocolVersion (ShelleyBlock proto era) where , (NodeToClientV_16, ShelleyNodeToClientVersion8) , (NodeToClientV_17, ShelleyNodeToClientVersion9) , (NodeToClientV_18, ShelleyNodeToClientVersion10) + , (NodeToClientV_19, ShelleyNodeToClientVersion10) ] latestReleasedNodeVersion = latestReleasedNodeVersionDefault diff --git a/ouroboros-consensus-diffusion/changelog.d/20241021_094154_coot_typed_protocols_new_api.md b/ouroboros-consensus-diffusion/changelog.d/20241021_094154_coot_typed_protocols_new_api.md new file mode 100644 index 0000000000..8a1d194861 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20241021_094154_coot_typed_protocols_new_api.md @@ -0,0 +1,4 @@ +### Breaking + +- Updated to `typed-protocols-0.3.0.0` +- Added `KeepAlive` tracer to `Tracers'` data type. diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index c4cc4af077..623e5b86a8 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -90,10 +90,10 @@ library io-classes ^>=1.5, mtl, ouroboros-consensus ^>=0.21, - ouroboros-network ^>=0.17.1, - ouroboros-network-api ^>=0.10, - ouroboros-network-framework ^>=0.13.2, - ouroboros-network-protocols ^>=0.11, + ouroboros-network ^>=0.18, + ouroboros-network-api ^>=0.11, + ouroboros-network-framework ^>=0.14, + ouroboros-network-protocols ^>=0.12, random, safe-wild-cards ^>=1.0, serialise ^>=0.2, @@ -103,6 +103,7 @@ library time, transformers, typed-protocols, + typed-protocols-stateful, -- GHC 8.10.7 on aarch64-darwin cannot use text-2 build-depends: text >=1.2.5.0 && <2.2 diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs index 5e7bac2757..0d7b9fb83c 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -40,6 +42,7 @@ import Control.Tracer import Data.ByteString.Lazy (ByteString) import Data.Void (Void) import Network.TypedProtocol.Codec +import qualified Network.TypedProtocol.Stateful.Codec as Stateful import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query @@ -66,6 +69,7 @@ import Ouroboros.Network.BlockFetch import Ouroboros.Network.Channel import Ouroboros.Network.Context import Ouroboros.Network.Driver +import qualified Ouroboros.Network.Driver.Stateful as Stateful import Ouroboros.Network.Mux import Ouroboros.Network.NodeToClient hiding (NodeToClientVersion (..)) @@ -75,7 +79,7 @@ import Ouroboros.Network.Protocol.ChainSync.Server import Ouroboros.Network.Protocol.ChainSync.Type import Ouroboros.Network.Protocol.LocalStateQuery.Codec import Ouroboros.Network.Protocol.LocalStateQuery.Server -import Ouroboros.Network.Protocol.LocalStateQuery.Type +import Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery import Ouroboros.Network.Protocol.LocalTxMonitor.Codec import Ouroboros.Network.Protocol.LocalTxMonitor.Server import Ouroboros.Network.Protocol.LocalTxMonitor.Type @@ -144,7 +148,7 @@ mkHandlers NodeKernelArgs {cfg, tracers} NodeKernel {getChainDB, getMempool} = data Codecs' blk serialisedBlk e m bCS bTX bSQ bTM = Codecs { cChainSyncCodec :: Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS , cTxSubmissionCodec :: Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX - , cStateQueryCodec :: Codec (LocalStateQuery blk (Point blk) (Query blk)) e m bSQ + , cStateQueryCodec :: Stateful.Codec (LocalStateQuery blk (Point blk) (Query blk)) e LocalStateQuery.State m bSQ , cTxMonitorCodec :: Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM } @@ -293,7 +297,7 @@ identityCodecs :: (Monad m, BlockSupportsLedgerQuery blk) => Codecs blk CodecFailure m (AnyMessage (ChainSync (Serialised blk) (Point blk) (Tip blk))) (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))) - (AnyMessage (LocalStateQuery blk (Point blk) (Query blk))) + (Stateful.AnyMessage (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State) (AnyMessage (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo)) identityCodecs = Codecs { cChainSyncCodec = codecChainSyncId @@ -313,7 +317,7 @@ type Tracers m peer blk e = data Tracers' peer blk e f = Tracers { tChainSyncTracer :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Serialised blk) (Point blk) (Tip blk)))) , tTxSubmissionTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))) - , tStateQueryTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)))) + , tStateQueryTracer :: f (TraceLabelPeer peer (Stateful.TraceSendRecv (LocalStateQuery blk (Point blk) (Query blk)) LocalStateQuery.State)) , tTxMonitorTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo))) } @@ -433,10 +437,11 @@ mkApps kernel Tracers {..} Codecs {..} Handlers {..} = -> m ((), Maybe bSQ) aStateQueryServer them channel = do labelThisThread "LocalStateQueryServer" - runPeer + Stateful.runPeer (contramap (TraceLabelPeer them) tStateQueryTracer) cStateQueryCodec channel + LocalStateQuery.StateIdle (localStateQueryServerPeer hStateQueryServer) aTxMonitorServer 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 6b21bd87f2..400827d7ab 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 @@ -245,14 +245,14 @@ mkHandlers , hTxSubmissionClient = \version controlMessageSTM peer -> txSubmissionOutbound (contramap (TraceLabelPeer peer) (Node.txOutboundTracer tracers)) - (NumTxIdsToAck $ txSubmissionMaxUnacked miniProtocolParameters) + (txSubmissionMaxUnacked miniProtocolParameters) (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) version controlMessageSTM , hTxSubmissionServer = \version peer -> txSubmissionInbound (contramap (TraceLabelPeer peer) (Node.txInboundTracer tracers)) - (NumTxIdsToAck $ txSubmissionMaxUnacked miniProtocolParameters) + (txSubmissionMaxUnacked miniProtocolParameters) (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version @@ -377,6 +377,7 @@ data Tracers' peer blk e f = Tracers { , tBlockFetchTracer :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk (Point blk)))) , tBlockFetchSerialisedTracer :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))) , tTxSubmission2Tracer :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk)))) + , tKeepAliveTracer :: f (TraceLabelPeer peer (TraceSendRecv KeepAlive)) } instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer blk e f) where @@ -386,6 +387,7 @@ instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer blk e f) where , tBlockFetchTracer = f tBlockFetchTracer , tBlockFetchSerialisedTracer = f tBlockFetchSerialisedTracer , tTxSubmission2Tracer = f tTxSubmission2Tracer + , tKeepAliveTracer = f tKeepAliveTracer } where f :: forall a. Semigroup a @@ -401,6 +403,7 @@ nullTracers = Tracers { , tBlockFetchTracer = nullTracer , tBlockFetchSerialisedTracer = nullTracer , tTxSubmission2Tracer = nullTracer + , tKeepAliveTracer = nullTracer } showTracers :: ( Show blk @@ -418,6 +421,7 @@ showTracers tr = Tracers { , tBlockFetchTracer = showTracing tr , tBlockFetchSerialisedTracer = showTracing tr , tTxSubmission2Tracer = showTracing tr + , tKeepAliveTracer = showTracing tr } {------------------------------------------------------------------------------- @@ -721,7 +725,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke labelThisThread "KeepAliveClient" let kacApp = \dqCtx -> runPeerWithLimits - nullTracer + (TraceLabelPeer them `contramap` tKeepAliveTracer) (cKeepAliveCodec (mkCodecs version)) blKeepAlive timeLimitsKeepAlive @@ -738,10 +742,10 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke -> ResponderContext addrNTN -> Channel m bKA -> m ((), Maybe bKA) - aKeepAliveServer version _responderCtx channel = do + aKeepAliveServer version ResponderContext { rcConnectionId = them } channel = do labelThisThread "KeepAliveServer" runPeerWithLimits - nullTracer + (TraceLabelPeer them `contramap` tKeepAliveTracer) (cKeepAliveCodec (mkCodecs version)) (byteLimitsKeepAlive (const 0)) -- TODO: Real Bytelimits, see #1727 timeLimitsKeepAlive @@ -765,6 +769,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke $ \controller -> do psClient <- hPeerSharingClient version controlMessageSTM them controller ((), trailing) <- runPeerWithLimits + -- TODO: add tracer nullTracer (cPeerSharingCodec (mkCodecs version)) (byteLimitsPeerSharing (const 0)) @@ -781,6 +786,7 @@ mkApps kernel Tracers {..} mkCodecs ByteLimits {..} genChainSyncTimeout lopBucke aPeerSharingServer version ResponderContext { rcConnectionId = them } channel = do labelThisThread "PeerSharingServer" runPeerWithLimits + -- TODO: add tracer nullTracer (cPeerSharingCodec (mkCodecs version)) (byteLimitsPeerSharing (const 0)) 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 c5eb199ecd..22d63fc9ff 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 @@ -1387,8 +1387,11 @@ directedEdgeInner registry clock (version, blockVersion) (cfg, calcMessageDelay) -- first step in process of one node diffusing a block to another node. chainSyncMiddle :: Lazy.ByteString -> m () chainSyncMiddle bs = do - let tok = Codec.ServerAgency $ CS.TokNext CS.TokMustReply - decodeStep <- Codec.decode codec tok + let tok = CS.SingNext CS.SingMustReply + decodeStep :: Codec.DecodeStep + Lazy.ByteString DeserialiseFailure m + (Codec.SomeMessage ('CS.StNext 'CS.StMustReply)) + <- Codec.decode codec tok Codec.runDecoder [bs] decodeStep >>= \case Right (Codec.SomeMessage (CS.MsgRollForward hdr _tip)) -> do s <- OracularClock.getCurrentSlot clock diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index 291084b8e6..6f320285d9 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -24,8 +24,8 @@ import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Tracer (Tracer, nullTracer, traceWith) import Data.Functor.Contravariant ((>$<)) import Data.Map.Strict (Map) -import Network.TypedProtocol.Codec (AnyMessage, PeerHasAgency (..), - PeerRole) +import Network.TypedProtocol.Codec (ActiveState, AnyMessage, + StateToken, notActiveState) import Ouroboros.Consensus.Block (HasHeader) import Ouroboros.Consensus.Block.Abstract (Header, Point (..)) import Ouroboros.Consensus.Config @@ -55,7 +55,7 @@ import Ouroboros.Network.Protocol.BlockFetch.Codec import Ouroboros.Network.Protocol.BlockFetch.Server (BlockFetchServer (..), blockFetchServerPeer) import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch (..), - ClientHasAgency (..), ServerHasAgency (..)) + SingBlockFetch (..)) import Ouroboros.Network.Protocol.Limits (ProtocolSizeLimits (..), ProtocolTimeLimits (..), waitForever) import Test.Consensus.PeerSimulator.StateView @@ -190,11 +190,12 @@ timeLimitsBlockFetch :: forall block point. BlockFetchTimeout -> ProtocolTimeLim timeLimitsBlockFetch BlockFetchTimeout{busyTimeout, streamingTimeout} = ProtocolTimeLimits stateToLimit where - stateToLimit :: forall (pr :: PeerRole) (st :: BlockFetch block point). - PeerHasAgency pr st -> Maybe DiffTime - stateToLimit (ClientAgency TokIdle) = waitForever - stateToLimit (ServerAgency TokBusy) = busyTimeout - stateToLimit (ServerAgency TokStreaming) = streamingTimeout + stateToLimit :: forall (st :: BlockFetch block point). + ActiveState st => StateToken st-> Maybe DiffTime + stateToLimit SingBFIdle = waitForever + stateToLimit SingBFBusy = busyTimeout + stateToLimit SingBFStreaming = streamingTimeout + stateToLimit a@SingBFDone = notActiveState a blockFetchNoTimeouts :: BlockFetchTimeout blockFetchNoTimeouts = diff --git a/ouroboros-consensus/changelog.d/20241021_094516_coot_typed_protocols_new_api.md b/ouroboros-consensus/changelog.d/20241021_094516_coot_typed_protocols_new_api.md new file mode 100644 index 0000000000..bf8f9bd34b --- /dev/null +++ b/ouroboros-consensus/changelog.d/20241021_094516_coot_typed_protocols_new_api.md @@ -0,0 +1,6 @@ +### Breaking + +- Updated to `typed-protocols-0.3.0.0`. +- The `ChainSync` client now requires `MoandLabelledSTM` constraint. +- `NodeToClientV_19` was added in `ouroboros-network-api-0.11`. + diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index ddafe8f16c..a782f3e6ff 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -296,9 +296,9 @@ library measures, mtl, nothunks ^>=0.2, - ouroboros-network-api ^>=0.10, + ouroboros-network-api ^>=0.11, ouroboros-network-mock ^>=0.1, - ouroboros-network-protocols ^>=0.11, + ouroboros-network-protocols ^>=0.12, primitive, psqueues ^>=0.2.3, quiet ^>=0.2, @@ -316,7 +316,7 @@ library these ^>=1.2, time, transformers, - typed-protocols ^>=0.1.1, + typed-protocols ^>=0.3, vector ^>=0.13, -- GHC 8.10.7 on aarch64-darwin cannot use text-2 @@ -575,8 +575,9 @@ test-suite consensus-test tasty-quickcheck, time, tree-diff, - typed-protocols ^>=0.1.1, + typed-protocols ^>=0.3, typed-protocols-examples, + typed-protocols-stateful, unstable-consensus-testlib, unstable-mock-block, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query/Version.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query/Version.hs index 9c14b9bf0d..204c8e5ded 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query/Version.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Query/Version.hs @@ -30,3 +30,4 @@ nodeToClientVersionToQueryVersion x = case x of NodeToClientV_16 -> QueryVersion2 NodeToClientV_17 -> QueryVersion2 NodeToClientV_18 -> QueryVersion2 + NodeToClientV_19 -> QueryVersion2 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index 019ee52736..239c049d02 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -88,7 +88,7 @@ import Data.Typeable import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) -import Network.TypedProtocol.Pipelined +import Network.TypedProtocol.Core import NoThunks.Class (unsafeNoThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (RelativeTime) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs index c7b2a4b1b6..f5567139e5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs @@ -68,6 +68,8 @@ import Ouroboros.Consensus.Util.Orphans () -------------------------------------------------------------------------------} class ( MonadAsync m + , MonadLabelledSTM m + , MonadTraceSTM m , MonadMVar m , MonadEventlog m , MonadFork m 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 a52b7b980e..e82537b586 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs @@ -525,6 +525,32 @@ instance MonadSTM m => MonadSTM (OverrideDelay m) where unGetTChan v = OverrideDelaySTM . lift . LazySTM.unGetTChan v isEmptyTChan = OverrideDelaySTM . lift . LazySTM.isEmptyTChan +instance MonadLabelledSTM m => MonadLabelledSTM (OverrideDelay m) where + labelTVar v = OverrideDelaySTM . lift . LazySTM.labelTVar v + labelTMVar v = OverrideDelaySTM . lift . LazySTM.labelTMVar v + labelTQueue v = OverrideDelaySTM . lift . LazySTM.labelTQueue v + labelTBQueue v = OverrideDelaySTM . lift . LazySTM.labelTBQueue v + labelTArray v = OverrideDelaySTM . lift . LazySTM.labelTArray v + labelTSem v = OverrideDelaySTM . lift . LazySTM.labelTSem v + labelTChan v = OverrideDelaySTM . lift . LazySTM.labelTChan v + + labelTVarIO v = OverrideDelay . lift . LazySTM.labelTVarIO v + labelTMVarIO v = OverrideDelay . lift . LazySTM.labelTMVarIO v + labelTQueueIO v = OverrideDelay . lift . LazySTM.labelTQueueIO v + labelTBQueueIO v = OverrideDelay . lift . LazySTM.labelTBQueueIO v + +instance MonadInspectSTM m => MonadInspectSTM (OverrideDelay m) where + type InspectMonad (OverrideDelay m) = InspectMonad m + inspectTVar _ = inspectTVar (Proxy :: Proxy m) + inspectTMVar _ = inspectTMVar (Proxy :: Proxy m) + +instance MonadTraceSTM m => MonadTraceSTM (OverrideDelay m) where + traceTVar _ v = OverrideDelaySTM . lift . LazySTM.traceTVar Proxy v + traceTMVar _ v = OverrideDelaySTM . lift . LazySTM.traceTMVar Proxy v + traceTQueue _ v = OverrideDelaySTM . lift . LazySTM.traceTQueue Proxy v + traceTBQueue _ v = OverrideDelaySTM . lift . LazySTM.traceTBQueue Proxy v + traceTSem _ v = OverrideDelaySTM . lift . LazySTM.traceTSem Proxy v + newtype OverrideDelayAsync m a = OverrideDelayAsync { unOverrideDelayAsync :: Async m a } diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs index c9c4da126c..6ec692e4d0 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs @@ -522,7 +522,7 @@ runChainSync skew securityParam (ClientUpdates clientUpdates) atomically $ do handles <- readTVar varHandles modifyTVar varFinalCandidates $ Map.insert serverId (handles Map.! serverId) - result <- + (result, _) <- runPipelinedPeer protocolTracer codecChainSyncId clientChannel $ chainSyncClientPeerPipelined $ client csState atomically $ writeTVar varClientResult (Just (ClientFinished result)) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index 87fc853e7f..5310647fd7 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -24,7 +24,7 @@ import Control.Monad.IOSim (runSimOrThrow) import Control.Tracer (nullTracer) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Network.TypedProtocol.Proofs (connect) +import Network.TypedProtocol.Stateful.Proofs (connect) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config @@ -51,7 +51,7 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Examples (localStateQueryClient) import Ouroboros.Network.Protocol.LocalStateQuery.Server import Ouroboros.Network.Protocol.LocalStateQuery.Type - (AcquireFailure (..), Target (..)) + (AcquireFailure (..), State (..), Target (..)) import System.FS.API (HasFS, SomeHasFS (..)) import Test.QuickCheck hiding (Result) import Test.Tasty @@ -101,6 +101,7 @@ prop_localStateQueryServer k bt p (Positive (Small n)) = checkOutcome k chain ac server <- mkServer k chain (\(a, _, _) -> a) <$> connect + StateIdle (localStateQueryClientPeer client) (localStateQueryServerPeer server)