{-# LANGUAGE DeriveDataTypeable     #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE FunctionalDependencies #-}

-- | Types used throughout the Extras package
--
module Control.Distributed.Process.Extras.Internal.Types
  ( -- * Tagging
    Tag
  , TagPool
  , newTagPool
  , getTag
    -- * Addressing
  , Linkable(..)
  , Killable(..)
  , Resolvable(..)
  , Routable(..)
  , Monitored(..)
  , Addressable
  , Recipient(..)
  , RegisterSelf(..)
    -- * Interactions
  , whereisRemote
  , resolveOrDie
  , CancelWait(..)
  , Channel
  , Shutdown(..)
  , ExitReason(..)
  , ServerDisconnected(..)
  , NFSerializable
  ) where

import Control.Concurrent.MVar
  ( MVar
  , newMVar
  , modifyMVar
  )
import Control.DeepSeq (NFData(..), ($!!))
import Control.Distributed.Process hiding (send, catch)
import qualified Control.Distributed.Process as P
  ( send
  , unsafeSend
  , unsafeNSend
  )
import Control.Distributed.Process.Serializable
import Control.Exception (SomeException)
import Control.Monad.Catch (catch)
import Data.Binary
import Data.Foldable (traverse_)
import Data.Maybe (fromJust)
import Data.Typeable (Typeable)
import GHC.Generics

--------------------------------------------------------------------------------
-- API                                                                        --
--------------------------------------------------------------------------------

-- | Introduces a class that brings NFData into scope along with Serializable,
-- such that we can force evaluation. Intended for use with the UnsafePrimitives
-- module (which wraps "Control.Distributed.Process.UnsafePrimitives"), and
-- guarantees evaluatedness in terms of @NFData@. Please note that we /cannot/
-- guarantee that an @NFData@ instance will behave the same way as a @Binary@
-- one with regards evaluation, so it is still possible to introduce unexpected
-- behaviour by using /unsafe/ primitives in this way.
--
class (NFData a, Serializable a) => NFSerializable a
instance (NFData a, Serializable a) => NFSerializable a

instance (NFSerializable a) => NFSerializable (SendPort a)

-- | Tags provide uniqueness for messages, so that they can be
-- matched with their response.
type Tag = Int

-- | Generates unique 'Tag' for messages and response pairs.
-- Each process that depends, directly or indirectly, on
-- the call mechanisms in "Control.Distributed.Process.Global.Call"
-- should have at most one TagPool on which to draw unique message
-- tags.
type TagPool = MVar Tag

-- | Create a new per-process source of unique
-- message identifiers.
newTagPool :: Process TagPool
newTagPool :: Process TagPool
newTagPool = IO TagPool -> Process TagPool
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TagPool -> Process TagPool) -> IO TagPool -> Process TagPool
forall a b. (a -> b) -> a -> b
$ Tag -> IO TagPool
forall a. a -> IO (MVar a)
newMVar Tag
0

-- | Extract a new identifier from a 'TagPool'.
getTag :: TagPool -> Process Tag
getTag :: TagPool -> Process Tag
getTag TagPool
tp = IO Tag -> Process Tag
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Tag -> Process Tag) -> IO Tag -> Process Tag
forall a b. (a -> b) -> a -> b
$ TagPool -> (Tag -> IO (Tag, Tag)) -> IO Tag
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar TagPool
tp (\Tag
tag -> (Tag, Tag) -> IO (Tag, Tag)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tag
tagTag -> Tag -> Tag
forall a. Num a => a -> a -> a
+Tag
1,Tag
tag))

-- | A synchronous version of 'whereis', this monitors the remote node
-- and returns @Nothing@ if the node goes down (since a remote node failing
-- or being non-contactible has the same effect as a process not being
-- registered from the caller's point of view).
whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
whereisRemote NodeId
node String
name = do
  MonitorRef
mRef <- NodeId -> Process MonitorRef
monitorNode NodeId
node
  NodeId -> String -> Process ()
whereisRemoteAsync NodeId
node String
name
  [Match (Maybe ProcessId)] -> Process (Maybe ProcessId)
forall b. [Match b] -> Process b
receiveWait [ (NodeMonitorNotification -> Bool)
-> (NodeMonitorNotification -> Process (Maybe ProcessId))
-> Match (Maybe ProcessId)
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(NodeMonitorNotification MonitorRef
ref NodeId
nid DiedReason
_) -> MonitorRef
ref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
mRef Bool -> Bool -> Bool
&&
                                                                 NodeId
nid NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
== NodeId
node)
                        (\NodeMonitorNotification{} -> Maybe ProcessId -> Process (Maybe ProcessId)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessId
forall a. Maybe a
Nothing)
              , (WhereIsReply -> Bool)
-> (WhereIsReply -> Process (Maybe ProcessId))
-> Match (Maybe ProcessId)
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(WhereIsReply String
n Maybe ProcessId
_) -> String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name)
                        (\(WhereIsReply String
_ Maybe ProcessId
mPid) -> Maybe ProcessId -> Process (Maybe ProcessId)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessId
mPid)
              ]

-- | Wait cancellation message.
data CancelWait = CancelWait
    deriving (CancelWait -> CancelWait -> Bool
(CancelWait -> CancelWait -> Bool)
-> (CancelWait -> CancelWait -> Bool) -> Eq CancelWait
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CancelWait -> CancelWait -> Bool
== :: CancelWait -> CancelWait -> Bool
$c/= :: CancelWait -> CancelWait -> Bool
/= :: CancelWait -> CancelWait -> Bool
Eq, Tag -> CancelWait -> ShowS
[CancelWait] -> ShowS
CancelWait -> String
(Tag -> CancelWait -> ShowS)
-> (CancelWait -> String)
-> ([CancelWait] -> ShowS)
-> Show CancelWait
forall a.
(Tag -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Tag -> CancelWait -> ShowS
showsPrec :: Tag -> CancelWait -> ShowS
$cshow :: CancelWait -> String
show :: CancelWait -> String
$cshowList :: [CancelWait] -> ShowS
showList :: [CancelWait] -> ShowS
Show, Typeable, (forall x. CancelWait -> Rep CancelWait x)
-> (forall x. Rep CancelWait x -> CancelWait) -> Generic CancelWait
forall x. Rep CancelWait x -> CancelWait
forall x. CancelWait -> Rep CancelWait x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CancelWait -> Rep CancelWait x
from :: forall x. CancelWait -> Rep CancelWait x
$cto :: forall x. Rep CancelWait x -> CancelWait
to :: forall x. Rep CancelWait x -> CancelWait
Generic)
instance Binary CancelWait where
instance NFData CancelWait where

-- | Simple representation of a channel.
type Channel a = (SendPort a, ReceivePort a)

-- | Used internally in whereisOrStart. Sent as (RegisterSelf,ProcessId).
data RegisterSelf = RegisterSelf
  deriving (Typeable, (forall x. RegisterSelf -> Rep RegisterSelf x)
-> (forall x. Rep RegisterSelf x -> RegisterSelf)
-> Generic RegisterSelf
forall x. Rep RegisterSelf x -> RegisterSelf
forall x. RegisterSelf -> Rep RegisterSelf x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RegisterSelf -> Rep RegisterSelf x
from :: forall x. RegisterSelf -> Rep RegisterSelf x
$cto :: forall x. Rep RegisterSelf x -> RegisterSelf
to :: forall x. Rep RegisterSelf x -> RegisterSelf
Generic)
instance Binary RegisterSelf where
instance NFData RegisterSelf where

-- | A ubiquitous /shutdown signal/ that can be used
-- to maintain a consistent shutdown/stop protocol for
-- any process that wishes to handle it.
data Shutdown = Shutdown
  deriving (Typeable, (forall x. Shutdown -> Rep Shutdown x)
-> (forall x. Rep Shutdown x -> Shutdown) -> Generic Shutdown
forall x. Rep Shutdown x -> Shutdown
forall x. Shutdown -> Rep Shutdown x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Shutdown -> Rep Shutdown x
from :: forall x. Shutdown -> Rep Shutdown x
$cto :: forall x. Rep Shutdown x -> Shutdown
to :: forall x. Rep Shutdown x -> Shutdown
Generic, Tag -> Shutdown -> ShowS
[Shutdown] -> ShowS
Shutdown -> String
(Tag -> Shutdown -> ShowS)
-> (Shutdown -> String) -> ([Shutdown] -> ShowS) -> Show Shutdown
forall a.
(Tag -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Tag -> Shutdown -> ShowS
showsPrec :: Tag -> Shutdown -> ShowS
$cshow :: Shutdown -> String
show :: Shutdown -> String
$cshowList :: [Shutdown] -> ShowS
showList :: [Shutdown] -> ShowS
Show, Shutdown -> Shutdown -> Bool
(Shutdown -> Shutdown -> Bool)
-> (Shutdown -> Shutdown -> Bool) -> Eq Shutdown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Shutdown -> Shutdown -> Bool
== :: Shutdown -> Shutdown -> Bool
$c/= :: Shutdown -> Shutdown -> Bool
/= :: Shutdown -> Shutdown -> Bool
Eq)
instance Binary Shutdown where
instance NFData Shutdown where

-- | Provides a /reason/ for process termination.
data ExitReason =
    ExitNormal        -- ^ indicates normal exit
  | ExitShutdown      -- ^ normal response to a 'Shutdown'
  | ExitOther !String -- ^ abnormal (error) shutdown
  deriving (Typeable, (forall x. ExitReason -> Rep ExitReason x)
-> (forall x. Rep ExitReason x -> ExitReason) -> Generic ExitReason
forall x. Rep ExitReason x -> ExitReason
forall x. ExitReason -> Rep ExitReason x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ExitReason -> Rep ExitReason x
from :: forall x. ExitReason -> Rep ExitReason x
$cto :: forall x. Rep ExitReason x -> ExitReason
to :: forall x. Rep ExitReason x -> ExitReason
Generic, ExitReason -> ExitReason -> Bool
(ExitReason -> ExitReason -> Bool)
-> (ExitReason -> ExitReason -> Bool) -> Eq ExitReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExitReason -> ExitReason -> Bool
== :: ExitReason -> ExitReason -> Bool
$c/= :: ExitReason -> ExitReason -> Bool
/= :: ExitReason -> ExitReason -> Bool
Eq, Tag -> ExitReason -> ShowS
[ExitReason] -> ShowS
ExitReason -> String
(Tag -> ExitReason -> ShowS)
-> (ExitReason -> String)
-> ([ExitReason] -> ShowS)
-> Show ExitReason
forall a.
(Tag -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Tag -> ExitReason -> ShowS
showsPrec :: Tag -> ExitReason -> ShowS
$cshow :: ExitReason -> String
show :: ExitReason -> String
$cshowList :: [ExitReason] -> ShowS
showList :: [ExitReason] -> ShowS
Show)
instance Binary ExitReason where
instance NFData ExitReason where

baseAddressableErrorMessage :: (Resolvable a) => a -> String
baseAddressableErrorMessage :: forall a. Resolvable a => a -> String
baseAddressableErrorMessage a
_ = String
"CannotResolveAddressable"

-- | Class of things to which a @Process@ can /link/ itself.
class Linkable a where
  -- | Create a /link/ with the supplied object.
  linkTo :: (Resolvable a) => a -> Process ()
  linkTo a
r = a -> Process (Maybe ProcessId)
forall a. Resolvable a => a -> Process (Maybe ProcessId)
resolve a
r Process (Maybe ProcessId)
-> (Maybe ProcessId -> 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
>>= (ProcessId -> Process ()) -> Maybe ProcessId -> Process ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ProcessId -> Process ()
link

class Monitored a r m | a r -> m where
  mkMonitor :: a -> Process r
  checkMonitor :: a -> r -> m -> Process Bool

instance (Resolvable a) => Monitored a MonitorRef ProcessMonitorNotification where
  mkMonitor :: a -> Process MonitorRef
mkMonitor a
a = ProcessId -> Process MonitorRef
monitor (ProcessId -> Process MonitorRef)
-> (Maybe ProcessId -> ProcessId)
-> Maybe ProcessId
-> Process MonitorRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ProcessId -> ProcessId
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ProcessId -> Process MonitorRef)
-> Process (Maybe ProcessId) -> Process MonitorRef
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> Process (Maybe ProcessId)
forall a. Resolvable a => a -> Process (Maybe ProcessId)
resolve a
a
  checkMonitor :: a -> MonitorRef -> ProcessMonitorNotification -> Process Bool
checkMonitor a
p MonitorRef
r (ProcessMonitorNotification MonitorRef
ref ProcessId
pid DiedReason
_) = do
    Maybe ProcessId
p' <- a -> Process (Maybe ProcessId)
forall a. Resolvable a => a -> Process (Maybe ProcessId)
resolve a
p
    case Maybe ProcessId
p' of
      Maybe ProcessId
Nothing -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Just ProcessId
pr -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool) -> Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ MonitorRef
ref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
r Bool -> Bool -> Bool
&& ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pr

-- | Class of things that can be killed (or instructed to exit).
class Killable p where
  -- | Kill (instruct to exit) generic process, using 'kill' primitive.
  killProc :: Resolvable p => p -> String -> Process ()
  killProc p
r String
s = p -> Process (Maybe ProcessId)
forall a. Resolvable a => a -> Process (Maybe ProcessId)
resolve p
r Process (Maybe ProcessId)
-> (Maybe ProcessId -> 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
>>= (ProcessId -> Process ()) -> Maybe ProcessId -> Process ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((ProcessId -> String -> Process ())
-> String -> ProcessId -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProcessId -> String -> Process ()
kill (String -> ProcessId -> Process ())
-> String -> ProcessId -> Process ()
forall a b. (a -> b) -> a -> b
$ String
s)

  -- | Kill (instruct to exit) generic process, using 'exit' primitive.
  exitProc :: (Resolvable p, Serializable m) => p -> m -> Process ()
  exitProc p
r m
m = p -> Process (Maybe ProcessId)
forall a. Resolvable a => a -> Process (Maybe ProcessId)
resolve p
r Process (Maybe ProcessId)
-> (Maybe ProcessId -> 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
>>= (ProcessId -> Process ()) -> Maybe ProcessId -> Process ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((ProcessId -> m -> Process ()) -> m -> ProcessId -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProcessId -> m -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
exit (m -> ProcessId -> Process ()) -> m -> ProcessId -> Process ()
forall a b. (a -> b) -> a -> b
$ m
m)

instance Resolvable p => Killable p

-- | resolve the Resolvable or die with specified msg plus details of what didn't resolve
resolveOrDie  :: (Resolvable a) => a -> String -> Process ProcessId
resolveOrDie :: forall a. Resolvable a => a -> String -> Process ProcessId
resolveOrDie a
resolvable String
failureMsg = do
  Maybe ProcessId
result <- a -> Process (Maybe ProcessId)
forall a. Resolvable a => a -> Process (Maybe ProcessId)
resolve a
resolvable
  case Maybe ProcessId
result of
    Maybe ProcessId
Nothing  -> String -> Process ProcessId
forall a b. Serializable a => a -> Process b
die (String -> Process ProcessId) -> String -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ String
failureMsg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. (Resolvable a, Resolvable a) => a -> String
unresolvableMessage a
resolvable
    Just ProcessId
pid -> ProcessId -> Process ProcessId
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessId
pid

-- | Class of things that can be resolved to a 'ProcessId'.
--
class Resolvable a where
  -- | Resolve the reference to a process id, or @Nothing@ if resolution fails
  resolve :: a -> Process (Maybe ProcessId)

  -- | Unresolvable @Addressable@ Message
  unresolvableMessage :: (Resolvable a) => a -> String
  unresolvableMessage = a -> String
forall a. Resolvable a => a -> String
baseAddressableErrorMessage

instance Resolvable ProcessId where
  resolve :: ProcessId -> Process (Maybe ProcessId)
resolve ProcessId
p = Maybe ProcessId -> Process (Maybe ProcessId)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
p)
  unresolvableMessage :: Resolvable ProcessId => ProcessId -> String
unresolvableMessage ProcessId
p  = String
"CannotResolvePid[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ProcessId -> String
forall a. Show a => a -> String
show ProcessId
p) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"

instance Resolvable String where
  resolve :: String -> Process (Maybe ProcessId)
resolve = String -> Process (Maybe ProcessId)
whereis
  unresolvableMessage :: Resolvable String => ShowS
unresolvableMessage String
s = String
"CannotResolveRegisteredName[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"

instance Resolvable (NodeId, String) where
  resolve :: (NodeId, String) -> Process (Maybe ProcessId)
resolve (NodeId
nid, String
pname) =
    NodeId -> String -> Process (Maybe ProcessId)
whereisRemote NodeId
nid String
pname Process (Maybe ProcessId)
-> (SomeException -> Process (Maybe ProcessId))
-> Process (Maybe ProcessId)
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` (\(SomeException
_ :: SomeException) -> Maybe ProcessId -> Process (Maybe ProcessId)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessId
forall a. Maybe a
Nothing)
  unresolvableMessage :: Resolvable (NodeId, String) => (NodeId, String) -> String
unresolvableMessage (NodeId
n, String
s) =
    String
"CannotResolveRemoteRegisteredName[name: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", node: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (NodeId -> String
forall a. Show a => a -> String
show NodeId
n) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"

-- Provide a unified API for addressing processes.

-- | Class of things that you can route/send serializable message to
class Routable a where

  -- | Send a message to the target asynchronously
  sendTo  :: (Serializable m, Resolvable a) => a -> m -> Process ()
  sendTo a
a m
m = do
    Maybe ProcessId
mPid <- a -> Process (Maybe ProcessId)
forall a. Resolvable a => a -> Process (Maybe ProcessId)
resolve a
a
    Process ()
-> (ProcessId -> Process ()) -> Maybe ProcessId -> Process ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Process ()
forall a b. Serializable a => a -> Process b
die (a -> String
forall a. (Resolvable a, Resolvable a) => a -> String
unresolvableMessage a
a))
          (\ProcessId
p -> ProcessId -> m -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
P.send ProcessId
p m
m)
          Maybe ProcessId
mPid

  -- | Send some @NFData@ message to the target asynchronously,
  -- forcing evaluation (i.e., @deepseq@) beforehand.
  unsafeSendTo :: (NFSerializable m, Resolvable a) => a -> m -> Process ()
  unsafeSendTo a
a m
m = do
    Maybe ProcessId
mPid <- a -> Process (Maybe ProcessId)
forall a. Resolvable a => a -> Process (Maybe ProcessId)
resolve a
a
    Process ()
-> (ProcessId -> Process ()) -> Maybe ProcessId -> Process ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Process ()
forall a b. Serializable a => a -> Process b
die (a -> String
forall a. (Resolvable a, Resolvable a) => a -> String
unresolvableMessage a
a))
          (\ProcessId
p -> ProcessId -> m -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
P.unsafeSend ProcessId
p (m -> Process ()) -> m -> Process ()
forall a b. NFData a => (a -> b) -> a -> b
$!! m
m)
          Maybe ProcessId
mPid

instance Routable ProcessId where
  sendTo :: forall m.
(Serializable m, Resolvable ProcessId) =>
ProcessId -> m -> Process ()
sendTo                 = ProcessId -> m -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
P.send
  unsafeSendTo :: forall m.
(NFSerializable m, Resolvable ProcessId) =>
ProcessId -> m -> Process ()
unsafeSendTo ProcessId
pid m
msg   = ProcessId -> m -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
P.unsafeSend ProcessId
pid (m -> Process ()) -> m -> Process ()
forall a b. NFData a => (a -> b) -> a -> b
$!! m
msg

instance Routable String where
  sendTo :: forall m.
(Serializable m, Resolvable String) =>
String -> m -> Process ()
sendTo                = String -> m -> Process ()
forall a. Serializable a => String -> a -> Process ()
nsend
  unsafeSendTo :: forall m.
(NFSerializable m, Resolvable String) =>
String -> m -> Process ()
unsafeSendTo String
name m
msg = String -> m -> Process ()
forall a. Serializable a => String -> a -> Process ()
P.unsafeNSend String
name (m -> Process ()) -> m -> Process ()
forall a b. NFData a => (a -> b) -> a -> b
$!! m
msg

instance Routable (NodeId, String) where
  sendTo :: forall m.
(Serializable m, Resolvable (NodeId, String)) =>
(NodeId, String) -> m -> Process ()
sendTo  (NodeId
nid, String
pname) = NodeId -> String -> m -> Process ()
forall a. Serializable a => NodeId -> String -> a -> Process ()
nsendRemote NodeId
nid String
pname
  unsafeSendTo :: forall m.
(NFSerializable m, Resolvable (NodeId, String)) =>
(NodeId, String) -> m -> Process ()
unsafeSendTo         = (NodeId, String) -> m -> Process ()
forall m.
(Serializable m, Resolvable (NodeId, String)) =>
(NodeId, String) -> m -> Process ()
forall a m.
(Routable a, Serializable m, Resolvable a) =>
a -> m -> Process ()
sendTo -- because serialisation *must* take place

instance Routable (Message -> Process ()) where
  sendTo :: forall m.
(Serializable m, Resolvable (Message -> Process ())) =>
(Message -> Process ()) -> m -> Process ()
sendTo Message -> Process ()
f       = Message -> Process ()
f (Message -> Process ()) -> (m -> Message) -> m -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> Message
forall a. Serializable a => a -> Message
wrapMessage
  unsafeSendTo :: forall m.
(NFSerializable m, Resolvable (Message -> Process ())) =>
(Message -> Process ()) -> m -> Process ()
unsafeSendTo Message -> Process ()
f = Message -> Process ()
f (Message -> Process ()) -> (m -> Message) -> m -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> Message
forall a. Serializable a => a -> Message
unsafeWrapMessage

class (Resolvable a, Routable a) => Addressable a
instance Addressable ProcessId

-- | A simple means of mapping to a receiver.
data Recipient =
    Pid !ProcessId
  | Registered !String
  | RemoteRegistered !String !NodeId
--  | ProcReg !ProcessId !String
--  | RemoteProcReg NodeId String
--  | GlobalReg String
  deriving (Typeable, (forall x. Recipient -> Rep Recipient x)
-> (forall x. Rep Recipient x -> Recipient) -> Generic Recipient
forall x. Rep Recipient x -> Recipient
forall x. Recipient -> Rep Recipient x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Recipient -> Rep Recipient x
from :: forall x. Recipient -> Rep Recipient x
$cto :: forall x. Rep Recipient x -> Recipient
to :: forall x. Rep Recipient x -> Recipient
Generic, Tag -> Recipient -> ShowS
[Recipient] -> ShowS
Recipient -> String
(Tag -> Recipient -> ShowS)
-> (Recipient -> String)
-> ([Recipient] -> ShowS)
-> Show Recipient
forall a.
(Tag -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Tag -> Recipient -> ShowS
showsPrec :: Tag -> Recipient -> ShowS
$cshow :: Recipient -> String
show :: Recipient -> String
$cshowList :: [Recipient] -> ShowS
showList :: [Recipient] -> ShowS
Show, Recipient -> Recipient -> Bool
(Recipient -> Recipient -> Bool)
-> (Recipient -> Recipient -> Bool) -> Eq Recipient
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Recipient -> Recipient -> Bool
== :: Recipient -> Recipient -> Bool
$c/= :: Recipient -> Recipient -> Bool
/= :: Recipient -> Recipient -> Bool
Eq)
instance Binary Recipient where
instance NFData Recipient where
  rnf :: Recipient -> ()
rnf (Pid ProcessId
p) = ProcessId -> ()
forall a. NFData a => a -> ()
rnf ProcessId
p () -> () -> ()
forall a b. a -> b -> b
`seq` ()
  rnf (Registered String
s) = String -> ()
forall a. NFData a => a -> ()
rnf String
s () -> () -> ()
forall a b. a -> b -> b
`seq` ()
  rnf (RemoteRegistered String
s NodeId
n) = String -> ()
forall a. NFData a => a -> ()
rnf String
s () -> () -> ()
forall a b. a -> b -> b
`seq` NodeId -> ()
forall a. NFData a => a -> ()
rnf NodeId
n () -> () -> ()
forall a b. a -> b -> b
`seq` ()

instance Resolvable Recipient where
  resolve :: Recipient -> Process (Maybe ProcessId)
resolve (Pid                ProcessId
p) = Maybe ProcessId -> Process (Maybe ProcessId)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
p)
  resolve (Registered         String
n) = String -> Process (Maybe ProcessId)
whereis String
n
  resolve (RemoteRegistered String
s NodeId
n) = NodeId -> String -> Process (Maybe ProcessId)
whereisRemote NodeId
n String
s

  unresolvableMessage :: Resolvable Recipient => Recipient -> String
unresolvableMessage (Pid                ProcessId
p) = ProcessId -> String
forall a. (Resolvable a, Resolvable a) => a -> String
unresolvableMessage ProcessId
p
  unresolvableMessage (Registered         String
n) = ShowS
forall a. (Resolvable a, Resolvable a) => a -> String
unresolvableMessage String
n
  unresolvableMessage (RemoteRegistered String
s NodeId
n) = (NodeId, String) -> String
forall a. (Resolvable a, Resolvable a) => a -> String
unresolvableMessage (NodeId
n, String
s)

-- although we have an instance of Routable for Resolvable, it really
-- makes no sense to do remote lookups on a pid, only to then send to it!
instance Routable Recipient where

  sendTo :: forall m.
(Serializable m, Resolvable Recipient) =>
Recipient -> m -> Process ()
sendTo (Pid ProcessId
p)                m
m = ProcessId -> m -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
P.send ProcessId
p m
m
  sendTo (Registered String
s)         m
m = String -> m -> Process ()
forall a. Serializable a => String -> a -> Process ()
nsend String
s m
m
  sendTo (RemoteRegistered String
s NodeId
n) m
m = NodeId -> String -> m -> Process ()
forall a. Serializable a => NodeId -> String -> a -> Process ()
nsendRemote NodeId
n String
s m
m

  unsafeSendTo :: forall m.
(NFSerializable m, Resolvable Recipient) =>
Recipient -> m -> Process ()
unsafeSendTo (Pid ProcessId
p)                m
m = ProcessId -> m -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
P.unsafeSend ProcessId
p (m -> Process ()) -> m -> Process ()
forall a b. NFData a => (a -> b) -> a -> b
$!! m
m
  unsafeSendTo (Registered String
s)         m
m = String -> m -> Process ()
forall a. Serializable a => String -> a -> Process ()
P.unsafeNSend String
s (m -> Process ()) -> m -> Process ()
forall a b. NFData a => (a -> b) -> a -> b
$!! m
m
  unsafeSendTo (RemoteRegistered String
s NodeId
n) m
m = NodeId -> String -> m -> Process ()
forall a. Serializable a => NodeId -> String -> a -> Process ()
nsendRemote NodeId
n String
s m
m

-- useful exit reasons

-- | Given when a server is unobtainable.
newtype ServerDisconnected = ServerDisconnected DiedReason
  deriving (Typeable, (forall x. ServerDisconnected -> Rep ServerDisconnected x)
-> (forall x. Rep ServerDisconnected x -> ServerDisconnected)
-> Generic ServerDisconnected
forall x. Rep ServerDisconnected x -> ServerDisconnected
forall x. ServerDisconnected -> Rep ServerDisconnected x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ServerDisconnected -> Rep ServerDisconnected x
from :: forall x. ServerDisconnected -> Rep ServerDisconnected x
$cto :: forall x. Rep ServerDisconnected x -> ServerDisconnected
to :: forall x. Rep ServerDisconnected x -> ServerDisconnected
Generic)
instance Binary ServerDisconnected where
instance NFData ServerDisconnected where