git.iko.soy/distributed-process
on 28beaa2 help sign in
distributed-process/src/Control/Distributed/Process/Internal/Trace/Primitives.hs
175 lines 5.5 kB history raw
1-- | Keeps the tracing API calls separate from the Tracer implementation,
2-- which allows us to avoid a nasty import cycle between tracing and
3-- the messaging primitives that rely on it, and also between the node
4-- controller (which requires access to the tracing related elements of
5-- our RemoteTable) and the Debug module, which requires @forkProcess@.
6-- This module is also used by the management agent, which relies on the
7-- tracing infrastructure's messaging fabric.
8module Control.Distributed.Process.Internal.Trace.Primitives
9 ( Tracer
10 , TraceEvent(..)
11 -- * Sending Trace Data
12 , traceLog
13 , traceLogFmt
14 , traceMessage
15 -- * Configuring A Tracer
16 , defaultTraceFlags
17 , enableTrace
18 , enableTraceAsync
19 , disableTrace
20 , disableTraceAsync
21 , getTraceFlags
22 , setTraceFlags
23 , setTraceFlagsAsync
24 , traceOnly
25 , traceOn
26 , traceOff
27 , withLocalTracer
28 , withRegisteredTracer
29 ) where
31import Control.Applicative ((<$>))
32import Control.Distributed.Process.Internal.Primitives
33 ( whereis
34 , newChan
35 , receiveChan
36 )
37import Control.Distributed.Process.Internal.Trace.Types
38 ( TraceArg(..)
39 , TraceEvent(..)
40 , TraceFlags(..)
41 , TraceOk(..)
42 , TraceSubject(..)
43 , defaultTraceFlags
44 )
45import qualified Control.Distributed.Process.Internal.Trace.Types as Tracer
46 ( traceLog
47 , traceLogFmt
48 , traceMessage
49 , enableTrace
50 , enableTraceSync
51 , disableTrace
52 , disableTraceSync
53 , setTraceFlags
54 , setTraceFlagsSync
55 , getTraceFlags
56 , getCurrentTraceClient
57 )
58import Control.Distributed.Process.Internal.Types
59 ( Tracer(..)
60 , Process
61 , ProcessId
62 , LocalProcess(..)
63 , LocalNode(localEventBus)
64 , SendPort
65 , MxEventBus(..)
66 )
67import Control.Distributed.Process.Serializable
68import Control.Monad.IO.Class (liftIO)
69import Control.Monad.Reader (ask)
71import Data.Maybe (isJust)
72import qualified Data.Set as Set (fromList)
74--------------------------------------------------------------------------------
75-- Main API --
76--------------------------------------------------------------------------------
78-- | Converts a list of identifiers (that can be
79-- mapped to process ids), to a 'TraceSubject'.
80class Traceable a where
81 uod :: [a] -> TraceSubject
83instance Traceable ProcessId where
84 uod = TraceProcs . Set.fromList
86instance Traceable String where
87 uod = TraceNames . Set.fromList
89-- | Turn tracing for for a subset of trace targets.
90traceOnly :: Traceable a => [a] -> Maybe TraceSubject
91traceOnly = Just . uod
93-- | Trace all targets.
94traceOn :: Maybe TraceSubject
95traceOn = Just TraceAll
97-- | Trace no targets.
98traceOff :: Maybe TraceSubject
99traceOff = Nothing
101-- | Enable tracing to the supplied process.
102enableTraceAsync :: ProcessId -> Process ()
103enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid
105-- TODO: refactor _Sync versions of trace configuration functions...
107-- | Enable tracing to the supplied process and wait for a @TraceOk@
108-- response from the trace coordinator process.
109enableTrace :: ProcessId -> Process ()
110enableTrace pid =
111 withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid
113-- | Disable the currently configured trace.
114disableTraceAsync :: Process ()
115disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t
117-- | Disable the currently configured trace and wait for a @TraceOk@
118-- response from the trace coordinator process.
119disableTrace :: Process ()
120disableTrace =
121 withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp
123getTraceFlags :: Process TraceFlags
124getTraceFlags = do
125 (sp, rp) <- newChan
126 withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp
127 receiveChan rp
129-- | Set the given flags for the current tracer.
130setTraceFlagsAsync :: TraceFlags -> Process ()
131setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f
133-- | Set the given flags for the current tracer and wait for a @TraceOk@
134-- response from the trace coordinator process.
135setTraceFlags :: TraceFlags -> Process ()
136setTraceFlags f =
137 withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f
139-- | Send a log message to the internal tracing facility. If tracing is
140-- enabled, this will create a custom trace log event.
141--
142traceLog :: String -> Process ()
143traceLog s = withLocalTracer $ \t -> liftIO $ Tracer.traceLog t s
145-- | Send a log message to the internal tracing facility, using the given
146-- list of printable 'TraceArg's interspersed with the preceding delimiter.
147--
148traceLogFmt :: String -> [TraceArg] -> Process ()
149traceLogFmt d ls = withLocalTracer $ \t -> liftIO $ Tracer.traceLogFmt t d ls
151-- | Send an arbitrary 'Message' to the tracer process.
152traceMessage :: Serializable m => m -> Process ()
153traceMessage msg = withLocalTracer $ \t -> liftIO $ Tracer.traceMessage t msg
155withLocalTracer :: (MxEventBus -> Process ()) -> Process ()
156withLocalTracer act = do
157 node <- processNode <$> ask
158 act (localEventBus node)
160withLocalTracerSync :: (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
161withLocalTracerSync act = do
162 (sp, rp) <- newChan
163 withLocalTracer $ \t -> liftIO $ (act t sp)
164 TraceOk <- receiveChan rp
165 return ()
167withRegisteredTracer :: (ProcessId -> Process a) -> Process a
168withRegisteredTracer act = do
169 (sp, rp) <- newChan
170 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
171 currentTracer <- receiveChan rp
172 case currentTracer of
173 Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }
174 (Just p) -> act p