d8c36b5 · distributed-process

git.iko.soy/distributed-process

Avoid loop when tracing received messages.

When a trace message was sent to "trace.logger", the NC would produce a trace message to indicate the arrival of it, this new trace message would in turn have the NC produce another trace message and so on. In this patch the NC does not produce a trace message when the destination is the "trace.logger" process.

commitd8c36b547c1776d8b39003f5f697d7c12c3b3d03 authorFacundo Domínguez <facundo.dominguez@tweag.io> dateThu 21 Jan 2016, 15:29 (11 years ago) parentc18f525

3 files changed+108−5

compare with master

unifiedsplit

distributed-process-tests/distributed-process-tests.cabal+1 distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs+93 src/Control/Distributed/Process/Node.hs+14−5

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

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

3535 network >= 2.5 && < 2.7,

3636 random >= 1.0 && < 1.2,

3737 rematch >= 0.1.2.1,

38+ setenv >= 0.1.1.3,

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

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

4041 stm

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

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

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

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

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

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

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

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

663663

664664ncSendToProcess :: 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

666669 node <- ask

667670 if processNodeId pid == localNodeId node

668− then ncEffectLocalSend node pid msg

671+ then ncEffectLocalSendAndTrace shouldTrace node pid msg

669672 else liftIO $ sendBinary node

670673 (NodeIdentifier $ localNodeId node)

671674 (NodeIdentifier $ processNodeId pid)

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

946949ncEffectNamedSend label msg = do

947950 mPid <- gets (^. registeredHereFor label)

948951 -- 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

950956

951957-- [Issue #DP-20]

952958ncEffectLocalSend :: 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 =

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

955964 enqueue (processQueue p) msg

956− trace node (MxReceived to msg)

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

957966

958967-- [Issue #DP-20]

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