ProtocolLimitFailure: updated components

Including ouroboros-network-framework and ouroboros-network components.
IntersectMBO · Jul 6, 2020 · 64bf9c0 · 64bf9c0
1 parent d8b954b
commit 64bf9c0
Show file tree

Hide file tree

Showing 2 changed files with 31 additions and 10 deletions.
diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Driver.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Driver.hs
@@ -35,6 +35,8 @@ import Control.Monad.Class.MonadThrow
 import Control.Monad.IOSim (runSimOrThrow)
 import Control.Tracer
 
+import Test.Ouroboros.Network.Orphans ()
+
 import Test.QuickCheck
 import Text.Show.Functions ()
 import Test.Tasty (TestTree, testGroup)
@@ -94,6 +96,12 @@ timeUnLimitsReqResp = ProtocolTimeLimits stateToLimit
 --
 
 
+data ShouldFail
+    = ShouldExceededTimeLimit
+    | ShouldExceededSizeLimit
+  deriving Eq
+
+
 -- |
 -- Run the server peer using @runPeerWithByteLimit@, which will receive requests
 -- with the given payloads.
@@ -117,9 +125,18 @@ prop_runPeerWithLimits tracer limit reqPayloads = do
               c2 sendPeer)
 
       case res :: Either ProtocolLimitFailure ([DiffTime], ()) of
-        Right _                -> pure $ shouldFail reqPayloads == Nothing
-        Left ExceededSizeLimit -> pure $ shouldFail reqPayloads == Just ExceededSizeLimit
-        Left ExceededTimeLimit -> pure $ shouldFail reqPayloads == Just ExceededTimeLimit
+        Right _ ->
+          pure $ shouldFail reqPayloads == Nothing
+        Left ExceededSizeLimit{} ->
+          pure $ case shouldFail reqPayloads of
+            Just ShouldExceededSizeLimit -> True
+            Just ShouldExceededTimeLimit -> False
+            Nothing -> False
+        Left ExceededTimeLimit{} ->
+          pure $ case shouldFail reqPayloads of
+            Just ShouldExceededTimeLimit -> True
+            Just ShouldExceededSizeLimit -> False
+            Nothing -> False
 
     where
       sendPeer :: Peer (ReqResp String ()) AsClient StIdle m [()]
@@ -136,19 +153,19 @@ prop_runPeerWithLimits tracer limit reqPayloads = do
 
       -- It is not enough to check if a testcase is expected to fail, we need to
       -- calculate which type of failure is going to happen first.
-      shouldFail ::  [(String, DiffTime)] -> Maybe ProtocolLimitFailure
+      shouldFail ::  [(String, DiffTime)] -> Maybe ShouldFail
       shouldFail [] =
           -- Check @MsgDone@ which is always sent
           let msgDone = encode (codecReqResp @String @() @m) (ClientAgency TokIdle) MsgDone in
           if length msgDone > fromIntegral limit
-             then Just ExceededSizeLimit
+             then Just ShouldExceededSizeLimit
              else Nothing
       shouldFail ((msg, delay):cmds) =
           let msg' = encode (codecReqResp @String @() @m) (ClientAgency TokIdle) (MsgReq msg) in
           if length msg' > fromIntegral limit 
-          then Just ExceededSizeLimit
+          then Just ShouldExceededSizeLimit
           else if delay >= serverTimeout
-          then Just ExceededTimeLimit
+          then Just ShouldExceededTimeLimit
           else shouldFail cmds
 
 data ReqRespPayloadWithLimit = ReqRespPayloadWithLimit Word (String, DiffTime)

diff --git a/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs
@@ -18,6 +18,7 @@ import           Data.Map (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Set (Set)
 import qualified Data.Set as Set
+import           Data.Typeable (Typeable)
 
 import           Control.Exception (assert)
 import           Control.Monad (forever)
@@ -190,7 +191,8 @@ exampleFixedPeerGSVs =
 
 runFetchClient :: (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
                    MonadST m, MonadTime m, MonadTimer m,
-                   Ord peerid, Serialise block, Serialise (HeaderHash block))
+                   Ord peerid, Serialise block, Serialise (HeaderHash block),
+                   Typeable block)
                 => Tracer m (TraceSendRecv (BlockFetch block))
                 -> FetchClientRegistry peerid header block m
                 -> peerid
@@ -209,7 +211,8 @@ runFetchClient tracer registry peerid channel client =
 runFetchServer :: (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
                    MonadST m, MonadTime m, MonadTimer m,
                    Serialise block,
-                   Serialise (HeaderHash block))
+                   Serialise (HeaderHash block),
+                   Typeable block)
                 => Tracer m (TraceSendRecv (BlockFetch block))
                 -> Channel m LBS.ByteString
                 -> BlockFetchServer block m a
@@ -225,7 +228,8 @@ runFetchClientAndServerAsync
                :: (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m),
                    MonadST m, MonadTime m, MonadTimer m, Ord peerid,
                    Serialise header, Serialise block,
-                   Serialise (HeaderHash block))
+                   Serialise (HeaderHash block),
+                   Typeable block)
                 => Tracer m (TraceSendRecv (BlockFetch block))
                 -> Tracer m (TraceSendRecv (BlockFetch block))
                 -> FetchClientRegistry peerid header block m