Typed Protocols: new API (#1223)

# Description Use `typed-protocols-0.3.0.0`. Depends on: * [x] input-output-hk/typed-protocols#52 * [x] input-output-hk/typed-protocols#61 * [x] IntersectMBO/ouroboros-network#4935 - **Updated to use typed-protocols-0.3.0.0** - **Added KeepAlive tracer**
IntersectMBO · Oct 21, 2024 · 7dd936f · 7dd936f
2 parents b0884a3 + 120d92d
commit 7dd936f
Show file tree

Hide file tree

Showing 20 changed files with 107 additions and 44 deletions.
diff --git 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
diff --git a/...s-consensus-cardano/changelog.d/20241021_094824_coot_typed_protocols_new_api.md b/...s-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
@@ -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/...ros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/...ros-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/...onsensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs b/...onsensus-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/...consensus-diffusion/changelog.d/20241021_094154_coot_typed_protocols_new_api.md b/...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
@@ -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/...s-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs b/...s-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/...sus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/...sus-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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -30,3 +30,4 @@ nodeToClientVersionToQueryVersion x = case x of
   NodeToClientV_16 -> QueryVersion2
   NodeToClientV_17 -> QueryVersion2
   NodeToClientV_18 -> QueryVersion2
+  NodeToClientV_19 -> QueryVersion2
diff --git a/...os-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/...os-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
@@ -68,6 +68,8 @@ import           Ouroboros.Consensus.Util.Orphans ()
 -------------------------------------------------------------------------------}
 
 class ( MonadAsync              m
+      , MonadLabelledSTM        m
+      , MonadTraceSTM           m
       , MonadMVar               m
       , MonadEventlog           m
       , MonadFork               m