git.iko.soy/distributed-process
on remove-table-api help sign in
distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs
172 lines 5.5 kB history raw
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE TypeSynonymInstances #-}
3-- | Keeps the tracing API calls separate from the Tracer implementation,
4-- which allows us to avoid a nasty import cycle between tracing and
5-- the messaging primitives that rely on it, and also between the node
6-- controller (which requires access to the tracing related elements of
7-- our RemoteTable) and the Debug module, which requires @forkProcess@.
8-- This module is also used by the management agent, which relies on the
9-- tracing infrastructure's messaging fabric.
10module Control.Distributed.Process.Management.Internal.Trace.Primitives
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.Management.Internal.Trace.Types
38 ( TraceArg(..)
39 , TraceFlags(..)
40 , TraceOk(..)
41 , TraceSubject(..)
42 , defaultTraceFlags
43 )
44import qualified Control.Distributed.Process.Management.Internal.Trace.Types as Tracer
45 ( traceLog
46 , traceLogFmt
47 , traceMessage
48 , enableTrace
49 , enableTraceSync
50 , disableTrace
51 , disableTraceSync
52 , setTraceFlags
53 , setTraceFlagsSync
54 , getTraceFlags
55 , getCurrentTraceClient
56 )
57import Control.Distributed.Process.Internal.Types
58 ( Process
59 , ProcessId
60 , LocalProcess(..)
61 , LocalNode(localEventBus)
62 , SendPort
63 , MxEventBus(..)
64 )
65import Control.Distributed.Process.Serializable
66import Control.Monad.IO.Class (liftIO)
67import Control.Monad.Reader (ask)
69import qualified Data.Set as Set (fromList)
71--------------------------------------------------------------------------------
72-- Main API --
73--------------------------------------------------------------------------------
75-- | Converts a list of identifiers (that can be
76-- mapped to process ids), to a 'TraceSubject'.
77class Traceable a where
78 uod :: [a] -> TraceSubject
80instance Traceable ProcessId where
81 uod = TraceProcs . Set.fromList
83instance Traceable String where
84 uod = TraceNames . Set.fromList
86-- | Turn tracing for for a subset of trace targets.
87traceOnly :: Traceable a => [a] -> Maybe TraceSubject
88traceOnly = Just . uod
90-- | Trace all targets.
91traceOn :: Maybe TraceSubject
92traceOn = Just TraceAll
94-- | Trace no targets.
95traceOff :: Maybe TraceSubject
96traceOff = Nothing
98-- | Enable tracing to the supplied process.
99enableTraceAsync :: ProcessId -> Process ()
100enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid
102-- TODO: refactor _Sync versions of trace configuration functions...
104-- | Enable tracing to the supplied process and wait for a @TraceOk@
105-- response from the trace coordinator process.
106enableTrace :: ProcessId -> Process ()
107enableTrace pid =
108 withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid
110-- | Disable the currently configured trace.
111disableTraceAsync :: Process ()
112disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t
114-- | Disable the currently configured trace and wait for a @TraceOk@
115-- response from the trace coordinator process.
116disableTrace :: Process ()
117disableTrace =
118 withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp
120getTraceFlags :: Process TraceFlags
121getTraceFlags = do
122 (sp, rp) <- newChan
123 withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp
124 receiveChan rp
126-- | Set the given flags for the current tracer.
127setTraceFlagsAsync :: TraceFlags -> Process ()
128setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f
130-- | Set the given flags for the current tracer and wait for a @TraceOk@
131-- response from the trace coordinator process.
132setTraceFlags :: TraceFlags -> Process ()
133setTraceFlags f =
134 withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f
136-- | Send a log message to the internal tracing facility. If tracing is
137-- enabled, this will create a custom trace log event.
138--
139traceLog :: String -> Process ()
140traceLog s = withLocalTracer $ \t -> liftIO $ Tracer.traceLog t s
142-- | Send a log message to the internal tracing facility, using the given
143-- list of printable 'TraceArg's interspersed with the preceding delimiter.
144--
145traceLogFmt :: String -> [TraceArg] -> Process ()
146traceLogFmt d ls = withLocalTracer $ \t -> liftIO $ Tracer.traceLogFmt t d ls
148-- | Send an arbitrary 'Message' to the tracer process.
149traceMessage :: Serializable m => m -> Process ()
150traceMessage msg = withLocalTracer $ \t -> liftIO $ Tracer.traceMessage t msg
152withLocalTracer :: (MxEventBus -> Process ()) -> Process ()
153withLocalTracer act = do
154 node <- processNode <$> ask
155 act (localEventBus node)
157withLocalTracerSync :: (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
158withLocalTracerSync act = do
159 (sp, rp) <- newChan
160 withLocalTracer $ \t -> liftIO $ (act t sp)
161 TraceOk <- receiveChan rp
162 return ()
164withRegisteredTracer :: (ProcessId -> Process a) -> Process a
165withRegisteredTracer act = do
166 (sp, rp) <- newChan
167 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
168 currentTracer <- receiveChan rp
169 case currentTracer of
170 Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }
171 (Just p) -> act p