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