git.iko.soy/distributed-process
on 0171bc6 help sign in
distributed-process/src/Control/Distributed/Process/Management/Trace/Tracer.hs
346 lines 12 kB history raw
1-- | Tracing/Debugging support - Trace Implementation
2module Control.Distributed.Process.Management.Trace.Tracer
3 ( -- * API for the Management Agent
4 traceController
5 -- * Built in tracers
6 , defaultTracer
7 , systemLoggerTracer
8 , logfileTracer
9 , eventLogTracer
10 ) where
12import Control.Applicative ((<$>))
13import Control.Concurrent.Chan (writeChan)
14import Control.Concurrent.MVar
15 ( MVar
16 , putMVar
17 )
18import Control.Distributed.Process.Internal.CQueue
19 ( CQueue
20 )
21import Control.Distributed.Process.Internal.Primitives
22 ( catch
23 , finally
24 , die
25 , receiveWait
26 , forward
27 , sendChan
28 , match
29 , matchAny
30 , matchIf
31 , handleMessage
32 , matchUnknown
33 )
34import Control.Distributed.Process.Management.Types
35 ( MxEvent(..)
36 , Addressable(..)
37 )
38import Control.Distributed.Process.Management.Trace.Types
39 ( SetTrace(..)
40 , TraceSubject(..)
41 , TraceFlags(..)
42 , TraceOk(..)
43 , defaultTraceFlags
44 )
45import Control.Distributed.Process.Management.Trace.Primitives
46 ( traceOn )
47import Control.Distributed.Process.Internal.Types
48 ( LocalNode(..)
49 , NCMsg(..)
50 , ProcessId
51 , Process
52 , LocalProcess(..)
53 , Identifier(..)
54 , ProcessSignal(NamedSend)
55 , Message
56 , SendPort
57 , forever'
58 , nullProcessId
59 , createUnencodedMessage
60 )
62import Control.Monad.IO.Class (liftIO)
63import Control.Monad.Reader (ask)
65import Data.Set (Set)
66import qualified Data.Set as Set
67import Data.Map (Map)
68import qualified Data.Map as Map
70import Data.Maybe (fromMaybe)
71import Data.Time.Clock (getCurrentTime)
72import Data.Time.Format (formatTime)
73import Debug.Trace (traceEventIO)
75#if ! MIN_VERSION_base(4,6,0)
76import Prelude hiding (catch)
77#endif
79import System.Environment (getEnv)
80import System.IO
81 ( Handle
82 , IOMode(AppendMode)
83 , BufferMode(..)
84 , openFile
85 , hClose
86 , hPutStrLn
87 , hSetBuffering
88 )
89import System.Locale (defaultTimeLocale)
90import System.Mem.Weak
91 ( Weak
92 )
94data TracerState =
95 TracerST
96 {
97 client :: !(Maybe ProcessId)
98 , flags :: !TraceFlags
99 , regNames :: !(Map ProcessId (Set String))
100 }
102--------------------------------------------------------------------------------
103-- Trace Handlers --
104--------------------------------------------------------------------------------
106defaultTracer :: Process ()
107defaultTracer =
108 catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)
109 (\(_ :: IOError) -> defaultTracerAux)
111defaultTracerAux :: Process ()
112defaultTracerAux =
113 catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" >> systemLoggerTracer)
114 (\(_ :: IOError) -> defaultEventLogTracer)
116-- TODO: it would be /nice/ if we had some way of checking the runtime
117-- options to see if +RTS -v (or similar) has been given...
118defaultEventLogTracer :: Process ()
119defaultEventLogTracer =
120 catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_EVENTLOG" >> eventLogTracer)
121 (\(_ :: IOError) -> nullTracer)
123checkEnv :: String -> Process String
124checkEnv s = liftIO $ getEnv s
126-- This trace client is (intentionally) a noop - it simply provides
127-- an intial client for the trace controller to talk to, until some
128-- other (hopefully more useful) client is installed over the top of
129-- it. This is the default trace client.
130nullTracer :: Process ()
131nullTracer =
132 forever' $ receiveWait [ matchUnknown (return ()) ]
134systemLoggerTracer :: Process ()
135systemLoggerTracer = do
136 node <- processNode <$> ask
137 let tr = sendTraceLog node
138 forever' $ receiveWait [ matchAny (\m -> handleMessage m tr) ]
139 where
140 sendTraceLog :: LocalNode -> MxEvent -> Process ()
141 sendTraceLog node ev = do
142 now <- liftIO $ getCurrentTime
143 msg <- return $ (formatTime defaultTimeLocale "%c" now, buildTxt ev)
144 emptyPid <- return $ (nullProcessId (localNodeId node))
145 traceMsg <- return $ NCMsg {
146 ctrlMsgSender = ProcessIdentifier (emptyPid)
147 , ctrlMsgSignal = (NamedSend "logger"
148 (createUnencodedMessage msg))
149 }
150 liftIO $ writeChan (localCtrlChan node) traceMsg
152 buildTxt :: MxEvent -> String
153 buildTxt (MxLog msg) = msg
154 buildTxt ev = show ev
156eventLogTracer :: Process ()
157eventLogTracer =
158 -- NB: when the GHC event log supports tracing arbitrary (ish) data, we will
159 -- almost certainly use *that* facility independently of whether or not there
160 -- is a tracer process installed. This is just a stop gap until then.
161 forever' $ receiveWait [ matchAny (\m -> handleMessage m writeTrace) ]
162 where
163 writeTrace :: MxEvent -> Process ()
164 writeTrace ev = liftIO $ traceEventIO (show ev)
166logfileTracer :: FilePath -> Process ()
167logfileTracer p = do
168 -- TODO: error handling if the handle cannot be opened
169 h <- liftIO $ openFile p AppendMode
170 liftIO $ hSetBuffering h LineBuffering
171 logger h `finally` (liftIO $ hClose h)
172 where
173 logger :: Handle -> Process ()
174 logger h' = forever' $ do
175 receiveWait [
176 matchIf (\ev -> case ev of
177 MxTraceDisable -> True
178 (MxTraceTakeover _) -> True
179 _ -> False)
180 (\_ -> (liftIO $ hClose h') >> die "trace stopped")
181 , matchAny (\ev -> handleMessage ev (writeTrace h'))
182 ]
184 writeTrace :: Handle -> MxEvent -> Process ()
185 writeTrace h ev = do
186 liftIO $ do
187 now <- getCurrentTime
188 hPutStrLn h $ (formatTime defaultTimeLocale "%c - " now) ++ (show ev)
190--------------------------------------------------------------------------------
191-- Tracer Implementation --
192--------------------------------------------------------------------------------
194traceController :: MVar ((Weak (CQueue Message))) -> Process ()
195traceController mv = do
196 -- See the documentation for mxAgentController for a
197 -- commentary that explains this breach of encapsulation
198 weakQueue <- processWeakQ <$> ask
199 liftIO $ putMVar mv weakQueue
200 initState <- initialState
201 traceLoop initState { client = Nothing }
202 where
203 traceLoop :: TracerState -> Process ()
204 traceLoop st = do
205 let client' = client st
206 -- Trace events are forwarded to the enabled trace target.
207 -- At some point in the future, we're going to start writing these custom
208 -- events to the ghc eventlog, at which point this design might change.
209 st' <- receiveWait [
210 match (\(setResp, set :: SetTrace) -> do
211 -- We consider at most one trace client, which is a process.
212 -- Tracking multiple clients represents too high an overhead,
213 -- so we leave that kind of thing to our consumers (e.g., the
214 -- high level Debug client module) to figure out.
215 case set of
216 (TraceEnable pid) -> do
217 -- notify the previous tracer it has been replaced
218 sendTraceMsg client' (createUnencodedMessage (MxTraceTakeover pid))
219 sendOk setResp
220 return st { client = (Just pid) }
221 TraceDisable -> do
222 sendTraceMsg client' (createUnencodedMessage MxTraceDisable)
223 sendOk setResp
224 return st { client = Nothing })
225 , match (\(confResp, flags') ->
226 sendOk confResp >> applyTraceFlags flags' st)
227 , match (\chGetFlags -> sendChan chGetFlags (flags st) >> return st)
228 , match (\chGetCurrent -> sendChan chGetCurrent (client st) >> return st)
229 -- we dequeue incoming events even if we don't process them
230 , matchAny (\ev ->
231 handleMessage ev (handleTrace st ev) >>= return . fromMaybe st)
232 ]
233 traceLoop st'
235 sendOk :: Maybe (SendPort TraceOk) -> Process ()
236 sendOk Nothing = return ()
237 sendOk (Just sp) = sendChan sp TraceOk
239 initialState :: Process TracerState
240 initialState = do
241 flags' <- checkEnvFlags
242 return $ TracerST { client = Nothing
243 , flags = flags'
244 , regNames = Map.empty
245 }
247 checkEnvFlags :: Process TraceFlags
248 checkEnvFlags =
249 catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" >>= return . parseFlags)
250 (\(_ :: IOError) -> return defaultTraceFlags)
252 parseFlags :: String -> TraceFlags
253 parseFlags s = parseFlags' s defaultTraceFlags
254 where parseFlags' :: String -> TraceFlags -> TraceFlags
255 parseFlags' [] parsedFlags = parsedFlags
256 parseFlags' (x:xs) parsedFlags
257 | x == 'p' = parseFlags' xs parsedFlags { traceSpawned = traceOn }
258 | x == 'n' = parseFlags' xs parsedFlags { traceRegistered = traceOn }
259 | x == 'u' = parseFlags' xs parsedFlags { traceUnregistered = traceOn }
260 | x == 'd' = parseFlags' xs parsedFlags { traceDied = traceOn }
261 | x == 's' = parseFlags' xs parsedFlags { traceSend = traceOn }
262 | x == 'r' = parseFlags' xs parsedFlags { traceRecv = traceOn }
263 | x == 'l' = parseFlags' xs parsedFlags { traceNodes = True }
264 | otherwise = parseFlags' xs parsedFlags
266applyTraceFlags :: TraceFlags -> TracerState -> Process TracerState
267applyTraceFlags flags' state = return state { flags = flags' }
269handleTrace :: TracerState -> Message -> MxEvent -> Process TracerState
270handleTrace st msg ev@(MxRegistered p n) =
271 let regNames' =
272 Map.insertWith (\_ ns -> Set.insert n ns) p
273 (Set.singleton n)
274 (regNames st)
275 in do
276 traceEv ev msg (traceRegistered (flags st)) st
277 return st { regNames = regNames' }
278handleTrace st msg ev@(MxUnRegistered p n) =
279 let f ns = case ns of
280 Nothing -> Nothing
281 Just ns' -> Just (Set.delete n ns')
282 regNames' = Map.alter f p (regNames st)
283 in do
284 traceEv ev msg (traceUnregistered (flags st)) st
285 return st { regNames = regNames' }
286handleTrace st msg ev@(MxSpawned _) = do
287 traceEv ev msg (traceSpawned (flags st)) st >> return st
288handleTrace st msg ev@(MxProcessDied _ _) = do
289 traceEv ev msg (traceDied (flags st)) st >> return st
290handleTrace st msg ev@(MxSent _ _ _) =
291 traceEv ev msg (traceSend (flags st)) st >> return st
292handleTrace st msg ev@(MxReceived _ _) =
293 traceEv ev msg (traceRecv (flags st)) st >> return st
294handleTrace st msg ev = do
295 case ev of
296 (MxNodeDied _ _) ->
297 case (traceNodes (flags st)) of
298 True -> sendTrace st ev msg
299 False -> return ()
300 (MxUser _) -> sendTrace st ev msg
301 (MxLog _) -> sendTrace st ev msg
302 _ ->
303 case (traceConnections (flags st)) of
304 True -> sendTrace st ev msg
305 False -> return ()
306 return st
308traceEv :: MxEvent
309 -> Message
310 -> Maybe TraceSubject
311 -> TracerState
312 -> Process ()
313traceEv _ _ Nothing _ = return ()
314traceEv ev msg (Just TraceAll) st = sendTrace st ev msg
315traceEv ev msg (Just (TraceProcs pids)) st = do
316 node <- processNode <$> ask
317 let p = case resolveToPid ev of
318 Nothing -> (nullProcessId (localNodeId node))
319 Just pid -> pid
320 case (Set.member p pids) of
321 True -> sendTrace st ev msg
322 False -> return ()
323traceEv ev msg (Just (TraceNames names)) st = do
324 -- if we have recorded regnames for p, then we forward the trace iif
325 -- there are overlapping trace targets
326 node <- processNode <$> ask
327 let p = case resolveToPid ev of
328 Nothing -> (nullProcessId (localNodeId node))
329 Just pid -> pid
330 case (Map.lookup p (regNames st)) of
331 Nothing -> return ()
332 Just ns -> if (Set.null (Set.intersection ns names))
333 then return ()
334 else sendTrace st ev msg
336sendTrace :: TracerState -> MxEvent -> Message -> Process ()
337sendTrace st ev msg = do
338 let c = client st
339 if c == (resolveToPid ev) -- we do not send the tracer events about itself...
340 then return ()
341 else sendTraceMsg c msg
343sendTraceMsg :: Maybe ProcessId -> Message -> Process ()
344sendTraceMsg Nothing _ = return ()
345sendTraceMsg (Just p) msg = (flip forward) p msg