git.iko.soy/distributed-process
on b8de850 help sign in
distributed-process/src/Control/Distributed/Process/Management/Trace/Primitives.hs
170 lines 5.4 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.Management.Trace.Primitives
9 ( -- * Sending Trace Data
10 traceLog
11 , traceLogFmt
12 , traceMessage
13 -- * Configuring A Tracer
14 , defaultTraceFlags
15 , enableTrace
16 , enableTraceAsync
17 , disableTrace
18 , disableTraceAsync
19 , getTraceFlags
20 , setTraceFlags
21 , setTraceFlagsAsync
22 , traceOnly
23 , traceOn
24 , traceOff
25 , withLocalTracer
26 , withRegisteredTracer
27 ) where
29import Control.Applicative ((<$>))
30import Control.Distributed.Process.Internal.Primitives
31 ( whereis
32 , newChan
33 , receiveChan
34 )
35import Control.Distributed.Process.Management.Trace.Types
36 ( TraceArg(..)
37 , TraceFlags(..)
38 , TraceOk(..)
39 , TraceSubject(..)
40 , defaultTraceFlags
41 )
42import qualified Control.Distributed.Process.Management.Trace.Types as Tracer
43 ( traceLog
44 , traceLogFmt
45 , traceMessage
46 , enableTrace
47 , enableTraceSync
48 , disableTrace
49 , disableTraceSync
50 , setTraceFlags
51 , setTraceFlagsSync
52 , getTraceFlags
53 , getCurrentTraceClient
54 )
55import Control.Distributed.Process.Internal.Types
56 ( Process
57 , ProcessId
58 , LocalProcess(..)
59 , LocalNode(localEventBus)
60 , SendPort
61 , MxEventBus(..)
62 )
63import Control.Distributed.Process.Serializable
64import Control.Monad.IO.Class (liftIO)
65import Control.Monad.Reader (ask)
67import qualified Data.Set as Set (fromList)
69--------------------------------------------------------------------------------
70-- Main API --
71--------------------------------------------------------------------------------
73-- | Converts a list of identifiers (that can be
74-- mapped to process ids), to a 'TraceSubject'.
75class Traceable a where
76 uod :: [a] -> TraceSubject
78instance Traceable ProcessId where
79 uod = TraceProcs . Set.fromList
81instance Traceable String where
82 uod = TraceNames . Set.fromList
84-- | Turn tracing for for a subset of trace targets.
85traceOnly :: Traceable a => [a] -> Maybe TraceSubject
86traceOnly = Just . uod
88-- | Trace all targets.
89traceOn :: Maybe TraceSubject
90traceOn = Just TraceAll
92-- | Trace no targets.
93traceOff :: Maybe TraceSubject
94traceOff = Nothing
96-- | Enable tracing to the supplied process.
97enableTraceAsync :: ProcessId -> Process ()
98enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid
100-- TODO: refactor _Sync versions of trace configuration functions...
102-- | Enable tracing to the supplied process and wait for a @TraceOk@
103-- response from the trace coordinator process.
104enableTrace :: ProcessId -> Process ()
105enableTrace pid =
106 withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid
108-- | Disable the currently configured trace.
109disableTraceAsync :: Process ()
110disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t
112-- | Disable the currently configured trace and wait for a @TraceOk@
113-- response from the trace coordinator process.
114disableTrace :: Process ()
115disableTrace =
116 withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp
118getTraceFlags :: Process TraceFlags
119getTraceFlags = do
120 (sp, rp) <- newChan
121 withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp
122 receiveChan rp
124-- | Set the given flags for the current tracer.
125setTraceFlagsAsync :: TraceFlags -> Process ()
126setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f
128-- | Set the given flags for the current tracer and wait for a @TraceOk@
129-- response from the trace coordinator process.
130setTraceFlags :: TraceFlags -> Process ()
131setTraceFlags f =
132 withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f
134-- | Send a log message to the internal tracing facility. If tracing is
135-- enabled, this will create a custom trace log event.
136--
137traceLog :: String -> Process ()
138traceLog s = withLocalTracer $ \t -> liftIO $ Tracer.traceLog t s
140-- | Send a log message to the internal tracing facility, using the given
141-- list of printable 'TraceArg's interspersed with the preceding delimiter.
142--
143traceLogFmt :: String -> [TraceArg] -> Process ()
144traceLogFmt d ls = withLocalTracer $ \t -> liftIO $ Tracer.traceLogFmt t d ls
146-- | Send an arbitrary 'Message' to the tracer process.
147traceMessage :: Serializable m => m -> Process ()
148traceMessage msg = withLocalTracer $ \t -> liftIO $ Tracer.traceMessage t msg
150withLocalTracer :: (MxEventBus -> Process ()) -> Process ()
151withLocalTracer act = do
152 node <- processNode <$> ask
153 act (localEventBus node)
155withLocalTracerSync :: (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
156withLocalTracerSync act = do
157 (sp, rp) <- newChan
158 withLocalTracer $ \t -> liftIO $ (act t sp)
159 TraceOk <- receiveChan rp
160 return ()
162withRegisteredTracer :: (ProcessId -> Process a) -> Process a
163withRegisteredTracer act = do
164 (sp, rp) <- newChan
165 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
166 currentTracer <- receiveChan rp
167 case currentTracer of
168 Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }
169 (Just p) -> act p