git.iko.soy/distributed-process
on 3178dec help sign in
distributed-process/src/Control/Distributed/Process/Internal/Trace/Primitives.hs
180 lines 5.6 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@.
6module Control.Distributed.Process.Internal.Trace.Primitives
7 ( Tracer
8 , TraceEvent(..)
9 -- * Sending Trace Data
10 , traceLog
11 , traceLogFmt
12 , traceMessage
13 -- * Configuring A Tracer
14 , isTracingEnabled
15 , defaultTraceFlags
16 , enableTrace
17 , enableTraceAsync
18 , disableTrace
19 , disableTraceAsync
20 , getTraceFlags
21 , setTraceFlags
22 , setTraceFlagsAsync
23 , traceOnly
24 , traceOn
25 , traceOff
26 , withLocalTracer
27 , withRegisteredTracer
28 ) where
30import Control.Applicative ((<$>))
31import Control.Distributed.Process.Internal.Primitives
32 ( whereis
33 , newChan
34 , receiveChan
35 )
36import Control.Distributed.Process.Internal.Trace.Types
37 ( TraceArg(..)
38 , TraceEvent(..)
39 , TraceFlags(..)
40 , TraceOk(..)
41 , TraceSubject(..)
42 , defaultTraceFlags
43 )
44import qualified Control.Distributed.Process.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 ( Tracer(..)
59 , Process
60 , ProcessId
61 , LocalProcess(..)
62 , LocalNode(localTracer)
63 , SendPort
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-- | Maps a list of identifiers that can be mapped to process ids,
76-- 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-- | Determine whether or not tracing has been enabled.
99isTracingEnabled :: Process Bool
100isTracingEnabled = do
101 node <- processNode <$> ask
102 case (localTracer node) of
103 (ActiveTracer _ _) -> return True
104 _ -> return False
106-- | Enable tracing to the supplied process.
107enableTraceAsync :: ProcessId -> Process ()
108enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid
110-- TODO: refactor _Sync versions of trace configuration functions...
112-- | Enable tracing to the supplied process and wait for a @TraceOk@
113-- response from the trace coordinator process.
114enableTrace :: ProcessId -> Process ()
115enableTrace pid =
116 withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid
118-- | Disable the currently configured trace.
119disableTraceAsync :: Process ()
120disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t
122-- | Disable the currently configured trace and wait for a @TraceOk@
123-- response from the trace coordinator process.
124disableTrace :: Process ()
125disableTrace =
126 withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp
128getTraceFlags :: Process TraceFlags
129getTraceFlags = do
130 (sp, rp) <- newChan
131 withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp
132 receiveChan rp
134-- | Set the given flags for the current tracer.
135setTraceFlagsAsync :: TraceFlags -> Process ()
136setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f
138-- | Set the given flags for the current tracer and wait for a @TraceOk@
139-- response from the trace coordinator process.
140setTraceFlags :: TraceFlags -> Process ()
141setTraceFlags f =
142 withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f
144-- | Send a log message to the internal tracing facility. If tracing is
145-- enabled, this will create a custom trace log event.
146--
147traceLog :: String -> Process ()
148traceLog s = withLocalTracer $ \t -> liftIO $ Tracer.traceLog t s
150-- | Send a log message to the internal tracing facility, using the given
151-- list of printable 'TraceArg's interspersed with the preceding delimiter.
152--
153traceLogFmt :: String -> [TraceArg] -> Process ()
154traceLogFmt d ls = withLocalTracer $ \t -> liftIO $ Tracer.traceLogFmt t d ls
156-- | Send an arbitrary 'Message' to the tracer process.
157traceMessage :: Serializable m => m -> Process ()
158traceMessage msg = withLocalTracer $ \t -> liftIO $ Tracer.traceMessage t msg
160withLocalTracer :: (Tracer -> Process ()) -> Process ()
161withLocalTracer act = do
162 node <- processNode <$> ask
163 act (localTracer node)
165withLocalTracerSync :: (Tracer -> SendPort TraceOk -> IO ()) -> Process ()
166withLocalTracerSync act = do
167 (sp, rp) <- newChan
168 withLocalTracer $ \t -> liftIO $ (act t sp)
169 TraceOk <- receiveChan rp
170 return ()
172withRegisteredTracer :: (ProcessId -> Process a) -> Process a
173withRegisteredTracer act = do
174 (sp, rp) <- newChan
175 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
176 currentTracer <- receiveChan rp
177 case currentTracer of
178 Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }
179 (Just p) -> act p