c600749 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Do not use (re)register APIs to track trace clients

c600749Tim Watson14 years ago

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

compare with master

unifiedsplit

@@ -168,6 +168,7 @@ import qualified Control.Distributed.Process.Internal.Trace.Primitives as Tracer

168 , setTraceFlags

169 , setTraceFlagsSync

170 , getTraceFlags

171+ , getCurrentTraceClient

171 , traceOn

172 , traceOn

172 , traceOff

173 , traceOff

173 , traceOnly

174 , traceOnly

@@ -195,20 +196,14 @@ import Prelude hiding (catch)

195-- Only one tracer can be registered at a time, however /this/ function overlays

196-- Only one tracer can be registered at a time, however /this/ function overlays

196-- the registered tracer with the supplied handler, allowing the user to layer

197-- the registered tracer with the supplied handler, allowing the user to layer

197-- multiple tracers on top of one another, with trace events forwarded down

198-- multiple tracers on top of one another, with trace events forwarded down

198−-- through all the layers in turn. Once the top layer is stopped, it will

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

199−-- reregister the original (prior) tracer pid before terminating.

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

201+-- terminating. See 'withTracer' for a mechanism that handles that.

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

202startTracer :: (TraceEvent -> Process ()) -> Process ProcessId

201startTracer handler = do

203startTracer handler = do

202 withRegisteredTracer $ \pid -> do

204 withRegisteredTracer $ \pid -> do

203 node <- processNode <$> ask

205 node <- processNode <$> ask

204− newPid <- liftIO $ forkProcess node $ do

206+ newPid <- liftIO $ forkProcess node $ traceProxy pid handler

205− -- TODO: we ensure that the original

206− -- tracer is re-registered, but it is

207− -- possible this could lead to races

208− -- if multiple tracers crash in very

209− -- close succession, due to scheduling

210− finally (traceProxy pid handler)

211− (resetTracer pid)

212 enableTrace newPid -- invokes sync + registration

207 enableTrace newPid -- invokes sync + registration

213 return newPid

208 return newPid

214

209

@@ -221,20 +216,25 @@ withTracer :: forall a.

221 -> Process (Either SomeException a)

216 -> Process (Either SomeException a)

222withTracer handler proc = do

217withTracer handler proc = do

223 say "starting new tracer"

218 say "starting new tracer"

219+ previous <- whereis "tracer"

224 tracer <- startTracer handler

220 tracer <- startTracer handler

225− finally (try ((say "evaluating tracer proc...") >> proc))

221+ finally (try proc)

226− (stopTracing tracer)

222+ (stopTracing tracer previous)

227 where

223 where

228− stopTracing :: ProcessId -> Process ()

224+ stopTracing :: ProcessId -> Maybe ProcessId -> Process ()

229− stopTracing tracer = do

225+ stopTracing tracer previousTracer = do

230− say "stopping tracer"

226+ case previousTracer of

227+ Nothing -> return ()

228+ Just p -> do

231− ref <- monitor tracer

229+ ref <- monitor tracer

232− stopTracer

230+ say "resetting to previous tracer" >> enableTrace p

231+ say "stopping tracer"

232+ send tracer TraceEvDisable

233+ say $ "waiting for EXIT from tracer " ++ (show tracer)

233− receiveWait [

234+ receiveWait [

234− matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')

235+ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')

235− (\_ -> return ())

236+ (\_ -> say "seen EXIT ok")

236− ]

237+ ]

237− say "stopped..."

238

239-- | Evaluate @proc@ with the supplied flags enabled. Any previously set

240-- flags are restored immediately afterwards.

@@ -254,14 +254,9 @@ traceProxy pid act = do

254 say "tracing has started"

255 proxy pid $ \(ev :: TraceEvent) ->

256 case ev of

257− (TraceEvTakeover _) -> die "takeover"

257+ (TraceEvTakeover p) -> say ((show p) ++ " has taken over...") >> return False

258− TraceEvDisable -> die "disabled"

258+ TraceEvDisable -> say "dying - disabled..." >> die "disabled"

259− _ -> act ev >> return True

259+ _ -> say ("act on " ++ (show ev)) >> act ev >> return True

260−

261−resetTracer :: ProcessId -> Process ()

262−resetTracer pid = do

263− say $ "resetting trace to " ++ (show pid)

264− enableTrace pid

265

260

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

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

267-- Note that only one tracer process can be active at any given time.

262-- Note that only one tracer process can be active at any given time.

@@ -275,14 +270,17 @@ resetTracer pid = do

275-- supplied tracers (i.e., processes started via 'startTracer') have exited,

270-- supplied tracers (i.e., processes started via 'startTracer') have exited,

276-- subsequent calls to this function will have no effect.

271-- subsequent calls to this function will have no effect.

277--

272--

278−-- If tracing is support disabled for the node, this function will also

273+-- If tracing support is disabled for the node, this function will also

279−-- have no effect.

274+-- have no effect. If the last tracer to have been registered (or the process

275+-- registered with the label @"tracer"@ at the time the stop instruction

276+-- is received) was not started with 'startTracer' then the behaviour of

277+-- this function is /undefined/.

280stopTracer :: Process ()

278stopTracer :: Process ()

281stopTracer =

279stopTracer =

282 withRegisteredTracer $ \pid -> do

280 withRegisteredTracer $ \pid -> do

283 -- we need to avoid killing the initial (base) tracer, as

281 -- we need to avoid killing the initial (base) tracer, as

284 -- nothing we rely on having exactly 1 registered tracer

282 -- nothing we rely on having exactly 1 registered tracer

285− -- process at all times!

283+ -- process at all times.

286 basePid <- whereis "tracer.initial"

284 basePid <- whereis "tracer.initial"

287 case basePid == (Just pid) of

285 case basePid == (Just pid) of

288 True -> return ()

286 True -> return ()

@@ -290,7 +288,9 @@ stopTracer =

290

288

291withRegisteredTracer :: (ProcessId -> Process a) -> Process a

289withRegisteredTracer :: (ProcessId -> Process a) -> Process a

292withRegisteredTracer act = do

290withRegisteredTracer act = do

291+ (sp, rp) <- newChan

292+ withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp

293− currentTracer <- whereis "tracer"

293+ currentTracer <- receiveChan rp

294 case currentTracer of

295 Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }

296 (Just p) -> act p

src/Control/Distributed/Process/Internal/Trace/Primitives.hs+4

@@ -18,6 +18,7 @@ module Control.Distributed.Process.Internal.Trace.Primitives

18 , getTraceFlags

19 , setTraceFlags

20 , setTraceFlagsSync

21+ , getCurrentTraceClient

21 , traceOnly

22 , traceOnly

22 , traceOn

23 , traceOn

23 , traceOff

24 , traceOff

@@ -98,6 +99,9 @@ setTraceFlagsSync t s f =

98getTraceFlags :: Tracer -> SendPort TraceFlags -> IO ()

99getTraceFlags :: Tracer -> SendPort TraceFlags -> IO ()

99getTraceFlags t s = traceIt t (createUnencodedMessage s)

100getTraceFlags t s = traceIt t (createUnencodedMessage s)

100

101

102+getCurrentTraceClient :: Tracer -> SendPort (Maybe ProcessId) -> IO ()

103+getCurrentTraceClient t s = traceIt t (createUnencodedMessage s)

104+

101-- aux API and utilities

105-- aux API and utilities

102

106

103class Traceable a where

107class Traceable a where

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

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

27 , matchAny

28 , matchAnyIf

29 , handleMessage

30+ , matchUnknown

31+ , whereis

30− , reregister, say

32+ , reregister, say, unwrapMessage

31 )

33 )

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

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

33 ( TraceEvent(..)

35 ( TraceEvent(..)

@@ -87,9 +89,9 @@ import System.Mem.Weak

87 )

89 )

89data TracerState = TracerST {

91data TracerState = TracerST {

90− sendTrace :: !(Message -> Process ())

92+ client :: !(Maybe ProcessId)

91− , flags :: !TraceFlags

93+ , flags :: !TraceFlags

92− , regNames :: !(Map ProcessId (Set String))

94+ , regNames :: !(Map ProcessId (Set String))

93 }

95 }

95--------------------------------------------------------------------------------

97--------------------------------------------------------------------------------

@@ -104,11 +106,25 @@ defaultTracer =

104defaultTracerAux :: Process ()

106defaultTracerAux :: Process ()

105defaultTracerAux =

107defaultTracerAux =

106 catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" >> systemLoggerTracer)

108 catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" >> systemLoggerTracer)

107− (\(_ :: IOError) -> eventLogTracer)

109+ (\(_ :: IOError) -> defaultEventLogTracer)

110+

111+-- TODO: it would be /nice/ if we had some way of checking the runtime

112+-- options to see if +RTS -v (or similar) has been given...

113+defaultEventLogTracer :: Process ()

114+defaultEventLogTracer =

115+ catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_EVENTLOG" >> eventLogTracer)

116+ (\(_ :: IOError) -> nullTracer)

108

117

109checkEnv :: String -> Process String

118checkEnv :: String -> Process String

110checkEnv s = liftIO $ getEnv s

119checkEnv s = liftIO $ getEnv s

111

120

121+-- This trace client is (intentionally) useful - it simply provides

122+-- an intial client for the trace controller to talk to, until some

123+-- other (hopefully more useful) client is installed over the top of

124+-- it. This is the default trace client.

125+nullTracer :: Process ()

126+nullTracer = forever' $ receiveWait [ matchUnknown (return ()) ]

127+

112systemLoggerTracer :: Process ()

128systemLoggerTracer :: Process ()

113systemLoggerTracer = do

129systemLoggerTracer = do

114 node <- processNode <$> ask

130 node <- processNode <$> ask

@@ -171,7 +187,10 @@ traceController mv = do

171 -- the node's internal control channel if we can possibly help it!

187 -- the node's internal control channel if we can possibly help it!

172 weakQueue <- processWeakQ <$> ask

188 weakQueue <- processWeakQ <$> ask

173 liftIO $ putMVar mv weakQueue

189 liftIO $ putMVar mv weakQueue

190+ initialTracer <- whereis "tracer.initial"

174− traceLoop initialState

191+ traceLoop initialState {

192+ client = initialTracer

193+ }

175 where

194 where

176 traceLoop :: TracerState -> Process ()

195 traceLoop :: TracerState -> Process ()

177 traceLoop st = do

196 traceLoop st = do

@@ -179,22 +198,27 @@ traceController mv = do

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

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

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

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

181 st' <- receiveWait [

200 st' <- receiveWait [

182− -- we notify the previous tracer process that it has been replaced

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

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

184− -- We allow at most one trace target, which is a process id.

202+ -- We allow at most one trace client, which is a process id.

203+ -- Tracking multiple clients represents too high an overhead,

204+ -- so we leave that kind of thing to our consumers to figure

205+ -- figure out.

185 case set of

206 case set of

186 (TraceEnable pid) -> do

207 (TraceEnable pid) -> do

208+ -- notify the previous tracer it has been replaced

187 sendTrace st (createUnencodedMessage (TraceEvTakeover pid))

209 sendTrace st (createUnencodedMessage (TraceEvTakeover pid))

188− reregister "tracer" pid

210+ say $ "registering " ++ (show pid) ++ " as new tracer"

189 sendOk setResp

211 sendOk setResp

190− return st { sendTrace = (mkSender pid) }

212+ return st { client = (Just pid) }

191 TraceDisable -> do

213 TraceDisable -> do

192 sendTrace st (createUnencodedMessage TraceEvDisable)

214 sendTrace st (createUnencodedMessage TraceEvDisable)

193 sendOk setResp

215 sendOk setResp

194− return st { sendTrace = (\_ -> return ()) })

216+ say "setting sendTrace to noop"

217+ return st { client = Nothing })

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

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

196 sendOk confResp >> applyTraceFlags flags' st)

219 sendOk confResp >> applyTraceFlags flags' st)

197 , match (\chGetFlags -> sendChan chGetFlags (flags st) >> return st)

220 , match (\chGetFlags -> sendChan chGetFlags (flags st) >> return st)

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

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

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

199 , matchAny (\ev ->

223 , matchAny (\ev ->

200 handleMessage ev (handleTrace st ev) >>= return . fromMaybe st)

224 handleMessage ev (handleTrace st ev) >>= return . fromMaybe st)

@@ -205,26 +229,21 @@ traceController mv = do

205 sendOk Nothing = return ()

229 sendOk Nothing = return ()

206 sendOk (Just sp) = sendChan sp TraceOk

230 sendOk (Just sp) = sendChan sp TraceOk

207

231

208− mkSender :: ProcessId -> (Message -> Process ())

209− mkSender pid = \m -> do

210− say ("sending " ++ (show m) ++ " to " ++ (show pid))

211− (flip forward) pid m

212−

213 initialState :: TracerState

232 initialState :: TracerState

214 initialState =

233 initialState =

215 TracerST

234 TracerST

216− { sendTrace = (\_ -> return ())

235+ { client = Nothing

217− , flags = defaultTraceFlags

236+ , flags = defaultTraceFlags

218− , regNames = Map.empty

237+ , regNames = Map.empty

219 }

238 }

220

239

221−-- node [runtime tracer control]

240+-- note [runtime tracer control]

222--

241--

223-- The trace mechanism is designed to put as little stress on the system, and

242-- The trace mechanism is designed to put as little stress on the system, and

224-- in particular the node controller, as possible. The LocalNode's @tracer@

243-- in particular the node controller, as possible. The LocalNode's @tracer@

225-- field is therefore immutable, since we don't want to be blocking the node

244-- field is therefore immutable, since we don't want to be blocking the node

226-- controller when writing trace information out. The runtime cost of enabling

245-- controller when writing trace information out. The runtime cost of enabling

227−-- tracing is therefore, the cost of enqueue for all trace-able operations at

246+-- tracing is therefore the cost of enqueue for all trace-able operations at

228-- all times. If tracing is not explicitly enabled, the trace record stored in

247-- all times. If tracing is not explicitly enabled, the trace record stored in

229-- the local node state is matched and ignored in API calls, reducing the cost

248-- the local node state is matched and ignored in API calls, reducing the cost

230-- to a single function call.

249-- to a single function call.

@@ -262,13 +281,13 @@ handleTrace st msg ev = do

262 case ev of

281 case ev of

263 (TraceEvNodeDied _ _) ->

282 (TraceEvNodeDied _ _) ->

264 case (traceNodes (flags st)) of

283 case (traceNodes (flags st)) of

265− True -> (sendTrace st) msg

284+ True -> sendTrace st msg

266 False -> return ()

285 False -> return ()

267 (TraceEvUser _) -> do

286 (TraceEvUser _) -> do

268− (sendTrace st) msg

287+ sendTrace st msg

269 _ ->

288 _ ->

270 case (traceConnections (flags st)) of

289 case (traceConnections (flags st)) of

271− True -> (sendTrace st) msg

290+ True -> sendTrace st msg

272 False -> return ()

291 False -> return ()

273 return st

292 return st

274

293

@@ -278,14 +297,14 @@ traceEv :: TraceEvent

278 -> TracerState

297 -> TracerState

279 -> Process ()

298 -> Process ()

280traceEv _ _ Nothing _ = return ()

299traceEv _ _ Nothing _ = return ()

281−traceEv _ msg (Just TraceAll) st = (sendTrace st) msg

300+traceEv _ msg (Just TraceAll) st = sendTrace st msg

282traceEv ev msg (Just (TraceProcs pids)) st = do

301traceEv ev msg (Just (TraceProcs pids)) st = do

283 node <- processNode <$> ask

302 node <- processNode <$> ask

284 let p = case resolveToPid ev of

303 let p = case resolveToPid ev of

285 Nothing -> (nullProcessId (localNodeId node))

304 Nothing -> (nullProcessId (localNodeId node))

286 Just pid -> pid

305 Just pid -> pid

287 case (Set.member p pids) of

306 case (Set.member p pids) of

288− True -> (sendTrace st) msg

307+ True -> sendTrace st msg

289 False -> return ()

308 False -> return ()

290traceEv ev msg (Just (TraceNames names)) st = do

309traceEv ev msg (Just (TraceNames names)) st = do

291 -- TODO: if we have recorded regnames for p, then we

310 -- TODO: if we have recorded regnames for p, then we

@@ -298,5 +317,15 @@ traceEv ev msg (Just (TraceNames names)) st = do

298 Nothing -> return ()

317 Nothing -> return ()

299 Just ns -> if (Set.null (Set.intersection ns names))

318 Just ns -> if (Set.null (Set.intersection ns names))

300 then return ()

319 then return ()

320+ else sendTrace st msg

321+

322+sendTrace :: TracerState -> Message -> Process ()

301− else (sendTrace st) msg

323+sendTrace st msg =

324+ let pid = (client st) in do

325+ (Just ev) <- unwrapMessage msg :: Process (Maybe TraceEvent)

326+ say ("sending " ++ (show ev) ++ " to " ++ (show pid))

327+ case pid of

328+ Just p -> (flip forward) p msg

329+ Nothing -> return ()

330+

302

331

src/Control/Distributed/Process/Node.hs+1−2

@@ -272,8 +272,7 @@ startServiceProcesses node = do

272 mPid <- startDefaultTracer node

273 case mPid of

274 Nothing -> return ()

275− Just pid ->

276− runProcess node (register "tracer" pid >> register "tracer.initial" pid)

275+ Just pid -> runProcess node $ register "tracer.initial" pid

277

276

278 logger <- forkProcess node loop

277 logger <- forkProcess node loop

279 runProcess node $ register "logger" logger

278 runProcess node $ register "logger" logger

tests/TestTracing.hs+76−74

@@ -5,6 +5,7 @@ module Main where

5import Control.Concurrent.MVar

6 ( MVar

7 , newEmptyMVar

8+ , newMVar

8 , putMVar

9 , putMVar

9 , takeMVar

10 , takeMVar

10 )

11 )

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

17 , closeLocalNode

18 , closeLocalNode

18 , LocalNode)

19 , LocalNode)

19import Control.Exception as Ex (catch)

20import Control.Exception as Ex (catch)

20−import Data.Binary()

21−import Data.Typeable()

22import Network.Transport.TCP

21import Network.Transport.TCP

23import Prelude hiding (catch, log)

22import Prelude hiding (catch, log)

24import Test.Framework

23import Test.Framework

@@ -41,12 +40,22 @@ import System.Posix.Env

41-- | A mutable cell containing a test result.

40-- | A mutable cell containing a test result.

42type TestResult a = MVar a

41type TestResult a = MVar a

44−delayedAssertion :: (Eq a) => String -> LocalNode -> a ->

43+delayedAssertion :: (Eq a)

44+ => String

45+ -> LocalNode

46+ -> a

45− (TestResult a -> Process ()) -> Assertion

47+ -> (TestResult a -> Process ())

48+ -> MVar ()

49+ -> Assertion

46−delayedAssertion note localNode expected testProc = do

50+delayedAssertion note localNode expected testProc lock = do

47 result <- newEmptyMVar

51 result <- newEmptyMVar

48− _ <- forkProcess localNode $ testProc result

52+ _ <- forkProcess localNode $ do

53+ acquire lock

54+ finally (testProc result)

55+ (release lock)

49 assertComplete note result expected

56 assertComplete note result expected

57+ where acquire lock' = liftIO $ takeMVar lock'

58+ release lock' = liftIO $ putMVar lock' ()

51assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()

60assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()

52assertComplete msg mv a = do

61assertComplete msg mv a = do

@@ -67,29 +76,36 @@ testSpawnTracing result = do

68 evSpawned <- liftIO $ newEmptyMVar

77 evSpawned <- liftIO $ newEmptyMVar

69 evDied <- liftIO $ newEmptyMVar

78 evDied <- liftIO $ newEmptyMVar

70− startTracer $ \ev -> do

79+ tracer <- startTracer $ \ev -> do

80+ say "in spawn tracer..."

71 case ev of

81 case ev of

72 (TraceEvSpawned p) -> liftIO $ putMVar evSpawned p

82 (TraceEvSpawned p) -> liftIO $ putMVar evSpawned p

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

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

74 _ -> return ()

84 _ -> return ()

76 (sp, rp) <- newChan

86 (sp, rp) <- newChan

77− pid <- spawnLocal $ do

87+ pid <- spawnLocal $ sendChan sp ()

78− sendChan sp ()

79 () <- receiveChan rp

88 () <- receiveChan rp

81 tracedAlive <- liftIO $ takeMVar evSpawned

90 tracedAlive <- liftIO $ takeMVar evSpawned

82 (tracedDead, tracedReason) <- liftIO $ takeMVar evDied

91 (tracedDead, tracedReason) <- liftIO $ takeMVar evDied

84− stopTracer

93+ mref <- monitor tracer

94+ stopTracer -- this is asynchronous, so we need to wait...

95+ receiveWait [

96+ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)

97+ ((\_ -> return ()))

98+ ]

99+ say "seen the death of tracer"

85 setTraceFlags defaultTraceFlags

100 setTraceFlags defaultTraceFlags

101+ say "finishing setting default flags"

86 stash result (tracedAlive == pid &&

102 stash result (tracedAlive == pid &&

87 tracedDead == pid &&

103 tracedDead == pid &&

88 tracedReason == DiedNormal)

104 tracedReason == DiedNormal)

105

90testTraceRecvExplicitPid :: TestResult Bool -> Process ()

106testTraceRecvExplicitPid :: TestResult Bool -> Process ()

91testTraceRecvExplicitPid result = do

107testTraceRecvExplicitPid result = do

92− say "testTraceRecvExplicitPid"

108+ res <- liftIO $ newEmptyMVar

93 pid <- spawnLocal $ do

109 pid <- spawnLocal $ do

94 self <- getSelfPid

110 self <- getSelfPid

95 expect >>= (flip sendChan) self

111 expect >>= (flip sendChan) self

@@ -99,19 +115,18 @@ testTraceRecvExplicitPid result = do

99 withTracer

115 withTracer

100 (\ev ->

116 (\ev ->

101 case ev of

117 case ev of

102− (TraceEvReceived pid' _) -> stash result (pid == pid')

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

103 _ -> return ()) $ do

119 _ -> return ()) $ do

104 (sp, rp) <- newChan

120 (sp, rp) <- newChan

105 send pid sp

121 send pid sp

106 p <- receiveChan rp

122 p <- receiveChan rp

107− res <- liftIO $ takeMVar result

123+ res' <- liftIO $ takeMVar res

108− stash result (res && (p == pid))

124+ stash result (res' && (p == pid))

109− say "Explicit done!!!"

110 return ()

125 return ()

111

126

112testTraceRecvNamedPid :: TestResult Bool -> Process ()

127testTraceRecvNamedPid :: TestResult Bool -> Process ()

113testTraceRecvNamedPid result = do

128testTraceRecvNamedPid result = do

114− say "testTraceRecvNamedPid"

129+ res <- liftIO $ newEmptyMVar

115 pid <- spawnLocal $ do

130 pid <- spawnLocal $ do

116 self <- getSelfPid

131 self <- getSelfPid

117 register "foobar" self

132 register "foobar" self

@@ -122,98 +137,85 @@ testTraceRecvNamedPid result = do

122 withTracer

137 withTracer

123 (\ev ->

138 (\ev ->

124 case ev of

139 case ev of

125− (TraceEvReceived pid' _) -> stash result (pid == pid')

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

126 _ -> return ()) $ do

141 _ -> return ()) $ do

127 (sp, rp) <- newChan

142 (sp, rp) <- newChan

128 send pid sp

143 send pid sp

129 p <- receiveChan rp

144 p <- receiveChan rp

130− res <- liftIO $ takeMVar result

145+ res' <- liftIO $ takeMVar res

131− stash result (res && (p == pid))

146+ stash result (res' && (p == pid))

132 return ()

147 return ()

133

148

134−data TraceWhat = User | Die | Rec

135− deriving (Show)

136−

137testTraceLayering :: TestResult () -> Process ()

149testTraceLayering :: TestResult () -> Process ()

138testTraceLayering result = do

150testTraceLayering result = do

139 pid <- spawnLocal $ do

151 pid <- spawnLocal $ do

140 getSelfPid >>= register "foobar"

152 getSelfPid >>= register "foobar"

141− say "registered - waiting for 'hello'"

142− "hello" <- expect

143− say "received 'hello' - waiting for () go"

144− p <- expect

145− say "pid received - sending trace msg"

146− traceMessage ("traceMsg", 123 :: Int)

147− say "sending reply"

148− send p ()

149 () <- expect

153 () <- expect

154+ traceMessage ("traceMsg", 123 :: Int)

150 return ()

155 return ()

151 withFlags defaultTraceFlags {

156 withFlags defaultTraceFlags {

152− traceDied = traceOnly ["foobar"]

157+ traceDied = traceOnly [pid]

153− , traceRecv = traceOnly [pid]

158+ , traceRecv = traceOnly ["foobar"]

154 } $ doTest pid result

159 } $ doTest pid result

155 return ()

160 return ()

156 where

161 where

157 doTest :: ProcessId -> MVar () -> Process ()

162 doTest :: ProcessId -> MVar () -> Process ()

158 doTest pid result' = do

163 doTest pid result' = do

159− go Die $ do

164+ -- TODO: this is pretty gross, even for a test case

160− go Rec $ do

165+ died <- liftIO $ newEmptyMVar

161− say "sending 'hello'"

166+ withTracer

162− send pid "hello"

167+ (\ev ->

163− go User $ do

168+ case ev of

164− getSelfPid >>= send pid

169+ TraceEvDied _ _ -> liftIO $ putMVar died ()

165− () <- expect

170+ _ -> return ())

166− say "received reply, returning to rec block"

171+ ( do {

172+ recv <- liftIO $ newEmptyMVar

173+ ; withTracer

174+ (\ev' ->

175+ case ev' of

176+ TraceEvReceived _ _ -> liftIO $ putMVar recv ()

177+ _ -> return ())

178+ ( do {

179+ user <- liftIO $ newEmptyMVar

180+ ; withTracer

181+ (\ev'' ->

182+ case ev'' of

183+ TraceEvUser _ -> liftIO $ putMVar user ()

167− return ()

184+ _ -> return ())

185+ (send pid () >> (liftIO $ takeMVar user))

186+ ; liftIO $ takeMVar recv

187+ })

188+ ; liftIO $ takeMVar died

189+ })

168 liftIO $ putMVar result' ()

190 liftIO $ putMVar result' ()

169

191

170− go :: TraceWhat -> Process () -> Process ()

171− go what proc = do {

172− say ("tracing " ++ (show what))

173− ; mv <- liftIO $ newEmptyMVar

174− ; r <- (withTracer

175− (\ev ->

176− case (matchTest what ev) of

177− True -> do

178− say ("matched " ++ (show ev))

179− liftIO $ putMVar mv ()

180− False -> say ("ignoring " ++ (show ev))) $ do

181− say ("in block for " ++ (show what))

182− proc)

183− ; case r of

184− Left e -> say "whoops"

185− Right _ -> say "ok!" >> (liftIO $ takeMVar mv)

186− }

187−

188− matchTest :: TraceWhat -> TraceEvent -> Bool

189− matchTest User (TraceEvUser _) = True

190− matchTest Die (TraceEvDied _ _) = True

191− matchTest Rec (TraceEvReceived _ _) = True

192− matchTest _ _ = False

193−

194tests :: LocalNode -> IO [Test]

192tests :: LocalNode -> IO [Test]

195tests node1 = do

193tests node1 = do

194+ -- if we execute the test cases in parallel, the

195+ -- various tracers will race with one another and

196+ -- we'll get garbage results (or worse, deadlocks)

197+ lock <- liftIO $ newMVar ()

196 enabled <- checkTraceEnabled

198 enabled <- checkTraceEnabled

197 case enabled of

199 case enabled of

198 True ->

200 True ->

199 return [

201 return [

200− testGroup "Process Info" [

202+ testGroup "Tracing" [

201− testCase "Test Spawn Tracing"

203+ testCase "Spawn Tracing"

202 (delayedAssertion

204 (delayedAssertion

203 "expected dead process-info to be ProcessInfoNone"

205 "expected dead process-info to be ProcessInfoNone"

204− node1 True testSpawnTracing)

206+ node1 True testSpawnTracing lock)

205− , testCase "Test Recv Tracing (Explicit Pid)"

207+ , testCase "Recv Tracing (Explicit Pid)"

206 (delayedAssertion

208 (delayedAssertion

207 "expected a recv trace for the supplied pid"

209 "expected a recv trace for the supplied pid"

208− node1 True testTraceRecvExplicitPid)

210+ node1 True testTraceRecvExplicitPid lock)

209− , testCase "Test Recv Tracing (Named Pid)"

211+ , testCase "Recv Tracing (Named Pid)"

210 (delayedAssertion

212 (delayedAssertion

211 "expected a recv trace for the process registered as 'foobar'"

213 "expected a recv trace for the process registered as 'foobar'"

212− node1 True testTraceRecvNamedPid)

214+ node1 True testTraceRecvNamedPid lock)

213− , testCase "Test Trace Layering"

215+ , testCase "Trace Layering"

214 (delayedAssertion

216 (delayedAssertion

215 "expected blah"

217 "expected blah"

216− node1 () testTraceLayering)

218+ node1 () testTraceLayering lock)

217 ] ]

219 ] ]

218 False ->

220 False ->

219 return []

221 return []