{-# LANGUAGE CPP  #-}
{-# LANGUAGE ScopedTypeVariables  #-}
-- | Tracing/Debugging support - Trace Implementation
module Control.Distributed.Process.Management.Internal.Trace.Tracer
  ( -- * API for the Management Agent
    traceController
    -- * Built in tracers
  , defaultTracer
  , systemLoggerTracer
  , logfileTracer
  , eventLogTracer
  ) where

import Control.Applicative
import Control.Concurrent.Chan (writeChan)
import Control.Concurrent.MVar
  ( MVar
  , putMVar
  )
import Control.Distributed.Process.Internal.CQueue
  ( CQueue
  )
import Control.Distributed.Process.Internal.Primitives
  ( die
  , receiveWait
  , forward
  , sendChan
  , match
  , matchAny
  , matchIf
  , handleMessage
  , matchUnknown
  )
import Control.Distributed.Process.Management.Internal.Types
  ( MxEvent(..)
  , Addressable(..)
  )
import Control.Distributed.Process.Management.Internal.Trace.Types
  ( SetTrace(..)
  , TraceSubject(..)
  , TraceFlags(..)
  , TraceOk(..)
  , defaultTraceFlags
  )
import Control.Distributed.Process.Management.Internal.Trace.Primitives
  ( traceOn )
import Control.Distributed.Process.Internal.Types
  ( LocalNode(..)
  , NCMsg(..)
  , ProcessId
  , Process
  , LocalProcess(..)
  , Identifier(..)
  , ProcessSignal(NamedSend)
  , Message
  , SendPort
  , forever'
  , nullProcessId
  , createUnencodedMessage
  )

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import Control.Monad.Catch
  ( catch
  , finally
  )

import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map

import Data.Maybe (fromMaybe)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
import Debug.Trace (traceEventIO)
import Prelude

#if ! MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif

import System.Environment (getEnv)
import System.IO
  ( Handle
  , IOMode(AppendMode)
  , BufferMode(..)
  , openFile
  , hClose
  , hPutStrLn
  , hSetBuffering
  )
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
import System.Mem.Weak
  ( Weak
  )

data TracerState =
  TracerST
  {
    TracerState -> Maybe ProcessId
client   :: !(Maybe ProcessId)
  , TracerState -> TraceFlags
flags    :: !TraceFlags
  , TracerState -> Map ProcessId (Set String)
regNames :: !(Map ProcessId (Set String))
  }

--------------------------------------------------------------------------------
-- Trace Handlers                                                             --
--------------------------------------------------------------------------------

defaultTracer :: Process ()
defaultTracer :: Process ()
defaultTracer =
  Process () -> (IOError -> Process ()) -> Process ()
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (String -> Process String
checkEnv String
"DISTRIBUTED_PROCESS_TRACE_FILE" Process String -> (String -> Process ()) -> Process ()
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Process ()
logfileTracer)
        (\(IOError
_ :: IOError) -> Process ()
defaultTracerAux)

defaultTracerAux :: Process ()
defaultTracerAux :: Process ()
defaultTracerAux =
  Process () -> (IOError -> Process ()) -> Process ()
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (String -> Process String
checkEnv String
"DISTRIBUTED_PROCESS_TRACE_CONSOLE" Process String -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Process ()
systemLoggerTracer)
        (\(IOError
_ :: IOError) -> Process ()
defaultEventLogTracer)

-- TODO: it would be /nice/ if we had some way of checking the runtime
-- options to see if +RTS -v (or similar) has been given...
defaultEventLogTracer :: Process ()
defaultEventLogTracer :: Process ()
defaultEventLogTracer =
  Process () -> (IOError -> Process ()) -> Process ()
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (String -> Process String
checkEnv String
"DISTRIBUTED_PROCESS_TRACE_EVENTLOG" Process String -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Process ()
eventLogTracer)
        (\(IOError
_ :: IOError) -> Process ()
nullTracer)

checkEnv :: String -> Process String
checkEnv :: String -> Process String
checkEnv String
s = IO String -> Process String
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> Process String) -> IO String -> Process String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
s

-- This trace client is (intentionally) a noop - it simply provides
-- an intial client for the trace controller to talk to, until some
-- other (hopefully more useful) client is installed over the top of
-- it. This is the default trace client.
nullTracer :: Process ()
nullTracer :: Process ()
nullTracer =
  Process () -> Process ()
forall (m :: * -> *) a b. Monad m => m a -> m b
forever' (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [ Process () -> Match ()
forall b. Process b -> Match b
matchUnknown (() -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]

systemLoggerTracer :: Process ()
systemLoggerTracer :: Process ()
systemLoggerTracer = 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
  let tr :: MxEvent -> Process ()
tr = LocalNode -> MxEvent -> Process ()
sendTraceLog LocalNode
node
  Process (Maybe ()) -> Process ()
forall (m :: * -> *) a b. Monad m => m a -> m b
forever' (Process (Maybe ()) -> Process ())
-> Process (Maybe ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ [Match (Maybe ())] -> Process (Maybe ())
forall b. [Match b] -> Process b
receiveWait [ (Message -> Process (Maybe ())) -> Match (Maybe ())
forall b. (Message -> Process b) -> Match b
matchAny (\Message
m -> Message -> (MxEvent -> Process ()) -> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
m MxEvent -> Process ()
tr) ]
  where
    sendTraceLog :: LocalNode -> MxEvent -> Process ()
    sendTraceLog :: LocalNode -> MxEvent -> Process ()
sendTraceLog LocalNode
node MxEvent
ev = do
      UTCTime
now <- IO UTCTime -> Process UTCTime
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> Process UTCTime) -> IO UTCTime -> Process UTCTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime
getCurrentTime
      (String, String)
msg <- (String, String) -> Process (String, String)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Process (String, String))
-> (String, String) -> Process (String, String)
forall a b. (a -> b) -> a -> b
$ (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%c" UTCTime
now, MxEvent -> String
buildTxt MxEvent
ev)
      ProcessId
emptyPid <- ProcessId -> Process ProcessId
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessId -> Process ProcessId) -> ProcessId -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ (NodeId -> ProcessId
nullProcessId (LocalNode -> NodeId
localNodeId LocalNode
node))
      NCMsg
traceMsg <- NCMsg -> Process NCMsg
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (NCMsg -> Process NCMsg) -> NCMsg -> Process NCMsg
forall a b. (a -> b) -> a -> b
$ NCMsg {
                             ctrlMsgSender :: Identifier
ctrlMsgSender = ProcessId -> Identifier
ProcessIdentifier (ProcessId
emptyPid)
                           , ctrlMsgSignal :: ProcessSignal
ctrlMsgSignal = (String -> Message -> ProcessSignal
NamedSend String
"trace.logger"
                                                 ((String, String) -> Message
forall a. Serializable a => a -> Message
createUnencodedMessage (String, String)
msg))
                           }
      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
$ Chan NCMsg -> NCMsg -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (LocalNode -> Chan NCMsg
localCtrlChan LocalNode
node) NCMsg
traceMsg

    buildTxt :: MxEvent -> String
    buildTxt :: MxEvent -> String
buildTxt (MxLog String
msg) = String
msg
    buildTxt MxEvent
ev          = MxEvent -> String
forall a. Show a => a -> String
show MxEvent
ev

eventLogTracer :: Process ()
eventLogTracer :: Process ()
eventLogTracer =
  -- NB: when the GHC event log supports tracing arbitrary (ish) data, we will
  -- almost certainly use *that* facility independently of whether or not there
  -- is a tracer process installed. This is just a stop gap until then.
  Process (Maybe ()) -> Process ()
forall (m :: * -> *) a b. Monad m => m a -> m b
forever' (Process (Maybe ()) -> Process ())
-> Process (Maybe ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ [Match (Maybe ())] -> Process (Maybe ())
forall b. [Match b] -> Process b
receiveWait [ (Message -> Process (Maybe ())) -> Match (Maybe ())
forall b. (Message -> Process b) -> Match b
matchAny (\Message
m -> Message -> (MxEvent -> Process ()) -> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
m MxEvent -> Process ()
writeTrace) ]
  where
    writeTrace :: MxEvent -> Process ()
    writeTrace :: MxEvent -> Process ()
writeTrace MxEvent
ev = 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
$ String -> IO ()
traceEventIO (MxEvent -> String
forall a. Show a => a -> String
show MxEvent
ev)

logfileTracer :: FilePath -> Process ()
logfileTracer :: String -> Process ()
logfileTracer String
p = do
  -- TODO: error handling if the handle cannot be opened
  Handle
h <- IO Handle -> Process Handle
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> Process Handle) -> IO Handle -> Process Handle
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> IO Handle
openFile String
p IOMode
AppendMode
  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
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
  Handle -> Process ()
logger Handle
h Process () -> Process () -> Process ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` (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
$ Handle -> IO ()
hClose Handle
h)
  where
    logger :: Handle -> Process ()
    logger :: Handle -> Process ()
logger Handle
h' = Process (Maybe ()) -> Process ()
forall (m :: * -> *) a b. Monad m => m a -> m b
forever' (Process (Maybe ()) -> Process ())
-> Process (Maybe ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ do
      [Match (Maybe ())] -> Process (Maybe ())
forall b. [Match b] -> Process b
receiveWait [
          (MxEvent -> Bool)
-> (MxEvent -> Process (Maybe ())) -> Match (Maybe ())
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\MxEvent
ev -> case MxEvent
ev of
                            MxEvent
MxTraceDisable      -> Bool
True
                            (MxTraceTakeover ProcessId
_) -> Bool
True
                            MxEvent
_                   -> Bool
False)
                  (\MxEvent
_ -> (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
$ Handle -> IO ()
hClose Handle
h') Process () -> Process (Maybe ()) -> Process (Maybe ())
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process (Maybe ())
forall a b. Serializable a => a -> Process b
die String
"trace stopped")
        , (Message -> Process (Maybe ())) -> Match (Maybe ())
forall b. (Message -> Process b) -> Match b
matchAny (\Message
ev -> Message -> (MxEvent -> Process ()) -> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
ev (Handle -> MxEvent -> Process ()
writeTrace Handle
h'))
        ]

    writeTrace :: Handle -> MxEvent -> Process ()
    writeTrace :: Handle -> MxEvent -> Process ()
writeTrace Handle
h MxEvent
ev = do
      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
$ do
        UTCTime
now <- IO UTCTime
getCurrentTime
        Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%c - " UTCTime
now) String -> String -> String
forall a. [a] -> [a] -> [a]
++ (MxEvent -> String
forall a. Show a => a -> String
show MxEvent
ev)

--------------------------------------------------------------------------------
-- Tracer Implementation                                                      --
--------------------------------------------------------------------------------

traceController :: MVar ((Weak (CQueue Message))) -> Process ()
traceController :: MVar (Weak (CQueue Message)) -> Process ()
traceController MVar (Weak (CQueue Message))
mv = do
    -- See the documentation for mxAgentController for a
    -- commentary that explains this breach of encapsulation
    Weak (CQueue Message)
weakQueue <- LocalProcess -> Weak (CQueue Message)
processWeakQ (LocalProcess -> Weak (CQueue Message))
-> Process LocalProcess -> Process (Weak (CQueue Message))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Process LocalProcess
forall r (m :: * -> *). MonadReader r m => m r
ask
    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
$ MVar (Weak (CQueue Message)) -> Weak (CQueue Message) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Weak (CQueue Message))
mv Weak (CQueue Message)
weakQueue
    TracerState
initState <- Process TracerState
initialState
    TracerState -> Process ()
traceLoop TracerState
initState { client = Nothing }
  where
    traceLoop :: TracerState -> Process ()
    traceLoop :: TracerState -> Process ()
traceLoop TracerState
st = do
      let client' :: Maybe ProcessId
client' = TracerState -> Maybe ProcessId
client TracerState
st
      -- Trace events are forwarded to the enabled trace target.
      -- At some point in the future, we're going to start writing these custom
      -- events to the ghc eventlog, at which point this design might change.
      TracerState
st' <- [Match TracerState] -> Process TracerState
forall b. [Match b] -> Process b
receiveWait [
          ((Maybe (SendPort TraceOk), SetTrace) -> Process TracerState)
-> Match TracerState
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(Maybe (SendPort TraceOk)
setResp, SetTrace
set :: SetTrace) -> do
                  -- We consider at most one trace client, which is a process.
                  -- Tracking multiple clients represents too high an overhead,
                  -- so we leave that kind of thing to our consumers (e.g., the
                  -- high level Debug client module) to figure out.
                  case SetTrace
set of
                    (TraceEnable ProcessId
pid) -> do
                      -- notify the previous tracer it has been replaced
                      Maybe ProcessId -> Message -> Process ()
sendTraceMsg Maybe ProcessId
client' (MxEvent -> Message
forall a. Serializable a => a -> Message
createUnencodedMessage (ProcessId -> MxEvent
MxTraceTakeover ProcessId
pid))
                      Maybe (SendPort TraceOk) -> Process ()
sendOk Maybe (SendPort TraceOk)
setResp
                      TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st { client = (Just pid) }
                    SetTrace
TraceDisable -> do
                      Maybe ProcessId -> Message -> Process ()
sendTraceMsg Maybe ProcessId
client' (MxEvent -> Message
forall a. Serializable a => a -> Message
createUnencodedMessage MxEvent
MxTraceDisable)
                      Maybe (SendPort TraceOk) -> Process ()
sendOk Maybe (SendPort TraceOk)
setResp
                      TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st { client = Nothing })
        , ((Maybe (SendPort TraceOk), TraceFlags) -> Process TracerState)
-> Match TracerState
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(Maybe (SendPort TraceOk)
confResp, TraceFlags
flags') ->
                  Maybe (SendPort TraceOk) -> Process ()
sendOk Maybe (SendPort TraceOk)
confResp Process () -> Process TracerState -> Process TracerState
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TraceFlags -> TracerState -> Process TracerState
applyTraceFlags TraceFlags
flags' TracerState
st)
        , (SendPort TraceFlags -> Process TracerState) -> Match TracerState
forall a b. Serializable a => (a -> Process b) -> Match b
match (\SendPort TraceFlags
chGetFlags -> SendPort TraceFlags -> TraceFlags -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort TraceFlags
chGetFlags (TracerState -> TraceFlags
flags TracerState
st) Process () -> Process TracerState -> Process TracerState
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st)
        , (SendPort (Maybe ProcessId) -> Process TracerState)
-> Match TracerState
forall a b. Serializable a => (a -> Process b) -> Match b
match (\SendPort (Maybe ProcessId)
chGetCurrent -> SendPort (Maybe ProcessId) -> Maybe ProcessId -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort (Maybe ProcessId)
chGetCurrent (TracerState -> Maybe ProcessId
client TracerState
st) Process () -> Process TracerState -> Process TracerState
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st)
          -- we dequeue incoming events even if we don't process them
        , (Message -> Process TracerState) -> Match TracerState
forall b. (Message -> Process b) -> Match b
matchAny (\Message
ev ->
            Message
-> (MxEvent -> Process TracerState) -> Process (Maybe TracerState)
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
ev (TracerState -> Message -> MxEvent -> Process TracerState
handleTrace TracerState
st Message
ev) Process (Maybe TracerState)
-> (Maybe TracerState -> Process TracerState)
-> Process TracerState
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (TracerState -> Process TracerState)
-> (Maybe TracerState -> TracerState)
-> Maybe TracerState
-> Process TracerState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracerState -> Maybe TracerState -> TracerState
forall a. a -> Maybe a -> a
fromMaybe TracerState
st)
        ]
      TracerState -> Process ()
traceLoop TracerState
st'

    sendOk :: Maybe (SendPort TraceOk) -> Process ()
    sendOk :: Maybe (SendPort TraceOk) -> Process ()
sendOk Maybe (SendPort TraceOk)
Nothing   = () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    sendOk (Just SendPort TraceOk
sp) = SendPort TraceOk -> TraceOk -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort TraceOk
sp TraceOk
TraceOk

    initialState :: Process TracerState
    initialState :: Process TracerState
initialState = do
      TraceFlags
flags' <- Process TraceFlags
checkEnvFlags
      TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (TracerState -> Process TracerState)
-> TracerState -> Process TracerState
forall a b. (a -> b) -> a -> b
$ TracerST { client :: Maybe ProcessId
client   = Maybe ProcessId
forall a. Maybe a
Nothing
                        , flags :: TraceFlags
flags    = TraceFlags
flags'
                        , regNames :: Map ProcessId (Set String)
regNames = Map ProcessId (Set String)
forall k a. Map k a
Map.empty
                        }

    checkEnvFlags :: Process TraceFlags
    checkEnvFlags :: Process TraceFlags
checkEnvFlags =
      Process TraceFlags
-> (IOError -> Process TraceFlags) -> Process TraceFlags
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (String -> Process String
checkEnv String
"DISTRIBUTED_PROCESS_TRACE_FLAGS" Process String
-> (String -> Process TraceFlags) -> Process TraceFlags
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TraceFlags -> Process TraceFlags
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (TraceFlags -> Process TraceFlags)
-> (String -> TraceFlags) -> String -> Process TraceFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TraceFlags
parseFlags)
            (\(IOError
_ :: IOError) -> TraceFlags -> Process TraceFlags
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TraceFlags
defaultTraceFlags)

    parseFlags :: String -> TraceFlags
    parseFlags :: String -> TraceFlags
parseFlags String
s = String -> TraceFlags -> TraceFlags
parseFlags' String
s TraceFlags
defaultTraceFlags
      where parseFlags' :: String -> TraceFlags -> TraceFlags
            parseFlags' :: String -> TraceFlags -> TraceFlags
parseFlags' [] TraceFlags
parsedFlags = TraceFlags
parsedFlags
            parseFlags' (Char
x:String
xs) TraceFlags
parsedFlags
              | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'p'  = String -> TraceFlags -> TraceFlags
parseFlags' String
xs TraceFlags
parsedFlags { traceSpawned = traceOn }
              | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'n'  = String -> TraceFlags -> TraceFlags
parseFlags' String
xs TraceFlags
parsedFlags { traceRegistered = traceOn }
              | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'u'  = String -> TraceFlags -> TraceFlags
parseFlags' String
xs TraceFlags
parsedFlags { traceUnregistered = traceOn }
              | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'd'  = String -> TraceFlags -> TraceFlags
parseFlags' String
xs TraceFlags
parsedFlags { traceDied = traceOn }
              | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
's'  = String -> TraceFlags -> TraceFlags
parseFlags' String
xs TraceFlags
parsedFlags { traceSend = traceOn }
              | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'r'  = String -> TraceFlags -> TraceFlags
parseFlags' String
xs TraceFlags
parsedFlags { traceRecv = traceOn }
              | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'l'  = String -> TraceFlags -> TraceFlags
parseFlags' String
xs TraceFlags
parsedFlags { traceNodes = True }
              | Bool
otherwise = String -> TraceFlags -> TraceFlags
parseFlags' String
xs TraceFlags
parsedFlags

applyTraceFlags :: TraceFlags -> TracerState -> Process TracerState
applyTraceFlags :: TraceFlags -> TracerState -> Process TracerState
applyTraceFlags TraceFlags
flags' TracerState
state = TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
state { flags = flags' }

handleTrace :: TracerState -> Message -> MxEvent -> Process TracerState
handleTrace :: TracerState -> Message -> MxEvent -> Process TracerState
handleTrace TracerState
st Message
msg ev :: MxEvent
ev@(MxRegistered ProcessId
p String
n) =
  let regNames' :: Map ProcessId (Set String)
regNames' =
        (Set String -> Set String -> Set String)
-> ProcessId
-> Set String
-> Map ProcessId (Set String)
-> Map ProcessId (Set String)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\Set String
_ Set String
ns -> String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
n Set String
ns) ProcessId
p
                       (String -> Set String
forall a. a -> Set a
Set.singleton String
n)
                       (TracerState -> Map ProcessId (Set String)
regNames TracerState
st)
  in do
    MxEvent
-> Message -> Maybe TraceSubject -> TracerState -> Process ()
traceEv MxEvent
ev Message
msg (TraceFlags -> Maybe TraceSubject
traceRegistered (TracerState -> TraceFlags
flags TracerState
st)) TracerState
st
    TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st { regNames = regNames' }
handleTrace TracerState
st Message
msg ev :: MxEvent
ev@(MxUnRegistered ProcessId
p String
n) =
  let f :: Maybe (Set String) -> Maybe (Set String)
f Maybe (Set String)
ns = case Maybe (Set String)
ns of
               Maybe (Set String)
Nothing  -> Maybe (Set String)
forall a. Maybe a
Nothing
               Just Set String
ns' -> Set String -> Maybe (Set String)
forall a. a -> Maybe a
Just (String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.delete String
n Set String
ns')
      regNames' :: Map ProcessId (Set String)
regNames' = (Maybe (Set String) -> Maybe (Set String))
-> ProcessId
-> Map ProcessId (Set String)
-> Map ProcessId (Set String)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Set String) -> Maybe (Set String)
f ProcessId
p (TracerState -> Map ProcessId (Set String)
regNames TracerState
st)
  in do
    MxEvent
-> Message -> Maybe TraceSubject -> TracerState -> Process ()
traceEv MxEvent
ev Message
msg (TraceFlags -> Maybe TraceSubject
traceUnregistered (TracerState -> TraceFlags
flags TracerState
st)) TracerState
st
    TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st { regNames = regNames' }
handleTrace TracerState
st Message
msg ev :: MxEvent
ev@(MxSpawned  ProcessId
_)   = do
  MxEvent
-> Message -> Maybe TraceSubject -> TracerState -> Process ()
traceEv MxEvent
ev Message
msg (TraceFlags -> Maybe TraceSubject
traceSpawned (TracerState -> TraceFlags
flags TracerState
st)) TracerState
st Process () -> Process TracerState -> Process TracerState
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st
handleTrace TracerState
st Message
msg ev :: MxEvent
ev@(MxProcessDied ProcessId
_ DiedReason
_)     = do
  MxEvent
-> Message -> Maybe TraceSubject -> TracerState -> Process ()
traceEv MxEvent
ev Message
msg (TraceFlags -> Maybe TraceSubject
traceDied (TracerState -> TraceFlags
flags TracerState
st)) TracerState
st Process () -> Process TracerState -> Process TracerState
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st
handleTrace TracerState
st Message
msg ev :: MxEvent
ev@(MxSent ProcessId
_ ProcessId
_ Message
_)   =
  MxEvent
-> Message -> Maybe TraceSubject -> TracerState -> Process ()
traceEv MxEvent
ev Message
msg (TraceFlags -> Maybe TraceSubject
traceSend (TracerState -> TraceFlags
flags TracerState
st)) TracerState
st Process () -> Process TracerState -> Process TracerState
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st
handleTrace TracerState
st Message
msg ev :: MxEvent
ev@(MxReceived ProcessId
_ Message
_) =
  MxEvent
-> Message -> Maybe TraceSubject -> TracerState -> Process ()
traceEv MxEvent
ev Message
msg (TraceFlags -> Maybe TraceSubject
traceRecv (TracerState -> TraceFlags
flags TracerState
st)) TracerState
st Process () -> Process TracerState -> Process TracerState
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st
handleTrace TracerState
st Message
msg MxEvent
ev = do
  case MxEvent
ev of
    (MxNodeDied NodeId
_ DiedReason
_) ->
      case (TraceFlags -> Bool
traceNodes (TracerState -> TraceFlags
flags TracerState
st)) of
        Bool
True  -> TracerState -> MxEvent -> Message -> Process ()
sendTrace TracerState
st MxEvent
ev Message
msg
        Bool
False -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (MxUser Message
_) -> TracerState -> MxEvent -> Message -> Process ()
sendTrace TracerState
st MxEvent
ev Message
msg
    (MxLog String
_)  -> TracerState -> MxEvent -> Message -> Process ()
sendTrace TracerState
st MxEvent
ev Message
msg
    MxEvent
_ ->
      case (TraceFlags -> Bool
traceConnections (TracerState -> TraceFlags
flags TracerState
st)) of
        Bool
True  -> TracerState -> MxEvent -> Message -> Process ()
sendTrace TracerState
st MxEvent
ev Message
msg
        Bool
False -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  TracerState -> Process TracerState
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return TracerState
st

traceEv :: MxEvent
        -> Message
        -> Maybe TraceSubject
        -> TracerState
        -> Process ()
traceEv :: MxEvent
-> Message -> Maybe TraceSubject -> TracerState -> Process ()
traceEv MxEvent
_  Message
_   Maybe TraceSubject
Nothing                  TracerState
_  = () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
traceEv MxEvent
ev Message
msg (Just TraceSubject
TraceAll)          TracerState
st = TracerState -> MxEvent -> Message -> Process ()
sendTrace TracerState
st MxEvent
ev Message
msg
traceEv MxEvent
ev Message
msg (Just (TraceProcs Set ProcessId
pids)) TracerState
st = 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
  let p :: ProcessId
p = case MxEvent -> Maybe ProcessId
forall a. Addressable a => a -> Maybe ProcessId
resolveToPid MxEvent
ev of
            Maybe ProcessId
Nothing  -> (NodeId -> ProcessId
nullProcessId (LocalNode -> NodeId
localNodeId LocalNode
node))
            Just ProcessId
pid -> ProcessId
pid
  case (ProcessId -> Set ProcessId -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ProcessId
p Set ProcessId
pids) of
    Bool
True  -> TracerState -> MxEvent -> Message -> Process ()
sendTrace TracerState
st MxEvent
ev Message
msg
    Bool
False -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
traceEv MxEvent
ev Message
msg (Just (TraceNames Set String
names)) TracerState
st = do
  -- if we have recorded regnames for p, then we forward the trace iif
  -- there are overlapping trace targets
  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
  let p :: ProcessId
p = case MxEvent -> Maybe ProcessId
forall a. Addressable a => a -> Maybe ProcessId
resolveToPid MxEvent
ev of
            Maybe ProcessId
Nothing  -> (NodeId -> ProcessId
nullProcessId (LocalNode -> NodeId
localNodeId LocalNode
node))
            Just ProcessId
pid -> ProcessId
pid
  case (ProcessId -> Map ProcessId (Set String) -> Maybe (Set String)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProcessId
p (TracerState -> Map ProcessId (Set String)
regNames TracerState
st)) of
    Maybe (Set String)
Nothing -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Set String
ns -> if (Set String -> Bool
forall a. Set a -> Bool
Set.null (Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set String
ns Set String
names))
                 then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 else TracerState -> MxEvent -> Message -> Process ()
sendTrace TracerState
st MxEvent
ev Message
msg

sendTrace :: TracerState -> MxEvent -> Message -> Process ()
sendTrace :: TracerState -> MxEvent -> Message -> Process ()
sendTrace TracerState
st MxEvent
ev Message
msg = do
  let c :: Maybe ProcessId
c = TracerState -> Maybe ProcessId
client TracerState
st
  if Maybe ProcessId
c Maybe ProcessId -> Maybe ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== (MxEvent -> Maybe ProcessId
forall a. Addressable a => a -> Maybe ProcessId
resolveToPid MxEvent
ev)  -- we do not send the tracer events about itself...
     then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     else Maybe ProcessId -> Message -> Process ()
sendTraceMsg Maybe ProcessId
c Message
msg

sendTraceMsg :: Maybe ProcessId -> Message -> Process ()
sendTraceMsg :: Maybe ProcessId -> Message -> Process ()
sendTraceMsg Maybe ProcessId
Nothing  Message
_   = () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
sendTraceMsg (Just ProcessId
p) Message
msg = ((Message -> ProcessId -> Process ())
-> ProcessId -> Message -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Message -> ProcessId -> Process ()
forward) ProcessId
p Message
msg