@@ -88,9 +88,14 @@ module Control.Distributed.Process.Debug
8888 , TraceFlags(..)
8989 , TraceSubject(..)
9090 -- * Configuring Tracing
91+ , isTracingEnabled
9192 , enableTrace
93+ , enableTraceAsync
9294 , disableTrace
95+ , disableTraceAsync
96+ , withTracer
9397 , setTraceFlags
98+ , setTraceFlagsAsync
9499 , defaultTraceFlags
95100 -- * Debugging
96101 , startTracer
@@ -113,9 +118,16 @@ import Control.Distributed.Process.Internal.Primitives
113118 , die
114119 , getSelfPid
115120 , reregister
116− , register
117121 , whereis
118122 , send
123+ , newChan
124+ , sendChan
125+ , receiveChan
126+ , receiveWait
127+ , matchIf
128+ , finally
129+ , try
130+ , monitor
119131 )
120132import Control.Distributed.Process.Internal.Types
121133 ( Tracer(..)
@@ -123,12 +135,15 @@ import Control.Distributed.Process.Internal.Types
123135 , ProcessId
124136 , Process
125137 , LocalProcess(..)
138+ , SendPort(..)
139+ , ProcessMonitorNotification(..)
126140 )
127141import Control.Distributed.Process.Internal.Trace.Types
128142 ( TraceArg(..)
129143 , TraceEvent(..)
130144 , TraceFlags(..)
131145 , TraceSubject(..)
146+ , TraceOk(..)
132147 , defaultTraceFlags
133148 )
134149import Control.Distributed.Process.Internal.Trace.Tracer
@@ -141,17 +156,27 @@ import qualified Control.Distributed.Process.Internal.Trace.Primitives as Tracer
141156 , traceLogFmt
142157 , traceMessage
143158 , enableTrace
159+ , enableTraceSync
144160 , disableTrace
161+ , disableTraceSync
145162 , setTraceFlags
163+ , setTraceFlagsSync
146164 )
147165import Control.Distributed.Process.Node
148166import Control.Distributed.Process.Serializable
149167
168+import Control.Exception (SomeException)
169+
150170import Control.Monad.IO.Class (liftIO)
151171import Control.Monad.Reader (ask)
152172
153173import Data.Binary()
154174
175+#if ! MIN_VERSION_base(4,6,0)
176+import Prelude hiding (catch)
177+#endif
178+
179+
155180--------------------------------------------------------------------------------
156181-- Debugging/Tracing API --
157182--------------------------------------------------------------------------------
@@ -161,24 +186,56 @@ import Data.Binary()
161186-- the registered tracer with the supplied handler, allowing the user to layer
162187-- multiple tracers on top of one another, with trace events forwarded down
163188-- through all the layers in turn. Once the top layer is stopped, it will
164−-- reregister the original tracer pid before terminating. If no tracer is
165−-- currently registered, this function will have no effect.
166−startTracer :: (TraceEvent -> Process ()) -> Process ()
167−startTracer handler = withRegisteredTracer $ \pid -> do
168− node <- processNode <$> ask
169− newPid <- liftIO $ forkProcess node $ do
170− finally (mkProxy pid handler)
171− (reregister "tracer" pid)
172− enableTrace newPid
189+-- reregister the original (prior) tracer pid before terminating.
190+startTracer :: (TraceEvent -> Process ()) -> Process ProcessId
191+startTracer handler = do
192+ (sp, rp) <- newChan
193+ withRegisteredTracer $ \pid -> do
194+ node <- processNode <$> ask
195+ newPid <- liftIO $ forkProcess node $ do
196+ -- TODO: we ensure that the original
197+ -- tracer is re-registered, but it is
198+ -- possible this could lead to races
199+ -- if multiple tracers crash in very
200+ -- close succession, due to scheduling
201+ finally (traceProxy pid handler)
202+ (resetTracer pid)
203+ enableTrace newPid
204+ sendChan sp newPid
205+ receiveChan rp
206+
207+-- | Evaluate @proc@ with tracing enabled via @handler@, and immediately
208+-- disable tracing thereafter, before giving the result (or exception
209+-- in case of failure).
210+withTracer :: forall a.
211+ (TraceEvent -> Process ())
212+ -> Process a
213+ -> Process (Either SomeException a)
214+withTracer handler proc = do
215+ tracer <- startTracer handler
216+ finally (try proc)
217+ (stopTracing tracer)
173218 where
174− mkProxy :: ProcessId -> (TraceEvent -> Process ()) -> Process ()
175− mkProxy pid act = do
176− getSelfPid >>= register "tracer"
177− proxy pid $ \(ev :: TraceEvent) ->
178− case ev of
179− (TraceEvTakeover _) -> die "finished"
180− TraceEvDisable -> die "stop"
181− _ -> act ev >> return True
219+ stopTracing :: ProcessId -> Process ()
220+ stopTracing tracer = do
221+ ref <- monitor tracer
222+ stopTracer
223+ receiveWait [
224+ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
225+ (\_ -> return ())
226+ ]
227+
228+traceProxy :: ProcessId -> (TraceEvent -> Process ()) -> Process ()
229+traceProxy pid act = do
230+ getSelfPid >>= reregister "tracer" -- registration is synchronous
231+ proxy pid $ \(ev :: TraceEvent) ->
232+ case ev of
233+ (TraceEvTakeover _) -> die "takeover"
234+ TraceEvDisable -> die "disabled"
235+ _ -> act ev >> return True
236+
237+resetTracer :: ProcessId -> Process ()
238+resetTracer pid = enableTrace pid
182239
183240-- | Stops a user supplied tracer started with 'startTracer'.
184241-- Note that only one tracer process can be active at any given time.
@@ -190,7 +247,7 @@ startTracer handler = withRegisteredTracer $ \pid -> do
190247-- This function will never stop the system tracer (i.e., the tracer
191248-- initially started when the node is created), therefore once all user
192249-- supplied tracers (i.e., processes started via 'startTracer') have exited,
193−-- subsequent calls to this function have no effect.
250+-- subsequent calls to this function will have no effect.
194251--
195252-- If tracing is support disabled for the node, this function will also
196253-- have no effect.
@@ -209,22 +266,57 @@ stopTracer = withLocalTracer $ \t ->
209266
210267withRegisteredTracer :: (ProcessId -> Process ()) -> Process ()
211268withRegisteredTracer act = do
212− t <- whereis "tracer"
213− case t of
214− Nothing -> return ()
215− Just pid -> act pid
269+ currentTracer <- whereis "tracer"
270+ case currentTracer of
271+ Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }
272+ (Just p) -> act p
273+
274+-- | Determine whether or not tracing has been enabled.
275+isTracingEnabled :: Process Bool
276+isTracingEnabled = do
277+ node <- processNode <$> ask
278+ case (localTracer node) of
279+ (ActiveTracer _ _) -> return True
280+ _ -> return False
216281
217282-- | Enable tracing to the supplied process.
283+enableTraceAsync :: ProcessId -> Process ()
284+enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid
285+
286+-- TODO: refactor _Sync versions of trace configuration functions...
287+
288+-- | Enable tracing to the supplied process and wait for a @TraceOk@
289+-- response from the trace coordinator process.
218290enableTrace :: ProcessId -> Process ()
219−enableTrace pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid
291+enableTrace pid =
292+ withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid
220293
221294-- | Disable the currently configured trace.
295+disableTraceAsync :: Process ()
296+disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t
297+
298+-- | Disable the currently configured trace and wait for a @TraceOk@
299+-- response from the trace coordinator process.
222300disableTrace :: Process ()
223−disableTrace = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t
301+disableTrace =
302+ withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp
224303
225304-- | Set the given flags for the current tracer.
305+setTraceFlagsAsync :: TraceFlags -> Process ()
306+setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f
307+
308+-- | Set the given flags for the current tracer and wait for a @TraceOk@
309+-- response from the trace coordinator process.
226310setTraceFlags :: TraceFlags -> Process ()
227−setTraceFlags f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f
311+setTraceFlags f =
312+ withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f
313+
314+withLocalTracerSync :: (Tracer -> SendPort TraceOk -> IO ()) -> Process ()
315+withLocalTracerSync act = do
316+ (sp, rp) <- newChan
317+ withLocalTracer $ \t -> liftIO $ (act t sp)
318+ TraceOk <- receiveChan rp
319+ return ()
228320
229321-- | Send a log message to the internal tracing facility. If tracing is
230322-- enabled, this will create a custom trace log event.
@@ -246,3 +338,4 @@ withLocalTracer :: (Tracer -> Process ()) -> Process ()
246338withLocalTracer act = do
247339 node <- processNode <$> ask
248340 act (localTracer node)
341+