From 22cd4231b00436f710ad6ba537523aec2053a940 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 21 Sep 2020 11:40:35 +0200 Subject: [PATCH] block-fetch properties: introduced channel delay Thanks to this I discovered isuee #2622. --- .../Ouroboros/Network/BlockFetch/Examples.hs | 21 +++++++--- .../test/Test/Ouroboros/Network/BlockFetch.hs | 41 ++++++++++++------- 2 files changed, 43 insertions(+), 19 deletions(-) diff --git a/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs index 0d4ddc986d3..683bacb26cd 100644 --- a/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs +++ b/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,6 +250,8 @@ 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 @@ -251,17 +259,20 @@ runFetchClientAndServerAsync -> 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 diff --git a/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs index b5d9ac8d6b1..f9184aa7d1d 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs +++ b/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