git.iko.soy/distributed-process
on master help sign in
try a bit harder to avoid races in the tests...
commit1d06898fd7a98bc11a3f3f0a92aad5a48a715e70 authorTim Watson <watson.timothy@gmail.com> dateTue 13 Nov 2018, 01:40 (8 years ago) parent7254c4b
2 files changed+35−9
compare with master
unifiedsplit
distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs+11−3 distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs+24−6
distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs+11−3
@@ -20,6 +20,7 @@ module Control.Distributed.Process.Tests.Internal.Utils
2020 -- ping !
2121 , Ping(Ping)
2222 , ping
23+ , pause
2324 , shouldBe
2425 , shouldMatch
2526 , shouldContain
@@ -78,10 +79,10 @@ import Control.Distributed.Process.Node
7879import Control.Distributed.Process.Serializable()
7980
8081import Control.Exception (AsyncException(ThreadKilled), SomeException)
81−import Control.Monad (forever)
82+import Control.Monad (forever, void)
8283import Control.Monad.STM (atomically)
8384import Control.Rematch hiding (match)
84−import Control.Rematch.Run
85+import Control.Rematch.Run
8586import Data.Binary
8687import Data.Typeable (Typeable)
8788
@@ -107,10 +108,18 @@ data TestProcessControl = Stop | Go | Report ProcessId
107108
108109instance Binary TestProcessControl where
109110
111+data Private = Private
112+ deriving (Typeable, Generic)
113+instance Binary Private where
114+
110115-- | Does exactly what it says on the tin, doing so in the @Process@ monad.
111116noop :: Process ()
112117noop = return ()
113118
119+pause :: Int -> Process ()
120+pause delay =
121+ void $ receiveTimeout delay [ match (\Private -> return ()) ]
122+
114123synchronisedAssertion :: Eq a
115124 => String
116125 -> LocalNode
@@ -229,4 +238,3 @@ tryForkProcess :: LocalNode -> Process () -> IO ProcessId
229238tryForkProcess node p = do
230239 tid <- liftIO myThreadId
231240 forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
232−
distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs+24−6
@@ -23,11 +23,11 @@ import Control.Distributed.Process.Management
2323 , mxBroadcast
2424 , mxGetId
2525 )
26−import Control.Monad (void)
26+import Control.Monad (void, unless)
2727import Control.Rematch (equalTo)
2828import Data.Binary
2929import Data.List (find, sort)
30−import Data.Maybe (isJust)
30+import Data.Maybe (isJust, isNothing)
3131import Data.Typeable
3232import GHC.Generics
3333#if ! MIN_VERSION_base(4,6,0)
@@ -141,6 +141,8 @@ testAgentMailboxHandling result = do
141141testAgentEventHandling :: TestResult Bool -> Process ()
142142testAgentEventHandling result = do
143143 let initState = [] :: [MxEvent]
144+
145+ (rc, rs) <- newChan
144146 agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [
145147 (mxSink $ \ev -> do
146148 st <- mxGetLocal
@@ -149,7 +151,7 @@ testAgentEventHandling result = do
149151 (MxSpawned _) -> mxSetLocal (ev:st)
150152 (MxProcessDied _ _) -> mxSetLocal (ev:st)
151153 _ -> return ()
152− act >> mxReady),
154+ act >> (liftMX $ sendChan rc ()) >> mxReady),
153155 (mxSink $ \(ev, sp :: SendPort Bool) -> do
154156 st <- mxGetLocal
155157 let found =
@@ -169,16 +171,26 @@ testAgentEventHandling result = do
169171 mxReady)
170172 ]
171173
174+ -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...
175+ faff 2000000 rs
176+
172177 _ <- monitor agentPid
173178 (sp, rp) <- newChan
174− pid <- spawnLocal $ sendChan sp ()
175− () <- receiveChan rp
179+
180+ pid <- spawnLocal $ expect >>= sendChan sp
176181
177182 -- By waiting for a monitor notification, we have a
178− -- higher probably that the agent has seen
183+ -- higher probably that the agent has seen the spawn and died events
179184 monitor pid
185+
186+ send pid ()
187+ () <- receiveChan rp
188+
180189 receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ]
181190
191+ -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...
192+ faff 2000000 rs
193+
182194 (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)
183195 mxNotify (MxSpawned pid, replyTo)
184196 mxNotify (MxProcessDied pid DiedNormal, replyTo)
@@ -188,6 +200,12 @@ testAgentEventHandling result = do
188200
189201 stash result $ seenAlive && seenDead
190202 kill agentPid "test-complete" >> awaitExit agentPid
203+ where
204+ faff delay port = do
205+ res <- receiveChanTimeout delay port
206+ unless (isNothing res) $ do
207+ pause delay
208+ faff delay port
191209
192210testMxRegEvents :: TestResult () -> Process ()
193211testMxRegEvents result = do