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