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