1c2bc74 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Allow users to set initial trace flags via environment variables

1c2bc74Tim Watson13 years ago

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

compare with master

unifiedsplit

@@ -45,6 +45,8 @@ import Control.Distributed.Process.Internal.Trace.Types

45 , TraceOk(..)

46 , defaultTraceFlags

47 )

48+import Control.Distributed.Process.Internal.Trace.Primitives

49+ ( traceOn )

48import Control.Distributed.Process.Internal.Types

50import Control.Distributed.Process.Internal.Types

49 ( LocalNode(..)

51 ( LocalNode(..)

50 , NCMsg(..)

52 , NCMsg(..)

@@ -150,7 +152,7 @@ systemLoggerTracer = do

150 liftIO $ writeChan (localCtrlChan node) traceMsg

152 liftIO $ writeChan (localCtrlChan node) traceMsg

151

153

152eventLogTracer :: Process ()

154eventLogTracer :: Process ()

153−eventLogTracer = do

155+eventLogTracer =

154 -- NB: when the GHC event log supports tracing arbitrary (ish) data, we will

156 -- NB: when the GHC event log supports tracing arbitrary (ish) data, we will

155 -- almost certainly use *that* facility independently of whether or not there

157 -- almost certainly use *that* facility independently of whether or not there

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

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

@@ -194,10 +196,8 @@ traceController mv = do

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

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

195 weakQueue <- processWeakQ <$> ask

197 weakQueue <- processWeakQ <$> ask

196 liftIO $ putMVar mv weakQueue

198 liftIO $ putMVar mv weakQueue

197− initialTracer <- whereis "tracer.initial"

199+ initState <- initialState

198− traceLoop initialState {

200+ traceLoop initState { client = Nothing }

199− client = initialTracer

200− }

201 where

202 traceLoop :: TracerState -> Process ()

203 traceLoop st = do

@@ -234,13 +234,33 @@ traceController mv = do

234 sendOk Nothing = return ()

235 sendOk (Just sp) = sendChan sp TraceOk

236

237− initialState :: TracerState

237+ initialState :: Process TracerState

238− initialState =

238+ initialState = do

239− TracerST

239+ flags' <- checkEnvFlags

240− { client = Nothing

240+ return $ TracerST { client = Nothing

241− , flags = defaultTraceFlags

241+ , flags = flags'

242− , regNames = Map.empty

242+ , regNames = Map.empty

243− }

243+ }

244+

245+ checkEnvFlags :: Process TraceFlags

246+ checkEnvFlags =

247+ catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" >>= return . parseFlags)

248+ (\(_ :: IOError) -> return defaultTraceFlags)

249+

250+ -- quick and dirty fold-while

251+ parseFlags :: String -> TraceFlags

252+ parseFlags flags = parseFlags' flags defaultTraceFlags

253+ where parseFlags' :: String -> TraceFlags -> TraceFlags

254+ parseFlags' [] parsedFlags = parsedFlags

255+ parseFlags' (x:xs) parsedFlags

256+ | x == 'p' = parseFlags' xs parsedFlags { traceSpawned = traceOn }

257+ | x == 'n' = parseFlags' xs parsedFlags { traceRegistered = traceOn }

258+ | x == 'u' = parseFlags' xs parsedFlags { traceUnregistered = traceOn }

259+ | x == 'd' = parseFlags' xs parsedFlags { traceDied = traceOn }

260+ | x == 's' = parseFlags' xs parsedFlags { traceSend = traceOn }

261+ | x == 'r' = parseFlags' xs parsedFlags { traceRecv = traceOn }

262+ | x == 'l' = parseFlags' xs parsedFlags { traceNodes = True }

263+ | otherwise = parseFlags' xs parsedFlags

244

264

245-- note [runtime tracer control]

265-- note [runtime tracer control]

246--

266--

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

@@ -105,6 +105,7 @@ data TraceSubject =

105 TraceAll -- enable tracing for all running processes

106 | TraceProcs !(Set ProcessId) -- enable tracing for a set of processes

107 | TraceNames !(Set String) -- enable tracing for a set of named/registered processes

108+ deriving (Show)

108

109

109-- | Defines /what/ will be traced. Flags that control tracing of

110-- | Defines /what/ will be traced. Flags that control tracing of

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

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

@@ -118,7 +119,7 @@ data TraceFlags = TraceFlags {

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

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

119 , traceNodes :: !Bool -- enable node status trace events

120 , traceNodes :: !Bool -- enable node status trace events

120 , traceConnections :: !Bool -- enable connection status trace events

121 , traceConnections :: !Bool -- enable connection status trace events

121− } deriving (Typeable)

122+ } deriving (Typeable, Show)

122

123

123defaultTraceFlags :: TraceFlags

124defaultTraceFlags :: TraceFlags

124defaultTraceFlags =

125defaultTraceFlags =