@@ -45,6 +45,8 @@ import Control.Distributed.Process.Internal.Trace.Types
4545 , TraceOk(..)
4646 , defaultTraceFlags
4747 )
48+import Control.Distributed.Process.Internal.Trace.Primitives
49+ ( traceOn )
4850import Control.Distributed.Process.Internal.Types
4951 ( LocalNode(..)
5052 , NCMsg(..)
@@ -150,7 +152,7 @@ systemLoggerTracer = do
150152 liftIO $ writeChan (localCtrlChan node) traceMsg
151153
152154eventLogTracer :: Process ()
153−eventLogTracer = do
155+eventLogTracer =
154156 -- NB: when the GHC event log supports tracing arbitrary (ish) data, we will
155157 -- almost certainly use *that* facility independently of whether or not there
156158 -- is a tracer process installed. This is just a stop gap until then.
@@ -194,10 +196,8 @@ traceController mv = do
194196 -- the node's internal control channel if we can possibly help it!
195197 weakQueue <- processWeakQ <$> ask
196198 liftIO $ putMVar mv weakQueue
197− initialTracer <- whereis "tracer.initial"
198− traceLoop initialState {
199− client = initialTracer
200− }
199+ initState <- initialState
200+ traceLoop initState { client = Nothing }
201201 where
202202 traceLoop :: TracerState -> Process ()
203203 traceLoop st = do
@@ -234,13 +234,33 @@ traceController mv = do
234234 sendOk Nothing = return ()
235235 sendOk (Just sp) = sendChan sp TraceOk
236236
237− initialState :: TracerState
238− initialState =
239− TracerST
240− { client = Nothing
241− , flags = defaultTraceFlags
242− , regNames = Map.empty
243− }
237+ initialState :: Process TracerState
238+ initialState = do
239+ flags' <- checkEnvFlags
240+ return $ TracerST { client = Nothing
241+ , flags = flags'
242+ , regNames = Map.empty
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
244264
245265-- note [runtime tracer control]
246266--