{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE TypeSynonymInstances  #-}
-- | Keeps the tracing API calls separate from the Tracer implementation,
-- which allows us to avoid a nasty import cycle between tracing and
-- the messaging primitives that rely on it, and also between the node
-- controller (which requires access to the tracing related elements of
-- our RemoteTable) and the Debug module, which requires @forkProcess@.
-- This module is also used by the management agent, which relies on the
-- tracing infrastructure's messaging fabric.
module Control.Distributed.Process.Management.Internal.Trace.Primitives
  ( -- * Sending Trace Data
    traceLog
  , traceLogFmt
  , traceMessage
    -- * Configuring A Tracer
  , 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

--------------------------------------------------------------------------------
-- Main API                                                                   --
--------------------------------------------------------------------------------

-- | Converts a list of identifiers (that can be
-- mapped to process ids), to a 'TraceSubject'.
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

-- | Turn tracing for for a subset of trace targets.
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

-- | Trace all targets.
traceOn :: Maybe TraceSubject
traceOn :: Maybe TraceSubject
traceOn = TraceSubject -> Maybe TraceSubject
forall a. a -> Maybe a
Just TraceSubject
TraceAll

-- | Trace no targets.
traceOff :: Maybe TraceSubject
traceOff :: Maybe TraceSubject
traceOff = Maybe TraceSubject
forall a. Maybe a
Nothing

-- | Enable tracing to the supplied process.
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

-- TODO: refactor _Sync versions of trace configuration functions...

-- | Enable tracing to the supplied process and wait for a @TraceOk@
-- response from the trace coordinator process.
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

-- | Disable the currently configured trace.
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

-- | Disable the currently configured trace and wait for a @TraceOk@
-- response from the trace coordinator process.
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

-- | Set the given flags for the current tracer.
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

-- | Set the given flags for the current tracer and wait for a @TraceOk@
-- response from the trace coordinator process.
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

-- | Send a log message to the internal tracing facility. If tracing is
-- enabled, this will create a custom trace log event.
--
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

-- | Send a log message to the internal tracing facility, using the given
-- list of printable 'TraceArg's interspersed with the preceding delimiter.
--
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

-- | Send an arbitrary 'Message' to the tracer process.
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"
                   -- NB: this should NOT ever happen, but forcing pattern matches
                   --     is not considered cool in later versions of MonadFail
                   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