git.iko.soy/distributed-process
on 7930062 help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs
431 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 mS <- unwrapMessage msg :: Process (Maybe String)
129 case mS of
130 (Just s) -> do stash res (to == pid && from == self && s == "hello there")
131 stash res (to == pid && from == self)
132 _ -> die "failed state invariant, message type unmatched..."
133 _ ->
134 return ()) $ do
135 send pid "hello there"
136 res' <- liftIO $ takeMVar res
137 stash result res'
139testTraceRegistration :: TestResult Bool -> Process ()
140testTraceRegistration result = do
141 (sp, rp) <- newChan
142 pid <- spawnLocal $ do
143 self <- getSelfPid
144 () <- expect
145 register "foobar" self
146 sendChan sp ()
147 () <- expect
148 return ()
149 res <- liftIO $ newEmptyMVar
150 withFlags defaultTraceFlags { traceRegistered = traceOn } $ do
151 withTracer
152 (\ev ->
153 case ev of
154 MxRegistered p s ->
155 stash res (p == pid && s == "foobar")
156 _ ->
157 return ()) $ do
158 _ <- monitor pid
159 send pid ()
160 () <- receiveChan rp
161 send pid ()
162 receiveWait [
163 match (\(ProcessMonitorNotification _ _ _) -> return ())
164 ]
165 res' <- liftIO $ takeMVar res
166 stash result res'
168testTraceUnRegistration :: TestResult Bool -> Process ()
169testTraceUnRegistration result = do
170 pid <- spawnLocal $ do
171 () <- expect
172 unregister "foobar"
173 () <- expect
174 return ()
175 register "foobar" pid
176 res <- liftIO $ newEmptyMVar
177 withFlags defaultTraceFlags { traceUnregistered = traceOn } $ do
178 withTracer
179 (\ev ->
180 case ev of
181 MxUnRegistered p n -> do
182 stash res (p == pid && n == "foobar")
183 send pid ()
184 _ ->
185 return ()) $ do
186 mref <- monitor pid
187 send pid ()
188 receiveWait [
189 matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')
190 (\_ -> return ())
191 ]
192 res' <- liftIO $ takeMVar res
193 stash result res'
195testTraceLayering :: TestResult () -> Process ()
196testTraceLayering result = do
197 pid <- spawnLocal $ do
198 getSelfPid >>= register "foobar"
199 () <- expect
200 traceMessage ("traceMsg", 123 :: Int)
201 return ()
202 withFlags defaultTraceFlags {
203 traceDied = traceOnly [pid]
204 , traceRecv = traceOnly ["foobar"]
205 } $ doTest pid result
206 return ()
207 where
208 doTest :: ProcessId -> MVar () -> Process ()
209 doTest pid result' = do
210 -- TODO: this is pretty gross, even for a test case
211 died <- liftIO $ newEmptyMVar
212 withTracer
213 (\ev ->
214 case ev of
215 MxProcessDied _ _ -> liftIO $ putMVar died ()
216 _ -> return ())
217 ( do {
218 recv <- liftIO $ newEmptyMVar
219 ; withTracer
220 (\ev' ->
221 case ev' of
222 MxReceived _ _ -> liftIO $ putMVar recv ()
223 _ -> return ())
224 ( do {
225 user <- liftIO $ newEmptyMVar
226 ; withTracer
227 (\ev'' ->
228 case ev'' of
229 MxUser _ -> liftIO $ putMVar user ()
230 _ -> return ())
231 (send pid () >> (liftIO $ takeMVar user))
232 ; liftIO $ takeMVar recv
233 })
234 ; liftIO $ takeMVar died
235 })
236 liftIO $ putMVar result' ()
238testRemoteTraceRelay :: TestTransport -> TestResult Bool -> Process ()
239testRemoteTraceRelay TestTransport{..} result =
240 let flags = defaultTraceFlags { traceSpawned = traceOn }
241 in do
242 node2 <- liftIO $ newLocalNode testTransport initRemoteTable
243 mvNid <- liftIO $ newEmptyMVar
245 -- As well as needing node2's NodeId, we want to
246 -- redirect all its logs back here, to avoid generating
247 -- garbage on stderr for the duration of the test run.
248 -- Here we set up that relay, and then wait for a signal
249 -- that the tracer (on node1) has seen the expected
250 -- MxSpawned message, at which point we're finished
252 pid <- splinchLogger node2 mvNid
253 nid <- liftIO $ takeMVar mvNid
254 mref <- monitor pid
255 observedPid <- liftIO $ newEmptyMVar
256 spawnedPid <- liftIO $ newEmptyMVar
257 setTraceFlagsRemote flags nid
259 withFlags defaultTraceFlags { traceSpawned = traceOn } $ do
260 withTracer
261 (\ev ->
262 case ev of
263 MxSpawned p -> stash observedPid p >> send pid ()
264 _ -> return ()) $ do
265 relayPid <- startTraceRelay nid
266 liftIO $ threadDelay 1000000
267 p <- liftIO $ forkProcess node2 $ do
268 expectTimeout 1000000 :: Process (Maybe ())
269 return ()
270 stash spawnedPid p
272 -- Now we wait for (the outer) pid to exit. This won't happen until
273 -- our tracer has seen the trace event for `p' and sent `p' the
274 -- message it's waiting for prior to exiting
275 receiveWait [
276 matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')
277 (\_ -> return ())
278 ]
280 relayRef <- monitor relayPid
281 kill relayPid "stop"
282 receiveWait [
283 matchIf (\(ProcessMonitorNotification rref' _ _) -> rref' == relayRef)
284 (\_ -> return ())
285 ]
286 observed <- liftIO $ takeMVar observedPid
287 expected <- liftIO $ takeMVar spawnedPid
288 stash result (observed == expected)
289 -- and just to be polite...
290 liftIO $ closeLocalNode node2
292 where
293 splinchLogger n2 mv = do
294 mLog <- whereis "logger"
295 case mLog of
296 Nothing -> die "no logger registered"
297 Just log' -> do liftIO $ forkProcess n2 $ do
298 logRelay <- spawnLocal $ relay log'
299 reregister "logger" logRelay
300 getSelfNode >>= stash mv >> (expect :: Process ())
303-- | Sets the value of an environment variable while executing the given IO
304-- computation and restores the preceeding value upon completion.
305withEnv :: String -> String -> IO a -> IO a
306withEnv var val =
307 IO.bracket (fmap (lookup var) getEnvironment <* setEnv var val)
308 (maybe (unsetEnv var) (setEnv var))
309 . const
311-- | Tests that one and only one interesting trace message is produced when a
312-- given action is performed. A message is considered interesting when the given
313-- function return @True@.
314testSystemLoggerMsg :: TestTransport
315 -> Process a
316 -> (a -> String -> Bool)
317 -> IO ()
318testSystemLoggerMsg t action interestingMessage =
319 withEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" "yes" $
320 withEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" "pdnusrl" $ do
321 n <- newLocalNode (testTransport t) initRemoteTable
323 runProcess n $ do
324 self <- getSelfPid
325 reregister "trace.logger" self
326 a <- action
327 let interestingMessage' (_ :: String, msg) = interestingMessage a msg
328 -- Wait for the trace message.
329 receiveWait [ matchIf interestingMessage' $ const $ return () ]
330 -- Only one interesting message should arrive.
331 expectedTimeout <- receiveTimeout
332 100000
333 [ matchIf interestingMessage' $ const $ return () ]
334 case expectedTimeout of
335 Nothing -> return ()
336 Just _ -> die "Unexpected message arrived..."
339-- | Tests that one and only one trace message is produced when a message is
340-- received.
341testSystemLoggerMxReceive :: TestTransport -> IO ()
342testSystemLoggerMxReceive t = testSystemLoggerMsg t
343 (getSelfPid >>= flip send ())
344 (\_ msg -> "MxReceived" `isPrefixOf` msg
345 -- discard traces of internal messages
346 && not (":: RegisterReply" `isSuffixOf` msg)
347 )
349-- | Tests that one and only one trace message is produced when a message is
350-- sent.
351testSystemLoggerMxSent :: TestTransport -> IO ()
352testSystemLoggerMxSent t = testSystemLoggerMsg t
353 (getSelfPid >>= flip send ())
354 (const $ isPrefixOf "MxSent")
356-- | Tests that one and only one trace message is produced when a process dies.
357testSystemLoggerMxProcessDied :: TestTransport -> IO ()
358testSystemLoggerMxProcessDied t = testSystemLoggerMsg t
359 (spawnLocal $ return ())
360 (\pid -> isPrefixOf $ "MxProcessDied " ++ show pid)
362-- | Tests that one and only one trace message appears when a process spawns.
363testSystemLoggerMxSpawned :: TestTransport -> IO ()
364testSystemLoggerMxSpawned t = testSystemLoggerMsg t
365 (spawnLocal $ return ())
366 (\pid -> isPrefixOf $ "MxSpawned " ++ show pid)
368-- | Tests that one and only one trace message appears when a process is
369-- registered.
370testSystemLoggerMxRegistered :: TestTransport -> IO ()
371testSystemLoggerMxRegistered t = testSystemLoggerMsg t
372 (getSelfPid >>= register "a" >> getSelfPid)
373 (\self -> isPrefixOf $ "MxRegistered " ++ show self ++ " " ++ show "a")
375-- | Tests that one and only one trace message appears when a process is
376-- unregistered.
377testSystemLoggerMxUnRegistered :: TestTransport -> IO ()
378testSystemLoggerMxUnRegistered t = testSystemLoggerMsg t
379 (getSelfPid >>= register "a" >> unregister "a" >> getSelfPid)
380 (\self -> isPrefixOf $ "MxUnRegistered " ++ show self ++ " " ++ show "a")
382tests :: TestTransport -> IO [Test]
383tests testtrans@TestTransport{..} = do
384 node1 <- newLocalNode testTransport initRemoteTable
385 -- if we execute the test cases in parallel, the
386 -- various tracers will race with one another and
387 -- we'll get garbage results (or worse, deadlocks)
388 lock <- liftIO $ newMVar ()
389 return [
390 testGroup "Tracing" [
391 testCase "Spawn Tracing"
392 (synchronisedAssertion
393 "expected dead process-info to be ProcessInfoNone"
394 node1 True testSpawnTracing lock)
395 , testCase "Recv Tracing (Explicit Pid)"
396 (synchronisedAssertion
397 "expected a recv trace for the supplied pid"
398 node1 True testTraceRecvExplicitPid lock)
399 , testCase "Recv Tracing (Named Pid)"
400 (synchronisedAssertion
401 "expected a recv trace for the process registered as 'foobar'"
402 node1 True testTraceRecvNamedPid lock)
403 , testCase "Trace Send(er)"
404 (synchronisedAssertion
405 "expected a 'send' trace with the requisite fields set"
406 node1 True testTraceSending lock)
407 , testCase "Trace Registration"
408 (synchronisedAssertion
409 "expected a 'registered' trace"
410 node1 True testTraceRegistration lock)
411 , testCase "Trace Unregistration"
412 (synchronisedAssertion
413 "expected an 'unregistered' trace"
414 node1 True testTraceUnRegistration lock)
415 , testCase "Trace Layering"
416 (synchronisedAssertion
417 "expected blah"
418 node1 () testTraceLayering lock)
419 , testCase "Remote Trace Relay"
420 (synchronisedAssertion
421 "expected blah"
422 node1 True (testRemoteTraceRelay testtrans) lock)
423 , testGroup "SystemLoggerTracer"
424 [ testCase "MxReceive" $ testSystemLoggerMxReceive testtrans
425 , testCase "MxSent" $ testSystemLoggerMxSent testtrans
426 , testCase "MxProcessDied" $ testSystemLoggerMxProcessDied testtrans
427 , testCase "MxSpawned" $ testSystemLoggerMxSpawned testtrans
428 , testCase "MxRegistered" $ testSystemLoggerMxRegistered testtrans
429 , testCase "MxUnRegistered" $ testSystemLoggerMxUnRegistered testtrans
430 ]
431 ] ]