d251210 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Pass on registration trace events to clients

d251210Tim Watson14 years ago

src/Control/Distributed/Process/Debug.hs+30−23

compare with master

unifiedsplit

@@ -42,9 +42,10 @@

42-- trace handlers using Cloud Haskell's built-in delegation primitives.

43--

44-- The 'startTracer' function wraps the registered @tracer@ process with the

45−-- supplied handler, forwarding trace events to the original tracer. The

45+-- supplied handler and also forwarding trace events to the original tracer.

46−-- corresponding 'stopTracer' function terminates tracer processes in reverse

46+-- The corresponding 'stopTracer' function terminates tracer processes in

47−-- of the order in which they were started.

47+-- reverse of the order in which they were started, and re-establishes the

48+-- previous tracer process.

48--

49--

49-- [Built in tracers]

50-- [Built in tracers]

50--

51--

@@ -53,32 +54,39 @@

53-- can be configured using environment variables, or specified manually using

54-- can be configured using environment variables, or specified manually using

54-- the 'traceEnable' function. The base tracer process cannot be

55-- the 'traceEnable' function. The base tracer process cannot be

55--

56--

56−-- When a new local node is started, the contents of the environment variable

57+-- When a new local node is started, the contents of several environment

58+-- variables are checked to determine how the default tracer process

59+-- will handle trace events. If none of these variables is set, then the

60+-- trace events will be effectively ignored, although they will still be

61+-- generated and passed through the system. Only one configuration will be

62+-- chosen - the first that contains a (valid) value. These environment

63+-- variables, in the order they're checked, are:

64+--

57−-- @DISTRIBUTED_PROCESS_TRACE_FILE@ are checked for a valid file path. If this

65+-- 1. @DISTRIBUTED_PROCESS_TRACE_FILE@

66+-- This is checked for a valid file path. If it exists and the file can be

58−-- exists and the file can be opened for writing, all trace output will be

67+-- opened for writing, all trace output will be directed thence. If the supplied

59−-- directed thence. If the environment variable is empty, the path invalid, or

60−-- the file is unavailable for writing - e.g., because another node has already

68+-- path is invalid, or the file is unavailable for writing - e.g., because

69+-- another node has already started tracing to it - then this tracer will be

70+-- disabled.

71+--

61−-- started tracing to it - then the @DISTRIBUTED_PROCESS_TRACE_CONSOLE@

72+-- 2. @DISTRIBUTED_PROCESS_TRACE_CONSOLE@

62−-- environment variable is checked for /any/ non-empty value. If this is set,

73+-- This is checked for /any/ non-empty value. If set, then all trace output will

63−-- then all trace output will be directed to the system logger process. If

74+-- be directed to the system logger process.

64−-- neither variable provides a valid trace configuration, all internal traces

75+--

76+-- 3. @DISTRIBUTED_PROCESS_TRACE_EVENTLOG@

77+-- This is checked for /any/ non-empty value. If set, all internal traces are

65−-- are written to "Debug.Trace.traceEventIO", which writes to the GHC eventlog.

78+-- written to the GHC eventlog.

66--

79--

67-- Users of the /simplelocalnet/ Cloud Haskell backend should also note that

80-- Users of the /simplelocalnet/ Cloud Haskell backend should also note that

68-- because the trace file option only supports trace output from a single node

81-- because the trace file option only supports trace output from a single node

69-- (so as to avoid interleaving), a file trace configured for the master node

82-- (so as to avoid interleaving), a file trace configured for the master node

70−-- will prevent slaves from tracing to the file and they will fall back to using

83+-- will prevent slaves from tracing to the file and will need to fall back to

71-- the console or eventlog tracers instead.

84-- the console or eventlog tracers instead.

72--

85--

73−-- Just as with the "Debug.Trace" module, this is a debugging/tracing facility

74−-- for use in development, and probably not best used in a production setting -

75−-- which is why the default behaviour is to trace to the GHC eventlog. For a

76−-- general purpose logging facility, you should consider 'say'.

77−--

78-- Support for writing to the eventlog requires specific intervention to work,

86-- Support for writing to the eventlog requires specific intervention to work,

79−-- without which traces are silently dropped/ignored and no output will be

87+-- without which, written traces are silently dropped/ignored and no output will

80−-- generated. The GHC eventlog documentation provides information about enabling,

88+-- be generated. The GHC eventlog documentation provides information about

81−-- viewing and working with event traces at

89+-- enabling, viewing and working with event traces at

82-- <http://hackage.haskell.org/trac/ghc/wiki/EventLog>.

90-- <http://hackage.haskell.org/trac/ghc/wiki/EventLog>.

83--

91--

84module Control.Distributed.Process.Debug

92module Control.Distributed.Process.Debug

@@ -187,7 +195,6 @@ import Data.Binary()

187import Prelude hiding (catch)

195import Prelude hiding (catch)

188#endif

196#endif

189

197

190−

191--------------------------------------------------------------------------------

198--------------------------------------------------------------------------------

192-- Debugging/Tracing API --

199-- Debugging/Tracing API --

193--------------------------------------------------------------------------------

200--------------------------------------------------------------------------------

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

@@ -888,7 +888,7 @@ say :: String -> Process ()

888say string = do

889 now <- liftIO getCurrentTime

890 us <- getSelfPid

891− nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)

891+ nsend "logger" (formatTime defaultTimeLocale "[%d-%m-%Y] [%H:%M:%S-%q]" now, us, string)

892

893--------------------------------------------------------------------------------

894-- Registry --

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

@@ -271,7 +271,7 @@ handleTrace st msg ev@(TraceEvUnRegistered p n) =

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

272 regNames' = Map.alter f p (regNames st)

273 in do

274− traceEv ev msg (traceRegistered (flags st)) st

274+ traceEv ev msg (traceUnregistered (flags st)) st

275 return st { regNames = regNames' }

276handleTrace st msg ev@(TraceEvSpawned _) = do

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

src/Control/Distributed/Process/Internal/Trace/Types.hs+20−16

@@ -89,25 +89,27 @@ data TraceSubject =

89-- @Process@ events, take a 'TraceSubject' controlling which processes

90-- should generate trace events in the target process.

91data TraceFlags = TraceFlags {

92− traceSpawned :: !(Maybe TraceSubject) -- filter process spawned tracing

92+ traceSpawned :: !(Maybe TraceSubject) -- filter process spawned tracing

93− , traceDied :: !(Maybe TraceSubject) -- filter process died tracing

93+ , traceDied :: !(Maybe TraceSubject) -- filter process died tracing

94− , traceRegistered :: !(Maybe TraceSubject) -- filter process registration tracing

94+ , traceRegistered :: !(Maybe TraceSubject) -- filter process registration tracing

95+ , traceUnregistered :: !(Maybe TraceSubject) -- filter process un-registration

95− , traceSend :: !(Maybe TraceSubject) -- filter process/message tracing by sender

96+ , traceSend :: !(Maybe TraceSubject) -- filter process/message tracing by sender

96− , traceRecv :: !(Maybe TraceSubject) -- filter process/message tracing by receiver

97+ , traceRecv :: !(Maybe TraceSubject) -- filter process/message tracing by receiver

97− , traceNodes :: !Bool -- enable node status trace events

98+ , traceNodes :: !Bool -- enable node status trace events

98− , traceConnections :: !Bool -- enable connection status trace events

99+ , traceConnections :: !Bool -- enable connection status trace events

99 } deriving (Typeable)

100 } deriving (Typeable)

100

101

101defaultTraceFlags :: TraceFlags

102defaultTraceFlags :: TraceFlags

102defaultTraceFlags =

103defaultTraceFlags =

103 TraceFlags {

104 TraceFlags {

104− traceSpawned = Nothing

105+ traceSpawned = Nothing

105− , traceDied = Nothing

106+ , traceDied = Nothing

106− , traceRegistered = Nothing

107+ , traceRegistered = Nothing

108+ , traceUnregistered = Nothing

107− , traceSend = Nothing

109+ , traceSend = Nothing

108− , traceRecv = Nothing

110+ , traceRecv = Nothing

109− , traceNodes = False

111+ , traceNodes = False

110− , traceConnections = False

112+ , traceConnections = False

111 }

113 }

112

114

113data TraceArg =

115data TraceArg =

@@ -180,8 +182,10 @@ instance Binary TraceSubject where

180 _ -> error "TraceSubject.get - invalid header"

182 _ -> error "TraceSubject.get - invalid header"

181

183

182instance Binary TraceFlags where

184instance Binary TraceFlags where

185+ put (TraceFlags s d g u m r n c) =

183− put (TraceFlags s d g m r n c) = put s >> put d >> put g >> put m >> put r >> put n >> put c

186+ put s >> put d >> put g >> put u >> put m >> put r >> put n >> put c

187+ get =

184− get = TraceFlags <$> get <*> get <*> get <*> get <*> get <*> get <*> get

188+ TraceFlags <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

185

189

186instance Binary TraceOk where

190instance Binary TraceOk where

187 put _ = return ()

191 put _ = return ()

tests/TestTracing.hs+103−21

@@ -77,7 +77,6 @@ testSpawnTracing result = do

77 evSpawned <- liftIO $ newEmptyMVar

78 evDied <- liftIO $ newEmptyMVar

79 tracer <- startTracer $ \ev -> do

80− say "in spawn tracer..."

81 case ev of

80 case ev of

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

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

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

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

@@ -96,9 +95,7 @@ testSpawnTracing result = do

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

95 matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)

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

96 ((\_ -> return ()))

98 ]

97 ]

99− say "seen the death of tracer"

100 setTraceFlags defaultTraceFlags

98 setTraceFlags defaultTraceFlags

101− say "finishing setting default flags"

102 stash result (tracedAlive == pid &&

99 stash result (tracedAlive == pid &&

103 tracedDead == pid &&

100 tracedDead == pid &&

104 tracedReason == DiedNormal)

101 tracedReason == DiedNormal)

@@ -146,6 +143,79 @@ testTraceRecvNamedPid result = do

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

143 stash result (res' && (p == pid))

147 return ()

144 return ()

148

145

146+testTraceSending :: TestResult Bool -> Process ()

147+testTraceSending result = do

148+ pid <- spawnLocal $ (expect :: Process String) >> return ()

149+ self <- getSelfPid

150+ res <- liftIO $ newEmptyMVar

151+ withFlags defaultTraceFlags { traceSend = traceOn } $ do

152+ withTracer

153+ (\ev ->

154+ case ev of

155+ (TraceEvSent to from _) ->

156+ stash res (to == pid && from == self)

157+ _ ->

158+ return ()) $ do

159+ send pid "hello there"

160+ res' <- liftIO $ takeMVar res

161+ stash result res'

162+

163+testTraceRegistration :: TestResult Bool -> Process ()

164+testTraceRegistration result = do

165+ (sp, rp) <- newChan

166+ pid <- spawnLocal $ do

167+ self <- getSelfPid

168+ () <- expect

169+ register "foobar" self

170+ sendChan sp ()

171+ () <- expect

172+ return ()

173+ res <- liftIO $ newEmptyMVar

174+ withFlags defaultTraceFlags { traceRegistered = traceOn } $ do

175+ withTracer

176+ (\ev ->

177+ case ev of

178+ TraceEvRegistered p s ->

179+ stash res (p == pid && s == "foobar")

180+ _ ->

181+ return ()) $ do

182+ _ <- monitor pid

183+ send pid ()

184+ () <- receiveChan rp

185+ send pid ()

186+ receiveWait [

187+ match (\(ProcessMonitorNotification _ _ _) -> return ())

188+ ]

189+ res' <- liftIO $ takeMVar res

190+ stash result res'

191+

192+testTraceUnRegistration :: TestResult Bool -> Process ()

193+testTraceUnRegistration result = do

194+ pid <- spawnLocal $ do

195+ () <- expect

196+ unregister "foobar"

197+ () <- expect

198+ return ()

199+ register "foobar" pid

200+ res <- liftIO $ newEmptyMVar

201+ withFlags defaultTraceFlags { traceUnregistered = traceOn } $ do

202+ withTracer

203+ (\ev ->

204+ case ev of

205+ TraceEvUnRegistered p n -> do

206+ stash res (p == pid && n == "foobar")

207+ send pid ()

208+ _ ->

209+ return ()) $ do

210+ mref <- monitor pid

211+ send pid ()

212+ receiveWait [

213+ matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')

214+ (\_ -> return ())

215+ ]

216+ res' <- liftIO $ takeMVar res

217+ stash result res'

218+

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

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

150testTraceLayering result = do

220testTraceLayering result = do

151 pid <- spawnLocal $ do

221 pid <- spawnLocal $ do

@@ -154,8 +224,8 @@ testTraceLayering result = do

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

224 traceMessage ("traceMsg", 123 :: Int)

155 return ()

225 return ()

156 withFlags defaultTraceFlags {

226 withFlags defaultTraceFlags {

157− traceDied = traceOnly [pid]

227+ traceDied = traceOnly [pid]

158− , traceRecv = traceOnly ["foobar"]

228+ , traceRecv = traceOnly ["foobar"]

159 } $ doTest pid result

229 } $ doTest pid result

160 return ()

230 return ()

161 where

231 where

@@ -171,22 +241,22 @@ testTraceLayering result = do

171 ( do {

241 ( do {

172 recv <- liftIO $ newEmptyMVar

242 recv <- liftIO $ newEmptyMVar

173 ; withTracer

243 ; withTracer

174− (\ev' ->

244+ (\ev' ->

175− case ev' of

245+ case ev' of

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

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

177− _ -> return ())

247+ _ -> return ())

178− ( do {

248+ ( do {

179− user <- liftIO $ newEmptyMVar

249+ user <- liftIO $ newEmptyMVar

180− ; withTracer

250+ ; withTracer

181− (\ev'' ->

251+ (\ev'' ->

182− case ev'' of

252+ case ev'' of

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

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

184− _ -> return ())

254+ _ -> return ())

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

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

186− ; liftIO $ takeMVar recv

256+ ; liftIO $ takeMVar recv

187− })

257+ })

188− ; liftIO $ takeMVar died

258+ ; liftIO $ takeMVar died

189− })

259+ })

190 liftIO $ putMVar result' ()

260 liftIO $ putMVar result' ()

191

261

192tests :: LocalNode -> IO [Test]

262tests :: LocalNode -> IO [Test]

@@ -212,6 +282,18 @@ tests node1 = do

212 (delayedAssertion

282 (delayedAssertion

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

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

214 node1 True testTraceRecvNamedPid lock)

284 node1 True testTraceRecvNamedPid lock)

285+ , testCase "Trace Send(er)"

286+ (delayedAssertion

287+ "expected a 'send' trace with the requisite fields set"

288+ node1 True testTraceSending lock)

289+ , testCase "Trace Registration"

290+ (delayedAssertion

291+ "expected a 'registered' trace"

292+ node1 True testTraceRegistration lock)

293+ , testCase "Trace Unregistration"

294+ (delayedAssertion

295+ "expected an 'unregistered' trace"

296+ node1 True testTraceUnRegistration lock)

215 , testCase "Trace Layering"

297 , testCase "Trace Layering"

216 (delayedAssertion

298 (delayedAssertion

217 "expected blah"

299 "expected blah"