typed-protocols-1.2 integration

cabal.project

@@ -53,3 +53,10 @@ package acts
   flags: -finitary
 
 allow-newer: quickcheck-instances:QuickCheck
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/typed-protocols
+  tag: 3cbc13762f8129d255552f0dfab6c18c6909d33a
+  --sha256: sha256-obHwd0CnZPmxWkBgYrubzOU0W069pijbztalvbDJOhI=
+  subdir: typed-protocols

cardano-diffusion/api/lib/Cardano/Network/NodeToClient/Version.hs

@@ -122,7 +122,7 @@ data NodeToClientVersionData = NodeToClientVersionData
   { networkMagic :: !NetworkMagic
   , query        :: !Bool
   }
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic, NFData)
 
 instance Acceptable NodeToClientVersionData where
     acceptableVersion local remote

cardano-diffusion/api/lib/Cardano/Network/NodeToNode/Version.hs

@@ -98,7 +98,7 @@ data NodeToNodeVersionData = NodeToNodeVersionData
   , peerSharing   :: !PeerSharing
   , query         :: !Bool
   }
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic, NFData)
   -- 'Eq' instance is not provided, it is not what we need in version
   -- negotiation (see 'Acceptable' instance below).
 

cardano-diffusion/cardano-diffusion.cabal

@@ -161,14 +161,15 @@ library
     cardano-diffusion:{api, protocols},
     containers,
     contra-tracer,
+    deepseq,
     dns,
     io-classes:{io-classes, si-timers, strict-stm} ^>=1.8,
     monoidal-synchronisation,
     network ^>=3.2.7,
     network-mux,
     ouroboros-network:{ouroboros-network, api, framework, protocols},
     random,
-    typed-protocols:{typed-protocols, stateful} ^>=1.1,
+    typed-protocols:{typed-protocols, stateful} ^>=1.2,
 
   if !os(windows)
     build-depends:
@@ -294,7 +295,7 @@ library protocols
     io-classes:{io-classes, si-timers} ^>=1.8.0.1,
     ouroboros-network:{api, framework, protocols},
     random,
-    typed-protocols:{typed-protocols, cborg, stateful} ^>=1.1,
+    typed-protocols:{typed-protocols, cborg, stateful} ^>=1.2,
 
 library protocols-tests-lib
   import: ghc-options
@@ -347,6 +348,7 @@ library protocols-tests-lib
     cborg,
     containers,
     contra-tracer,
+    deepseq,
     io-classes:{io-classes, si-timers},
     io-sim,
     ouroboros-network:{api, framework, protocols, protocols-tests-lib},
@@ -456,6 +458,7 @@ library cardano-diffusion-tests-lib
     cborg,
     containers,
     contra-tracer,
+    deepseq,
     dns,
     io-classes:{io-classes, si-timers, strict-stm},
     io-sim,
@@ -525,6 +528,7 @@ library subscription
     cborg >=0.2.8 && <0.3,
     containers >=0.5 && <0.9,
     contra-tracer >=0.1 && <0.3,
+    deepseq,
     io-classes:si-timers ^>=1.8.0.1,
     network-mux ^>=0.10,
     ouroboros-network:{api, framework} ^>=0.24,

cardano-diffusion/lib/Cardano/Network/Diffusion.hs

@@ -16,6 +16,7 @@ module Cardano.Network.Diffusion
   , run
   ) where
 
+import Control.DeepSeq (NFData)
 import Control.Monad.Class.MonadThrow
 import Control.Tracer (traceWith)
 import Data.Set qualified as Set
@@ -50,7 +51,8 @@ import Ouroboros.Network.Protocol.Handshake
 --   information from the running system.  This is used by 'cardano-cli' or
 --   a wallet and a like local services.
 --
-run :: CardanoNodeArguments IO
+run :: NFData a
+    => CardanoNodeArguments IO
     -- ^ node API: instantiated in `cardano-node`.
     -> CardanoConsensusArguments RemoteAddress IO
     -- ^ consensus API; instantiated in `ouroboros-consensus-diffusion` (with

cardano-diffusion/lib/Cardano/Network/NodeToClient.hs

@@ -53,6 +53,7 @@ module Cardano.Network.NodeToClient
   ) where
 
 import Control.Exception (SomeException)
+import Control.DeepSeq (NFData)
 import Control.Monad (forever)
 import Control.Monad.Class.MonadAsync
 import Control.Monad.Class.MonadTimer.SI
@@ -200,7 +201,8 @@ versionedNodeToClientProtocols versionNumber versionData protocols =
 -- protocol.  This is mostly useful for future enhancements.
 --
 connectTo
-  :: LocalSnocket
+  :: NFData a
+  => LocalSnocket
   -- ^ callback constructed by 'Ouroboros.Network.IOManager.withIOManager'
   -> NetworkConnectTracers LocalAddress NodeToClientVersion
   -> Versions NodeToClientVersion

cardano-diffusion/lib/Cardano/Network/NodeToNode.hs

@@ -72,6 +72,7 @@ module Cardano.Network.NodeToNode
   , peerSharingMiniProtocolNum
   ) where
 
+import Control.DeepSeq (NFData)
 import Control.Exception (SomeException)
 
 import Data.ByteString.Lazy qualified as BL
@@ -398,7 +399,10 @@ peerSharingMiniProtocolNum = MiniProtocolNum 10
 -- | A specialised version of @'Ouroboros.Network.Socket.connectToNode'@.
 --
 connectTo
-  :: Snocket IO Socket.Socket Socket.SockAddr
+  :: ( NFData a
+     , NFData b
+     )
+  => Snocket IO Socket.Socket Socket.SockAddr
   -> NetworkConnectTracers Socket.SockAddr NodeToNodeVersion
   -> Versions NodeToNodeVersion
               NodeToNodeVersionData

cardano-diffusion/protocols/tests-lib/Cardano/Network/Protocol/Handshake/Test.hs

@@ -1,11 +1,12 @@
-{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE DerivingVia         #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE PolyKinds           #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE DerivingVia                #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns             #-}
+{-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 
 -- TODO: Needed for PeerSharing arbitrary instance see
 -- todo there.
@@ -20,6 +21,7 @@ import Data.Text (Text)
 import Codec.CBOR.Read qualified as CBOR
 import Codec.CBOR.Term qualified as CBOR
 
+import Control.DeepSeq (NFData)
 import Control.Monad.Class.MonadAsync
 import Control.Monad.Class.MonadThrow
 import Control.Monad.IOSim (runSimOrThrow)
@@ -102,16 +104,18 @@ tests =
 
 newtype ArbitraryNodeToNodeVersion =
         ArbitraryNodeToNodeVersion { getNodeToNodeVersion :: NodeToNodeVersion }
-  deriving Show
+  deriving stock   Show
+  deriving newtype NFData
 
 instance Arbitrary ArbitraryNodeToNodeVersion where
     arbitrary = elements (ArbitraryNodeToNodeVersion <$> [minBound .. maxBound])
 
 newtype ArbitraryNodeToNodeVersionData =
         ArbitraryNodeToNodeVersionData
           { getNodeToNodeVersionData :: NodeToNodeVersionData }
-    deriving Show
-    deriving Acceptable via NodeToNodeVersionData
+    deriving stock   Show
+    deriving         Acceptable via NodeToNodeVersionData
+    deriving newtype NFData
 
 -- | With the introduction of PeerSharing to 'NodeToNodeVersionData' this type's
 -- 'Acceptable' instance is no longer symmetric. Because when handshake is
@@ -370,8 +374,9 @@ prop_query_version_NodeToClient_SimNet
 -- | Run a query for the server's supported version.
 --
 prop_peerSharing_symmetric ::
-                           ( MonadAsync m
-                           , MonadCatch m
+                           ( MonadAsync    m
+                           , MonadCatch    m
+                           , MonadEvaluate m
                            )
                            => m (Channel m ByteString, Channel m ByteString)
                            -> Codec (Handshake NodeToNodeVersion CBOR.Term)

cardano-diffusion/subscription/Cardano/Client/Subscription.hs

@@ -28,6 +28,7 @@ module Cardano.Client.Subscription
   ) where
 
 import Codec.CBOR.Term qualified as CBOR
+import Control.DeepSeq (NFData)
 import Control.Exception
 import Control.Monad (join)
 import Control.Monad.Class.MonadTime.SI
@@ -100,7 +101,8 @@ data SubscriptionTrace a =
 --
 subscribe
   :: forall blockVersion a.
-     Snocket.LocalSnocket
+     NFData a
+  => Snocket.LocalSnocket
   -> NetworkMagic
   -> Map NodeToClientVersion blockVersion
   -- ^ Use `supportedNodeToClientVersions` from `ouroboros-consensus`.

cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs

@@ -1685,7 +1685,7 @@ prop_peer_selection_action_trace_coverage defaultBearerInfo diffScript =
         | Just ioe <- fromException e
         = "AcquireConnectionError: " ++ show (ioe_type ioe)
         | otherwise
-        = "AcquireConnectionError: " ++ show e
+        = "AcquireConnectionError"
       peerSelectionActionsTraceMap (PeerHotDuration _id _dt) =
         "PeerHotDuration"
 

cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/MiniProtocols.hs

@@ -250,6 +250,7 @@ applications :: forall block header s m.
                 ( Alternative (STM m)
                 , MonadAsync m
                 , MonadDelay m
+                , MonadEvaluate m
                 , MonadFork  m
                 , MonadMask  m
                 , MonadMVar  m

cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs

@@ -1013,6 +1013,7 @@ diffusionSimulationM
                , MonadAsync       m
                , MonadDelay       m
                , MonadFix         m
+               , MonadEvaluate    m
                , MonadFork        m
                , MonadSay         m
                , MonadST          m

ouroboros-network/api/lib/Ouroboros/Network/Block.hs

@@ -69,14 +69,14 @@ module Ouroboros.Network.Block
   , fromSerialised
   ) where
 
-import Cardano.Binary (DecoderError)
 import Codec.CBOR.Decoding (Decoder)
 import Codec.CBOR.Decoding qualified as Dec
 import Codec.CBOR.Encoding (Encoding)
 import Codec.CBOR.Encoding qualified as Enc
 import Codec.CBOR.Read qualified as Read
 import Codec.CBOR.Write qualified as Write
 import Codec.Serialise (Serialise (..))
+import Control.DeepSeq (NFData (..))
 import Control.Monad (when)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.ByteString.Base16.Lazy qualified as B16
@@ -89,6 +89,7 @@ import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 import Quiet
 
+import Cardano.Binary (DecoderError)
 import Cardano.Slotting.Block
 import Cardano.Slotting.Slot (SlotNo (..))
 
@@ -211,6 +212,14 @@ newtype Point block = Point
     }
   deriving (Generic)
 
+instance NFData (Point block) where
+  rnf point = rnf (pointSlot point)
+              `seq`
+              pointHash point
+              `seq`
+              ()
+
+
 deriving newtype instance StandardHash block => Eq       (Point block)
 deriving newtype instance StandardHash block => Ord      (Point block)
 deriving via (Quiet (Point block))

ouroboros-network/api/lib/Ouroboros/Network/DiffusionMode.hs

@@ -1,5 +1,11 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric  #-}
+
 module Ouroboros.Network.DiffusionMode (DiffusionMode (..)) where
 
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
+
 
 -- | The flag which indicates whether the node runs only initiator or both
 -- initiator or responder node.
@@ -18,4 +24,4 @@ module Ouroboros.Network.DiffusionMode (DiffusionMode (..)) where
 data DiffusionMode
     = InitiatorOnlyDiffusionMode
     | InitiatorAndResponderDiffusionMode
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Generic, NFData)

ouroboros-network/api/lib/Ouroboros/Network/PeerSelection/PeerSharing.hs

@@ -1,10 +1,12 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric  #-}
+{-# LANGUAGE InstanceSigs   #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE InstanceSigs  #-}
 
 module Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) where
 
+import Control.DeepSeq (NFData)
 import GHC.Generics (Generic)
 
 -- | Is a peer willing to participate in Peer Sharing? If yes are others allowed
@@ -17,7 +19,7 @@ import GHC.Generics (Generic)
 data PeerSharing = PeerSharingDisabled -- ^ Peer does not participate in Peer Sharing
                                        -- at all
                  | PeerSharingEnabled -- ^ Peer participates in Peer Sharing
-  deriving  (Eq, Show, Read, Generic)
+  deriving  (Eq, Show, Read, Generic, NFData)
 
 -- | The combination of two 'PeerSharing' values forms a Monoid where the unit
 -- is 'PeerSharingEnabled'.

ouroboros-network/api/lib/Ouroboros/Network/Point.hs

@@ -13,6 +13,7 @@ module Ouroboros.Network.Point
   , withOriginFromMaybe
   ) where
 
+import Control.DeepSeq (NFData)
 import Data.Aeson
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
@@ -23,7 +24,7 @@ data Block slot hash = Block
   { blockPointSlot :: !slot
   , blockPointHash :: !hash
   }
-  deriving (Eq, Ord, Show, ToJSON, FromJSON, Generic, NoThunks)
+  deriving (Eq, Ord, Show, ToJSON, FromJSON, Generic, NoThunks, NFData)
 
 block :: slot -> hash -> WithOrigin (Block slot hash)
 block slot hash = at (Block slot hash)

ouroboros-network/api/lib/Ouroboros/Network/Protocol/Limits.hs

@@ -1,14 +1,18 @@
 {-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE PolyKinds             #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE StandaloneDeriving    #-}
 {-# LANGUAGE TypeFamilies          #-}
 
 module Ouroboros.Network.Protocol.Limits where
 
+import Control.DeepSeq (NFData (..))
 import Control.Exception
 import Control.Monad.Class.MonadTime.SI
 import System.Random (StdGen)
@@ -74,6 +78,26 @@ instance Show ProtocolLimitFailure where
         ]
 
 instance Exception ProtocolLimitFailure where
+instance NFData ProtocolLimitFailure where
+  rnf = \case
+      -- for singletons WHNF => NF
+      (ExceededTimeLimit sing) -> sing
+                            `seq` rnf (showProxy (singToProxy sing))
+                            `seq` singToActiveAgency sing
+                            `seq` ()
+      (ExceededSizeLimit sing) -> sing
+                            `seq` rnf (showProxy (singToProxy sing))
+                            `seq` singToActiveAgency sing
+                            `seq` ()
+    where
+      singToProxy :: forall ps (st :: ps). StateToken st -> Proxy ps
+      singToProxy _ = Proxy
+
+      singToActiveAgency :: forall ps (st :: ps).
+                            ActiveState st
+                         => StateToken st
+                         -> ActiveAgency st
+      singToActiveAgency _ = activeAgency
 
 
 -- TODO: better limits