block-fetch properties: introduced channel delay

Thanks to this I discovered isuee #2622.

ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs

@@ -16,7 +16,7 @@ import qualified Data.ByteString.Lazy as LBS
 import           Data.List (foldl')
 import           Data.Map (Map)
 import qualified Data.Map.Strict as Map
-import           Data.Proxy (Proxy (..))
+import           Data.Maybe (fromMaybe)
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Typeable (Typeable)
@@ -41,7 +41,7 @@ import qualified Ouroboros.Network.ChainFragment as ChainFragment
 
 import           Network.TypedProtocol.Core
 import           Network.TypedProtocol.Pipelined
-import           Ouroboros.Network.Mux (continueForever)
+import           Ouroboros.Network.Mux (ControlMessageSTM)
 
 import           Ouroboros.Network.Channel
 import           Ouroboros.Network.Driver
@@ -80,10 +80,15 @@ blockFetchExample1 :: forall m.
                                  (TraceFetchClientState BlockHeader))
                    -> Tracer m (TraceLabelPeer Int
                                  (TraceSendRecv (BlockFetch Block)))
+                   -> Maybe DiffTime -- ^ client's channel delay
+                   -> Maybe DiffTime -- ^ server's channel delay
+                   -> ControlMessageSTM m
                    -> AnchoredFragment Block   -- ^ Fixed current chain
                    -> [AnchoredFragment Block] -- ^ Fixed candidate chains
                    -> m ()
 blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer
+                   clientDelay serverDelay
+                   controlMessageSTM
                    currentChain candidateChains = do
 
     registry    <- newFetchClientRegistry
@@ -93,8 +98,9 @@ blockFetchExample1 decisionTracer clientStateTracer clientMsgTracer
                     [ runFetchClientAndServerAsync
                         (contramap (TraceLabelPeer peerno) clientMsgTracer)
                         (contramap (TraceLabelPeer peerno) serverMsgTracer)
+                        clientDelay serverDelay
                         registry peerno
-                        (blockFetchClient NodeToNodeV_1 (continueForever (Proxy :: Proxy m)))
+                        (blockFetchClient NodeToNodeV_1 controlMessageSTM)
                         (mockBlockFetchServer1 (unanchorFragment candidateChain))
                     | (peerno, candidateChain) <- zip [1..] candidateChains
                     ]
@@ -244,24 +250,29 @@ runFetchClientAndServerAsync
                    ShowProxy block)
                 => Tracer m (TraceSendRecv (BlockFetch block))
                 -> Tracer m (TraceSendRecv (BlockFetch block))
+                -> Maybe DiffTime -- ^ client's channel delay
+                -> Maybe DiffTime -- ^ server's channel delay
                 -> FetchClientRegistry peerid header block m
                 -> peerid
                 -> (  FetchClientContext header block m
                    -> PeerPipelined (BlockFetch block) AsClient BFIdle m a)
                 -> BlockFetchServer block m b
                 -> m (Async m a, Async m b, Async m (), Async m ())
 runFetchClientAndServerAsync clientTracer serverTracer
+                             clientDelay  serverDelay
                              registry peerid client server = do
     (clientChannel, serverChannel) <- createConnectedChannels
 
     clientAsync <- async $ runFetchClient
                              clientTracer
                              registry peerid
-                             clientChannel client
+                             (fromMaybe id (delayChannel <$> clientDelay) clientChannel)
+                             client
 
     serverAsync <- async $ runFetchServer
                              serverTracer
-                             serverChannel server
+                             (fromMaybe id (delayChannel <$> serverDelay) serverChannel)
+                             server
 
     -- we are tagging messages with the current peerid, not the target
     -- one, this is different than what's intended but it's fine to do that in

ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs

@@ -16,6 +16,7 @@ import           Data.List
 import           Data.Map (Map)
 import qualified Data.Map as Map
 import           Data.Maybe (mapMaybe)
+import           Data.Proxy (Proxy (..))
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Typeable (Typeable)
@@ -40,6 +41,7 @@ import           Ouroboros.Network.BlockFetch.ClientRegistry
 import           Ouroboros.Network.BlockFetch.ClientState
 import           Ouroboros.Network.BlockFetch.Examples
 import qualified Ouroboros.Network.MockChain.Chain as Chain
+import           Ouroboros.Network.Mux (continueForever)
 import           Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch)
 import           Ouroboros.Network.Testing.ConcreteBlock
 
@@ -89,13 +91,7 @@ tests = testGroup "BlockFetch"
 --
 prop_blockFetchStaticNoOverlap :: TestChainFork -> Property
 prop_blockFetchStaticNoOverlap (TestChainFork common fork1 fork2) =
-    let trace = selectTraceEventsDynamic $
-                runSimTrace $
-                  blockFetchExample1
-                    (contramap TraceFetchDecision       dynamicTracer)
-                    (contramap TraceFetchClientState    dynamicTracer)
-                    (contramap TraceFetchClientSendRecv dynamicTracer)
-                    common' forks
+    let trace = selectTraceEventsDynamic (runSimTrace simulation)
 
      in counterexample ("\nTrace:\n" ++ unlines (map show trace)) $
 
@@ -110,6 +106,16 @@ prop_blockFetchStaticNoOverlap (TestChainFork common fork1 fork2) =
    .&&. tracePropertyInFlight trace
 
   where
+    simulation :: SimM s ()
+    simulation =
+      blockFetchExample1
+        (contramap TraceFetchDecision       dynamicTracer)
+        (contramap TraceFetchClientState    dynamicTracer)
+        (contramap TraceFetchClientSendRecv dynamicTracer)
+        Nothing Nothing
+        (continueForever (Proxy :: Proxy (SimM s)))
+        common' forks
+
     -- TODO: consider making a specific generator for anchored fragment forks
     common' = chainToAnchoredFragment common
     fork1'  = chainToAnchoredFragment fork1
@@ -138,15 +144,11 @@ prop_blockFetchStaticNoOverlap (TestChainFork common fork1 fork2) =
 -- * 'tracePropertyClientStateSanity'
 -- * 'tracePropertyInFlight'
 --
+-- TODO: 'prop_blockFetchStaticWithOverlap' fails if we introduce delays. issue #2622
+--
 prop_blockFetchStaticWithOverlap :: TestChainFork -> Property
 prop_blockFetchStaticWithOverlap (TestChainFork _common fork1 fork2) =
-    let trace = selectTraceEventsDynamic $
-                runSimTrace $
-                  blockFetchExample1
-                    (contramap TraceFetchDecision       dynamicTracer)
-                    (contramap TraceFetchClientState    dynamicTracer)
-                    (contramap TraceFetchClientSendRecv dynamicTracer)
-                    (AnchoredFragment.Empty AnchoredFragment.AnchorGenesis) forks
+    let trace = selectTraceEventsDynamic (runSimTrace simulation)
 
      in counterexample ("\nTrace:\n" ++ unlines (map show trace)) $
 
@@ -165,6 +167,17 @@ prop_blockFetchStaticWithOverlap (TestChainFork _common fork1 fork2) =
    .&&. tracePropertyInFlight trace
 
   where
+    simulation :: forall s. SimM s ()
+    simulation =
+      blockFetchExample1
+        (contramap TraceFetchDecision       dynamicTracer)
+        (contramap TraceFetchClientState    dynamicTracer)
+        (contramap TraceFetchClientSendRecv dynamicTracer)
+        Nothing Nothing
+        (continueForever (Proxy :: Proxy (SimM s)))
+        (AnchoredFragment.Empty AnchoredFragment.AnchorGenesis)
+        forks
+
     -- TODO: consider making a specific generator for anchored fragment forks
     fork1'  = chainToAnchoredFragment fork1
     fork2'  = chainToAnchoredFragment fork2