Typed Protocols: new API (#4935)

* Updated cabal.project file * ouroboros-network-framework: updated against typed-protocols changes * ouroboros-network-framework: stateful driver implementation * ouroboros-network-framework: added unbounded buffered channel * ouroboros-network-framework: added runConnectedPeersWithLimits * ouroboros-network-framework: extend driver tests Using PingPong protocol to test the driver. Use both `Ouroboros.Network.Driver.Simple` and `Ouroboros.Network.Driver.Limits`. Also use a ping pong client which is relaying on the `CollectSTM` primitive. The original test is renamed to fit the naming convention, which is also used in `typed-protocols-examples`. * ouroboros-network-protocols: updated against typed-protocols changes Only the main library is updated. * ouroboros-network: updated against typed-protocol changes Only the main library is updated. * ouroboros-protocol-tests: stateful cborg utilities * ouroboros-network-protocols:testlib updated against typed-protocols changes * ouroboros-network:sim-tests-lib updated against typed-prococols changes * ouroboros-network-protocols: updated cddl and benchmarks * ouroboros-network-framework: name some tvars & threads Most part of this patch is updating dependencies. * tx-submission2 tests: name client & server traces This is only useful for debugging a failing test case. * tx-submission2 tests: use unbounded channel We use pipelined client, hence we need to use an buffered channel. * block-fetch tests: fix termination of blockFetchExample1 The client side of each block-fetch protocol has to run until it's completion, otherwise it might happen that we will not generate a trace which marks completion of fetching all blocks in a batch (`CompletedFetchBatch`). This results in failure of `tracePropertyInFlight`. * block-fetch tests: fixed termination tests The first assertion of `fetchDecisionsForStateSnapshot` was triggered. We need first kill the fetch thread before the client side terminates. * tx-submission test: fixed a deadlock due to pipelining * ouroboros-network-framework: added stateful driver tests * ouroboros-network-framework: added simple driver tests * ouroboros-network-framework: reorganised Test.Ouroboros.Network.Driver module * ouroboros-network-framework: added mkMiniProtocolCbFromPeerSt This is useful API for running stateful peers. * ouroboros-network-framework: ProtocolTimeLimits ProtocolTimeLimits can be a newtype. * ouroboros-network-framework: strictness annotations in drivers * ouroboros-network:demo-chain-sync improvements * ouroboros-network-framework: relax bounds of nothunks Allow to build against nothunks-0.1; `ouroboros-consensus` and `plutus-core` do not yet use `nothunks-0.2`. * MiniProtocolParameters: use NumTxIdsToAck This ought to be part of the PR which introduced `NumTxIdsToAck`. * block-fetch tests: use `===` over `==` * Updated CHANGELOG.md files * ouroboros-network-framework: updated stateful driver test * typed-protocols-0.3.0.0 typed-protocols-0.3.0.0 provide better stateful API, which allows us to decouple `Message` type from it encoding. This is used to remove `query resesult` field of `MsgResp` of the `LocalStateQuery` mini-protocol. * ouroboros-network-protocols:testlib removed unused constraints * flake.nix: increased heap limit
IntersectMBO · Sep 27, 2024 · faf4c69 · faf4c69
1 parent 0d462a3
commit faf4c69
Show file tree

Hide file tree

Showing 100 changed files with 3,355 additions and 2,342 deletions.
diff --git a/cabal.project b/cabal.project
@@ -18,7 +18,7 @@ index-state:
   , hackage.haskell.org 2024-07-10T11:10:47Z
 
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2024-07-09T10:22:18Z
+  , cardano-haskell-packages 2024-09-26T15:16:07Z
 
 packages: ./cardano-ping
           ./monoidal-synchronisation
@@ -53,4 +53,3 @@ package network-mux
 
 package ouroboros-network
   flags: +asserts +cddl
-
diff --git a/flake.lock b/flake.lock
diff --git a/nix/ouroboros-network.nix b/nix/ouroboros-network.nix
@@ -106,7 +106,7 @@ let
         # to discover space leaks Once #4698 and #4699 are done we can
         # further constrain the heap size.
         preCheck = lib.mkForce ''
-        export GHCRTS=-M200M
+        export GHCRTS=-M250M
         '';
 
         # pkgs are instantiated for the host platform

diff --git a/ouroboros-network-api/CHANGELOG.md b/ouroboros-network-api/CHANGELOG.md
@@ -7,7 +7,8 @@
 * Renamed:
   * `accBigPoolStake` -> `accumulateBigLedgerStake`
      and `reRelativeStake` -> `recomputeRelativeStake`
-- Added `NodeToClientVersionV18`
+* Added `NodeToClientVersionV18`
+* Using `typed-protocols-0.3.0.0`.
 
 ### Non-breaking changes
 

diff --git a/ouroboros-network-api/ouroboros-network-api.cabal b/ouroboros-network-api/ouroboros-network-api.cabal
@@ -79,7 +79,7 @@ library
                        network-mux      ^>=0.4.5,
                        strict-stm,
                        si-timers,
-                       typed-protocols  ^>=0.1.1,
+                       typed-protocols  ^>=0.3,
 
   ghc-options:         -Wall
                        -Wno-unticked-promoted-constructors

diff --git a/ouroboros-network-api/src/Ouroboros/Network/Protocol/Limits.hs b/ouroboros-network-api/src/Ouroboros/Network/Protocol/Limits.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
 
 module Ouroboros.Network.Protocol.Limits where
 
@@ -17,47 +18,51 @@ import Ouroboros.Network.Util.ShowProxy
 
 
 data ProtocolSizeLimits ps bytes = ProtocolSizeLimits {
-       sizeLimitForState :: forall (pr :: PeerRole) (st :: ps).
-                            PeerHasAgency pr st -> Word,
+       sizeLimitForState :: forall (st :: ps). ActiveState st
+                         => StateToken st -> Word,
 
        dataSize          :: bytes -> Word
      }
 
-data ProtocolTimeLimits ps = ProtocolTimeLimits {
-       timeLimitForState :: forall (pr :: PeerRole) (st :: ps).
-                            PeerHasAgency pr st -> Maybe DiffTime
+newtype ProtocolTimeLimits ps = ProtocolTimeLimits {
+       timeLimitForState :: forall  (st :: ps). ActiveState st
+                         => StateToken st -> Maybe DiffTime
      }
 
 data ProtocolLimitFailure where
-    ExceededSizeLimit :: forall (pr :: PeerRole) ps (st :: ps).
-                         ( forall (st' :: ps). Show (ClientHasAgency st')
-                         , forall (st' :: ps). Show (ServerHasAgency st')
+    ExceededSizeLimit :: forall ps (st :: ps).
+                         ( Show (StateToken st)
                          , ShowProxy ps
+                         , ActiveState st
                          )
-                      => PeerHasAgency pr st
+                      => StateToken st
                       -> ProtocolLimitFailure
-    ExceededTimeLimit :: forall (pr :: PeerRole) ps (st :: ps).
-                         ( forall (st' :: ps). Show (ClientHasAgency st')
-                         , forall (st' :: ps). Show (ServerHasAgency st')
+    ExceededTimeLimit :: forall ps (st :: ps).
+                         ( Show (StateToken st)
                          , ShowProxy ps
+                         , ActiveState st
                          )
-                      => PeerHasAgency pr st
+                      => StateToken st
                       -> ProtocolLimitFailure
 
 instance Show ProtocolLimitFailure where
-    show (ExceededSizeLimit (stok :: PeerHasAgency pr (st :: ps))) =
+    show (ExceededSizeLimit (stok :: StateToken (st :: ps))) =
       concat
         [ "ExceededSizeLimit ("
         , showProxy (Proxy :: Proxy ps)
-        , ") ("
+        , ") "
+        , show (activeAgency :: ActiveAgency st)
+        , " ("
         , show stok
         , ")"
         ]
-    show (ExceededTimeLimit (stok :: PeerHasAgency pr (st :: ps))) =
+    show (ExceededTimeLimit (stok :: StateToken (st :: ps))) =
       concat
         [ "ExceededTimeLimit ("
         , showProxy (Proxy :: Proxy ps)
-        , ") ("
+        , ") "
+        , show (activeAgency :: ActiveAgency st)
+        , " ("
         , show stok
         , ")"
         ]

diff --git a/ouroboros-network-api/src/Ouroboros/Network/Protocol/Type.hs b/ouroboros-network-api/src/Ouroboros/Network/Protocol/Type.hs
@@ -6,57 +6,63 @@
 {-# LANGUAGE ScopedTypeVariables   #-}
 
 module Ouroboros.Network.Protocol.Type where
+{-# DEPRECATED Ouroboros.Network.Protocol.Type "Import Ouroboros.Network.Protocol.Limits instead" #-}
 
 import Control.Exception
 import Control.Monad.Class.MonadTime
+import Data.Singletons
 
 import Network.TypedProtocol.Core
 
 import Ouroboros.Network.Util.ShowProxy
 
 
 data ProtocolSizeLimits ps bytes = ProtocolSizeLimits {
-       sizeLimitForState :: forall (pr :: PeerRole) (st :: ps).
-                            PeerHasAgency pr st -> Word,
+       sizeLimitForState :: forall (st :: ps). ActiveState st
+                         => Sing st -> Word,
 
        dataSize          :: bytes -> Word
      }
 
 data ProtocolTimeLimits ps = ProtocolTimeLimits {
-       timeLimitForState :: forall (pr :: PeerRole) (st :: ps).
-                            PeerHasAgency pr st -> Maybe DiffTime
+       timeLimitForState :: forall  (st :: ps). ActiveState st
+                         => Sing st -> Maybe DiffTime
      }
 
 data ProtocolLimitFailure where
-    ExceededSizeLimit :: forall (pr :: PeerRole) ps (st :: ps).
-                         ( forall (st' :: ps). Show (ClientHasAgency st')
-                         , forall (st' :: ps). Show (ServerHasAgency st')
+    ExceededSizeLimit :: forall ps (st :: ps).
+                         ( Show (Sing st)
                          , ShowProxy ps
+                         , ActiveState st
                          )
-                      => PeerHasAgency pr st
+                      => Sing st
                       -> ProtocolLimitFailure
-    ExceededTimeLimit :: forall (pr :: PeerRole) ps (st :: ps).
-                         ( forall (st' :: ps). Show (ClientHasAgency st')
-                         , forall (st' :: ps). Show (ServerHasAgency st')
+    ExceededTimeLimit :: forall ps (st :: ps).
+                         ( Show (Sing st)
                          , ShowProxy ps
+                         , ActiveState st
                          )
-                      => PeerHasAgency pr st
+                      => Sing st
                       -> ProtocolLimitFailure
 
 instance Show ProtocolLimitFailure where
-    show (ExceededSizeLimit (stok :: PeerHasAgency pr (st :: ps))) =
+    show (ExceededSizeLimit (stok :: Sing (st :: ps))) =
       concat
         [ "ExceededSizeLimit ("
         , showProxy (Proxy :: Proxy ps)
-        , ") ("
+        , ") "
+        , show (activeAgency :: ActiveAgency st)
+        , " ("
         , show stok
         , ")"
         ]
-    show (ExceededTimeLimit (stok :: PeerHasAgency pr (st :: ps))) =
+    show (ExceededTimeLimit (stok :: Sing (st :: ps))) =
       concat
         [ "ExceededTimeLimit ("
         , showProxy (Proxy :: Proxy ps)
-        , ") ("
+        , ") "
+        , show (activeAgency :: ActiveAgency st)
+        , " ("
         , show stok
         , ")"
         ]

diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md
@@ -4,47 +4,40 @@
 
 ### Breaking changes
 
+* Added `createConnectedBufferedChannelsUnbounded`.
+* Use `typed-protocols-0.2.0.0`.
+
 ### Non-breaking changes
 
 * Added tracing on CM connVars for testing purposes.
 
 ## 0.13.2.4 -- 2024-08-27
 
-### Breaking changes
-
 ### Non-breaking changes
 
 * bump for bad ref in chap for 0.13.2.3
 
 ## 0.13.2.3 -- 2024-08-22
 
-### Breaking changes
-
 ### Non-breaking changes
 
 * version bump for build depends
 
 ## 0.13.2.2 -- 2024-08-07
 
-### Breaking changes
-
 ### Non-breaking changes
 
 * Make it build with ghc-9.10
 * Improve memory footprint of tests by using strict version of STM
 
 ## 0.13.2.1 -- 2024-06-26
 
-### Breaking changes
-
 ### Non-breaking changes
 
 - Fix `InboundGovernorCounters`
 
 ## 0.13.2.0 -- 2024-06-07
 
-### Breaking changes
-
 ### Non-breaking changes
 
 - Fixed `InboundGovernorCounters` tracing frequency
@@ -74,8 +67,6 @@
   `PublichInboundGovernorState`.
 * Added `serverDebugInboundGovernor` tracer was added to `ServerArguments`.
 
-### Non-breaking changes
-
 ## 0.12.0.0 -- 2024-03-15
 
 ### Breaking changes

diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs
@@ -43,7 +43,7 @@ import Data.Typeable (Typeable)
 import Network.Mux qualified as Mux
 import Network.Mux.Bearer qualified as Mux
 import Network.Socket qualified as Socket
-import Network.TypedProtocol.Core
+import Network.TypedProtocol.Peer
 
 import Options.Applicative
 
@@ -372,12 +372,13 @@ withBidirectionalConnectionManager snocket makeBearer socket
 runInitiatorProtocols
     :: forall muxMode addr m a b.
        ( Alternative (STM m)
-       , MonadAsync      m
-       , MonadCatch      m
-       , MonadSTM        m
-       , MonadThrow (STM m)
+       , MonadAsync       m
+       , MonadCatch       m
+       , MonadLabelledSTM m
+       , MonadMask        m
+       , MonadSTM         m
+       , MonadThrow  (STM m)
        , HasInitiator muxMode ~ True
-       , MonadSay        m
        )
     => SingMuxMode muxMode
     -> Mux.Mux muxMode m

diff --git a/ouroboros-network-framework/demo/ping-pong.hs b/ouroboros-network-framework/demo/ping-pong.hs
@@ -39,9 +39,9 @@ import Ouroboros.Network.Protocol.Handshake.Version
 
 import Network.TypedProtocol.PingPong.Client as PingPong
 import Network.TypedProtocol.PingPong.Codec.CBOR as PingPong
+import Network.TypedProtocol.PingPong.Examples
 import Network.TypedProtocol.PingPong.Server as PingPong
 import Network.TypedProtocol.PingPong.Type (PingPong)
-import Network.TypedProtocol.Pipelined
 
 
 main :: IO ()
@@ -134,9 +134,9 @@ clientPingPong pipelined =
     pingPongInitiator | pipelined =
       InitiatorProtocolOnly $
       mkMiniProtocolCbFromPeerPipelined $ \_ctx ->
-        ( tracer
+        ( contramap show stdoutTracer
         , codecPingPong
-        , pingPongClientPeerPipelined (pingPongClientPipelinedMax 5)
+        , void $ pingPongClientPeerPipelined (pingPongClientPipelinedMax 5)
         )
 
       | otherwise =
@@ -148,10 +148,6 @@ clientPingPong pipelined =
         )
 
 
-pingPongClientCount :: Applicative m => Int -> PingPongClient m ()
-pingPongClientCount 0 = PingPong.SendMsgDone ()
-pingPongClientCount n = SendMsgPing (pure (pingPongClientCount (n-1)))
-
 serverPingPong :: IO Void
 serverPingPong =
     withIOManager $ \iomgr -> do
@@ -186,16 +182,6 @@ serverPingPong =
         , pingPongServerPeer pingPongServerStandard
         )
 
-pingPongServerStandard
-  :: Applicative m
-  => PingPongServer m ()
-pingPongServerStandard =
-    PingPongServer {
-      recvMsgPing = pure pingPongServerStandard,
-      recvMsgDone = ()
-    }
-
-
 --
 -- Ping pong demo2
 --
@@ -254,23 +240,6 @@ clientPingPong2 =
         , pingPongClientPeer (pingPongClientCount 5)
         )
 
-pingPongClientPipelinedMax
-  :: forall m. Monad m
-  => Int
-  -> PingPongClientPipelined m ()
-pingPongClientPipelinedMax c =
-    PingPongClientPipelined (go [] Zero 0)
-  where
-    go :: [Either Int Int] -> Nat o -> Int
-       -> PingPongSender o Int m ()
-    go acc o        n | n < c
-                      = SendMsgPingPipelined
-                          (return n)
-                          (go (Left n : acc) (Succ o) (succ n))
-    go _    Zero     _ = SendMsgDonePipelined ()
-    go acc (Succ o) n = CollectPipelined
-                          Nothing
-                          (\n' -> go (Right n' : acc) o n)
 
 serverPingPong2 :: IO Void
 serverPingPong2 =