git.iko.soy/distributed-process
on 2d17ab6 help sign in
distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs
173 lines 5.6 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)
70import Prelude
72--------------------------------------------------------------------------------
73-- Main API --
74--------------------------------------------------------------------------------
76-- | Converts a list of identifiers (that can be
77-- mapped to process ids), to a 'TraceSubject'.
78class Traceable a where
79 uod :: [a] -> TraceSubject
81instance Traceable ProcessId where
82 uod = TraceProcs . Set.fromList
84instance Traceable String where
85 uod = TraceNames . Set.fromList
87-- | Turn tracing for for a subset of trace targets.
88traceOnly :: Traceable a => [a] -> Maybe TraceSubject
89traceOnly = Just . uod
91-- | Trace all targets.
92traceOn :: Maybe TraceSubject
93traceOn = Just TraceAll
95-- | Trace no targets.
96traceOff :: Maybe TraceSubject
97traceOff = Nothing
99-- | Enable tracing to the supplied process.
100enableTraceAsync :: ProcessId -> Process ()
101enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid
103-- TODO: refactor _Sync versions of trace configuration functions...
105-- | Enable tracing to the supplied process and wait for a @TraceOk@
106-- response from the trace coordinator process.
107enableTrace :: ProcessId -> Process ()
108enableTrace pid =
109 withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid
111-- | Disable the currently configured trace.
112disableTraceAsync :: Process ()
113disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t
115-- | Disable the currently configured trace and wait for a @TraceOk@
116-- response from the trace coordinator process.
117disableTrace :: Process ()
118disableTrace =
119 withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp
121getTraceFlags :: Process TraceFlags
122getTraceFlags = do
123 (sp, rp) <- newChan
124 withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp
125 receiveChan rp
127-- | Set the given flags for the current tracer.
128setTraceFlagsAsync :: TraceFlags -> Process ()
129setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f
131-- | Set the given flags for the current tracer and wait for a @TraceOk@
132-- response from the trace coordinator process.
133setTraceFlags :: TraceFlags -> Process ()
134setTraceFlags f =
135 withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f
137-- | Send a log message to the internal tracing facility. If tracing is
138-- enabled, this will create a custom trace log event.
139--
140traceLog :: String -> Process ()
141traceLog s = withLocalTracer $ \t -> liftIO $ Tracer.traceLog t s
143-- | Send a log message to the internal tracing facility, using the given
144-- list of printable 'TraceArg's interspersed with the preceding delimiter.
145--
146traceLogFmt :: String -> [TraceArg] -> Process ()
147traceLogFmt d ls = withLocalTracer $ \t -> liftIO $ Tracer.traceLogFmt t d ls
149-- | Send an arbitrary 'Message' to the tracer process.
150traceMessage :: Serializable m => m -> Process ()
151traceMessage msg = withLocalTracer $ \t -> liftIO $ Tracer.traceMessage t msg
153withLocalTracer :: (MxEventBus -> Process ()) -> Process ()
154withLocalTracer act = do
155 node <- processNode <$> ask
156 act (localEventBus node)
158withLocalTracerSync :: (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
159withLocalTracerSync act = do
160 (sp, rp) <- newChan
161 withLocalTracer $ \t -> liftIO $ (act t sp)
162 TraceOk <- receiveChan rp
163 return ()
165withRegisteredTracer :: (ProcessId -> Process a) -> Process a
166withRegisteredTracer act = do
167 (sp, rp) <- newChan
168 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
169 currentTracer <- receiveChan rp
170 case currentTracer of
171 Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }
172 (Just p) -> act p