@@ -5,6 +5,7 @@ module Control.Distributed.Process.Tests.Tracing (tests) where
55import Control.Distributed.Process.Tests.Internal.Utils
66import Network.Transport.Test (TestTransport(..))
77
8+import Control.Applicative ((<*))
89import Control.Concurrent (threadDelay)
910import Control.Concurrent.MVar
1011 ( MVar
@@ -19,9 +20,13 @@ import Control.Distributed.Process.Debug
1920import Control.Distributed.Process.Management
2021 ( MxEvent(..)
2122 )
23+import qualified Control.Exception as IO (bracket)
24+import Data.List (isPrefixOf, isSuffixOf)
2225
2326#if ! MIN_VERSION_base(4,6,0)
2427import Prelude hiding (catch, log)
28+#else
29+import Prelude hiding ((<*))
2530#endif
2631
2732import Test.Framework
@@ -29,6 +34,10 @@ import Test.Framework
2934 , testGroup
3035 )
3136import Test.Framework.Providers.HUnit (testCase)
37+import System.Environment (getEnvironment)
38+-- These are available in System.Environment only since base 4.7
39+import System.SetEnv (setEnv, unsetEnv)
40+
3241
3342testSpawnTracing :: TestResult Bool -> Process ()
3443testSpawnTracing result = do
@@ -282,6 +291,82 @@ testRemoteTraceRelay TestTransport{..} result =
282291 -- and just to be polite...
283292 liftIO $ closeLocalNode node2
284293
294+-- | Sets the value of an environment variable while executing the given IO
295+-- computation and restores the preceeding value upon completion.
296+withEnv :: String -> String -> IO a -> IO a
297+withEnv var val =
298+ IO.bracket (fmap (lookup var) getEnvironment <* setEnv var val)
299+ (maybe (unsetEnv var) (setEnv var))
300+ . const
301+
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@.
305+testSystemLoggerMsg :: TestTransport
306+ -> Process a
307+ -> (a -> String -> Bool)
308+ -> IO ()
309+testSystemLoggerMsg t action interestingMessage =
310+ withEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" "yes" $
311+ withEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" "pdnusrl" $ do
312+ n <- newLocalNode (testTransport t) initRemoteTable
313+
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 ()
325+
326+
327+-- | Tests that one and only one trace message is produced when a message is
328+-- received.
329+testSystemLoggerMxReceive :: TestTransport -> IO ()
330+testSystemLoggerMxReceive t = testSystemLoggerMsg t
331+ (getSelfPid >>= flip send ())
332+ (\_ msg -> "MxReceived" `isPrefixOf` msg
333+ -- discard traces of internal messages
334+ && not (":: RegisterReply" `isSuffixOf` msg)
335+ )
336+
337+-- | Tests that one and only one trace message is produced when a message is
338+-- sent.
339+testSystemLoggerMxSent :: TestTransport -> IO ()
340+testSystemLoggerMxSent t = testSystemLoggerMsg t
341+ (getSelfPid >>= flip send ())
342+ (const $ isPrefixOf "MxSent")
343+
344+-- | Tests that one and only one trace message is produced when a process dies.
345+testSystemLoggerMxProcessDied :: TestTransport -> IO ()
346+testSystemLoggerMxProcessDied t = testSystemLoggerMsg t
347+ (spawnLocal $ return ())
348+ (\pid -> isPrefixOf $ "MxProcessDied " ++ show pid)
349+
350+-- | Tests that one and only one trace message appears when a process spawns.
351+testSystemLoggerMxSpawned :: TestTransport -> IO ()
352+testSystemLoggerMxSpawned t = testSystemLoggerMsg t
353+ (spawnLocal $ return ())
354+ (\pid -> isPrefixOf $ "MxSpawned " ++ show pid)
355+
356+-- | Tests that one and only one trace message appears when a process is
357+-- registered.
358+testSystemLoggerMxRegistered :: TestTransport -> IO ()
359+testSystemLoggerMxRegistered t = testSystemLoggerMsg t
360+ (getSelfPid >>= register "a" >> getSelfPid)
361+ (\self -> isPrefixOf $ "MxRegistered " ++ show self ++ " " ++ show "a")
362+
363+-- | Tests that one and only one trace message appears when a process is
364+-- unregistered.
365+testSystemLoggerMxUnRegistered :: TestTransport -> IO ()
366+testSystemLoggerMxUnRegistered t = testSystemLoggerMsg t
367+ (getSelfPid >>= register "a" >> unregister "a" >> getSelfPid)
368+ (\self -> isPrefixOf $ "MxUnRegistered " ++ show self ++ " " ++ show "a")
369+
285370tests :: TestTransport -> IO [Test]
286371tests testtrans@TestTransport{..} = do
287372 node1 <- newLocalNode testTransport initRemoteTable
@@ -323,4 +408,12 @@ tests testtrans@TestTransport{..} = do
323408 (synchronisedAssertion
324409 "expected blah"
325410 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+ ]
326419 ] ]