git.iko.soy/distributed-process
on 6dfd5b1 help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs
419 lines 15 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Control.Distributed.Process.Tests.Tracing (tests) where
5import Control.Distributed.Process.Tests.Internal.Utils
6import Network.Transport.Test (TestTransport(..))
8import Control.Applicative ((<*))
9import Control.Concurrent (threadDelay)
10import Control.Concurrent.MVar
11 ( MVar
12 , newEmptyMVar
13 , newMVar
14 , putMVar
15 , takeMVar
16 )
17import Control.Distributed.Process
18import Control.Distributed.Process.Node
19import Control.Distributed.Process.Debug
20import Control.Distributed.Process.Management
21 ( MxEvent(..)
22 )
23import qualified Control.Exception as IO (bracket)
24import Data.List (isPrefixOf, isSuffixOf)
26#if ! MIN_VERSION_base(4,6,0)
27import Prelude hiding (catch, log)
28#else
29import Prelude hiding ((<*))
30#endif
32import Test.Framework
33 ( Test
34 , testGroup
35 )
36import Test.Framework.Providers.HUnit (testCase)
37import System.Environment (getEnvironment)
38-- These are available in System.Environment only since base 4.7
39import System.SetEnv (setEnv, unsetEnv)
42testSpawnTracing :: TestResult Bool -> Process ()
43testSpawnTracing result = do
44 setTraceFlags defaultTraceFlags {
45 traceSpawned = (Just TraceAll)
46 , traceDied = (Just TraceAll)
47 }
49 evSpawned <- liftIO $ newEmptyMVar
50 evDied <- liftIO $ newEmptyMVar
51 tracer <- startTracer $ \ev -> do
52 case ev of
53 (MxSpawned p) -> liftIO $ putMVar evSpawned p
54 (MxProcessDied p r) -> liftIO $ putMVar evDied (p, r)
55 _ -> return ()
57 (sp, rp) <- newChan
58 pid <- spawnLocal $ sendChan sp ()
59 () <- receiveChan rp
61 tracedAlive <- liftIO $ takeMVar evSpawned
62 (tracedDead, tracedReason) <- liftIO $ takeMVar evDied
64 mref <- monitor tracer
65 stopTracer -- this is asynchronous, so we need to wait...
66 receiveWait [
67 matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)
68 ((\_ -> return ()))
69 ]
70 setTraceFlags defaultTraceFlags
71 stash result (tracedAlive == pid &&
72 tracedDead == pid &&
73 tracedReason == DiedNormal)
75testTraceRecvExplicitPid :: TestResult Bool -> Process ()
76testTraceRecvExplicitPid result = do
77 res <- liftIO $ newEmptyMVar
78 pid <- spawnLocal $ do
79 self <- getSelfPid
80 expect >>= (flip sendChan) self
81 withFlags defaultTraceFlags {
82 traceRecv = traceOnly [pid]
83 } $ do
84 withTracer
85 (\ev ->
86 case ev of
87 (MxReceived pid' _) -> stash res (pid == pid')
88 _ -> return ()) $ do
89 (sp, rp) <- newChan
90 send pid sp
91 p <- receiveChan rp
92 res' <- liftIO $ takeMVar res
93 stash result (res' && (p == pid))
94 return ()
96testTraceRecvNamedPid :: TestResult Bool -> Process ()
97testTraceRecvNamedPid result = do
98 res <- liftIO $ newEmptyMVar
99 pid <- spawnLocal $ do
100 self <- getSelfPid
101 register "foobar" self
102 expect >>= (flip sendChan) self
103 withFlags defaultTraceFlags {
104 traceRecv = traceOnly ["foobar"]
105 } $ do
106 withTracer
107 (\ev ->
108 case ev of
109 (MxReceived pid' _) -> stash res (pid == pid')
110 _ -> return ()) $ do
111 (sp, rp) <- newChan
112 send pid sp
113 p <- receiveChan rp
114 res' <- liftIO $ takeMVar res
115 stash result (res' && (p == pid))
116 return ()
118testTraceSending :: TestResult Bool -> Process ()
119testTraceSending result = do
120 pid <- spawnLocal $ (expect :: Process String) >> return ()
121 self <- getSelfPid
122 res <- liftIO $ newEmptyMVar
123 withFlags defaultTraceFlags { traceSend = traceOn } $ do
124 withTracer
125 (\ev ->
126 case ev of
127 (MxSent to from msg) -> do
128 (Just s) <- unwrapMessage msg :: Process (Maybe String)
129 stash res (to == pid && from == self && s == "hello there")
130 stash res (to == pid && from == self)
131 _ ->
132 return ()) $ do
133 send pid "hello there"
134 res' <- liftIO $ takeMVar res
135 stash result res'
137testTraceRegistration :: TestResult Bool -> Process ()
138testTraceRegistration result = do
139 (sp, rp) <- newChan
140 pid <- spawnLocal $ do
141 self <- getSelfPid
142 () <- expect
143 register "foobar" self
144 sendChan sp ()
145 () <- expect
146 return ()
147 res <- liftIO $ newEmptyMVar
148 withFlags defaultTraceFlags { traceRegistered = traceOn } $ do
149 withTracer
150 (\ev ->
151 case ev of
152 MxRegistered p s ->
153 stash res (p == pid && s == "foobar")
154 _ ->
155 return ()) $ do
156 _ <- monitor pid
157 send pid ()
158 () <- receiveChan rp
159 send pid ()
160 receiveWait [
161 match (\(ProcessMonitorNotification _ _ _) -> return ())
162 ]
163 res' <- liftIO $ takeMVar res
164 stash result res'
166testTraceUnRegistration :: TestResult Bool -> Process ()
167testTraceUnRegistration result = do
168 pid <- spawnLocal $ do
169 () <- expect
170 unregister "foobar"
171 () <- expect
172 return ()
173 register "foobar" pid
174 res <- liftIO $ newEmptyMVar
175 withFlags defaultTraceFlags { traceUnregistered = traceOn } $ do
176 withTracer
177 (\ev ->
178 case ev of
179 MxUnRegistered p n -> do
180 stash res (p == pid && n == "foobar")
181 send pid ()
182 _ ->
183 return ()) $ do
184 mref <- monitor pid
185 send pid ()
186 receiveWait [
187 matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')
188 (\_ -> return ())
189 ]
190 res' <- liftIO $ takeMVar res
191 stash result res'
193testTraceLayering :: TestResult () -> Process ()
194testTraceLayering result = do
195 pid <- spawnLocal $ do
196 getSelfPid >>= register "foobar"
197 () <- expect
198 traceMessage ("traceMsg", 123 :: Int)
199 return ()
200 withFlags defaultTraceFlags {
201 traceDied = traceOnly [pid]
202 , traceRecv = traceOnly ["foobar"]
203 } $ doTest pid result
204 return ()
205 where
206 doTest :: ProcessId -> MVar () -> Process ()
207 doTest pid result' = do
208 -- TODO: this is pretty gross, even for a test case
209 died <- liftIO $ newEmptyMVar
210 withTracer
211 (\ev ->
212 case ev of
213 MxProcessDied _ _ -> liftIO $ putMVar died ()
214 _ -> return ())
215 ( do {
216 recv <- liftIO $ newEmptyMVar
217 ; withTracer
218 (\ev' ->
219 case ev' of
220 MxReceived _ _ -> liftIO $ putMVar recv ()
221 _ -> return ())
222 ( do {
223 user <- liftIO $ newEmptyMVar
224 ; withTracer
225 (\ev'' ->
226 case ev'' of
227 MxUser _ -> liftIO $ putMVar user ()
228 _ -> return ())
229 (send pid () >> (liftIO $ takeMVar user))
230 ; liftIO $ takeMVar recv
231 })
232 ; liftIO $ takeMVar died
233 })
234 liftIO $ putMVar result' ()
236testRemoteTraceRelay :: TestTransport -> TestResult Bool -> Process ()
237testRemoteTraceRelay TestTransport{..} result =
238 let flags = defaultTraceFlags { traceSpawned = traceOn }
239 in do
240 node2 <- liftIO $ newLocalNode testTransport initRemoteTable
241 mvNid <- liftIO $ newEmptyMVar
243 -- As well as needing node2's NodeId, we want to
244 -- redirect all its logs back here, to avoid generating
245 -- garbage on stderr for the duration of the test run.
246 -- Here we set up that relay, and then wait for a signal
247 -- that the tracer (on node1) has seen the expected
248 -- MxSpawned message, at which point we're finished
249 (Just log') <- whereis "logger"
250 pid <- liftIO $ forkProcess node2 $ do
251 logRelay <- spawnLocal $ relay log'
252 reregister "logger" logRelay
253 getSelfNode >>= stash mvNid >> (expect :: Process ())
255 nid <- liftIO $ takeMVar mvNid
256 mref <- monitor pid
257 observedPid <- liftIO $ newEmptyMVar
258 spawnedPid <- liftIO $ newEmptyMVar
259 setTraceFlagsRemote flags nid
261 withFlags defaultTraceFlags { traceSpawned = traceOn } $ do
262 withTracer
263 (\ev ->
264 case ev of
265 MxSpawned p -> stash observedPid p >> send pid ()
266 _ -> return ()) $ do
267 relayPid <- startTraceRelay nid
268 liftIO $ threadDelay 1000000
269 p <- liftIO $ forkProcess node2 $ do
270 expectTimeout 1000000 :: Process (Maybe ())
271 return ()
272 stash spawnedPid p
274 -- Now we wait for (the outer) pid to exit. This won't happen until
275 -- our tracer has seen the trace event for `p' and sent `p' the
276 -- message it's waiting for prior to exiting
277 receiveWait [
278 matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')
279 (\_ -> return ())
280 ]
282 relayRef <- monitor relayPid
283 kill relayPid "stop"
284 receiveWait [
285 matchIf (\(ProcessMonitorNotification rref' _ _) -> rref' == relayRef)
286 (\_ -> return ())
287 ]
288 observed <- liftIO $ takeMVar observedPid
289 expected <- liftIO $ takeMVar spawnedPid
290 stash result (observed == expected)
291 -- and just to be polite...
292 liftIO $ closeLocalNode node2
294-- | Sets the value of an environment variable while executing the given IO
295-- computation and restores the preceeding value upon completion.
296withEnv :: String -> String -> IO a -> IO a
297withEnv var val =
298 IO.bracket (fmap (lookup var) getEnvironment <* setEnv var val)
299 (maybe (unsetEnv var) (setEnv var))
300 . const
302-- | Tests that one and only one interesting trace message is produced when a
303-- given action is performed. A message is considered interesting when the given
304-- function return @True@.
305testSystemLoggerMsg :: TestTransport
306 -> Process a
307 -> (a -> String -> Bool)
308 -> IO ()
309testSystemLoggerMsg t action interestingMessage =
310 withEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" "yes" $
311 withEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" "pdnusrl" $ do
312 n <- newLocalNode (testTransport t) initRemoteTable
314 runProcess n $ do
315 self <- getSelfPid
316 reregister "trace.logger" self
317 a <- action
318 let interestingMessage' (_ :: String, msg) = interestingMessage a msg
319 -- Wait for the trace message.
320 receiveWait [ matchIf interestingMessage' $ const $ return () ]
321 -- Only one interesting message should arrive.
322 Nothing <- receiveTimeout 100000
323 [ matchIf interestingMessage' $ const $ return () ]
324 return ()
327-- | Tests that one and only one trace message is produced when a message is
328-- received.
329testSystemLoggerMxReceive :: TestTransport -> IO ()
330testSystemLoggerMxReceive t = testSystemLoggerMsg t
331 (getSelfPid >>= flip send ())
332 (\_ msg -> "MxReceived" `isPrefixOf` msg
333 -- discard traces of internal messages
334 && not (":: RegisterReply" `isSuffixOf` msg)
335 )
337-- | Tests that one and only one trace message is produced when a message is
338-- sent.
339testSystemLoggerMxSent :: TestTransport -> IO ()
340testSystemLoggerMxSent t = testSystemLoggerMsg t
341 (getSelfPid >>= flip send ())
342 (const $ isPrefixOf "MxSent")
344-- | Tests that one and only one trace message is produced when a process dies.
345testSystemLoggerMxProcessDied :: TestTransport -> IO ()
346testSystemLoggerMxProcessDied t = testSystemLoggerMsg t
347 (spawnLocal $ return ())
348 (\pid -> isPrefixOf $ "MxProcessDied " ++ show pid)
350-- | Tests that one and only one trace message appears when a process spawns.
351testSystemLoggerMxSpawned :: TestTransport -> IO ()
352testSystemLoggerMxSpawned t = testSystemLoggerMsg t
353 (spawnLocal $ return ())
354 (\pid -> isPrefixOf $ "MxSpawned " ++ show pid)
356-- | Tests that one and only one trace message appears when a process is
357-- registered.
358testSystemLoggerMxRegistered :: TestTransport -> IO ()
359testSystemLoggerMxRegistered t = testSystemLoggerMsg t
360 (getSelfPid >>= register "a" >> getSelfPid)
361 (\self -> isPrefixOf $ "MxRegistered " ++ show self ++ " " ++ show "a")
363-- | Tests that one and only one trace message appears when a process is
364-- unregistered.
365testSystemLoggerMxUnRegistered :: TestTransport -> IO ()
366testSystemLoggerMxUnRegistered t = testSystemLoggerMsg t
367 (getSelfPid >>= register "a" >> unregister "a" >> getSelfPid)
368 (\self -> isPrefixOf $ "MxUnRegistered " ++ show self ++ " " ++ show "a")
370tests :: TestTransport -> IO [Test]
371tests testtrans@TestTransport{..} = do
372 node1 <- newLocalNode testTransport initRemoteTable
373 -- if we execute the test cases in parallel, the
374 -- various tracers will race with one another and
375 -- we'll get garbage results (or worse, deadlocks)
376 lock <- liftIO $ newMVar ()
377 return [
378 testGroup "Tracing" [
379 testCase "Spawn Tracing"
380 (synchronisedAssertion
381 "expected dead process-info to be ProcessInfoNone"
382 node1 True testSpawnTracing lock)
383 , testCase "Recv Tracing (Explicit Pid)"
384 (synchronisedAssertion
385 "expected a recv trace for the supplied pid"
386 node1 True testTraceRecvExplicitPid lock)
387 , testCase "Recv Tracing (Named Pid)"
388 (synchronisedAssertion
389 "expected a recv trace for the process registered as 'foobar'"
390 node1 True testTraceRecvNamedPid lock)
391 , testCase "Trace Send(er)"
392 (synchronisedAssertion
393 "expected a 'send' trace with the requisite fields set"
394 node1 True testTraceSending lock)
395 , testCase "Trace Registration"
396 (synchronisedAssertion
397 "expected a 'registered' trace"
398 node1 True testTraceRegistration lock)
399 , testCase "Trace Unregistration"
400 (synchronisedAssertion
401 "expected an 'unregistered' trace"
402 node1 True testTraceUnRegistration lock)
403 , testCase "Trace Layering"
404 (synchronisedAssertion
405 "expected blah"
406 node1 () testTraceLayering lock)
407 , testCase "Remote Trace Relay"
408 (synchronisedAssertion
409 "expected blah"
410 node1 True (testRemoteTraceRelay testtrans) lock)
411 , testGroup "SystemLoggerTracer"
412 [ testCase "MxReceive" $ testSystemLoggerMxReceive testtrans
413 , testCase "MxSent" $ testSystemLoggerMxSent testtrans
414 , testCase "MxProcessDied" $ testSystemLoggerMxProcessDied testtrans
415 , testCase "MxSpawned" $ testSystemLoggerMxSpawned testtrans
416 , testCase "MxRegistered" $ testSystemLoggerMxRegistered testtrans
417 , testCase "MxUnRegistered" $ testSystemLoggerMxUnRegistered testtrans
418 ]
419 ] ]