From 268bee3ad076902abeecfb9311c30ea528d42766 Mon Sep 17 00:00:00 2001 From: Tim Watson Date: Thu, 9 Feb 2017 10:34:56 +0000 Subject: [PATCH] [no-ci] TEMP: this commit is broken, to be ammended --- .../Control/Distributed/Process/Tests/Mx.hs | 115 +++++++++++++++++- .../Distributed/Process/Tests/Tracing.hs | 40 +++--- .../Process/Internal/Primitives.hs | 92 ++++++++++---- src/Control/Distributed/Process/Management.hs | 2 + .../Process/Management/Internal/Agent.hs | 4 +- .../Management/Internal/Trace/Primitives.hs | 5 +- .../Management/Internal/Trace/Tracer.hs | 44 ++++--- .../Process/Management/Internal/Types.hs | 71 ++++++++--- src/Control/Distributed/Process/Node.hs | 1 + stack-ghc-8.0.1.yaml | 18 +++ stack.yaml | 18 +-- 11 files changed, 324 insertions(+), 86 deletions(-) create mode 100644 stack-ghc-8.0.1.yaml mode change 100644 => 120000 stack.yaml diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs b/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs index 85c9e305..a2eee409 100644 --- a/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs +++ b/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs @@ -5,10 +5,19 @@ import Control.Distributed.Process.Tests.Internal.Utils import Network.Transport.Test (TestTransport(..)) import Control.Concurrent (threadDelay) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan + ( newBroadcastTChanIO + , readTChan + , writeTChan + , dupTChan + ) + import Control.Distributed.Process import Control.Distributed.Process.Node import Control.Distributed.Process.Management ( MxEvent(..) + , Destination(..) , MxAgentId(..) , mxAgent , mxSink @@ -23,7 +32,7 @@ import Control.Distributed.Process.Management , mxBroadcast , mxGetId ) -import Control.Monad (void) +import Control.Monad (void, replicateM_, when) import Data.Binary import Data.List (find, sort) import Data.Maybe (isJust) @@ -175,6 +184,109 @@ testAgentEventHandling result = do stash result $ seenAlive && seenDead +testAgentSendRecvHandling :: LocalNode -> IO () +testAgentSendRecvHandling node = do + runProcess node $ do + testPid <- getSelfPid + agent <- mxAgent (MxAgentId "sendrecv-listener-agent") initState [ + (mxSink $ \(p1, p2, sp) -> do + mxSetLocal [p1, p2] + liftMX $ sendChan sp () + mxReady + ), + (mxSink $ \ev -> do + st <- mxGetLocal + let possiblyNotifyTestProcess pid = when (pid `elem` st) (liftMX $ send testPid ev) + let act = case ev of + MxSent{..} -> possiblyNotifyTestProcess whichProcess + MxReceived{..} -> possiblyNotifyTestProcess whichProcess + _ -> return () + act >> mxReady) + ] + + mRef <- monitor agent + + goSignal <- liftIO newBroadcastTChanIO + p1Ready <- liftIO $ atomically (dupTChan goSignal) + p2Ready <- liftIO $ atomically (dupTChan goSignal) + + p1 <- spawnLocal $ do + link testPid + liftIO $ atomically (readTChan p1Ready) + + -- first we expect a message via send + () <- expect + + -- then another, via nsend + liftIO $ atomically (readTChan p1Ready) + () <- expect + + -- then another, via usend + liftIO $ atomically (readTChan p1Ready) + () <- expect + + return () + + p2 <- spawnLocal $ do + link testPid + liftIO $ atomically (readTChan p2Ready) + + send p1 () + + liftIO $ atomically (readTChan p2Ready) + nsend "test.process.1" () + + liftIO $ atomically (readTChan p2Ready) + usend p1 () + -- and using unsafe primitives... + + + register testProcName p1 + (Just _) <- whereis testProcName + + (agentGo, agentReady) <- newChan + mxNotify (p1, p2, agentGo) + + () <- receiveChan agentReady + + replicateM_ 3 $ checkOnce p1 p2 goSignal + + kill agent "finished" + receiveWait [ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef) + (const $ return ()) ] + + where + checkOnce p1' p2' sig = do + -- tell both the sending and receiving actors to take a step + liftIO $ atomically $ writeTChan sig () + + -- ensure we saw the send first... + receiveWait [ + matchIf (\(ev :: MxEvent) -> + case ev of + (MxSent p' d' _) -> p' == p2' && destProc d' p1' + -- we should never get any other kind of MxEvent here... + _ -> error "unexpected MxEvent" + ) (const $ return ()) ] + + -- and the receive after... + receiveWait [ + matchIf (\(ev :: MxEvent) -> + case ev of + (MxReceived p' _) -> p' == p1' + -- we should never get any other kind of MxEvent here... + _ -> error "unexpected MxEvent" + ) (const $ return ()) ] + + initState :: [ProcessId] + initState = [] + + testProcName = "test.process.1" + + destProc (ProcId p) p' = p == p' + destProc (ProcName n) _ = n == testProcName + destProc _ _ = False + tests :: TestTransport -> IO [Test] tests TestTransport{..} = do node1 <- newLocalNode testTransport initRemoteTable @@ -184,6 +296,7 @@ tests TestTransport{..} = do (delayedAssertion "expected True, but events where not as expected" node1 True testAgentEventHandling) +-- , testCase "Send & Receive" (testAgentSendRecvHandling node1) , testCase "Inter-Agent Broadcast" (delayedAssertion "expected (), but no broadcast was received" diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs b/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs index 1f63b6cd..3ed81f7f 100644 --- a/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs +++ b/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Control.Distributed.Process.Tests.Tracing (tests) where @@ -19,6 +18,7 @@ import Control.Distributed.Process.Node import Control.Distributed.Process.Debug import Control.Distributed.Process.Management ( MxEvent(..) + , Destination(..) ) import qualified Control.Exception as IO (bracket) import Data.List (isPrefixOf, isSuffixOf) @@ -124,10 +124,11 @@ testTraceSending result = do withTracer (\ev -> case ev of - (MxSent to from msg) -> do - (Just s) <- unwrapMessage msg :: Process (Maybe String) - stash res (to == pid && from == self && s == "hello there") - stash res (to == pid && from == self) + MxSent{..} -> do + let to = procId whereTo + (Just s) <- unwrapMessage message :: Process (Maybe String) + stash res (to == pid && whichProcess == self && s == "hello there") + stash res (to == pid && whichProcess == self) _ -> return ()) $ do send pid "hello there" @@ -314,24 +315,29 @@ testSystemLoggerMsg t action interestingMessage = runProcess n $ do self <- getSelfPid reregister "trace.logger" self + a <- action let interestingMessage' (_ :: String, msg) = interestingMessage a msg -- Wait for the trace message. receiveWait [ matchIf interestingMessage' $ const $ return () ] -- Only one interesting message should arrive. Nothing <- receiveTimeout 100000 - [ matchIf interestingMessage' $ const $ return () ] + [ matchIf interestingMessage' $ const $ return () ] + -- return () + _ <- expectTimeout 5000000 :: Process (Maybe ()) return () + closeLocalNode n -- | Tests that one and only one trace message is produced when a message is -- received. testSystemLoggerMxReceive :: TestTransport -> IO () testSystemLoggerMxReceive t = testSystemLoggerMsg t - (getSelfPid >>= flip send ()) - (\_ msg -> "MxReceived" `isPrefixOf` msg + -- this is never going to work because we are trace.logger dumbass + ((spawnLocal expect) >>= \pid -> send pid () >> return pid) + (\pid msg -> ("MxReceived" `isPrefixOf` msg) -- discard traces of internal messages - && not (":: RegisterReply" `isSuffixOf` msg) + && not (":: RegisterReply}" `isSuffixOf` msg) ) -- | Tests that one and only one trace message is produced when a message is @@ -339,33 +345,39 @@ testSystemLoggerMxReceive t = testSystemLoggerMsg t testSystemLoggerMxSent :: TestTransport -> IO () testSystemLoggerMxSent t = testSystemLoggerMsg t (getSelfPid >>= flip send ()) - (const $ isPrefixOf "MxSent") + (\pid msg -> (("MxSent {whichProcess = " ++ show pid) `isPrefixOf` msg) + -- discard traces of internal messages + && not (":: RegisterReply}" `isSuffixOf` msg) + ) -- | Tests that one and only one trace message is produced when a process dies. testSystemLoggerMxProcessDied :: TestTransport -> IO () testSystemLoggerMxProcessDied t = testSystemLoggerMsg t (spawnLocal $ return ()) - (\pid -> isPrefixOf $ "MxProcessDied " ++ show pid) + (\pid -> (== "MxProcessDied {whichProcess = " ++ + show pid ++ ", why = DiedNormal}")) -- | Tests that one and only one trace message appears when a process spawns. testSystemLoggerMxSpawned :: TestTransport -> IO () testSystemLoggerMxSpawned t = testSystemLoggerMsg t (spawnLocal $ return ()) - (\pid -> isPrefixOf $ "MxSpawned " ++ show pid) + (\pid -> isPrefixOf $ "MxSpawned {whichProcess = " ++ show pid) -- | Tests that one and only one trace message appears when a process is -- registered. testSystemLoggerMxRegistered :: TestTransport -> IO () testSystemLoggerMxRegistered t = testSystemLoggerMsg t (getSelfPid >>= register "a" >> getSelfPid) - (\self -> isPrefixOf $ "MxRegistered " ++ show self ++ " " ++ show "a") + (\pid -> (== "MxRegistered {whichProcess = " ++ show pid ++ + ", whichName = " ++ show "a" ++ "}")) -- | Tests that one and only one trace message appears when a process is -- unregistered. testSystemLoggerMxUnRegistered :: TestTransport -> IO () testSystemLoggerMxUnRegistered t = testSystemLoggerMsg t (getSelfPid >>= register "a" >> unregister "a" >> getSelfPid) - (\self -> isPrefixOf $ "MxUnRegistered " ++ show self ++ " " ++ show "a") + (\pid -> (== "MxUnRegistered {whichProcess = " ++ + show pid ++ ", whichName = " ++ show "a" ++ "}")) tests :: TestTransport -> IO [Test] tests testtrans@TestTransport{..} = do diff --git a/src/Control/Distributed/Process/Internal/Primitives.hs b/src/Control/Distributed/Process/Internal/Primitives.hs index 5c3a66c0..bd820ca8 100644 --- a/src/Control/Distributed/Process/Internal/Primitives.hs +++ b/src/Control/Distributed/Process/Internal/Primitives.hs @@ -226,6 +226,7 @@ import Control.Distributed.Process.Internal.Messaging ) import Control.Distributed.Process.Management.Internal.Types ( MxEvent(..) + , Destination(..) ) import Control.Distributed.Process.Management.Internal.Trace.Types ( traceEvent @@ -256,14 +257,16 @@ send them msg = do case destNode == nodeId of True -> sendLocal them msg False -> liftIO $ sendMessage (processNode proc) - (ProcessIdentifier (processId proc)) - (ProcessIdentifier them) - NoImplicitReconnect - msg - -- We do not fire the trace event until after the sending is complete; - -- In the remote case, 'sendMessage' can block in the networking stack. + (ProcessIdentifier (processId proc)) + (ProcessIdentifier them) + NoImplicitReconnect + msg + -- see note [trace MxSent] liftIO $ traceEvent (localEventBus node) - (MxSent them us (createUnencodedMessage msg)) + MxSent { whichProcess = us + , whereTo = ProcId them + , message = (createUnencodedMessage msg) + } -- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize -- and (in the case when the destination process resides on the same local @@ -283,12 +286,22 @@ unsafeSend = Unsafe.send -- usend :: Serializable a => ProcessId -> a -> Process () usend them msg = do - here <- getSelfNode - let there = processNodeId them - if here == there + proc <- ask + let us = processId proc + node = processNode proc + nodeId = localNodeId node + let destNodeId = processNodeId them + if nodeId == destNodeId then sendLocal them msg - else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them) - (createMessage msg) + else do -- see note [trace MxSent] + let evBus = localEventBus node + let msg' = createMessage msg + sendCtrlMsg (Just destNodeId) $ UnreliableSend (processLocalId them) msg' + liftIO $ traceEvent evBus $ MxSent { whichProcess = us + , whereTo = ProcId them + , message = msg' + } + -- | /Unsafe/ variant of 'usend'. This function makes /no/ attempt to serialize -- the message when the destination process resides on the same local @@ -487,10 +500,12 @@ forward msg them = do (ProcessIdentifier them) NoImplicitReconnect (messageToPayload msg) - -- We do not fire the trace event until after the sending is complete; - -- In the remote case, 'sendMessage' can block in the networking stack. + liftIO $ traceEvent (localEventBus node) - (MxSent them us msg) + MxSent { whichProcess = us + , whereTo = ProcId them + , message = msg + } -- | Forward a raw 'Message' to the given 'ProcessId'. -- @@ -511,7 +526,10 @@ uforward msg them = do -- We do not fire the trace event until after the sending is complete; -- In the remote case, 'sendCtrlMsg' can block in the networking stack. liftIO $ traceEvent (localEventBus node) - (MxSent them us msg) + MxSent { whichProcess = us + , whereTo = ProcId them + , message = msg + } -- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are -- 'Serializable' - like the datum they contain - but also note, deserialising @@ -1220,8 +1238,20 @@ whereisRemoteAsync nid label = do -- | Named send to a process in the local registry (asynchronous) nsend :: Serializable a => String -> a -> Process () -nsend label msg = - sendCtrlMsg Nothing (NamedSend label (createUnencodedMessage msg)) +nsend label msg = do + proc <- ask + let us = processId proc + node = processNode proc + msg' = createMessage msg -- NB: using UnencodedMessage here causes chaos... :/ + + sendCtrlMsg Nothing (NamedSend label msg') + + -- see note [trace MxSent] + liftIO $ traceEvent (localEventBus node) + MxSent { whichProcess = us + , whereTo = ProcName label + , message = msg' + } -- | Named send to a process in the local registry (asynchronous). -- This function makes /no/ attempt to serialize and (in the case when the @@ -1233,9 +1263,19 @@ unsafeNSend = Unsafe.nsend -- | Named send to a process in a remote registry (asynchronous) nsendRemote :: Serializable a => NodeId -> String -> a -> Process () nsendRemote nid label msg = do + proc <- ask + let us = processId proc + node = processNode proc here <- getSelfNode if here == nid then nsend label msg - else sendCtrlMsg (Just nid) (NamedSend label (createMessage msg)) + else do let msg' = createMessage msg + sendCtrlMsg (Just nid) (NamedSend label msg') + -- see note [trace MxSent] + liftIO $ traceEvent (localEventBus node) + MxSent { whichProcess = us + , whereTo = ProcName label + , message = msg' + } -- | Named send to a process in a remote registry (asynchronous) -- This function makes /no/ attempt to serialize and (in the case when the @@ -1306,8 +1346,18 @@ reconnectPort them = do -------------------------------------------------------------------------------- sendLocal :: (Serializable a) => ProcessId -> a -> Process () -sendLocal to msg = - sendCtrlMsg Nothing $ LocalSend to (createUnencodedMessage msg) +sendLocal to msg = do + proc <- ask + let us = processId proc + node = processNode proc + msg' = createUnencodedMessage msg + + sendCtrlMsg Nothing $ LocalSend to msg' + liftIO $ traceEvent (localEventBus node) + MxSent { whichProcess = us + , whereTo = ProcId to + , message = msg' + } sendChanLocal :: (Serializable a) => SendPortId -> a -> Process () sendChanLocal spId msg = diff --git a/src/Control/Distributed/Process/Management.hs b/src/Control/Distributed/Process/Management.hs index 0af7892c..7fdb9aec 100644 --- a/src/Control/Distributed/Process/Management.hs +++ b/src/Control/Distributed/Process/Management.hs @@ -219,6 +219,7 @@ module Control.Distributed.Process.Management ( MxEvent(..) + , Destination(..) -- * Firing Arbitrary /Mx Events/ , mxNotify -- * Constructing Mx Agents @@ -276,6 +277,7 @@ import Control.Distributed.Process.Management.Internal.Types , MxAgentState(..) , MxSink , MxEvent(..) + , Destination(..) ) import Control.Distributed.Process.Serializable (Serializable) import Control.Monad.IO.Class (liftIO) diff --git a/src/Control/Distributed/Process/Management/Internal/Agent.hs b/src/Control/Distributed/Process/Management/Internal/Agent.hs index 40d53a8f..4c964e16 100644 --- a/src/Control/Distributed/Process/Management/Internal/Agent.hs +++ b/src/Control/Distributed/Process/Management/Internal/Agent.hs @@ -57,8 +57,8 @@ type AgentConfig = (Tracer, Weak (CQueue Message), (((TChan Message, TChan Message) -> Process ()) -> IO ProcessId)) --- | Starts a management agent for the current node. The agent process --- must not crash or be killed, so we generally avoid publishing its +-- | Starts a management agent controller for the current node. The process +-- must not crash or be killed, so we generally try to avoid publishing its -- @ProcessId@ where possible. -- -- Our process is also responsible for forwarding messages to the trace diff --git a/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs b/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs index 3de813cb..8c749f79 100644 --- a/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs +++ b/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs @@ -167,7 +167,10 @@ withRegisteredTracer act = do (sp, rp) <- newChan withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp currentTracer <- receiveChan rp + -- TODO: there is an obvious race here, whereby tracer.initial could + -- die or be replaced (via reregister) between the call to whereis + -- and the expression acting on the pid. Maybe pass the trace client + -- instead??? case currentTracer of Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' } (Just p) -> act p - diff --git a/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs b/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs index 982bec54..927c2fc4 100644 --- a/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs +++ b/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} -- | Tracing/Debugging support - Trace Implementation module Control.Distributed.Process.Management.Internal.Trace.Tracer ( -- * API for the Management Agent @@ -142,21 +144,28 @@ nullTracer = systemLoggerTracer :: Process () systemLoggerTracer = do - node <- processNode <$> ask - let tr = sendTraceLog node - forever' $ receiveWait [ matchAny (\m -> handleMessage m tr) ] + proc <- ask + let pid = processId proc + node = processNode proc + forever' $ receiveWait [ matchAny (\m -> handleMessage m (sendTraceLog pid node)) ] where - sendTraceLog :: LocalNode -> MxEvent -> Process () - sendTraceLog node ev = do - now <- liftIO $ getCurrentTime - msg <- return $ (formatTime defaultTimeLocale "%c" now, buildTxt ev) - emptyPid <- return $ (nullProcessId (localNodeId node)) - traceMsg <- return $ NCMsg { - ctrlMsgSender = ProcessIdentifier (emptyPid) - , ctrlMsgSignal = (NamedSend "trace.logger" - (createUnencodedMessage msg)) - } - liftIO $ writeChan (localCtrlChan node) traceMsg + sendTraceLog :: ProcessId -> LocalNode -> MxEvent -> Process () + sendTraceLog pid' node' ev + -- because process is the trace client, the trace coordinator cannot + -- filter out messages pertaining to the trace.logger, so we do so here + | MxReceived{..} <- ev + , whichProcess == pid' = return () + | otherwise = do + now <- liftIO $ getCurrentTime + msg <- return $ (formatTime defaultTimeLocale "%c" now, buildTxt ev) + emptyPid <- return $ nullPid node' + traceMsg <- return $ NCMsg { ctrlMsgSender = ProcessIdentifier (emptyPid) + , ctrlMsgSignal = (NamedSend "trace.logger" + (createUnencodedMessage msg)) + } + liftIO $ writeChan (localCtrlChan node') traceMsg + + nullPid node'' = nullProcessId (localNodeId node'') buildTxt :: MxEvent -> String buildTxt (MxLog msg) = msg @@ -235,7 +244,8 @@ traceController mv = do sendOk confResp >> applyTraceFlags flags' st) , match (\chGetFlags -> sendChan chGetFlags (flags st) >> return st) , match (\chGetCurrent -> sendChan chGetCurrent (client st) >> return st) - -- we dequeue incoming events even if we don't process them + -- we do not forward messages to the client that pertain to itself + -- also, we de-queue incoming events even if we don't process them , matchAny (\ev -> handleMessage ev (handleTrace st ev) >>= return . fromMaybe st) ] @@ -332,6 +342,10 @@ traceEv ev msg (Just (TraceProcs pids)) st = do traceEv ev msg (Just (TraceNames names)) st = do -- if we have recorded regnames for p, then we forward the trace iif -- there are overlapping trace targets + -- NB: this will now be broken for instances of Destination that cannot be + -- resolved, thus we need to re-examine this branch of the tracing code + -- to understand what the impact of that will actually be... + node <- processNode <$> ask let p = case resolveToPid ev of Nothing -> (nullProcessId (localNodeId node)) diff --git a/src/Control/Distributed/Process/Management/Internal/Types.hs b/src/Control/Distributed/Process/Management/Internal/Types.hs index 01621c82..de843647 100644 --- a/src/Control/Distributed/Process/Management/Internal/Types.hs +++ b/src/Control/Distributed/Process/Management/Internal/Types.hs @@ -11,6 +11,7 @@ module Control.Distributed.Process.Management.Internal.Types , Fork , MxSink , MxEvent(..) + , Destination(..) , Addressable(..) ) where @@ -18,10 +19,12 @@ import Control.Applicative (Applicative) import Control.Concurrent.STM ( TChan ) +import Control.DeepSeq (NFData(..)) import Control.Distributed.Process.Internal.Types ( Process , ProcessId , Message + , SendPort , DiedReason , NodeId ) @@ -38,35 +41,68 @@ import Network.Transport , EndPointAddress ) +-- | A simple means of mapping send events to their destinations +data Destination = + ProcId { procId :: !ProcessId } + | ProcName { procName :: !String } + | RemoteProcName { procName :: !String + , procNode :: !NodeId } + | UserDefined { userData :: !Message } + deriving (Typeable, Generic, Show) +instance Binary Destination where +instance NFData Destination where + rnf (ProcId p) = rnf p `seq` () + rnf (ProcName s) = rnf s `seq` () + rnf (RemoteProcName s n) = rnf s `seq` rnf n `seq` () + rnf (UserDefined m) = rnf m `seq` () + + -- | This is the /default/ management event, fired for various internal -- events around the NT connection and Process lifecycle. All published -- events that conform to this type, are eligible for tracing - i.e., -- they will be delivered to the trace controller. -- data MxEvent = - MxSpawned ProcessId + MxSpawned { whichProcess :: ProcessId } -- ^ fired whenever a local process is spawned - | MxRegistered ProcessId String + | MxRegistered { whichProcess :: ProcessId + , whichName :: String + } -- ^ fired whenever a process/name is registered (locally) - | MxUnRegistered ProcessId String + | MxUnRegistered { whichProcess :: ProcessId + , whichName :: String + } -- ^ fired whenever a process/name is unregistered (locally) - | MxProcessDied ProcessId DiedReason + | MxProcessDied { whichProcess :: ProcessId + , why :: DiedReason + } -- ^ fired whenever a process dies - | MxNodeDied NodeId DiedReason + | MxNodeDied { whichNode :: NodeId + , why :: DiedReason + } -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected) - | MxSent ProcessId ProcessId Message + | MxSent { whichProcess :: ProcessId + , whereTo :: Destination + , message :: Message + } -- ^ fired whenever a message is sent from a local process - | MxReceived ProcessId Message + | MxReceived { whichProcess :: ProcessId + , message :: Message + } -- ^ fired whenever a message is received by a local process - | MxConnected ConnectionId EndPointAddress + | MxConnected { whichConnection :: ConnectionId + , whichEndoint :: EndPointAddress + } -- ^ fired when a network-transport connection is first established - | MxDisconnected ConnectionId EndPointAddress + | MxDisconnected { whichConnection :: ConnectionId + , whichEndpoint :: EndPointAddress + } -- ^ fired when a network-transport connection is broken/disconnected - | MxUser Message + | MxUser { message :: Message } -- ^ a user defined trace event - | MxLog String + | MxLog { text :: String } -- ^ a /logging/ event - used for debugging purposes only - | MxTraceTakeover ProcessId + | MxTraceTakeover { whichProcess :: ProcessId } -- ^ notifies a trace listener that all subsequent traces will be sent to /pid/ | MxTraceDisable -- ^ notifies a trace listener that it has been disabled/removed @@ -74,15 +110,20 @@ data MxEvent = instance Binary MxEvent where --- | The class of things that we might be able to resolve to --- a @ProcessId@ (or not). +-- The class of things that we might be able to resolve to +-- a @ProcessId@ (or not). Note we don't want to export this! class Addressable a where resolveToPid :: a -> Maybe ProcessId +instance Addressable Destination where + resolveToPid dest + | (ProcId pid) <- dest = Just pid + | otherwise = Nothing + instance Addressable MxEvent where resolveToPid (MxSpawned p) = Just p resolveToPid (MxProcessDied p _) = Just p - resolveToPid (MxSent _ p _) = Just p + resolveToPid (MxSent _ p _) = resolveToPid p resolveToPid (MxReceived p _) = Just p resolveToPid _ = Nothing diff --git a/src/Control/Distributed/Process/Node.hs b/src/Control/Distributed/Process/Node.hs index c74c53b3..9b2d8822 100644 --- a/src/Control/Distributed/Process/Node.hs +++ b/src/Control/Distributed/Process/Node.hs @@ -550,6 +550,7 @@ handleIncomingMessages node = go initConnectionState forM_ mChan $ \chan -> atomically $ -- We make sure the message is fully decoded when it is enqueued writeTQueue chan $! decode (BSL.fromChunks payload) + -- trace node (MxReceived pid msg) go st Just (_, ToNode) -> do let ctrlMsg = decode . BSL.fromChunks $ payload diff --git a/stack-ghc-8.0.1.yaml b/stack-ghc-8.0.1.yaml new file mode 100644 index 00000000..7480b228 --- /dev/null +++ b/stack-ghc-8.0.1.yaml @@ -0,0 +1,18 @@ +# Specifies the GHC version and set of packages available +resolver: lts-7.14 + +packages: +- '.' +- distributed-process-tests/ + +extra-deps: +- rank1dynamic-0.3.3.0 +- distributed-static-0.3.5.0 +- network-transport-0.4.4.0 +- network-transport-tcp-0.5.1 +- network-transport-inmemory-0.5.1 +- rematch-0.2.0.0 + +flags: + distributed-process-tests: + tcp: true diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index c32436f4..00000000 --- a/stack.yaml +++ /dev/null @@ -1,17 +0,0 @@ -resolver: nightly-2016-06-09 - -packages: -- '.' -- distributed-process-tests/ - -extra-deps: -- rank1dynamic-0.3.3.0 -- distributed-static-0.3.5.0 -- network-transport-0.4.4.0 -- network-transport-tcp-0.5.1 -- network-transport-inmemory-0.5.1 -- rematch-0.2.0.0 - -flags: - distributed-process-tests: - tcp: true diff --git a/stack.yaml b/stack.yaml new file mode 120000 index 00000000..ebe5b92b --- /dev/null +++ b/stack.yaml @@ -0,0 +1 @@ +stack-ghc-8.0.1.yaml \ No newline at end of file