Support typed-protocols-0.3.0.0 and changes to ouroboros-network-protocols

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

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,

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

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           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.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 @@
 
 -- | 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 @@
                => 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 @@
 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 @@
       -> m ((), Maybe bSQ)
     aStateQueryServer them channel = do
       labelThisThread "LocalStateQueryServer"
-      runPeer
+      Stateful.runPeer
         (contramap (TraceLabelPeer them) tStateQueryTracer)
         cStateQueryCodec
         channel
+        StateIdle
         (localStateQueryServerPeer hStateQueryServer)
 
     aTxMonitorServer

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

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

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 =

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,
 

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)

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

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))

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