d59ac11 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Merge pull request #267 from haskell-distributed/fd/trace-loop

d59ac11Facundo Domínguez11 years ago

distributed-process-tests/distributed-process-tests.cabal+1

compare with master

unifiedsplit

@@ -35,6 +35,7 @@ library

35 network >= 2.5 && < 2.7,

36 random >= 1.0 && < 1.2,

37 rematch >= 0.1.2.1,

38+ setenv >= 0.1.1.3,

38 test-framework >= 0.6 && < 0.9,

39 test-framework >= 0.6 && < 0.9,

39 test-framework-hunit >= 0.2.0 && < 0.4,

40 test-framework-hunit >= 0.2.0 && < 0.4,

40 stm

41 stm

distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs+93

@@ -5,6 +5,7 @@ module Control.Distributed.Process.Tests.Tracing (tests) where

5import Control.Distributed.Process.Tests.Internal.Utils

6import Network.Transport.Test (TestTransport(..))

8+import Control.Applicative ((<*))

8import Control.Concurrent (threadDelay)

9import Control.Concurrent (threadDelay)

9import Control.Concurrent.MVar

10import Control.Concurrent.MVar

10 ( MVar

11 ( MVar

@@ -19,9 +20,13 @@ import Control.Distributed.Process.Debug

19import Control.Distributed.Process.Management

20import Control.Distributed.Process.Management

20 ( MxEvent(..)

21 ( MxEvent(..)

21 )

22 )

23+import qualified Control.Exception as IO (bracket)

24+import Data.List (isPrefixOf, isSuffixOf)

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

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

24import Prelude hiding (catch, log)

27import Prelude hiding (catch, log)

28+#else

29+import Prelude hiding ((<*))

25#endif

30#endif

27import Test.Framework

32import Test.Framework

@@ -29,6 +34,10 @@ import Test.Framework

29 , testGroup

34 , testGroup

30 )

35 )

31import Test.Framework.Providers.HUnit (testCase)

36import 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+

33testSpawnTracing :: TestResult Bool -> Process ()

42testSpawnTracing :: TestResult Bool -> Process ()

34testSpawnTracing result = do

43testSpawnTracing result = do

@@ -282,6 +291,82 @@ testRemoteTraceRelay TestTransport{..} result =

282 -- and just to be polite...

291 -- and just to be polite...

283 liftIO $ closeLocalNode node2

292 liftIO $ closeLocalNode node2

284

293

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+

285tests :: TestTransport -> IO [Test]

370tests :: TestTransport -> IO [Test]

286tests testtrans@TestTransport{..} = do

371tests testtrans@TestTransport{..} = do

287 node1 <- newLocalNode testTransport initRemoteTable

372 node1 <- newLocalNode testTransport initRemoteTable

@@ -323,4 +408,12 @@ tests testtrans@TestTransport{..} = do

323 (synchronisedAssertion

408 (synchronisedAssertion

324 "expected blah"

409 "expected blah"

325 node1 True (testRemoteTraceRelay testtrans) lock)

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+ ]

326 ] ]

419 ] ]

src/Control/Distributed/Process/Node.hs+14−5

@@ -662,10 +662,13 @@ instance Show ProcessKillException where

662 "killed-by=" ++ show pid ++ ",reason=" ++ reason

663

664ncSendToProcess :: ProcessId -> Message -> NC ()

665−ncSendToProcess pid msg = do

665+ncSendToProcess = ncSendToProcessAndTrace True

666+

667+ncSendToProcessAndTrace :: Bool -> ProcessId -> Message -> NC ()

668+ncSendToProcessAndTrace shouldTrace pid msg = do

666 node <- ask

669 node <- ask

667 if processNodeId pid == localNodeId node

670 if processNodeId pid == localNodeId node

668− then ncEffectLocalSend node pid msg

671+ then ncEffectLocalSendAndTrace shouldTrace node pid msg

669 else liftIO $ sendBinary node

672 else liftIO $ sendBinary node

670 (NodeIdentifier $ localNodeId node)

673 (NodeIdentifier $ localNodeId node)

671 (NodeIdentifier $ processNodeId pid)

674 (NodeIdentifier $ processNodeId pid)

@@ -946,14 +949,20 @@ ncEffectNamedSend :: String -> Message -> NC ()

946ncEffectNamedSend label msg = do

949ncEffectNamedSend label msg = do

947 mPid <- gets (^. registeredHereFor label)

950 mPid <- gets (^. registeredHereFor label)

948 -- If mPid is Nothing, we just ignore the named send (as per Table 14)

951 -- If mPid is Nothing, we just ignore the named send (as per Table 14)

949− forM_ mPid (`ncSendToProcess` msg)

952+ forM_ mPid $ \to ->

953+ -- If this is a trace message we don't trace it to avoid entering a loop

954+ -- where trace messages produce more trace messages.

955+ ncSendToProcessAndTrace (label /= "trace.logger") to msg

950

956

951-- [Issue #DP-20]

957-- [Issue #DP-20]

952ncEffectLocalSend :: LocalNode -> ProcessId -> Message -> NC ()

958ncEffectLocalSend :: LocalNode -> ProcessId -> Message -> NC ()

953−ncEffectLocalSend node to msg =

959+ncEffectLocalSend = ncEffectLocalSendAndTrace True

960+

961+ncEffectLocalSendAndTrace :: Bool -> LocalNode -> ProcessId -> Message -> NC ()

962+ncEffectLocalSendAndTrace shouldTrace node to msg =

954 liftIO $ withLocalProc node to $ \p -> do

963 liftIO $ withLocalProc node to $ \p -> do

955 enqueue (processQueue p) msg

964 enqueue (processQueue p) msg

956− trace node (MxReceived to msg)

965+ when shouldTrace $ trace node (MxReceived to msg)

957

966

958-- [Issue #DP-20]

967-- [Issue #DP-20]

959ncEffectLocalPortSend :: SendPortId -> Message -> NC ()

968ncEffectLocalPortSend :: SendPortId -> Message -> NC ()