{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving  #-}
{-# LANGUAGE DeriveGeneric   #-}
module Control.Distributed.Process.Management.Internal.Types
  ( MxAgentId(..)
  , MxAgentState(..)
  , MxAgent(..)
  , MxAction(..)
  , ChannelSelector(..)
  , Fork
  , MxSink
  , MxEvent(..)
  , Addressable(..)
  ) where

import Control.Concurrent.STM
  ( TChan
  )
import Control.Distributed.Process.Internal.Types
  ( Process
  , ProcessId
  , SendPortId
  , Message
  , DiedReason
  , NodeId
  )
import Control.Monad.IO.Class (MonadIO)
import qualified Control.Monad.State as ST
  ( MonadState
  , StateT
  )
import Control.Monad.Fix (MonadFix)
import Data.Binary
import Data.Typeable (Typeable)
import GHC.Generics
import Network.Transport
  ( ConnectionId
  , EndPointAddress
  )

-- | This is the /default/ management event, fired for various internal
-- events around the NT connection and Process lifecycle. All published
-- events that conform to this type, are eligible for tracing - i.e.,
-- they will be delivered to the trace controller.
--
data MxEvent =
    MxSpawned          ProcessId
    -- ^ fired whenever a local process is spawned
  | MxRegistered       ProcessId    String
    -- ^ fired whenever a process/name is registered (locally)
  | MxUnRegistered     ProcessId    String
    -- ^ fired whenever a process/name is unregistered (locally)
  | MxProcessDied      ProcessId    DiedReason
    -- ^ fired whenever a process dies
  | MxNodeDied         NodeId       DiedReason
    -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)
  | MxSent             ProcessId    ProcessId Message
    -- ^ fired whenever a message is sent from a local process
  | MxSentToName       String       ProcessId Message
    -- ^ fired whenever a named send occurs
  | MxSentToPort       ProcessId    SendPortId Message
    -- ^ fired whenever a sendChan occurs
  | MxReceived         ProcessId    Message
    -- ^ fired whenever a message is received by a local process
  | MxReceivedPort     SendPortId   Message
    -- ^ fired whenever a message is received via a typed channel
  | MxConnected        ConnectionId EndPointAddress
    -- ^ fired when a network-transport connection is first established
  | MxDisconnected     ConnectionId EndPointAddress
    -- ^ fired when a network-transport connection is broken/disconnected
  | MxUser             Message
    -- ^ a user defined trace event
  | MxLog              String
    -- ^ a /logging/ event - used for debugging purposes only
  | MxTraceTakeover    ProcessId
    -- ^ notifies a trace listener that all subsequent traces will be sent to /pid/
  | MxTraceDisable
    -- ^ notifies a trace listener that it has been disabled/removed
    deriving (Typeable, (forall x. MxEvent -> Rep MxEvent x)
-> (forall x. Rep MxEvent x -> MxEvent) -> Generic MxEvent
forall x. Rep MxEvent x -> MxEvent
forall x. MxEvent -> Rep MxEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MxEvent -> Rep MxEvent x
from :: forall x. MxEvent -> Rep MxEvent x
$cto :: forall x. Rep MxEvent x -> MxEvent
to :: forall x. Rep MxEvent x -> MxEvent
Generic, Int -> MxEvent -> ShowS
[MxEvent] -> ShowS
MxEvent -> String
(Int -> MxEvent -> ShowS)
-> (MxEvent -> String) -> ([MxEvent] -> ShowS) -> Show MxEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MxEvent -> ShowS
showsPrec :: Int -> MxEvent -> ShowS
$cshow :: MxEvent -> String
show :: MxEvent -> String
$cshowList :: [MxEvent] -> ShowS
showList :: [MxEvent] -> ShowS
Show)

instance Binary MxEvent where

-- | The class of things that we might be able to resolve to
-- a @ProcessId@ (or not).
class Addressable a where
  resolveToPid :: a -> Maybe ProcessId

instance Addressable MxEvent where
  resolveToPid :: MxEvent -> Maybe ProcessId
resolveToPid (MxSpawned     ProcessId
p)     = ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
p
  resolveToPid (MxProcessDied ProcessId
p DiedReason
_)   = ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
p
  resolveToPid (MxSent        ProcessId
_ ProcessId
p Message
_) = ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
p
  resolveToPid (MxReceived    ProcessId
p Message
_)   = ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
p
  resolveToPid MxEvent
_                     = Maybe ProcessId
forall a. Maybe a
Nothing

-- | Gross though it is, this synonym represents a function
-- used to forking new processes, which has to be passed as a HOF
-- when calling mxAgentController, since there's no other way to
-- avoid a circular dependency with Node.hs
type Fork = (Process () -> IO ProcessId)

-- | A newtype wrapper for an agent id (which is a string).
newtype MxAgentId = MxAgentId { MxAgentId -> String
agentId :: String }
  deriving (Typeable, Get MxAgentId
[MxAgentId] -> Put
MxAgentId -> Put
(MxAgentId -> Put)
-> Get MxAgentId -> ([MxAgentId] -> Put) -> Binary MxAgentId
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: MxAgentId -> Put
put :: MxAgentId -> Put
$cget :: Get MxAgentId
get :: Get MxAgentId
$cputList :: [MxAgentId] -> Put
putList :: [MxAgentId] -> Put
Binary, MxAgentId -> MxAgentId -> Bool
(MxAgentId -> MxAgentId -> Bool)
-> (MxAgentId -> MxAgentId -> Bool) -> Eq MxAgentId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MxAgentId -> MxAgentId -> Bool
== :: MxAgentId -> MxAgentId -> Bool
$c/= :: MxAgentId -> MxAgentId -> Bool
/= :: MxAgentId -> MxAgentId -> Bool
Eq, Eq MxAgentId
Eq MxAgentId =>
(MxAgentId -> MxAgentId -> Ordering)
-> (MxAgentId -> MxAgentId -> Bool)
-> (MxAgentId -> MxAgentId -> Bool)
-> (MxAgentId -> MxAgentId -> Bool)
-> (MxAgentId -> MxAgentId -> Bool)
-> (MxAgentId -> MxAgentId -> MxAgentId)
-> (MxAgentId -> MxAgentId -> MxAgentId)
-> Ord MxAgentId
MxAgentId -> MxAgentId -> Bool
MxAgentId -> MxAgentId -> Ordering
MxAgentId -> MxAgentId -> MxAgentId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MxAgentId -> MxAgentId -> Ordering
compare :: MxAgentId -> MxAgentId -> Ordering
$c< :: MxAgentId -> MxAgentId -> Bool
< :: MxAgentId -> MxAgentId -> Bool
$c<= :: MxAgentId -> MxAgentId -> Bool
<= :: MxAgentId -> MxAgentId -> Bool
$c> :: MxAgentId -> MxAgentId -> Bool
> :: MxAgentId -> MxAgentId -> Bool
$c>= :: MxAgentId -> MxAgentId -> Bool
>= :: MxAgentId -> MxAgentId -> Bool
$cmax :: MxAgentId -> MxAgentId -> MxAgentId
max :: MxAgentId -> MxAgentId -> MxAgentId
$cmin :: MxAgentId -> MxAgentId -> MxAgentId
min :: MxAgentId -> MxAgentId -> MxAgentId
Ord)

data MxAgentState s = MxAgentState
                      {
                        forall s. MxAgentState s -> MxAgentId
mxAgentId     :: !MxAgentId
                      , forall s. MxAgentState s -> TChan Message
mxBus         :: !(TChan Message)
                      , forall s. MxAgentState s -> s
mxLocalState  :: !s
                      }

-- | Monad for management agents.
--
newtype MxAgent s a =
  MxAgent
  {
    forall s a. MxAgent s a -> StateT (MxAgentState s) Process a
unAgent :: ST.StateT (MxAgentState s) Process a
  } deriving ( (forall a b. (a -> b) -> MxAgent s a -> MxAgent s b)
-> (forall a b. a -> MxAgent s b -> MxAgent s a)
-> Functor (MxAgent s)
forall a b. a -> MxAgent s b -> MxAgent s a
forall a b. (a -> b) -> MxAgent s a -> MxAgent s b
forall s a b. a -> MxAgent s b -> MxAgent s a
forall s a b. (a -> b) -> MxAgent s a -> MxAgent s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall s a b. (a -> b) -> MxAgent s a -> MxAgent s b
fmap :: forall a b. (a -> b) -> MxAgent s a -> MxAgent s b
$c<$ :: forall s a b. a -> MxAgent s b -> MxAgent s a
<$ :: forall a b. a -> MxAgent s b -> MxAgent s a
Functor
             , Applicative (MxAgent s)
Applicative (MxAgent s) =>
(forall a b. MxAgent s a -> (a -> MxAgent s b) -> MxAgent s b)
-> (forall a b. MxAgent s a -> MxAgent s b -> MxAgent s b)
-> (forall a. a -> MxAgent s a)
-> Monad (MxAgent s)
forall s. Applicative (MxAgent s)
forall a. a -> MxAgent s a
forall s a. a -> MxAgent s a
forall a b. MxAgent s a -> MxAgent s b -> MxAgent s b
forall a b. MxAgent s a -> (a -> MxAgent s b) -> MxAgent s b
forall s a b. MxAgent s a -> MxAgent s b -> MxAgent s b
forall s a b. MxAgent s a -> (a -> MxAgent s b) -> MxAgent s b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall s a b. MxAgent s a -> (a -> MxAgent s b) -> MxAgent s b
>>= :: forall a b. MxAgent s a -> (a -> MxAgent s b) -> MxAgent s b
$c>> :: forall s a b. MxAgent s a -> MxAgent s b -> MxAgent s b
>> :: forall a b. MxAgent s a -> MxAgent s b -> MxAgent s b
$creturn :: forall s a. a -> MxAgent s a
return :: forall a. a -> MxAgent s a
Monad
             , Monad (MxAgent s)
Monad (MxAgent s) =>
(forall a. IO a -> MxAgent s a) -> MonadIO (MxAgent s)
forall s. Monad (MxAgent s)
forall a. IO a -> MxAgent s a
forall s a. IO a -> MxAgent s a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall s a. IO a -> MxAgent s a
liftIO :: forall a. IO a -> MxAgent s a
MonadIO
             , Monad (MxAgent s)
Monad (MxAgent s) =>
(forall a. (a -> MxAgent s a) -> MxAgent s a)
-> MonadFix (MxAgent s)
forall s. Monad (MxAgent s)
forall a. (a -> MxAgent s a) -> MxAgent s a
forall s a. (a -> MxAgent s a) -> MxAgent s a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall s a. (a -> MxAgent s a) -> MxAgent s a
mfix :: forall a. (a -> MxAgent s a) -> MxAgent s a
MonadFix
             , ST.MonadState (MxAgentState s)
             , Typeable
             , Functor (MxAgent s)
Functor (MxAgent s) =>
(forall a. a -> MxAgent s a)
-> (forall a b. MxAgent s (a -> b) -> MxAgent s a -> MxAgent s b)
-> (forall a b c.
    (a -> b -> c) -> MxAgent s a -> MxAgent s b -> MxAgent s c)
-> (forall a b. MxAgent s a -> MxAgent s b -> MxAgent s b)
-> (forall a b. MxAgent s a -> MxAgent s b -> MxAgent s a)
-> Applicative (MxAgent s)
forall s. Functor (MxAgent s)
forall a. a -> MxAgent s a
forall s a. a -> MxAgent s a
forall a b. MxAgent s a -> MxAgent s b -> MxAgent s a
forall a b. MxAgent s a -> MxAgent s b -> MxAgent s b
forall a b. MxAgent s (a -> b) -> MxAgent s a -> MxAgent s b
forall s a b. MxAgent s a -> MxAgent s b -> MxAgent s a
forall s a b. MxAgent s a -> MxAgent s b -> MxAgent s b
forall s a b. MxAgent s (a -> b) -> MxAgent s a -> MxAgent s b
forall a b c.
(a -> b -> c) -> MxAgent s a -> MxAgent s b -> MxAgent s c
forall s a b c.
(a -> b -> c) -> MxAgent s a -> MxAgent s b -> MxAgent s c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall s a. a -> MxAgent s a
pure :: forall a. a -> MxAgent s a
$c<*> :: forall s a b. MxAgent s (a -> b) -> MxAgent s a -> MxAgent s b
<*> :: forall a b. MxAgent s (a -> b) -> MxAgent s a -> MxAgent s b
$cliftA2 :: forall s a b c.
(a -> b -> c) -> MxAgent s a -> MxAgent s b -> MxAgent s c
liftA2 :: forall a b c.
(a -> b -> c) -> MxAgent s a -> MxAgent s b -> MxAgent s c
$c*> :: forall s a b. MxAgent s a -> MxAgent s b -> MxAgent s b
*> :: forall a b. MxAgent s a -> MxAgent s b -> MxAgent s b
$c<* :: forall s a b. MxAgent s a -> MxAgent s b -> MxAgent s a
<* :: forall a b. MxAgent s a -> MxAgent s b -> MxAgent s a
Applicative
             )

data ChannelSelector = InputChan | Mailbox

-- | Represents the actions a management agent can take
-- when evaluating an /event sink/.
--
data MxAction =
    MxAgentDeactivate !String
  | MxAgentPrioritise !ChannelSelector
  | MxAgentReady
  | MxAgentSkip

-- | Type of a management agent's event sink.
type MxSink s = Message -> MxAgent s (Maybe MxAction)