From 0e62ccb8d4cee77adb0b8f829529ceb0cc07b912 Mon Sep 17 00:00:00 2001 From: Fraser Murray Date: Wed, 2 Oct 2024 13:06:29 +0100 Subject: [PATCH] wip: changes required for new (as-yet unreleased) ouroboros-network-protocols changes with typed-protocols-0.3 --- cabal.project | 2 +- .../ouroboros-consensus-cardano.cabal | 2 +- .../ouroboros-consensus-diffusion.cabal | 2 ++ .../Consensus/Network/NodeToClient.hs | 21 ++++++++++++------- .../Ouroboros/Consensus/Network/NodeToNode.hs | 4 ++-- .../Test/ThreadNet/Network.hs | 2 +- .../Consensus/PeerSimulator/BlockFetch.hs | 20 +++++++++++------- ouroboros-consensus/ouroboros-consensus.cabal | 5 +++-- .../MiniProtocol/ChainSync/Client.hs | 2 +- .../MiniProtocol/BlockFetch/Client.hs | 2 +- .../MiniProtocol/ChainSync/Client.hs | 4 ++-- .../MiniProtocol/LocalStateQuery/Server.hs | 12 +++++------ 12 files changed, 45 insertions(+), 33 deletions(-) diff --git a/cabal.project b/cabal.project index d6e9c25058..eeda5e34c1 100644 --- a/cabal.project +++ b/cabal.project @@ -16,7 +16,7 @@ index-state: -- Bump this if you need newer packages from Hackage , hackage.haskell.org 2024-08-26T10:41:44Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2024-09-03T00:18:11Z + , cardano-haskell-packages 2024-09-26T15:16:07Z packages: ouroboros-consensus diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index b4d678998d..40e16e4ac1 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -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, diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 82f6b6dd50..0cde16f817 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -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 @@ -155,6 +156,7 @@ library unstable-diffusion-testlib strict-stm, text, typed-protocols, + typed-protocols-stateful, library unstable-mock-testlib import: common-lib 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..a95461f539 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 FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} {-# 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 (..)) @@ -142,17 +146,17 @@ mkHandlers NodeKernelArgs {cfg, tracers} NodeKernel {getChainDB, getMempool} = -- | Node-to-client protocol codecs needed to run 'Handlers'. 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 - , cTxMonitorCodec :: Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM + cChainSyncCodec :: Codec (ChainSync serialisedBlk (Point blk) (Tip blk)) e m bCS + , cTxSubmissionCodec :: Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)) e m bTX + , cStateQueryCodec :: Stateful.Codec (LocalStateQuery blk (Point blk) (Query blk)) e State m bSQ + , cTxMonitorCodec :: Codec (LocalTxMonitor (GenTxId blk) (GenTx blk) SlotNo) e m bTM } type Codecs blk e m bCS bTX bSQ bTM = Codecs' blk (Serialised blk) e m bCS bTX bSQ bTM type DefaultCodecs blk m = Codecs' blk (Serialised blk) DeserialiseFailure m ByteString ByteString ByteString ByteString -type ClientCodecs blk m = +type ClientCodecs blk m = Codecs' blk blk DeserialiseFailure m ByteString ByteString ByteString ByteString -- | Protocol codecs for the node-to-client protocols @@ -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)) 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)) 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 + 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 50957bce77..477cd53552 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 @@ -243,14 +243,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 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 43399dfeb6..94504d74fa 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 @@ -1386,7 +1386,7 @@ 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 + let tok = CS.SingNext CS.SingMustReply decodeStep <- Codec.decode codec tok Codec.runDecoder [bs] decodeStep >>= \case Right (Codec.SomeMessage (CS.MsgRollForward hdr _tip)) -> do 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 c094684e2d..1970904058 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 @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} @@ -24,8 +25,7 @@ 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 (AnyMessage) import Ouroboros.Consensus.Block (HasHeader) import Ouroboros.Consensus.Block.Abstract (Header, Point (..)) import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface @@ -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 @@ -189,11 +189,15 @@ 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 :: SingBlockFetch a -> Maybe DiffTime + stateToLimit = \case + SingBFIdle -> waitForever + SingBFBusy -> busyTimeout + SingBFStreaming -> streamingTimeout + SingBFDone -> Nothing + -- stateToLimit (ClientAgency TokIdle) = waitForever + -- stateToLimit (ServerAgency TokBusy) = busyTimeout + -- stateToLimit (ServerAgency TokStreaming) = streamingTimeout blockFetchNoTimeouts :: BlockFetchTimeout blockFetchNoTimeouts = diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index cce3ffa020..e7ad1dce32 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -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/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index 2d8f42a710..c8f8340152 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 import NoThunks.Class (unsafeNoThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime (RelativeTime) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index df9e7ee64c..259d5a9c46 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -120,7 +120,7 @@ data BlockFetchClientOutcome = BlockFetchClientOutcome { runBlockFetchTest :: forall m. - (IOLike m, MonadTime m, MonadTimer m) + (IOLike m, MonadTime m, MonadTimer m, MonadLabelledSTM m, MonadTraceSTM m) => BlockFetchClientTestSetup -> m BlockFetchClientOutcome runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do 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 1047ec37c4..85eb5012a8 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 @@ -314,7 +314,7 @@ data ChainSyncOutcome = ChainSyncOutcome { -- Note that updates that are scheduled before the time at which we start -- syncing help generate different chains to start syncing from. runChainSync :: - forall m. (IOLike m, MonadTime m, MonadTimer m) + forall m. (IOLike m, MonadTime m, MonadTimer m, MonadLabelledSTM m, MonadTraceSTM m) => ClockSkew -> SecurityParam -> ClientUpdates @@ -516,7 +516,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..ef8eba4a0b 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 @@ -99,10 +99,10 @@ prop_localStateQueryServer k bt p (Positive (Small n)) = checkOutcome k chain ac actualOutcome = runSimOrThrow $ do let client = mkClient points server <- mkServer k chain - (\(a, _, _) -> a) <$> - connect - (localStateQueryClientPeer client) - (localStateQueryServerPeer server) + (r, _, _) <- connect StateIdle + (localStateQueryClientPeer client) + (localStateQueryServerPeer server) + pure r {------------------------------------------------------------------------------- Test setup