{-# 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

import System.Environment (getEnv)
import System.IO
  ( Handle
  , IOMode(AppendMode)
  , BufferMode(..)
  , openFile
  , hClose
  , hPutStrLn
  , hSetBuffering
  )
import Data.Time.Format (defaultTimeLocale)
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