1d06898 · distributed-process

git.iko.soy/distributed-process

on master help sign in

try a bit harder to avoid races in the tests...

1d06898Tim Watson8 years ago

distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs+11−3

compare with master

unifiedsplit

@@ -20,6 +20,7 @@ module Control.Distributed.Process.Tests.Internal.Utils

20 -- ping !

21 , Ping(Ping)

22 , ping

23+ , pause

23 , shouldBe

24 , shouldBe

24 , shouldMatch

25 , shouldMatch

25 , shouldContain

26 , shouldContain

@@ -78,10 +79,10 @@ import Control.Distributed.Process.Node

78import Control.Distributed.Process.Serializable()

79import Control.Distributed.Process.Serializable()

80import Control.Exception (AsyncException(ThreadKilled), SomeException)

81import Control.Exception (AsyncException(ThreadKilled), SomeException)

81−import Control.Monad (forever)

82+import Control.Monad (forever, void)

82import Control.Monad.STM (atomically)

83import Control.Monad.STM (atomically)

83import Control.Rematch hiding (match)

84import Control.Rematch hiding (match)

84−import Control.Rematch.Run

85+import Control.Rematch.Run

85import Data.Binary

86import Data.Binary

86import Data.Typeable (Typeable)

87import Data.Typeable (Typeable)

@@ -107,10 +108,18 @@ data TestProcessControl = Stop | Go | Report ProcessId

107

108

108instance Binary TestProcessControl where

109instance Binary TestProcessControl where

109

110

111+data Private = Private

112+ deriving (Typeable, Generic)

113+instance Binary Private where

114+

110-- | Does exactly what it says on the tin, doing so in the @Process@ monad.

115-- | Does exactly what it says on the tin, doing so in the @Process@ monad.

111noop :: Process ()

116noop :: Process ()

112noop = return ()

117noop = return ()

113

118

119+pause :: Int -> Process ()

120+pause delay =

121+ void $ receiveTimeout delay [ match (\Private -> return ()) ]

122+

114synchronisedAssertion :: Eq a

123synchronisedAssertion :: Eq a

115 => String

124 => String

116 -> LocalNode

125 -> LocalNode

@@ -229,4 +238,3 @@ tryForkProcess :: LocalNode -> Process () -> IO ProcessId

229tryForkProcess node p = do

238tryForkProcess node p = do

230 tid <- liftIO myThreadId

239 tid <- liftIO myThreadId

231 forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))

240 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

23 , mxBroadcast

24 , mxGetId

25 )

26−import Control.Monad (void)

26+import Control.Monad (void, unless)

27import Control.Rematch (equalTo)

28import Data.Binary

29import Data.List (find, sort)

30−import Data.Maybe (isJust)

30+import Data.Maybe (isJust, isNothing)

31import Data.Typeable

32import GHC.Generics

33#if ! MIN_VERSION_base(4,6,0)

@@ -141,6 +141,8 @@ testAgentMailboxHandling result = do

141testAgentEventHandling :: TestResult Bool -> Process ()

142testAgentEventHandling result = do

143 let initState = [] :: [MxEvent]

144+

145+ (rc, rs) <- newChan

144 agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [

146 agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [

145 (mxSink $ \ev -> do

147 (mxSink $ \ev -> do

146 st <- mxGetLocal

148 st <- mxGetLocal

@@ -149,7 +151,7 @@ testAgentEventHandling result = do

149 (MxSpawned _) -> mxSetLocal (ev:st)

151 (MxSpawned _) -> mxSetLocal (ev:st)

150 (MxProcessDied _ _) -> mxSetLocal (ev:st)

152 (MxProcessDied _ _) -> mxSetLocal (ev:st)

151 _ -> return ()

153 _ -> return ()

152− act >> mxReady),

154+ act >> (liftMX $ sendChan rc ()) >> mxReady),

153 (mxSink $ \(ev, sp :: SendPort Bool) -> do

155 (mxSink $ \(ev, sp :: SendPort Bool) -> do

154 st <- mxGetLocal

156 st <- mxGetLocal

155 let found =

157 let found =

@@ -169,16 +171,26 @@ testAgentEventHandling result = do

169 mxReady)

171 mxReady)

170 ]

172 ]

171

173

174+ -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

175+ faff 2000000 rs

176+

172 _ <- monitor agentPid

177 _ <- monitor agentPid

173 (sp, rp) <- newChan

178 (sp, rp) <- newChan

179+

174− pid <- spawnLocal $ sendChan sp ()

180+ pid <- spawnLocal $ expect >>= sendChan sp

175− () <- receiveChan rp

176

181

177 -- By waiting for a monitor notification, we have a

182 -- 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

179 monitor pid

184 monitor pid

185+

186+ send pid ()

187+ () <- receiveChan rp

188+

180 receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ]

189 receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ]

181

190

191+ -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

192+ faff 2000000 rs

193+

182 (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

194 (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

183 mxNotify (MxSpawned pid, replyTo)

195 mxNotify (MxSpawned pid, replyTo)

184 mxNotify (MxProcessDied pid DiedNormal, replyTo)

196 mxNotify (MxProcessDied pid DiedNormal, replyTo)

@@ -188,6 +200,12 @@ testAgentEventHandling result = do

188

200

189 stash result $ seenAlive && seenDead

201 stash result $ seenAlive && seenDead

190 kill agentPid "test-complete" >> awaitExit agentPid

202 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

191

209

192testMxRegEvents :: TestResult () -> Process ()

210testMxRegEvents :: TestResult () -> Process ()

193testMxRegEvents result = do

211testMxRegEvents result = do