f2f5fa5 · distributed-process

git.iko.soy/distributed-process

TraceEvent => MxEvent

commitf2f5fa554054debe787b196766c3be0fa317f871 authorTim Watson <watson.timothy@gmail.com> dateSun 1 Sep 2013, 19:46 (13 years ago) parent28beaa2

10 files changed+168−130

compare with master

unifiedsplit

src/Control/Distributed/Process/Debug.hs+13−13

@@ -20,10 +20,10 @@

2020-- Throughout the lifecycle of a local node, the distributed-process runtime

2121-- generates /trace events/, describing internal runtime activities such as

2222-- the spawning and death of processes, message sending, delivery and so on.

23−-- See the 'TraceEvent' type's documentation for a list of all the published

24−-- event types.

23+-- See the 'MxEvent' type's documentation for a list of all the published

24+-- event types, which correspond directly to the types of 'Management' event.

2525-- Users can additionally publish custom trace events in the form of

26−-- 'TraceEvLog' log messages or pass custom (i.e., completely user defined)

26+-- 'MxLog' log messages or pass custom (i.e., completely user defined)

2727-- event data using the 'traceMessage' function.

2828--

2929-- All published traces are forwarded to a /tracer process/, which can be

@@ -92,7 +92,7 @@

9292module Control.Distributed.Process.Debug

9393 ( -- * Exported Data Types

9494 TraceArg(..)

95− , TraceEvent(..)

95+ , MxEvent(..)

9696 , TraceFlags(..)

9797 , TraceSubject(..)

9898 -- * Configuring Tracing

@@ -147,7 +147,7 @@ import Control.Distributed.Process.Internal.Types

147147 )

148148import Control.Distributed.Process.Internal.Trace.Types

149149 ( TraceArg(..)

150− , TraceEvent(..)

150+ , MxEvent(..)

151151 , TraceFlags(..)

152152 , TraceSubject(..)

153153 , defaultTraceFlags

@@ -197,7 +197,7 @@ import Prelude hiding (catch)

197197-- through all the layers in turn. Once the top layer is stopped, the user

198198-- is responsible for re-registering the original (prior) tracer pid before

199199-- terminating. See 'withTracer' for a mechanism that handles that.

200−startTracer :: (TraceEvent -> Process ()) -> Process ProcessId

200+startTracer :: (MxEvent -> Process ()) -> Process ProcessId

201201startTracer handler = do

202202 withRegisteredTracer $ \pid -> do

203203 node <- processNode <$> ask

@@ -209,7 +209,7 @@ startTracer handler = do

209209-- disable tracing thereafter, before giving the result (or exception

210210-- in case of failure).

211211withTracer :: forall a.

212− (TraceEvent -> Process ())

212+ (MxEvent -> Process ())

213213 -> Process a

214214 -> Process (Either SomeException a)

215215withTracer handler proc = do

@@ -224,7 +224,7 @@ withTracer handler proc = do

224224 Nothing -> return ()

225225 Just _ -> do

226226 ref <- monitor tracer

227− send tracer TraceEvDisable

227+ send tracer MxTraceDisable

228228 receiveWait [

229229 matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')

230230 (\_ -> return ())

@@ -241,12 +241,12 @@ withFlags flags proc = do

241241 finally (setTraceFlags flags >> try proc)

242242 (setTraceFlags oldFlags)

243243

244−traceProxy :: ProcessId -> (TraceEvent -> Process ()) -> Process ()

244+traceProxy :: ProcessId -> (MxEvent -> Process ()) -> Process ()

245245traceProxy pid act = do

246− proxy pid $ \(ev :: TraceEvent) ->

246+ proxy pid $ \(ev :: MxEvent) ->

247247 case ev of

248− (TraceEvTakeover _) -> return False

249− TraceEvDisable -> die "disabled"

248+ (MxTraceTakeover _) -> return False

249+ MxTraceDisable -> die "disabled"

250250 _ -> act ev >> return True

251251

252252-- | Stops a user supplied tracer started with 'startTracer'.

@@ -272,5 +272,5 @@ stopTracer =

272272 basePid <- whereis "tracer.initial"

273273 case basePid == (Just pid) of

274274 True -> return ()

275− False -> send pid TraceEvDisable

275+ False -> send pid MxTraceDisable

276276

src/Control/Distributed/Process/Internal/Primitives.hs+3−3

@@ -193,7 +193,7 @@ import Control.Distributed.Process.Internal.Messaging

193193 )

194194import Control.Distributed.Process.Internal.Trace.Types

195195 ( traceEvent

196− , TraceEvent(..)

196+ , MxEvent(..)

197197 )

198198import Control.Distributed.Process.Internal.WeakTQueue

199199 ( newTQueueIO

@@ -227,7 +227,7 @@ send them msg = do

227227 -- We do not fire the trace event until after the sending is complete;

228228 -- In the remote case, 'sendMessage' can block in the networking stack.

229229 liftIO $ traceEvent (localEventBus node)

230− (TraceEvSent them us (createUnencodedMessage msg))

230+ (MxSent them us (createUnencodedMessage msg))

231231

232232-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize

233233-- and (in the case when the destination process resides on the same local

@@ -411,7 +411,7 @@ forward msg them = do

411411 -- We do not fire the trace event until after the sending is complete;

412412 -- In the remote case, 'sendMessage' can block in the networking stack.

413413 liftIO $ traceEvent (localEventBus node)

414− (TraceEvSent them us msg)

414+ (MxSent them us msg)

415415

416416

417417-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are

src/Control/Distributed/Process/Internal/Trace/Primitives.hs+2−2

@@ -7,7 +7,7 @@

77-- tracing infrastructure's messaging fabric.

88module Control.Distributed.Process.Internal.Trace.Primitives

99 ( Tracer

10− , TraceEvent(..)

10+ , MxEvent(..)

1111 -- * Sending Trace Data

1212 , traceLog

1313 , traceLogFmt

@@ -36,7 +36,7 @@ import Control.Distributed.Process.Internal.Primitives

3636 )

3737import Control.Distributed.Process.Internal.Trace.Types

3838 ( TraceArg(..)

39− , TraceEvent(..)

39+ , MxEvent(..)

4040 , TraceFlags(..)

4141 , TraceOk(..)

4242 , TraceSubject(..)

src/Control/Distributed/Process/Internal/Trace/Tracer.hs+27−27

@@ -32,7 +32,7 @@ import Control.Distributed.Process.Internal.Primitives

3232 , matchUnknown

3333 )

3434import Control.Distributed.Process.Internal.Trace.Types

35− ( TraceEvent(..)

35+ ( MxEvent(..)

3636 , SetTrace(..)

3737 , Addressable(..)

3838 , TraceSubject(..)

@@ -135,7 +135,7 @@ systemLoggerTracer = do

135135 let tr = sendTraceMsg node

136136 forever' $ receiveWait [ matchAny (\m -> handleMessage m tr) ]

137137 where

138− sendTraceMsg :: LocalNode -> TraceEvent -> Process ()

138+ sendTraceMsg :: LocalNode -> MxEvent -> Process ()

139139 sendTraceMsg node ev = do

140140 now <- liftIO $ getCurrentTime

141141 msg <- return $ (formatTime defaultTimeLocale "%c" now, buildTxt ev)

@@ -147,9 +147,9 @@ systemLoggerTracer = do

147147 }

148148 liftIO $ writeChan (localCtrlChan node) traceMsg

149149

150− buildTxt :: TraceEvent -> String

151− buildTxt (TraceEvLog msg) = msg

152− buildTxt ev = show ev

150+ buildTxt :: MxEvent -> String

151+ buildTxt (MxLog msg) = msg

152+ buildTxt ev = show ev

153153

154154eventLogTracer :: Process ()

155155eventLogTracer =

@@ -158,7 +158,7 @@ eventLogTracer =

158158 -- is a tracer process installed. This is just a stop gap until then.

159159 forever' $ receiveWait [ matchAny (\m -> handleMessage m writeTrace) ]

160160 where

161− writeTrace :: TraceEvent -> Process ()

161+ writeTrace :: MxEvent -> Process ()

162162 writeTrace ev = liftIO $ traceEventIO (show ev)

163163

164164logfileTracer :: FilePath -> Process ()

@@ -172,14 +172,14 @@ logfileTracer p = do

172172 logger h' = forever' $ do

173173 receiveWait [

174174 matchIf (\ev -> case ev of

175− TraceEvDisable -> True

176− (TraceEvTakeover _) -> True

175+ MxTraceDisable -> True

176+ (MxTraceTakeover _) -> True

177177 _ -> False)

178178 (\_ -> (liftIO $ hClose h') >> die "trace stopped")

179179 , matchAny (\ev -> handleMessage ev (writeTrace h'))

180180 ]

181181

182− writeTrace :: Handle -> TraceEvent -> Process ()

182+ writeTrace :: Handle -> MxEvent -> Process ()

183183 writeTrace h ev = do

184184 liftIO $ do

185185 now <- getCurrentTime

@@ -200,23 +200,23 @@ traceController mv = do

200200 where

201201 traceLoop :: TracerState -> Process ()

202202 traceLoop st = do

203− -- Trace events are forwarded to the trace target when tracing is enabled.

203+ -- Trace events are forwarded to the enabled trace target.

204204 -- At some point in the future, we're going to start writing these custom

205205 -- events to the ghc eventlog, at which point this design might change.

206206 st' <- receiveWait [

207207 match (\(setResp, set :: SetTrace) -> do

208− -- We allow at most one trace client, which is a process id.

208+ -- We consider at most one trace client, which is a process.

209209 -- Tracking multiple clients represents too high an overhead,

210− -- so we leave that kind of thing to our consumers to figure

211− -- figure out.

210+ -- so we leave that kind of thing to our consumers (e.g., the

211+ -- high level Debug client module) to figure out.

212212 case set of

213213 (TraceEnable pid) -> do

214214 -- notify the previous tracer it has been replaced

215− sendTrace st (createUnencodedMessage (TraceEvTakeover pid))

215+ sendTrace st (createUnencodedMessage (MxTraceTakeover pid))

216216 sendOk setResp

217217 return st { client = (Just pid) }

218218 TraceDisable -> do

219− sendTrace st (createUnencodedMessage TraceEvDisable)

219+ sendTrace st (createUnencodedMessage MxTraceDisable)

220220 sendOk setResp

221221 return st { client = Nothing })

222222 , match (\(confResp, flags') ->

@@ -225,7 +225,7 @@ traceController mv = do

225225 , match (\chGetCurrent -> sendChan chGetCurrent (client st) >> return st)

226226 -- we dequeue incoming events even if we don't process them

227227 , matchAny (\ev ->

228− handleMessage ev (handleTrace st ev) >>= return . fromMaybe st)

228+ handleMessage ev (handleTrace st ev) >>= return . fromMaybe st)

229229 ]

230230 traceLoop st'

231231

@@ -263,8 +263,8 @@ traceController mv = do

263263applyTraceFlags :: TraceFlags -> TracerState -> Process TracerState

264264applyTraceFlags flags' state = return state { flags = flags' }

265265

266−handleTrace :: TracerState -> Message -> TraceEvent -> Process TracerState

267−handleTrace st msg ev@(TraceEvRegistered p n) =

266+handleTrace :: TracerState -> Message -> MxEvent -> Process TracerState

267+handleTrace st msg ev@(MxRegistered p n) =

268268 let regNames' =

269269 Map.insertWith (\_ ns -> Set.insert n ns) p

270270 (Set.singleton n)

@@ -272,7 +272,7 @@ handleTrace st msg ev@(TraceEvRegistered p n) =

272272 in do

273273 traceEv ev msg (traceRegistered (flags st)) st

274274 return st { regNames = regNames' }

275−handleTrace st msg ev@(TraceEvUnRegistered p n) =

275+handleTrace st msg ev@(MxUnRegistered p n) =

276276 let f ns = case ns of

277277 Nothing -> Nothing

278278 Just ns' -> Just (Set.delete n ns')

@@ -280,29 +280,29 @@ handleTrace st msg ev@(TraceEvUnRegistered p n) =

280280 in do

281281 traceEv ev msg (traceUnregistered (flags st)) st

282282 return st { regNames = regNames' }

283−handleTrace st msg ev@(TraceEvSpawned _) = do

283+handleTrace st msg ev@(MxSpawned _) = do

284284 traceEv ev msg (traceSpawned (flags st)) st >> return st

285−handleTrace st msg ev@(TraceEvDied _ _) = do

285+handleTrace st msg ev@(MxProcessDied _ _) = do

286286 traceEv ev msg (traceDied (flags st)) st >> return st

287−handleTrace st msg ev@(TraceEvSent _ _ _) =

287+handleTrace st msg ev@(MxSent _ _ _) =

288288 traceEv ev msg (traceSend (flags st)) st >> return st

289−handleTrace st msg ev@(TraceEvReceived _ _) =

289+handleTrace st msg ev@(MxReceived _ _) =

290290 traceEv ev msg (traceRecv (flags st)) st >> return st

291291handleTrace st msg ev = do

292292 case ev of

293− (TraceEvNodeDied _ _) ->

293+ (MxNodeDied _ _) ->

294294 case (traceNodes (flags st)) of

295295 True -> sendTrace st msg

296296 False -> return ()

297− (TraceEvUser _) -> sendTrace st msg

298− (TraceEvLog _) -> sendTrace st msg

297+ (MxUser _) -> sendTrace st msg

298+ (MxLog _) -> sendTrace st msg

299299 _ ->

300300 case (traceConnections (flags st)) of

301301 True -> sendTrace st msg

302302 False -> return ()

303303 return st

304304

305−traceEv :: TraceEvent

305+traceEv :: MxEvent

306306 -> Message

307307 -> Maybe TraceSubject

308308 -> TracerState

src/Control/Distributed/Process/Internal/Trace/Types.hs+55−52

@@ -1,7 +1,7 @@

11-- | Tracing/Debugging support - Types

22module Control.Distributed.Process.Internal.Trace.Types

33 ( MxEventBus(..)

4− , TraceEvent(..)

4+ , MxEvent(..)

55 , SetTrace(..)

66 , Addressable(..)

77 , TraceSubject(..)

@@ -47,6 +47,7 @@ import Data.Typeable

4747import System.Mem.Weak (deRefWeak)

4848import Network.Transport

4949 ( ConnectionId

50+ , EndPointAddress

5051 )

5152

5253--------------------------------------------------------------------------------

@@ -56,47 +57,49 @@ import Network.Transport

5657data SetTrace = TraceEnable !ProcessId | TraceDisable

5758 deriving (Typeable, Eq, Show)

5859

60+-- TODO: MOVE the whole Trace namespace into C.D.Process.Management

61+

5962-- | An event that is fired when something /interesting/ happens.

6063-- Trace events are forwarded to a trace listener process, of which

6164-- at most one can be registered per-node.

62−data TraceEvent =

63− TraceEvSpawned ProcessId

65+data MxEvent =

66+ MxSpawned ProcessId

6467 -- ^ fired whenever a local process is spawned

65− | TraceEvRegistered ProcessId String

68+ | MxRegistered ProcessId String

6669 -- ^ fired whenever a process/name is registered (locally)

67− | TraceEvUnRegistered ProcessId String

70+ | MxUnRegistered ProcessId String

6871 -- ^ fired whenever a process/name is unregistered (locally)

69− | TraceEvDied ProcessId DiedReason

72+ | MxProcessDied ProcessId DiedReason

7073 -- ^ fired whenever a process dies

71− | TraceEvNodeDied NodeId DiedReason

74+ | MxNodeDied NodeId DiedReason

7275 -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)

73− | TraceEvSent ProcessId ProcessId Message

76+ | MxSent ProcessId ProcessId Message

7477 -- ^ fired whenever a message is sent from a local process

75− | TraceEvReceived ProcessId Message

78+ | MxReceived ProcessId Message

7679 -- ^ fired whenever a message is received by a local process

77− | TraceEvConnected ConnectionId

80+ | MxConnected ConnectionId EndPointAddress

7881 -- ^ fired when a network-transport connection is first established

79− | TraceEvDisconnected ConnectionId

82+ | MxDisconnected ConnectionId EndPointAddress

8083 -- ^ fired when a network-transport connection is broken/disconnected

81− | TraceEvUser Message

84+ | MxUser Message

8285 -- ^ a user defined trace event (see 'traceMessage')

83− | TraceEvLog String

86+ | MxLog String

8487 -- ^ a /logging/ event - used for debugging purposes only

85− | TraceEvTakeover ProcessId

88+ | MxTraceTakeover ProcessId

8689 -- ^ notifies a trace listener that all subsequent traces will be sent to /pid/

87− | TraceEvDisable

90+ | MxTraceDisable

8891 -- ^ notifies a trace listener that it has been disabled/removed

8992 deriving (Typeable, Show)

9093

9194class Addressable a where

9295 resolveToPid :: a -> Maybe ProcessId

9396

94−instance Addressable TraceEvent where

95− resolveToPid (TraceEvSpawned p) = Just p

96− resolveToPid (TraceEvDied p _) = Just p

97− resolveToPid (TraceEvSent _ p _) = Just p

98− resolveToPid (TraceEvReceived p _) = Just p

99− resolveToPid _ = Nothing

97+instance Addressable MxEvent where

98+ resolveToPid (MxSpawned p) = Just p

99+ resolveToPid (MxProcessDied p _) = Just p

100+ resolveToPid (MxSent _ p _) = Just p

101+ resolveToPid (MxReceived p _) = Just p

102+ resolveToPid _ = Nothing

100103

101104-- | Defines which processes will be traced by a given 'TraceFlag',

102105-- either by name, or @ProcessId@. Choosing @TraceAll@ is /by far/

@@ -149,7 +152,7 @@ data TraceOk = TraceOk

149152--------------------------------------------------------------------------------

150153

151154traceLog :: MxEventBus -> String -> IO ()

152−traceLog tr s = publishEvent tr (unsafeCreateUnencodedMessage $ TraceEvLog s)

155+traceLog tr s = publishEvent tr (unsafeCreateUnencodedMessage $ MxLog s)

153156

154157traceLogFmt :: MxEventBus

155158 -> String

@@ -161,11 +164,11 @@ traceLogFmt t d ls =

161164 toS (TraceStr s) = s

162165 toS (Trace a) = show a

163166

164−traceEvent :: MxEventBus -> TraceEvent -> IO ()

167+traceEvent :: MxEventBus -> MxEvent -> IO ()

165168traceEvent tr ev = publishEvent tr (unsafeCreateUnencodedMessage ev)

166169

167170traceMessage :: Serializable m => MxEventBus -> m -> IO ()

168−traceMessage tr msg = traceEvent tr (TraceEvUser (unsafeCreateUnencodedMessage msg))

171+traceMessage tr msg = traceEvent tr (MxUser (unsafeCreateUnencodedMessage msg))

169172

170173enableTrace :: MxEventBus -> ProcessId -> IO ()

171174enableTrace t p =

@@ -223,38 +226,38 @@ instance Binary SetTrace where

223226 2 -> return TraceDisable

224227 _ -> error "SetTrace.get - invalid header"

225228

226−instance Binary TraceEvent where

227− put (TraceEvSpawned pid) = putWord8 1 >> put pid

228− put (TraceEvRegistered pid str) = putWord8 2 >> put pid >> put str

229− put (TraceEvUnRegistered pid str) = putWord8 3 >> put pid >> put str

230− put (TraceEvDied pid res) = putWord8 4 >> put pid >> put res

231− put (TraceEvNodeDied nid res) = putWord8 5 >> put nid >> put res

232− put (TraceEvSent to from msg) = putWord8 6 >> put to >> put from >> put msg

233− put (TraceEvReceived pid msg) = putWord8 7 >> put pid >> put msg

234− put (TraceEvConnected cid) = putWord8 8 >> put cid

235− put (TraceEvDisconnected cid) = putWord8 9 >> put cid

236− put (TraceEvUser msg) = putWord8 10 >> put msg

237− put (TraceEvLog msg) = putWord8 11 >> put msg

238− put (TraceEvTakeover pid) = putWord8 12 >> put pid

239− put TraceEvDisable = putWord8 13

229+instance Binary MxEvent where

230+ put (MxSpawned pid) = putWord8 1 >> put pid

231+ put (MxRegistered pid str) = putWord8 2 >> put pid >> put str

232+ put (MxUnRegistered pid str) = putWord8 3 >> put pid >> put str

233+ put (MxProcessDied pid res) = putWord8 4 >> put pid >> put res

234+ put (MxNodeDied nid res) = putWord8 5 >> put nid >> put res

235+ put (MxSent to from msg) = putWord8 6 >> put to >> put from >> put msg

236+ put (MxReceived pid msg) = putWord8 7 >> put pid >> put msg

237+ put (MxConnected cid epid) = putWord8 8 >> put cid >> put epid

238+ put (MxDisconnected cid epid) = putWord8 9 >> put cid >> put epid

239+ put (MxUser msg) = putWord8 10 >> put msg

240+ put (MxLog msg) = putWord8 11 >> put msg

241+ put (MxTraceTakeover pid) = putWord8 12 >> put pid

242+ put MxTraceDisable = putWord8 13

240243

241244 get = do

242245 header <- getWord8

243246 case header of

244− 1 -> TraceEvSpawned <$> get

245− 2 -> TraceEvRegistered <$> get <*> get

246− 3 -> TraceEvUnRegistered <$> get <*> get

247− 4 -> TraceEvDied <$> get <*> get

248− 5 -> TraceEvNodeDied <$> get <*> get

249− 6 -> TraceEvSent <$> get <*> get <*> get

250− 7 -> TraceEvReceived <$> get <*> get

251− 8 -> TraceEvConnected <$> get

252− 9 -> TraceEvDisconnected <$> get

253− 10 -> TraceEvUser <$> get

254− 11 -> TraceEvLog <$> get

255− 12 -> TraceEvTakeover <$> get

256− 13 -> return TraceEvDisable

257− _ -> error "TraceEvent.get - invalid header"

247+ 1 -> MxSpawned <$> get

248+ 2 -> MxRegistered <$> get <*> get

249+ 3 -> MxUnRegistered <$> get <*> get

250+ 4 -> MxProcessDied <$> get <*> get

251+ 5 -> MxNodeDied <$> get <*> get

252+ 6 -> MxSent <$> get <*> get <*> get

253+ 7 -> MxReceived <$> get <*> get

254+ 8 -> MxConnected <$> get <*> get

255+ 9 -> MxDisconnected <$> get <*> get

256+ 10 -> MxUser <$> get

257+ 11 -> MxLog <$> get

258+ 12 -> MxTraceTakeover <$> get

259+ 13 -> return MxTraceDisable

260+ _ -> error "MxEvent.get - invalid header"

258261

259262instance Binary TraceSubject where

260263 put TraceAll = putWord8 1

src/Control/Distributed/Process/Internal/Types.hs+1

@@ -215,6 +215,7 @@ data MxEventBus =

215215 , tracer :: !Tracer

216216 , evbuss :: !(Weak (CQueue Message))

217217 , mxNew :: !((Message -> Process ()) -> IO ProcessId)

218+-- , mxReg :: !(StrictMVar (Map MxAgentId ))

218219 }

219220

220221-- | Local nodes

src/Control/Distributed/Process/Management.hs+11−2

@@ -20,7 +20,7 @@

2020--

2121-- /Management Extensions/ for Cloud Haskell.

2222--

23−-- This module provides a standard API for monitoring and/or responding to

23+-- This module provides a standard API for receiving and/or responding to

2424-- system events in a Cloud Haskell node.

2525--

2626-- [Architecture Overview]

@@ -37,7 +37,6 @@

3737-- 3. @Remote@ - provides an API for remote management and administration

3838--

3939--

40−--

4140-----------------------------------------------------------------------------

4241module Control.Distributed.Process.Management where

4342

@@ -73,3 +72,13 @@ mxAgent handler = do

7372 -- registerAgent pid

7473 return pid

7574

75+mxPublish = undefined

76+

77+mxSet = undefined

78+

79+mxGet = undefined

80+

81+mxIncrement = undefined

82+

83+mxDecrement = undefined

84+

src/Control/Distributed/Process/Management/Bus.hs+31

@@ -9,10 +9,41 @@ import Control.Distributed.Process.Internal.CQueue

99import Control.Distributed.Process.Internal.Types

1010 ( MxEventBus(..)

1111 , Message

12+ , ProcessId

13+ , DiedReason

14+ , NodeId

1215 )

1316import Data.Foldable (forM_)

17+import Data.Typeable (Typeable)

18+import Network.Transport

19+ ( ConnectionId

20+ , EndPointAddress

21+ )

1422import System.Mem.Weak (deRefWeak)

1523

24+data MxEvent =

25+ MxSpawned ProcessId

26+ -- ^ fired whenever a local process is spawned

27+ | MxRegistered ProcessId String

28+ -- ^ fired whenever a process/name is registered (locally)

29+ | MxUnRegistered ProcessId String

30+ -- ^ fired whenever a process/name is unregistered (locally)

31+ | MxProcessDied ProcessId DiedReason

32+ -- ^ fired whenever a process dies

33+ | MxNodeDied NodeId DiedReason

34+ -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)

35+ | MxSent ProcessId ProcessId Message

36+ -- ^ fired whenever a message is sent from a local process

37+ | MxReceived ProcessId Message

38+ -- ^ fired whenever a message is received by a local process

39+ | MxConnected ConnectionId EndPointAddress

40+ -- ^ fired when a network-transport connection is first established

41+ | MxDisconnected ConnectionId

42+ -- ^ fired when a network-transport connection is broken/disconnected

43+ | MxUser Message

44+ -- ^ a user defined trace event (see 'traceMessage')

45+ deriving (Typeable, Show)

46+

1647publishEvent :: MxEventBus -> Message -> IO ()

1748publishEvent MxEventBusInitialising _ = return ()

1849publishEvent (MxEventBus _ _ wqRef _) msg = do

src/Control/Distributed/Process/Node.hs+12−12

@@ -154,7 +154,7 @@ import qualified Control.Distributed.Process.Internal.Trace.Remote as Trace

154154 )

155155import Control.Distributed.Process.Internal.Trace.Types

156156 ( TraceArg(..)

157− , TraceEvent(..)

157+ , MxEvent(..)

158158 , traceEvent

159159 , traceLogFmt

160160 , enableTrace

@@ -355,7 +355,7 @@ forkProcess node proc = modifyMVar (localState node) startProcess

355355

356356

357357 -- see note [tracer/forkProcess races]

358− trace node (TraceEvSpawned pid)

358+ trace node (MxSpawned pid)

359359

360360 if lpidCounter lpid == maxBound

361361 then do

@@ -435,7 +435,7 @@ handleIncomingMessages node = go initConnectionState

435435 NT.ConnectionOpened cid rel theirAddr ->

436436 if rel == NT.ReliableOrdered

437437 then

438− trace node (TraceEvConnected cid)

438+ trace node (MxConnected cid theirAddr)

439439 >> go (

440440 (incomingAt cid ^= Just (theirAddr, Uninit))

441441 . (incomingFrom theirAddr ^: Set.insert cid)

@@ -451,7 +451,7 @@ handleIncomingMessages node = go initConnectionState

451451 -- it from the NC state? (and same for channels, below)

452452 let msg = payloadToMessage payload

453453 enqueue queue msg -- 'enqueue' is strict

454− trace node (TraceEvReceived pid msg)

454+ trace node (MxReceived pid msg)

455455 go st

456456 Just (_, ToChan (TypedChannel chan')) -> do

457457 mChan <- deRefWeak chan'

@@ -500,7 +500,7 @@ handleIncomingMessages node = go initConnectionState

500500 Nothing ->

501501 invalidRequest cid st

502502 Just (src, _) -> do

503− trace node (TraceEvDisconnected cid)

503+ trace node (MxDisconnected cid src)

504504 go ( (incomingAt cid ^= Nothing)

505505 . (incomingFrom src ^: Set.delete cid)

506506 $ st

@@ -599,8 +599,8 @@ traceNotifyDied node ident reason =

599599 -- TODO: sendPortDied notifications

600600 liftIO $ withLocalTracer node $ \t ->

601601 case ident of

602− (NodeIdentifier nid) -> traceEvent t (TraceEvNodeDied nid reason)

603− (ProcessIdentifier pid) -> traceEvent t (TraceEvDied pid reason)

602+ (NodeIdentifier nid) -> traceEvent t (MxNodeDied nid reason)

603+ (ProcessIdentifier pid) -> traceEvent t (MxProcessDied pid reason)

604604 _ -> return ()

605605

606606traceEventFmtIO :: LocalNode

@@ -610,7 +610,7 @@ traceEventFmtIO :: LocalNode

610610traceEventFmtIO node fmt args =

611611 withLocalTracer node $ \t -> traceLogFmt t fmt args

612612

613−trace :: LocalNode -> TraceEvent -> IO ()

613+trace :: LocalNode -> MxEvent -> IO ()

614614trace node ev = withLocalTracer node $ \t -> traceEvent t ev

615615

616616withLocalTracer :: LocalNode -> (MxEventBus -> IO ()) -> IO ()

@@ -781,7 +781,7 @@ ncEffectSpawn pid cProc ref = do

781781 mProc <- unClosure cProc

782782 -- If the closure does not exist, we spawn a process that throws an exception

783783 -- This allows the remote node to find out what's happening

784− -- TODO:

784+ -- TODO:

785785 let proc = case mProc of

786786 Left err -> fail $ "Error: Could not resolve closure: " ++ err

787787 Right p -> p

@@ -813,8 +813,8 @@ ncEffectRegister from label atnode mPid reregistration = do

813813 do modify' $ registeredHereFor label ^= mPid

814814 updateRemote node currentVal mPid

815815 case mPid of

816− (Just p) -> liftIO $ trace node (TraceEvRegistered p label)

817− Nothing -> liftIO $ trace node (TraceEvUnRegistered (fromJust currentVal) label)

816+ (Just p) -> liftIO $ trace node (MxRegistered p label)

817+ Nothing -> liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)

818818 liftIO $ sendMessage node

819819 (NodeIdentifier (localNodeId node))

820820 (ProcessIdentifier from)

@@ -882,7 +882,7 @@ ncEffectLocalSend :: LocalNode -> ProcessId -> Message -> NC ()

882882ncEffectLocalSend node to msg =

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

884884 enqueue (processQueue p) msg

885− trace node (TraceEvReceived to msg)

885+ trace node (MxReceived to msg)

886886

887887-- [Issue #DP-20]

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

tests/TestTracing.hs+13−19

@@ -18,7 +18,6 @@ import Control.Distributed.Process.Node

1818 , initRemoteTable

1919 , closeLocalNode

2020 , LocalNode)

21−import Control.Exception as Ex (catch)

2221import Network.Transport.TCP

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

2423import Prelude hiding (catch, log)

@@ -32,11 +31,6 @@ import Test.HUnit (Assertion)

3231import Test.HUnit.Base (assertBool)

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

3433

35−import System.Environment (getEnv)

36−import System.Posix.Env

37− ( setEnv

38− )

39−

4034-- these utilities have been cribbed from distributed-process-platform

4135-- we should really find a way to share them...

4236

@@ -81,8 +75,8 @@ testSpawnTracing result = do

8175 evDied <- liftIO $ newEmptyMVar

8276 tracer <- startTracer $ \ev -> do

8377 case ev of

84− (TraceEvSpawned p) -> liftIO $ putMVar evSpawned p

85− (TraceEvDied p r) -> liftIO $ putMVar evDied (p, r)

78+ (MxSpawned p) -> liftIO $ putMVar evSpawned p

79+ (MxProcessDied p r) -> liftIO $ putMVar evDied (p, r)

8680 _ -> return ()

8781

8882 (sp, rp) <- newChan

@@ -115,7 +109,7 @@ testTraceRecvExplicitPid result = do

115109 withTracer

116110 (\ev ->

117111 case ev of

118− (TraceEvReceived pid' _) -> stash res (pid == pid')

112+ (MxReceived pid' _) -> stash res (pid == pid')

119113 _ -> return ()) $ do

120114 (sp, rp) <- newChan

121115 send pid sp

@@ -137,7 +131,7 @@ testTraceRecvNamedPid result = do

137131 withTracer

138132 (\ev ->

139133 case ev of

140− (TraceEvReceived pid' _) -> stash res (pid == pid')

134+ (MxReceived pid' _) -> stash res (pid == pid')

141135 _ -> return ()) $ do

142136 (sp, rp) <- newChan

143137 send pid sp

@@ -155,7 +149,7 @@ testTraceSending result = do

155149 withTracer

156150 (\ev ->

157151 case ev of

158− (TraceEvSent to from msg) -> do

152+ (MxSent to from msg) -> do

159153 (Just s) <- unwrapMessage msg :: Process (Maybe String)

160154 stash res (to == pid && from == self && s == "hello there")

161155 stash res (to == pid && from == self)

@@ -180,7 +174,7 @@ testTraceRegistration result = do

180174 withTracer

181175 (\ev ->

182176 case ev of

183− TraceEvRegistered p s ->

177+ MxRegistered p s ->

184178 stash res (p == pid && s == "foobar")

185179 _ ->

186180 return ()) $ do

@@ -207,7 +201,7 @@ testTraceUnRegistration result = do

207201 withTracer

208202 (\ev ->

209203 case ev of

210− TraceEvUnRegistered p n -> do

204+ MxUnRegistered p n -> do

211205 stash res (p == pid && n == "foobar")

212206 send pid ()

213207 _ ->

@@ -241,21 +235,21 @@ testTraceLayering result = do

241235 withTracer

242236 (\ev ->

243237 case ev of

244− TraceEvDied _ _ -> liftIO $ putMVar died ()

245− _ -> return ())

238+ MxProcessDied _ _ -> liftIO $ putMVar died ()

239+ _ -> return ())

246240 ( do {

247241 recv <- liftIO $ newEmptyMVar

248242 ; withTracer

249243 (\ev' ->

250244 case ev' of

251− TraceEvReceived _ _ -> liftIO $ putMVar recv ()

245+ MxReceived _ _ -> liftIO $ putMVar recv ()

252246 _ -> return ())

253247 ( do {

254248 user <- liftIO $ newEmptyMVar

255249 ; withTracer

256250 (\ev'' ->

257251 case ev'' of

258− TraceEvUser _ -> liftIO $ putMVar user ()

252+ MxUser _ -> liftIO $ putMVar user ()

259253 _ -> return ())

260254 (send pid () >> (liftIO $ takeMVar user))

261255 ; liftIO $ takeMVar recv

@@ -276,7 +270,7 @@ testRemoteTraceRelay result =

276270 -- garbage on stderr for the duration of the test run.

277271 -- Here we set up that relay, and then wait for a signal

278272 -- that the tracer (on node1) has seen the expected

279− -- TraceEvSpawned message, at which point we're finished

273+ -- MxSpawned message, at which point we're finished

280274 (Just log') <- whereis "logger"

281275 pid <- liftIO $ forkProcess node2 $ do

282276 logRelay <- spawnLocal $ relay log'

@@ -293,7 +287,7 @@ testRemoteTraceRelay result =

293287 withTracer

294288 (\ev ->

295289 case ev of

296− TraceEvSpawned p -> stash observedPid p >> send pid ()

290+ MxSpawned p -> stash observedPid p >> send pid ()

297291 _ -> return ()) $ do

298292 relayPid <- startTraceRelay nid

299293 liftIO $ threadDelay 1000000