@@ -5,6 +5,7 @@ module Main where
55import Control.Concurrent.MVar
66 ( MVar
77 , newEmptyMVar
8+ , newMVar
89 , putMVar
910 , takeMVar
1011 )
@@ -17,8 +18,6 @@ import Control.Distributed.Process.Node
1718 , closeLocalNode
1819 , LocalNode)
1920import Control.Exception as Ex (catch)
20−import Data.Binary()
21−import Data.Typeable()
2221import Network.Transport.TCP
2322import Prelude hiding (catch, log)
2423import Test.Framework
@@ -41,12 +40,22 @@ import System.Posix.Env
4140-- | A mutable cell containing a test result.
4241type TestResult a = MVar a
4342
44−delayedAssertion :: (Eq a) => String -> LocalNode -> a ->
45− (TestResult a -> Process ()) -> Assertion
46−delayedAssertion note localNode expected testProc = do
43+delayedAssertion :: (Eq a)
44+ => String
45+ -> LocalNode
46+ -> a
47+ -> (TestResult a -> Process ())
48+ -> MVar ()
49+ -> Assertion
50+delayedAssertion note localNode expected testProc lock = do
4751 result <- newEmptyMVar
48− _ <- forkProcess localNode $ testProc result
52+ _ <- forkProcess localNode $ do
53+ acquire lock
54+ finally (testProc result)
55+ (release lock)
4956 assertComplete note result expected
57+ where acquire lock' = liftIO $ takeMVar lock'
58+ release lock' = liftIO $ putMVar lock' ()
5059
5160assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()
5261assertComplete msg mv a = do
@@ -67,29 +76,36 @@ testSpawnTracing result = do
6776
6877 evSpawned <- liftIO $ newEmptyMVar
6978 evDied <- liftIO $ newEmptyMVar
70− startTracer $ \ev -> do
79+ tracer <- startTracer $ \ev -> do
80+ say "in spawn tracer..."
7181 case ev of
7282 (TraceEvSpawned p) -> liftIO $ putMVar evSpawned p
7383 (TraceEvDied p r) -> liftIO $ putMVar evDied (p, r)
7484 _ -> return ()
7585
7686 (sp, rp) <- newChan
77− pid <- spawnLocal $ do
78− sendChan sp ()
87+ pid <- spawnLocal $ sendChan sp ()
7988 () <- receiveChan rp
8089
8190 tracedAlive <- liftIO $ takeMVar evSpawned
8291 (tracedDead, tracedReason) <- liftIO $ takeMVar evDied
8392
84− stopTracer
93+ mref <- monitor tracer
94+ stopTracer -- this is asynchronous, so we need to wait...
95+ receiveWait [
96+ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)
97+ ((\_ -> return ()))
98+ ]
99+ say "seen the death of tracer"
85100 setTraceFlags defaultTraceFlags
101+ say "finishing setting default flags"
86102 stash result (tracedAlive == pid &&
87103 tracedDead == pid &&
88104 tracedReason == DiedNormal)
89105
90106testTraceRecvExplicitPid :: TestResult Bool -> Process ()
91107testTraceRecvExplicitPid result = do
92− say "testTraceRecvExplicitPid"
108+ res <- liftIO $ newEmptyMVar
93109 pid <- spawnLocal $ do
94110 self <- getSelfPid
95111 expect >>= (flip sendChan) self
@@ -99,19 +115,18 @@ testTraceRecvExplicitPid result = do
99115 withTracer
100116 (\ev ->
101117 case ev of
102− (TraceEvReceived pid' _) -> stash result (pid == pid')
118+ (TraceEvReceived pid' _) -> stash res (pid == pid')
103119 _ -> return ()) $ do
104120 (sp, rp) <- newChan
105121 send pid sp
106122 p <- receiveChan rp
107− res <- liftIO $ takeMVar result
108− stash result (res && (p == pid))
109− say "Explicit done!!!"
123+ res' <- liftIO $ takeMVar res
124+ stash result (res' && (p == pid))
110125 return ()
111126
112127testTraceRecvNamedPid :: TestResult Bool -> Process ()
113128testTraceRecvNamedPid result = do
114− say "testTraceRecvNamedPid"
129+ res <- liftIO $ newEmptyMVar
115130 pid <- spawnLocal $ do
116131 self <- getSelfPid
117132 register "foobar" self
@@ -122,98 +137,85 @@ testTraceRecvNamedPid result = do
122137 withTracer
123138 (\ev ->
124139 case ev of
125− (TraceEvReceived pid' _) -> stash result (pid == pid')
140+ (TraceEvReceived pid' _) -> stash res (pid == pid')
126141 _ -> return ()) $ do
127142 (sp, rp) <- newChan
128143 send pid sp
129144 p <- receiveChan rp
130− res <- liftIO $ takeMVar result
131− stash result (res && (p == pid))
145+ res' <- liftIO $ takeMVar res
146+ stash result (res' && (p == pid))
132147 return ()
133148
134−data TraceWhat = User | Die | Rec
135− deriving (Show)
136−
137149testTraceLayering :: TestResult () -> Process ()
138150testTraceLayering result = do
139151 pid <- spawnLocal $ do
140152 getSelfPid >>= register "foobar"
141− say "registered - waiting for 'hello'"
142− "hello" <- expect
143− say "received 'hello' - waiting for () go"
144− p <- expect
145− say "pid received - sending trace msg"
146− traceMessage ("traceMsg", 123 :: Int)
147− say "sending reply"
148− send p ()
149153 () <- expect
154+ traceMessage ("traceMsg", 123 :: Int)
150155 return ()
151156 withFlags defaultTraceFlags {
152− traceDied = traceOnly ["foobar"]
153− , traceRecv = traceOnly [pid]
157+ traceDied = traceOnly [pid]
158+ , traceRecv = traceOnly ["foobar"]
154159 } $ doTest pid result
155160 return ()
156161 where
157162 doTest :: ProcessId -> MVar () -> Process ()
158163 doTest pid result' = do
159− go Die $ do
160− go Rec $ do
161− say "sending 'hello'"
162− send pid "hello"
163− go User $ do
164− getSelfPid >>= send pid
165− () <- expect
166− say "received reply, returning to rec block"
167− return ()
164+ -- TODO: this is pretty gross, even for a test case
165+ died <- liftIO $ newEmptyMVar
166+ withTracer
167+ (\ev ->
168+ case ev of
169+ TraceEvDied _ _ -> liftIO $ putMVar died ()
170+ _ -> return ())
171+ ( do {
172+ recv <- liftIO $ newEmptyMVar
173+ ; withTracer
174+ (\ev' ->
175+ case ev' of
176+ TraceEvReceived _ _ -> liftIO $ putMVar recv ()
177+ _ -> return ())
178+ ( do {
179+ user <- liftIO $ newEmptyMVar
180+ ; withTracer
181+ (\ev'' ->
182+ case ev'' of
183+ TraceEvUser _ -> liftIO $ putMVar user ()
184+ _ -> return ())
185+ (send pid () >> (liftIO $ takeMVar user))
186+ ; liftIO $ takeMVar recv
187+ })
188+ ; liftIO $ takeMVar died
189+ })
168190 liftIO $ putMVar result' ()
169191
170− go :: TraceWhat -> Process () -> Process ()
171− go what proc = do {
172− say ("tracing " ++ (show what))
173− ; mv <- liftIO $ newEmptyMVar
174− ; r <- (withTracer
175− (\ev ->
176− case (matchTest what ev) of
177− True -> do
178− say ("matched " ++ (show ev))
179− liftIO $ putMVar mv ()
180− False -> say ("ignoring " ++ (show ev))) $ do
181− say ("in block for " ++ (show what))
182− proc)
183− ; case r of
184− Left e -> say "whoops"
185− Right _ -> say "ok!" >> (liftIO $ takeMVar mv)
186− }
187−
188− matchTest :: TraceWhat -> TraceEvent -> Bool
189− matchTest User (TraceEvUser _) = True
190− matchTest Die (TraceEvDied _ _) = True
191− matchTest Rec (TraceEvReceived _ _) = True
192− matchTest _ _ = False
193−
194192tests :: LocalNode -> IO [Test]
195193tests node1 = do
194+ -- if we execute the test cases in parallel, the
195+ -- various tracers will race with one another and
196+ -- we'll get garbage results (or worse, deadlocks)
197+ lock <- liftIO $ newMVar ()
196198 enabled <- checkTraceEnabled
197199 case enabled of
198200 True ->
199201 return [
200− testGroup "Process Info" [
201− testCase "Test Spawn Tracing"
202+ testGroup "Tracing" [
203+ testCase "Spawn Tracing"
202204 (delayedAssertion
203205 "expected dead process-info to be ProcessInfoNone"
204− node1 True testSpawnTracing)
205− , testCase "Test Recv Tracing (Explicit Pid)"
206+ node1 True testSpawnTracing lock)
207+ , testCase "Recv Tracing (Explicit Pid)"
206208 (delayedAssertion
207209 "expected a recv trace for the supplied pid"
208− node1 True testTraceRecvExplicitPid)
209− , testCase "Test Recv Tracing (Named Pid)"
210+ node1 True testTraceRecvExplicitPid lock)
211+ , testCase "Recv Tracing (Named Pid)"
210212 (delayedAssertion
211213 "expected a recv trace for the process registered as 'foobar'"
212− node1 True testTraceRecvNamedPid)
213− , testCase "Test Trace Layering"
214+ node1 True testTraceRecvNamedPid lock)
215+ , testCase "Trace Layering"
214216 (delayedAssertion
215217 "expected blah"
216− node1 () testTraceLayering)
218+ node1 () testTraceLayering lock)
217219 ] ]
218220 False ->
219221 return []