git.iko.soy/distributed-process
on 0dad31a help sign in
distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs
179 lines 5.9 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 , die
37 )
38import Control.Distributed.Process.Management.Internal.Trace.Types
39 ( TraceArg(..)
40 , TraceFlags(..)
41 , TraceOk(..)
42 , TraceSubject(..)
43 , defaultTraceFlags
44 )
45import qualified Control.Distributed.Process.Management.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 ( Process
60 , ProcessId
61 , LocalProcess(..)
62 , LocalNode(localEventBus)
63 , SendPort
64 , MxEventBus(..)
65 )
66import Control.Distributed.Process.Serializable
67import Control.Monad.IO.Class (liftIO)
68import Control.Monad.Reader (ask)
70import qualified Data.Set as Set (fromList)
71import Prelude
73--------------------------------------------------------------------------------
74-- Main API --
75--------------------------------------------------------------------------------
77-- | Converts a list of identifiers (that can be
78-- mapped to process ids), to a 'TraceSubject'.
79class Traceable a where
80 uod :: [a] -> TraceSubject
82instance Traceable ProcessId where
83 uod = TraceProcs . Set.fromList
85instance Traceable String where
86 uod = TraceNames . Set.fromList
88-- | Turn tracing for for a subset of trace targets.
89traceOnly :: Traceable a => [a] -> Maybe TraceSubject
90traceOnly = Just . uod
92-- | Trace all targets.
93traceOn :: Maybe TraceSubject
94traceOn = Just TraceAll
96-- | Trace no targets.
97traceOff :: Maybe TraceSubject
98traceOff = Nothing
100-- | Enable tracing to the supplied process.
101enableTraceAsync :: ProcessId -> Process ()
102enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid
104-- TODO: refactor _Sync versions of trace configuration functions...
106-- | Enable tracing to the supplied process and wait for a @TraceOk@
107-- response from the trace coordinator process.
108enableTrace :: ProcessId -> Process ()
109enableTrace pid =
110 withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid
112-- | Disable the currently configured trace.
113disableTraceAsync :: Process ()
114disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t
116-- | Disable the currently configured trace and wait for a @TraceOk@
117-- response from the trace coordinator process.
118disableTrace :: Process ()
119disableTrace =
120 withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp
122getTraceFlags :: Process TraceFlags
123getTraceFlags = do
124 (sp, rp) <- newChan
125 withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp
126 receiveChan rp
128-- | Set the given flags for the current tracer.
129setTraceFlagsAsync :: TraceFlags -> Process ()
130setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f
132-- | Set the given flags for the current tracer and wait for a @TraceOk@
133-- response from the trace coordinator process.
134setTraceFlags :: TraceFlags -> Process ()
135setTraceFlags f =
136 withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f
138-- | Send a log message to the internal tracing facility. If tracing is
139-- enabled, this will create a custom trace log event.
140--
141traceLog :: String -> Process ()
142traceLog s = withLocalTracer $ \t -> liftIO $ Tracer.traceLog t s
144-- | Send a log message to the internal tracing facility, using the given
145-- list of printable 'TraceArg's interspersed with the preceding delimiter.
146--
147traceLogFmt :: String -> [TraceArg] -> Process ()
148traceLogFmt d ls = withLocalTracer $ \t -> liftIO $ Tracer.traceLogFmt t d ls
150-- | Send an arbitrary 'Message' to the tracer process.
151traceMessage :: Serializable m => m -> Process ()
152traceMessage msg = withLocalTracer $ \t -> liftIO $ Tracer.traceMessage t msg
154withLocalTracer :: (MxEventBus -> Process ()) -> Process ()
155withLocalTracer act = do
156 node <- processNode <$> ask
157 act (localEventBus node)
159withLocalTracerSync :: (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
160withLocalTracerSync act = do
161 (sp, rp) <- newChan
162 withLocalTracer $ \t -> liftIO $ (act t sp)
163 TraceOk <- receiveChan rp
164 return ()
166withRegisteredTracer :: (ProcessId -> Process a) -> Process a
167withRegisteredTracer act = do
168 (sp, rp) <- newChan
169 withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
170 currentTracer <- receiveChan rp
171 case currentTracer of
172 Nothing -> do mTP <- whereis "tracer.initial"
173 -- NB: this should NOT ever happen, but forcing pattern matches
174 -- is not considered cool in later versions of MonadFail
175 case mTP of
176 Just p' -> act p'
177 Nothing -> die $ "System Invariant Violation: Tracer Process "
178 ++ "Name Not Found (whereis tracer.initial)"
179 (Just p) -> act p