{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Control.Distributed.Process.Management.Internal.Trace.Primitives
(
traceLog
, traceLogFmt
, traceMessage
, defaultTraceFlags
, enableTrace
, enableTraceAsync
, disableTrace
, disableTraceAsync
, getTraceFlags
, setTraceFlags
, setTraceFlagsAsync
, traceOnly
, traceOn
, traceOff
, withLocalTracer
, withRegisteredTracer
) where
import Control.Applicative
import Control.Distributed.Process.Internal.Primitives
( whereis
, newChan
, receiveChan
, die
)
import Control.Distributed.Process.Management.Internal.Trace.Types
( TraceArg(..)
, TraceFlags(..)
, TraceOk(..)
, TraceSubject(..)
, defaultTraceFlags
)
import qualified Control.Distributed.Process.Management.Internal.Trace.Types as Tracer
( traceLog
, traceLogFmt
, traceMessage
, enableTrace
, enableTraceSync
, disableTrace
, disableTraceSync
, setTraceFlags
, setTraceFlagsSync
, getTraceFlags
, getCurrentTraceClient
)
import Control.Distributed.Process.Internal.Types
( Process
, ProcessId
, LocalProcess(..)
, LocalNode(localEventBus)
, SendPort
, MxEventBus(..)
)
import Control.Distributed.Process.Serializable
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import qualified Data.Set as Set (fromList)
import Prelude
class Traceable a where
uod :: [a] -> TraceSubject
instance Traceable ProcessId where
uod :: [ProcessId] -> TraceSubject
uod = Set ProcessId -> TraceSubject
TraceProcs (Set ProcessId -> TraceSubject)
-> ([ProcessId] -> Set ProcessId) -> [ProcessId] -> TraceSubject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ProcessId] -> Set ProcessId
forall a. Ord a => [a] -> Set a
Set.fromList
instance Traceable String where
uod :: [String] -> TraceSubject
uod = Set String -> TraceSubject
TraceNames (Set String -> TraceSubject)
-> ([String] -> Set String) -> [String] -> TraceSubject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
traceOnly :: Traceable a => [a] -> Maybe TraceSubject
traceOnly :: forall a. Traceable a => [a] -> Maybe TraceSubject
traceOnly = TraceSubject -> Maybe TraceSubject
forall a. a -> Maybe a
Just (TraceSubject -> Maybe TraceSubject)
-> ([a] -> TraceSubject) -> [a] -> Maybe TraceSubject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> TraceSubject
forall a. Traceable a => [a] -> TraceSubject
uod
traceOn :: Maybe TraceSubject
traceOn :: Maybe TraceSubject
traceOn = TraceSubject -> Maybe TraceSubject
forall a. a -> Maybe a
Just TraceSubject
TraceAll
traceOff :: Maybe TraceSubject
traceOff :: Maybe TraceSubject
traceOff = Maybe TraceSubject
forall a. Maybe a
Nothing
enableTraceAsync :: ProcessId -> Process ()
enableTraceAsync :: ProcessId -> Process ()
enableTraceAsync ProcessId
pid = (MxEventBus -> Process ()) -> Process ()
withLocalTracer ((MxEventBus -> Process ()) -> Process ())
-> (MxEventBus -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MxEventBus -> ProcessId -> IO ()
Tracer.enableTrace MxEventBus
t ProcessId
pid
enableTrace :: ProcessId -> Process ()
enableTrace :: ProcessId -> Process ()
enableTrace ProcessId
pid =
(MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
withLocalTracerSync ((MxEventBus -> SendPort TraceOk -> IO ()) -> Process ())
-> (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t SendPort TraceOk
sp -> MxEventBus -> SendPort TraceOk -> ProcessId -> IO ()
Tracer.enableTraceSync MxEventBus
t SendPort TraceOk
sp ProcessId
pid
disableTraceAsync :: Process ()
disableTraceAsync :: Process ()
disableTraceAsync = (MxEventBus -> Process ()) -> Process ()
withLocalTracer ((MxEventBus -> Process ()) -> Process ())
-> (MxEventBus -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MxEventBus -> IO ()
Tracer.disableTrace MxEventBus
t
disableTrace :: Process ()
disableTrace :: Process ()
disableTrace =
(MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
withLocalTracerSync ((MxEventBus -> SendPort TraceOk -> IO ()) -> Process ())
-> (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t SendPort TraceOk
sp -> MxEventBus -> SendPort TraceOk -> IO ()
Tracer.disableTraceSync MxEventBus
t SendPort TraceOk
sp
getTraceFlags :: Process TraceFlags
getTraceFlags :: Process TraceFlags
getTraceFlags = do
(SendPort TraceFlags
sp, ReceivePort TraceFlags
rp) <- Process (SendPort TraceFlags, ReceivePort TraceFlags)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
(MxEventBus -> Process ()) -> Process ()
withLocalTracer ((MxEventBus -> Process ()) -> Process ())
-> (MxEventBus -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MxEventBus -> SendPort TraceFlags -> IO ()
Tracer.getTraceFlags MxEventBus
t SendPort TraceFlags
sp
ReceivePort TraceFlags -> Process TraceFlags
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort TraceFlags
rp
setTraceFlagsAsync :: TraceFlags -> Process ()
setTraceFlagsAsync :: TraceFlags -> Process ()
setTraceFlagsAsync TraceFlags
f = (MxEventBus -> Process ()) -> Process ()
withLocalTracer ((MxEventBus -> Process ()) -> Process ())
-> (MxEventBus -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MxEventBus -> TraceFlags -> IO ()
Tracer.setTraceFlags MxEventBus
t TraceFlags
f
setTraceFlags :: TraceFlags -> Process ()
setTraceFlags :: TraceFlags -> Process ()
setTraceFlags TraceFlags
f =
(MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
withLocalTracerSync ((MxEventBus -> SendPort TraceOk -> IO ()) -> Process ())
-> (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t SendPort TraceOk
sp -> MxEventBus -> SendPort TraceOk -> TraceFlags -> IO ()
Tracer.setTraceFlagsSync MxEventBus
t SendPort TraceOk
sp TraceFlags
f
traceLog :: String -> Process ()
traceLog :: String -> Process ()
traceLog String
s = (MxEventBus -> Process ()) -> Process ()
withLocalTracer ((MxEventBus -> Process ()) -> Process ())
-> (MxEventBus -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MxEventBus -> String -> IO ()
Tracer.traceLog MxEventBus
t String
s
traceLogFmt :: String -> [TraceArg] -> Process ()
traceLogFmt :: String -> [TraceArg] -> Process ()
traceLogFmt String
d [TraceArg]
ls = (MxEventBus -> Process ()) -> Process ()
withLocalTracer ((MxEventBus -> Process ()) -> Process ())
-> (MxEventBus -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MxEventBus -> String -> [TraceArg] -> IO ()
Tracer.traceLogFmt MxEventBus
t String
d [TraceArg]
ls
traceMessage :: Serializable m => m -> Process ()
traceMessage :: forall m. Serializable m => m -> Process ()
traceMessage m
msg = (MxEventBus -> Process ()) -> Process ()
withLocalTracer ((MxEventBus -> Process ()) -> Process ())
-> (MxEventBus -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MxEventBus -> m -> IO ()
forall m. Serializable m => MxEventBus -> m -> IO ()
Tracer.traceMessage MxEventBus
t m
msg
withLocalTracer :: (MxEventBus -> Process ()) -> Process ()
withLocalTracer :: (MxEventBus -> Process ()) -> Process ()
withLocalTracer MxEventBus -> Process ()
act = do
LocalNode
node <- LocalProcess -> LocalNode
processNode (LocalProcess -> LocalNode)
-> Process LocalProcess -> Process LocalNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Process LocalProcess
forall r (m :: * -> *). MonadReader r m => m r
ask
MxEventBus -> Process ()
act (LocalNode -> MxEventBus
localEventBus LocalNode
node)
withLocalTracerSync :: (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
withLocalTracerSync :: (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()
withLocalTracerSync MxEventBus -> SendPort TraceOk -> IO ()
act = do
(SendPort TraceOk
sp, ReceivePort TraceOk
rp) <- Process (SendPort TraceOk, ReceivePort TraceOk)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
(MxEventBus -> Process ()) -> Process ()
withLocalTracer ((MxEventBus -> Process ()) -> Process ())
-> (MxEventBus -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ (MxEventBus -> SendPort TraceOk -> IO ()
act MxEventBus
t SendPort TraceOk
sp)
TraceOk
TraceOk <- ReceivePort TraceOk -> Process TraceOk
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort TraceOk
rp
() -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
withRegisteredTracer :: (ProcessId -> Process a) -> Process a
withRegisteredTracer :: forall a. (ProcessId -> Process a) -> Process a
withRegisteredTracer ProcessId -> Process a
act = do
(SendPort (Maybe ProcessId)
sp, ReceivePort (Maybe ProcessId)
rp) <- Process (SendPort (Maybe ProcessId), ReceivePort (Maybe ProcessId))
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
(MxEventBus -> Process ()) -> Process ()
withLocalTracer ((MxEventBus -> Process ()) -> Process ())
-> (MxEventBus -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MxEventBus
t -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MxEventBus -> SendPort (Maybe ProcessId) -> IO ()
Tracer.getCurrentTraceClient MxEventBus
t SendPort (Maybe ProcessId)
sp
Maybe ProcessId
currentTracer <- ReceivePort (Maybe ProcessId) -> Process (Maybe ProcessId)
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort (Maybe ProcessId)
rp
case Maybe ProcessId
currentTracer of
Maybe ProcessId
Nothing -> do Maybe ProcessId
mTP <- String -> Process (Maybe ProcessId)
whereis String
"tracer.initial"
case Maybe ProcessId
mTP of
Just ProcessId
p' -> ProcessId -> Process a
act ProcessId
p'
Maybe ProcessId
Nothing -> String -> Process a
forall a b. Serializable a => a -> Process b
die (String -> Process a) -> String -> Process a
forall a b. (a -> b) -> a -> b
$ String
"System Invariant Violation: Tracer Process "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Name Not Found (whereis tracer.initial)"
(Just ProcessId
p) -> ProcessId -> Process a
act ProcessId
p