{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE PatternGuards              #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Distributed.Process.ManagedProcess.Server
-- Copyright   :  (c) Tim Watson 2012 - 2017
-- License     :  BSD3 (see the file LICENSE)
--
-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (requires concurrency)
--
-- The Server Portion of the /Managed Process/ API.
-----------------------------------------------------------------------------

module Control.Distributed.Process.ManagedProcess.Server
  ( -- * Server actions
    condition
  , state
  , input
  , reply
  , replyWith
  , noReply
  , continue
  , timeoutAfter
  , hibernate
  , stop
  , stopWith
  , replyTo
  , replyChan
  , reject
  , rejectWith
  , become
    -- * Stateless actions
  , noReply_
  , haltNoReply_
  , continue_
  , timeoutAfter_
  , hibernate_
  , stop_
    -- * Server handler/callback creation
  , handleCall
  , handleCallIf
  , handleCallFrom
  , handleCallFromIf
  , handleRpcChan
  , handleRpcChanIf
  , handleCast
  , handleCastIf
  , handleInfo
  , handleRaw
  , handleDispatch
  , handleDispatchIf
  , handleExit
  , handleExitIf
    -- * Stateless handlers
  , action
  , handleCall_
  , handleCallIf_
  , handleCallFrom_
  , handleCallFromIf_
  , handleRpcChan_
  , handleRpcChanIf_
  , handleCast_
  , handleCastIf_
    -- * Working with Control Channels
  , handleControlChan
  , handleControlChan_
    -- * Working with external/STM actions
  , handleExternal
  , handleExternal_
  , handleCallExternal
  ) where

import Control.Concurrent.STM (STM, atomically)
import Control.Distributed.Process hiding (call, Message)
import qualified Control.Distributed.Process as P (Message)
import Control.Distributed.Process.Serializable
import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (liftIO, lift)
import Control.Distributed.Process.Extras
  ( ExitReason(..)
  , Routable(..)
  )
import Control.Distributed.Process.Extras.Time
import Prelude hiding (init)

--------------------------------------------------------------------------------
-- Producing ProcessAction and ProcessReply from inside handler expressions   --
--------------------------------------------------------------------------------

-- note [Message type]: Since we own both client and server portions of the
-- codebase, we know for certain which types will be passed to which kinds
-- of handler, so the catch-all cases that @die $ "THIS_CAN_NEVER_HAPPEN"@ and
-- such, are relatively sane despite appearances!

-- | Creates a 'Condition' from a function that takes a process state @a@ and
-- an input message @b@ and returns a 'Bool' indicating whether the associated
-- handler should run.
--
condition :: forall a b. (Serializable a, Serializable b)
          => (a -> b -> Bool)
          -> Condition a b
condition :: forall a b.
(Serializable a, Serializable b) =>
(a -> b -> Bool) -> Condition a b
condition = (a -> b -> Bool) -> Condition a b
forall s m. (s -> m -> Bool) -> Condition s m
Condition

-- | Create a 'Condition' from a function that takes a process state @a@ and
-- returns a 'Bool' indicating whether the associated handler should run.
--
state :: forall s m. (Serializable m) => (s -> Bool) -> Condition s m
state :: forall s m. Serializable m => (s -> Bool) -> Condition s m
state = (s -> Bool) -> Condition s m
forall s m. (s -> Bool) -> Condition s m
State

-- | Creates a 'Condition' from a function that takes an input message @m@ and
-- returns a 'Bool' indicating whether the associated handler should run.
--
input :: forall s m. (Serializable m) => (m -> Bool) -> Condition s m
input :: forall s m. Serializable m => (m -> Bool) -> Condition s m
input = (m -> Bool) -> Condition s m
forall s m. (m -> Bool) -> Condition s m
Input

-- | Reject the message we're currently handling.
reject :: forall r s . s -> String -> Reply r s
reject :: forall r s. s -> String -> Reply r s
reject s
st String
rs = s -> Action s
forall s. s -> Action s
continue s
st Action s
-> (ProcessAction s -> Process (ProcessReply r s))
-> Process (ProcessReply r s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcessReply r s -> Process (ProcessReply r s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessReply r s -> Process (ProcessReply r s))
-> (ProcessAction s -> ProcessReply r s)
-> ProcessAction s
-> Process (ProcessReply r s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProcessAction s -> ProcessReply r s
forall r s. String -> ProcessAction s -> ProcessReply r s
ProcessReject String
rs

-- | Reject the message we're currently handling, giving an explicit reason.
rejectWith :: forall r m s . (Show r) => s -> r -> Reply m s
rejectWith :: forall r m s. Show r => s -> r -> Reply m s
rejectWith s
st r
rs = s -> String -> Reply m s
forall r s. s -> String -> Reply r s
reject s
st (r -> String
forall a. Show a => a -> String
show r
rs)

-- | Instructs the process to send a reply and continue running.
reply :: (Serializable r) => r -> s -> Reply r s
reply :: forall r s. Serializable r => r -> s -> Reply r s
reply r
r s
s = s -> Action s
forall s. s -> Action s
continue s
s Action s
-> (ProcessAction s -> Process (ProcessReply r s))
-> Process (ProcessReply r s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= r -> ProcessAction s -> Process (ProcessReply r s)
forall r s. Serializable r => r -> ProcessAction s -> Reply r s
replyWith r
r

-- | Instructs the process to send a reply /and/ evaluate the 'ProcessAction'.
replyWith :: (Serializable r)
          => r
          -> ProcessAction s
          -> Reply r s
replyWith :: forall r s. Serializable r => r -> ProcessAction s -> Reply r s
replyWith r
r ProcessAction s
s = ProcessReply r s -> Process (ProcessReply r s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessReply r s -> Process (ProcessReply r s))
-> ProcessReply r s -> Process (ProcessReply r s)
forall a b. (a -> b) -> a -> b
$ r -> ProcessAction s -> ProcessReply r s
forall r s. r -> ProcessAction s -> ProcessReply r s
ProcessReply r
r ProcessAction s
s

-- | Instructs the process to skip sending a reply /and/ evaluate a 'ProcessAction'
noReply :: (Serializable r) => ProcessAction s -> Reply r s
noReply :: forall r s. Serializable r => ProcessAction s -> Reply r s
noReply = ProcessReply r s -> Process (ProcessReply r s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessReply r s -> Process (ProcessReply r s))
-> (ProcessAction s -> ProcessReply r s)
-> ProcessAction s
-> Process (ProcessReply r s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessAction s -> ProcessReply r s
forall r s. ProcessAction s -> ProcessReply r s
NoReply

-- | Continue without giving a reply to the caller - equivalent to 'continue',
-- but usable in a callback passed to the 'handleCall' family of functions.
noReply_ :: forall s r . (Serializable r) => s -> Reply r s
noReply_ :: forall s r. Serializable r => s -> Reply r s
noReply_ s
s = s -> Action s
forall s. s -> Action s
continue s
s Action s
-> (ProcessAction s -> Process (ProcessReply r s))
-> Process (ProcessReply r s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcessAction s -> Process (ProcessReply r s)
forall r s. Serializable r => ProcessAction s -> Reply r s
noReply

-- | Halt process execution during a call handler, without paying any attention
-- to the expected return type.
haltNoReply_ :: Serializable r => ExitReason -> Reply r s
haltNoReply_ :: forall r s. Serializable r => ExitReason -> Reply r s
haltNoReply_ ExitReason
r = ExitReason -> Action s
forall s. ExitReason -> Action s
stop ExitReason
r Action s
-> (ProcessAction s -> Process (ProcessReply r s))
-> Process (ProcessReply r s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProcessAction s -> Process (ProcessReply r s)
forall r s. Serializable r => ProcessAction s -> Reply r s
noReply

-- | Instructs the process to continue running and receiving messages.
continue :: s -> Action s
continue :: forall s. s -> Action s
continue = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessAction s -> Process (ProcessAction s))
-> (s -> ProcessAction s) -> s -> Process (ProcessAction s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> ProcessAction s
forall s. s -> ProcessAction s
ProcessContinue

-- | Version of 'continue' that can be used in handlers that ignore process state.
--
continue_ :: (s -> Action s)
continue_ :: forall s. s -> Action s
continue_ = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessAction s -> Process (ProcessAction s))
-> (s -> ProcessAction s) -> s -> Process (ProcessAction s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> ProcessAction s
forall s. s -> ProcessAction s
ProcessContinue

-- | Instructs the process loop to wait for incoming messages until 'Delay'
-- is exceeded. If no messages are handled during this period, the /timeout/
-- handler will be called. Note that this alters the process timeout permanently
-- such that the given @Delay@ will remain in use until changed.
--
-- Note that @timeoutAfter NoDelay@ will cause the timeout handler to execute
-- immediately if no messages are present in the process' mailbox.
--
timeoutAfter :: Delay -> s -> Action s
timeoutAfter :: forall s. Delay -> s -> Action s
timeoutAfter Delay
d s
s = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessAction s -> Process (ProcessAction s))
-> ProcessAction s -> Process (ProcessAction s)
forall a b. (a -> b) -> a -> b
$ Delay -> s -> ProcessAction s
forall s. Delay -> s -> ProcessAction s
ProcessTimeout Delay
d s
s

-- | Version of 'timeoutAfter' that can be used in handlers that ignore process state.
--
-- > action (\(TimeoutPlease duration) -> timeoutAfter_ duration)
--
timeoutAfter_ :: StatelessHandler s Delay
timeoutAfter_ :: forall s. Delay -> s -> Action s
timeoutAfter_ Delay
d = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessAction s -> Process (ProcessAction s))
-> (s -> ProcessAction s) -> s -> Process (ProcessAction s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Delay -> s -> ProcessAction s
forall s. Delay -> s -> ProcessAction s
ProcessTimeout Delay
d

-- | Instructs the process to /hibernate/ for the given 'TimeInterval'. Note
-- that no messages will be removed from the mailbox until after hibernation has
-- ceased. This is equivalent to calling @threadDelay@.
--
hibernate :: TimeInterval -> s -> Process (ProcessAction s)
hibernate :: forall s. TimeInterval -> s -> Process (ProcessAction s)
hibernate TimeInterval
d s
s = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessAction s -> Process (ProcessAction s))
-> ProcessAction s -> Process (ProcessAction s)
forall a b. (a -> b) -> a -> b
$ TimeInterval -> s -> ProcessAction s
forall s. TimeInterval -> s -> ProcessAction s
ProcessHibernate TimeInterval
d s
s

-- | Version of 'hibernate' that can be used in handlers that ignore process state.
--
-- > action (\(HibernatePlease delay) -> hibernate_ delay)
--
hibernate_ :: StatelessHandler s TimeInterval
hibernate_ :: forall s. TimeInterval -> s -> Process (ProcessAction s)
hibernate_ TimeInterval
d = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessAction s -> Process (ProcessAction s))
-> (s -> ProcessAction s) -> s -> Process (ProcessAction s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeInterval -> s -> ProcessAction s
forall s. TimeInterval -> s -> ProcessAction s
ProcessHibernate TimeInterval
d

-- | The server loop will execute against the supplied 'ProcessDefinition', allowing
-- the process to change its behaviour (in terms of message handlers, exit handling,
-- termination, unhandled message policy, etc)
become :: forall s . ProcessDefinition s -> s -> Action s
become :: forall s. ProcessDefinition s -> s -> Action s
become ProcessDefinition s
def s
st = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessAction s -> Process (ProcessAction s))
-> ProcessAction s -> Process (ProcessAction s)
forall a b. (a -> b) -> a -> b
$ ProcessDefinition s -> s -> ProcessAction s
forall s. ProcessDefinition s -> s -> ProcessAction s
ProcessBecome ProcessDefinition s
def s
st

-- | Instructs the process to terminate, giving the supplied reason. If a valid
-- 'shutdownHandler' is installed, it will be called with the 'ExitReason'
-- returned from this call, along with the process state.
stop :: ExitReason -> Action s
stop :: forall s. ExitReason -> Action s
stop ExitReason
r = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessAction s -> Process (ProcessAction s))
-> ProcessAction s -> Process (ProcessAction s)
forall a b. (a -> b) -> a -> b
$ ExitReason -> ProcessAction s
forall s. ExitReason -> ProcessAction s
ProcessStop ExitReason
r

-- | As 'stop', but provides an updated state for the shutdown handler.
stopWith :: s -> ExitReason -> Action s
stopWith :: forall s. s -> ExitReason -> Action s
stopWith s
s ExitReason
r = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessAction s -> Process (ProcessAction s))
-> ProcessAction s -> Process (ProcessAction s)
forall a b. (a -> b) -> a -> b
$ s -> ExitReason -> ProcessAction s
forall s. s -> ExitReason -> ProcessAction s
ProcessStopping s
s ExitReason
r

-- | Version of 'stop' that can be used in handlers that ignore process state.
--
-- > action (\ClientError -> stop_ ExitNormal)
--
stop_ :: StatelessHandler s ExitReason
stop_ :: forall s. StatelessHandler s ExitReason
stop_ ExitReason
r s
_ = ExitReason -> Action s
forall s. ExitReason -> Action s
stop ExitReason
r

-- | Sends a reply explicitly to a caller.
--
-- > replyTo = sendTo
--
replyTo :: (Serializable m) => CallRef m -> m -> Process ()
replyTo :: forall m. Serializable m => CallRef m -> m -> Process ()
replyTo cRef :: CallRef m
cRef@(CallRef (Recipient
_, CallId
tag)) m
msg = CallRef m -> CallResponse m -> Process ()
forall m.
(Serializable m, Resolvable (CallRef m)) =>
CallRef m -> m -> Process ()
forall a m.
(Routable a, Serializable m, Resolvable a) =>
a -> m -> Process ()
sendTo CallRef m
cRef (CallResponse m -> Process ()) -> CallResponse m -> Process ()
forall a b. (a -> b) -> a -> b
$ m -> CallId -> CallResponse m
forall a. a -> CallId -> CallResponse a
CallResponse m
msg CallId
tag

-- | Sends a reply to a 'SendPort' (for use in 'handleRpcChan' et al).
--
-- > replyChan = sendChan
--
replyChan :: (Serializable m) => SendPort m -> m -> Process ()
replyChan :: forall m. Serializable m => SendPort m -> m -> Process ()
replyChan = SendPort m -> m -> Process ()
forall m. Serializable m => SendPort m -> m -> Process ()
sendChan

--------------------------------------------------------------------------------
-- Wrapping handler expressions in Dispatcher and DeferredDispatcher          --
--------------------------------------------------------------------------------

-- | Constructs a 'call' handler from a function in the 'Process' monad.
-- The handler expression returns the reply, and the action will be
-- set to 'continue'.
--
-- > handleCall_ = handleCallIf_ $ input (const True)
--
handleCall_ :: (Serializable a, Serializable b)
           => (a -> Process b)
           -> Dispatcher s
handleCall_ :: forall a b s.
(Serializable a, Serializable b) =>
(a -> Process b) -> Dispatcher s
handleCall_ = Condition s a -> (a -> Process b) -> Dispatcher s
forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> (a -> Process b) -> Dispatcher s
handleCallIf_ (Condition s a -> (a -> Process b) -> Dispatcher s)
-> Condition s a -> (a -> Process b) -> Dispatcher s
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Condition s a
forall s m. Serializable m => (m -> Bool) -> Condition s m
input (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Constructs a 'call' handler from an ordinary function in the 'Process'
-- monad. This variant ignores the state argument present in 'handleCall' and
-- 'handleCallIf' and is therefore useful in a stateless server. Messges are
-- only dispatched to the handler if the supplied condition evaluates to @True@
--
-- See 'handleCall'
handleCallIf_ :: forall s a b . (Serializable a, Serializable b)
    => Condition s a -- ^ predicate that must be satisfied for the handler to run
    -> (a -> Process b) -- ^ a function from an input message to a reply
    -> Dispatcher s
handleCallIf_ :: forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> (a -> Process b) -> Dispatcher s
handleCallIf_ Condition s a
cond a -> Process b
handler
  = DispatchIf {
      dispatch :: s -> Message a b -> Process (ProcessAction s)
dispatch   = \s
s (CallMessage a
p CallRef b
c) -> a -> Process b
handler a
p Process b
-> (b -> Process (ProcessAction s)) -> Process (ProcessAction s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Serializable b => CallRef b -> s -> b -> Process (ProcessAction s)
CallRef b -> s -> b -> Process (ProcessAction s)
mkCallReply CallRef b
c s
s
    , dispatchIf :: s -> Message a b -> Bool
dispatchIf = Condition s a -> s -> Message a b -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
checkCall Condition s a
cond
    }
  where
        -- handling 'reply-to' in the main process loop is awkward at best,
        -- so we handle it here instead and return the 'action' to the loop
        mkCallReply :: (Serializable b)
                    => CallRef b
                    -> s
                    -> b
                    -> Process (ProcessAction s)
        mkCallReply :: Serializable b => CallRef b -> s -> b -> Process (ProcessAction s)
mkCallReply CallRef b
c s
s b
m =
          let (Recipient
c', CallId
t) = CallRef b -> (Recipient, CallId)
forall a. CallRef a -> (Recipient, CallId)
unCaller CallRef b
c
          in Recipient -> CallResponse b -> Process ()
forall m.
(Serializable m, Resolvable Recipient) =>
Recipient -> m -> Process ()
forall a m.
(Routable a, Serializable m, Resolvable a) =>
a -> m -> Process ()
sendTo Recipient
c' (b -> CallId -> CallResponse b
forall a. a -> CallId -> CallResponse a
CallResponse b
m CallId
t) Process ()
-> Process (ProcessAction s) -> Process (ProcessAction s)
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> Process (ProcessAction s)
forall s. s -> Action s
continue s
s

-- | Constructs a 'call' handler from a function in the 'Process' monad.
-- > handleCall = handleCallIf (const True)
--
handleCall :: (Serializable a, Serializable b)
           => CallHandler s a b
           -> Dispatcher s
handleCall :: forall a b s.
(Serializable a, Serializable b) =>
CallHandler s a b -> Dispatcher s
handleCall = Condition s a -> CallHandler s a b -> Dispatcher s
forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> CallHandler s a b -> Dispatcher s
handleCallIf (Condition s a -> CallHandler s a b -> Dispatcher s)
-> Condition s a -> CallHandler s a b -> Dispatcher s
forall a b. (a -> b) -> a -> b
$ (s -> Bool) -> Condition s a
forall s m. Serializable m => (s -> Bool) -> Condition s m
state (Bool -> s -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Constructs a 'call' handler from an ordinary function in the 'Process'
-- monad. Given a function @f :: (s -> a -> Process (ProcessReply b s))@,
-- the expression @handleCall f@ will yield a "Dispatcher" for inclusion
-- in a 'Behaviour' specification for the /GenProcess/. Messages are only
-- dispatched to the handler if the supplied condition evaluates to @True@.
--
handleCallIf :: forall s a b . (Serializable a, Serializable b)
    => Condition s a -- ^ predicate that must be satisfied for the handler to run
    -> CallHandler s a b
        -- ^ a reply yielding function over the process state and input message
    -> Dispatcher s
handleCallIf :: forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> CallHandler s a b -> Dispatcher s
handleCallIf Condition s a
cond CallHandler s a b
handler
  = DispatchIf
    { dispatch :: s -> Message a b -> Process (ProcessAction s)
dispatch   = \s
s (CallMessage a
p CallRef b
c) -> CallHandler s a b
handler s
s a
p Process (ProcessReply b s)
-> (ProcessReply b s -> Process (ProcessAction s))
-> Process (ProcessAction s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CallRef b -> ProcessReply b s -> Process (ProcessAction s)
forall b s.
Serializable b =>
CallRef b -> ProcessReply b s -> Process (ProcessAction s)
mkReply CallRef b
c
    , dispatchIf :: s -> Message a b -> Bool
dispatchIf = Condition s a -> s -> Message a b -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
checkCall Condition s a
cond
    }

-- | A variant of 'handleCallFrom_' that ignores the state argument.
--
handleCallFrom_ :: forall s a b . (Serializable a, Serializable b)
                => StatelessCallHandler s a b
                -> Dispatcher s
handleCallFrom_ :: forall s a b.
(Serializable a, Serializable b) =>
StatelessCallHandler s a b -> Dispatcher s
handleCallFrom_ = Condition s a -> StatelessCallHandler s a b -> Dispatcher s
forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> StatelessCallHandler s a b -> Dispatcher s
handleCallFromIf_ (Condition s a -> StatelessCallHandler s a b -> Dispatcher s)
-> Condition s a -> StatelessCallHandler s a b -> Dispatcher s
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Condition s a
forall s m. Serializable m => (m -> Bool) -> Condition s m
input (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | A variant of 'handleCallFromIf' that ignores the state argument.
--
handleCallFromIf_ :: forall s a b . (Serializable a, Serializable b)
                  => Condition s a
                  -> StatelessCallHandler s a b
                  -> Dispatcher s
handleCallFromIf_ :: forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> StatelessCallHandler s a b -> Dispatcher s
handleCallFromIf_ Condition s a
cond StatelessCallHandler s a b
handler =
  DispatchIf {
      dispatch :: s -> Message a b -> Process (ProcessAction s)
dispatch   = \s
_ (CallMessage a
p CallRef b
c) -> StatelessCallHandler s a b
handler CallRef b
c a
p Process (ProcessReply b s)
-> (ProcessReply b s -> Process (ProcessAction s))
-> Process (ProcessAction s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CallRef b -> ProcessReply b s -> Process (ProcessAction s)
forall b s.
Serializable b =>
CallRef b -> ProcessReply b s -> Process (ProcessAction s)
mkReply CallRef b
c
    , dispatchIf :: s -> Message a b -> Bool
dispatchIf = Condition s a -> s -> Message a b -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
checkCall Condition s a
cond
    }

-- | As 'handleCall' but passes the 'CallRef' to the handler function.
-- This can be useful if you wish to /reply later/ to the caller by, e.g.,
-- spawning a process to do some work and have it @replyTo caller response@
-- out of band. In this case the callback can pass the 'CallRef' to the
-- worker (or stash it away itself) and return 'noReply'.
--
handleCallFrom :: forall s a b . (Serializable a, Serializable b)
           => DeferredCallHandler s a b
           -> Dispatcher s
handleCallFrom :: forall s a b.
(Serializable a, Serializable b) =>
DeferredCallHandler s a b -> Dispatcher s
handleCallFrom = Condition s a -> DeferredCallHandler s a b -> Dispatcher s
forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> DeferredCallHandler s a b -> Dispatcher s
handleCallFromIf (Condition s a -> DeferredCallHandler s a b -> Dispatcher s)
-> Condition s a -> DeferredCallHandler s a b -> Dispatcher s
forall a b. (a -> b) -> a -> b
$ (s -> Bool) -> Condition s a
forall s m. Serializable m => (s -> Bool) -> Condition s m
state (Bool -> s -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | As 'handleCallFrom' but only runs the handler if the supplied 'Condition'
-- evaluates to @True@.
--
handleCallFromIf :: forall s a b . (Serializable a, Serializable b)
    => Condition s a -- ^ predicate that must be satisfied for the handler to run
    -> DeferredCallHandler s a b
        -- ^ a reply yielding function over the process state, sender and input message
    -> Dispatcher s
handleCallFromIf :: forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> DeferredCallHandler s a b -> Dispatcher s
handleCallFromIf Condition s a
cond DeferredCallHandler s a b
handler
  = DispatchIf {
      dispatch :: s -> Message a b -> Process (ProcessAction s)
dispatch   = \s
s (CallMessage a
p CallRef b
c) -> DeferredCallHandler s a b
handler CallRef b
c s
s a
p Process (ProcessReply b s)
-> (ProcessReply b s -> Process (ProcessAction s))
-> Process (ProcessAction s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CallRef b -> ProcessReply b s -> Process (ProcessAction s)
forall b s.
Serializable b =>
CallRef b -> ProcessReply b s -> Process (ProcessAction s)
mkReply CallRef b
c
    , dispatchIf :: s -> Message a b -> Bool
dispatchIf = Condition s a -> s -> Message a b -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
checkCall Condition s a
cond
    }

-- | Creates a handler for a /typed channel/ RPC style interaction. The
-- handler takes a @SendPort b@ to reply to, the initial input and evaluates
-- to a 'ProcessAction'. It is the handler code's responsibility to send the
-- reply to the @SendPort@.
--
handleRpcChan :: forall s a b . (Serializable a, Serializable b)
              => ChannelHandler s a b
              -> Dispatcher s
handleRpcChan :: forall s a b.
(Serializable a, Serializable b) =>
ChannelHandler s a b -> Dispatcher s
handleRpcChan = Condition s a -> ChannelHandler s a b -> Dispatcher s
forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> ChannelHandler s a b -> Dispatcher s
handleRpcChanIf (Condition s a -> ChannelHandler s a b -> Dispatcher s)
-> Condition s a -> ChannelHandler s a b -> Dispatcher s
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Condition s a
forall s m. Serializable m => (m -> Bool) -> Condition s m
input (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | As 'handleRpcChan', but only evaluates the handler if the supplied
-- condition is met.
--
handleRpcChanIf :: forall s a b . (Serializable a, Serializable b)
                => Condition s a
                -> ChannelHandler s a b
                -> Dispatcher s
handleRpcChanIf :: forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> ChannelHandler s a b -> Dispatcher s
handleRpcChanIf Condition s a
cond ChannelHandler s a b
handler
  = DispatchIf {
      dispatch :: s -> Message a b -> Process (ProcessAction s)
dispatch   = \s
s (ChanMessage a
p SendPort b
c) -> ChannelHandler s a b
handler SendPort b
c s
s a
p
    , dispatchIf :: s -> Message a b -> Bool
dispatchIf = Condition s a -> s -> Message a b -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
checkRpc Condition s a
cond
    }

-- | A variant of 'handleRpcChan' that ignores the state argument.
--
handleRpcChan_ :: forall s a b . (Serializable a, Serializable b)
                  => StatelessChannelHandler s a b
                     -- (SendPort b -> a -> (s -> Action s))
                  -> Dispatcher s
handleRpcChan_ :: forall s a b.
(Serializable a, Serializable b) =>
StatelessChannelHandler s a b -> Dispatcher s
handleRpcChan_ = Condition s a -> StatelessChannelHandler s a b -> Dispatcher s
forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> StatelessChannelHandler s a b -> Dispatcher s
handleRpcChanIf_ (Condition s a -> StatelessChannelHandler s a b -> Dispatcher s)
-> Condition s a -> StatelessChannelHandler s a b -> Dispatcher s
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Condition s a
forall s m. Serializable m => (m -> Bool) -> Condition s m
input (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | A variant of 'handleRpcChanIf' that ignores the state argument.
--
handleRpcChanIf_ :: forall s a b . (Serializable a, Serializable b)
                 => Condition s a
                 -> StatelessChannelHandler s a b
                 -> Dispatcher s
handleRpcChanIf_ :: forall s a b.
(Serializable a, Serializable b) =>
Condition s a -> StatelessChannelHandler s a b -> Dispatcher s
handleRpcChanIf_ Condition s a
c StatelessChannelHandler s a b
h
  = DispatchIf { dispatch :: s -> Message a b -> Process (ProcessAction s)
dispatch   = \s
s ((ChanMessage a
m SendPort b
p) :: Message a b) -> StatelessChannelHandler s a b
h SendPort b
p a
m s
s
               , dispatchIf :: s -> Message a b -> Bool
dispatchIf = Condition s a -> s -> Message a b -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
checkRpc Condition s a
c
               }

-- | Constructs a 'cast' handler from an ordinary function in the 'Process'
-- monad.
-- > handleCast = handleCastIf (const True)
--
handleCast :: (Serializable a)
           => CastHandler s a
           -> Dispatcher s
handleCast :: forall a s. Serializable a => CastHandler s a -> Dispatcher s
handleCast = Condition s a -> CastHandler s a -> Dispatcher s
forall s a.
Serializable a =>
Condition s a -> CastHandler s a -> Dispatcher s
handleCastIf (Condition s a -> CastHandler s a -> Dispatcher s)
-> Condition s a -> CastHandler s a -> Dispatcher s
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Condition s a
forall s m. Serializable m => (m -> Bool) -> Condition s m
input (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Constructs a 'cast' handler from an ordinary function in the 'Process'
-- monad. Given a function @f :: (s -> a -> Process (ProcessAction s))@,
-- the expression @handleCall f@ will yield a 'Dispatcher' for inclusion
-- in a 'Behaviour' specification for the /GenProcess/.
--
handleCastIf :: forall s a . (Serializable a)
    => Condition s a -- ^ predicate that must be satisfied for the handler to run
    -> CastHandler s a
       -- ^ an action yielding function over the process state and input message
    -> Dispatcher s
handleCastIf :: forall s a.
Serializable a =>
Condition s a -> CastHandler s a -> Dispatcher s
handleCastIf Condition s a
cond CastHandler s a
h
  = DispatchIf {
      dispatch :: s -> Message a () -> Process (ProcessAction s)
dispatch   = \s
s ((CastMessage a
p) :: Message a ()) -> CastHandler s a
h s
s a
p
    , dispatchIf :: s -> Message a () -> Bool
dispatchIf = Condition s a -> s -> Message a () -> Bool
forall s m.
Serializable m =>
Condition s m -> s -> Message m () -> Bool
checkCast Condition s a
cond
    }

-- | Creates a generic input handler for @STM@ actions, from an ordinary
-- function in the 'Process' monad. The @STM a@ action tells the server how
-- to read inputs, which when presented are passed to the handler in the same
-- manner as @handleInfo@ messages would be.
--
-- Note that messages sent to the server's mailbox will never match this
-- handler, only data arriving via the @STM a@ action will.
--
-- Notably, this kind of handler can be used to pass non-serialisable data to
-- a server process. In such situations, the programmer is responsible for
-- managing the underlying @STM@ infrastructure, and the server simply composes
-- the @STM a@ action with the other reads on its mailbox, using the underlying
-- @matchSTM@ API from distributed-process.
--
-- NB: this function cannot be used with a prioristised process definition.
--
handleExternal :: forall s a . (Serializable a)
               => STM a
               -> ActionHandler s a
               -> ExternDispatcher s
handleExternal :: forall s a.
Serializable a =>
STM a -> ActionHandler s a -> ExternDispatcher s
handleExternal STM a
a ActionHandler s a
h =
  let matchMsg' :: Match Message
matchMsg'   = STM a -> (a -> Process Message) -> Match Message
forall a b. STM a -> (a -> Process b) -> Match b
matchSTM STM a
a (\(a
m :: r) -> Message -> Process Message
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Process Message) -> Message -> Process Message
forall a b. (a -> b) -> a -> b
$ a -> Message
forall a. Serializable a => a -> Message
unsafeWrapMessage a
m)
      matchAny' :: (Message -> b) -> Match b
matchAny' Message -> b
f = STM a -> (a -> Process b) -> Match b
forall a b. STM a -> (a -> Process b) -> Match b
matchSTM STM a
a (\(a
m :: r) -> b -> Process b
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Process b) -> b -> Process b
forall a b. (a -> b) -> a -> b
$ Message -> b
f (a -> Message
forall a. Serializable a => a -> Message
unsafeWrapMessage a
m)) in
  DispatchSTM
    { stmAction :: STM a
stmAction   = STM a
a
    , dispatchStm :: ActionHandler s a
dispatchStm = ActionHandler s a
h
    , matchStm :: Match Message
matchStm    = Match Message
matchMsg'
    , matchAnyStm :: forall m. (Message -> m) -> Match m
matchAnyStm = (Message -> m) -> Match m
forall m. (Message -> m) -> Match m
matchAny'
    }

-- | Version of @handleExternal@ that ignores state.
handleExternal_ :: forall s a . (Serializable a)
                => STM a
                -> StatelessHandler s a
                -> ExternDispatcher s
handleExternal_ :: forall s a.
Serializable a =>
STM a -> StatelessHandler s a -> ExternDispatcher s
handleExternal_ STM a
a StatelessHandler s a
h = STM a -> ActionHandler s a -> ExternDispatcher s
forall s a.
Serializable a =>
STM a -> ActionHandler s a -> ExternDispatcher s
handleExternal STM a
a (StatelessHandler s a -> ActionHandler s a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StatelessHandler s a
h)

-- | Handle @call@ style API interactions using arbitrary /STM/ actions.
--
-- The usual @CallHandler@ is preceded by an stm action that, when evaluated,
-- yields a value, and a second expression that is used to send a reply back
-- to the /caller/. The corrolary client API is /callSTM/.
--
handleCallExternal :: forall s r w . (Serializable r)
                   => STM r
                   -> (w -> STM ())
                   -> CallHandler s r w
                   -> ExternDispatcher s
handleCallExternal :: forall s r w.
Serializable r =>
STM r -> (w -> STM ()) -> CallHandler s r w -> ExternDispatcher s
handleCallExternal STM r
reader w -> STM ()
writer CallHandler s r w
handler =
  let matchMsg' :: Match Message
matchMsg'   = STM r -> (r -> Process Message) -> Match Message
forall a b. STM a -> (a -> Process b) -> Match b
matchSTM STM r
reader (\(r
m :: r) -> Message -> Process Message
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Process Message) -> Message -> Process Message
forall a b. (a -> b) -> a -> b
$ r -> Message
forall a. Serializable a => a -> Message
unsafeWrapMessage r
m)
      matchAny' :: (Message -> b) -> Match b
matchAny' Message -> b
f = STM r -> (r -> Process b) -> Match b
forall a b. STM a -> (a -> Process b) -> Match b
matchSTM STM r
reader (\(r
m :: r) -> b -> Process b
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Process b) -> b -> Process b
forall a b. (a -> b) -> a -> b
$ Message -> b
f (Message -> b) -> Message -> b
forall a b. (a -> b) -> a -> b
$ r -> Message
forall a. Serializable a => a -> Message
unsafeWrapMessage r
m) in
  DispatchSTM
    { stmAction :: STM r
stmAction   = STM r
reader
    , dispatchStm :: s -> r -> Process (ProcessAction s)
dispatchStm = CallHandler s r w -> s -> r -> Process (ProcessAction s)
forall {m :: * -> *} {t} {t} {s}.
MonadIO m =>
(t -> t -> m (ProcessReply w s)) -> t -> t -> m (ProcessAction s)
doStmReply CallHandler s r w
handler
    , matchStm :: Match Message
matchStm    = Match Message
matchMsg'
    , matchAnyStm :: forall m. (Message -> m) -> Match m
matchAnyStm = (Message -> m) -> Match m
forall m. (Message -> m) -> Match m
matchAny'
    }
  where
    doStmReply :: (t -> t -> m (ProcessReply w s)) -> t -> t -> m (ProcessAction s)
doStmReply t -> t -> m (ProcessReply w s)
d t
s t
m = t -> t -> m (ProcessReply w s)
d t
s t
m m (ProcessReply w s)
-> (ProcessReply w s -> m (ProcessAction s)) -> m (ProcessAction s)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (w -> STM ()) -> ProcessReply w s -> m (ProcessAction s)
forall {m :: * -> *} {t} {a} {s}.
MonadIO m =>
(t -> STM a) -> ProcessReply t s -> m (ProcessAction s)
doXfmReply w -> STM ()
writer

    doXfmReply :: (t -> STM a) -> ProcessReply t s -> m (ProcessAction s)
doXfmReply t -> STM a
_ (NoReply ProcessAction s
a)         = ProcessAction s -> m (ProcessAction s)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessAction s
a
    doXfmReply t -> STM a
_ (ProcessReject String
_ ProcessAction s
a) = ProcessAction s -> m (ProcessAction s)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessAction s
a
    doXfmReply t -> STM a
w (ProcessReply t
r' ProcessAction s
a) = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> STM a -> IO a
forall a b. (a -> b) -> a -> b
$ t -> STM a
w t
r') m a -> m (ProcessAction s) -> m (ProcessAction s)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessAction s -> m (ProcessAction s)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessAction s
a

-- | Constructs a /control channel/ handler from a function in the
-- 'Process' monad. The handler expression returns no reply, and the
-- /control message/ is treated in the same fashion as a 'cast'.
--
-- > handleControlChan = handleControlChanIf $ input (const True)
--
handleControlChan :: forall s a . (Serializable a)
    => ControlChannel a -- ^ the receiving end of the control channel
    -> ActionHandler s a
       -- ^ an action yielding function over the process state and input message
    -> ExternDispatcher s
handleControlChan :: forall s a.
Serializable a =>
ControlChannel a -> ActionHandler s a -> ExternDispatcher s
handleControlChan ControlChannel a
chan ActionHandler s a
h
  = DispatchCC { channel :: ReceivePort (Message a ())
channel      = (SendPort (Message a ()), ReceivePort (Message a ()))
-> ReceivePort (Message a ())
forall a b. (a, b) -> b
snd ((SendPort (Message a ()), ReceivePort (Message a ()))
 -> ReceivePort (Message a ()))
-> (SendPort (Message a ()), ReceivePort (Message a ()))
-> ReceivePort (Message a ())
forall a b. (a -> b) -> a -> b
$ ControlChannel a
-> (SendPort (Message a ()), ReceivePort (Message a ()))
forall m.
ControlChannel m
-> (SendPort (Message m ()), ReceivePort (Message m ()))
unControl ControlChannel a
chan
               , dispatchChan :: s -> Message a () -> Process (ProcessAction s)
dispatchChan = \s
s ((CastMessage a
p) :: Message a ()) -> ActionHandler s a
h s
s a
p
               }

-- | Version of 'handleControlChan' that ignores the server state.
--
handleControlChan_ :: forall s a. (Serializable a)
           => ControlChannel a
           -> StatelessHandler s a
           -> ExternDispatcher s
handleControlChan_ :: forall s a.
Serializable a =>
ControlChannel a -> StatelessHandler s a -> ExternDispatcher s
handleControlChan_ ControlChannel a
chan StatelessHandler s a
h
  = DispatchCC { channel :: ReceivePort (Message a ())
channel      = (SendPort (Message a ()), ReceivePort (Message a ()))
-> ReceivePort (Message a ())
forall a b. (a, b) -> b
snd ((SendPort (Message a ()), ReceivePort (Message a ()))
 -> ReceivePort (Message a ()))
-> (SendPort (Message a ()), ReceivePort (Message a ()))
-> ReceivePort (Message a ())
forall a b. (a -> b) -> a -> b
$ ControlChannel a
-> (SendPort (Message a ()), ReceivePort (Message a ()))
forall m.
ControlChannel m
-> (SendPort (Message m ()), ReceivePort (Message m ()))
unControl ControlChannel a
chan
               , dispatchChan :: s -> Message a () -> Process (ProcessAction s)
dispatchChan = \s
s ((CastMessage a
p) :: Message a ()) -> StatelessHandler s a
h a
p s
s
               }

-- | Version of 'handleCast' that ignores the server state.
--
handleCast_ :: (Serializable a)
            => StatelessHandler s a
            -> Dispatcher s
handleCast_ :: forall a s. Serializable a => StatelessHandler s a -> Dispatcher s
handleCast_ = Condition s a -> StatelessHandler s a -> Dispatcher s
forall s a.
Serializable a =>
Condition s a -> StatelessHandler s a -> Dispatcher s
handleCastIf_ (Condition s a -> StatelessHandler s a -> Dispatcher s)
-> Condition s a -> StatelessHandler s a -> Dispatcher s
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Condition s a
forall s m. Serializable m => (m -> Bool) -> Condition s m
input (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Version of 'handleCastIf' that ignores the server state.
--
handleCastIf_ :: forall s a . (Serializable a)
    => Condition s a -- ^ predicate that must be satisfied for the handler to run
    -> StatelessHandler s a
        -- ^ a function from the input message to a /stateless action/, cf 'continue_'
    -> Dispatcher s
handleCastIf_ :: forall s a.
Serializable a =>
Condition s a -> StatelessHandler s a -> Dispatcher s
handleCastIf_ Condition s a
cond StatelessHandler s a
h
  = DispatchIf { dispatch :: s -> Message a () -> Process (ProcessAction s)
dispatch   = \s
s ((CastMessage a
p) :: Message a ()) -> StatelessHandler s a
h a
p (s -> Process (ProcessAction s)) -> s -> Process (ProcessAction s)
forall a b. (a -> b) -> a -> b
$ s
s
               , dispatchIf :: s -> Message a () -> Bool
dispatchIf = Condition s a -> s -> Message a () -> Bool
forall s m.
Serializable m =>
Condition s m -> s -> Message m () -> Bool
checkCast Condition s a
cond
               }

-- | Constructs an /action/ handler. Like 'handleDispatch' this can handle both
-- 'cast' and 'call' messages, but you won't know which you're dealing with.
-- This can be useful where certain inputs require a definite action, such as
-- stopping the server, without concern for the state (e.g., when stopping we
-- need only decide to stop, as the terminate handler can deal with state
-- cleanup etc). For example:
--
-- @action (\MyCriticalSignal -> stop_ ExitNormal)@
--
action :: forall s a . (Serializable a)
    => StatelessHandler s a
          -- ^ a function from the input message to a /stateless action/, cf 'continue_'
    -> Dispatcher s
action :: forall s a. Serializable a => StatelessHandler s a -> Dispatcher s
action StatelessHandler s a
h = ActionHandler s a -> Dispatcher s
forall s a. Serializable a => ActionHandler s a -> Dispatcher s
handleDispatch ActionHandler s a
perform
  where perform :: ActionHandler s a
        perform :: ActionHandler s a
perform s
s a
a = let f :: s -> Action s
f = StatelessHandler s a
h a
a in s -> Action s
f s
s

-- | Constructs a handler for both /call/ and /cast/ messages.
-- @handleDispatch = handleDispatchIf (const True)@
--
handleDispatch :: forall s a . (Serializable a)
               => ActionHandler s a
               -> Dispatcher s
handleDispatch :: forall s a. Serializable a => ActionHandler s a -> Dispatcher s
handleDispatch = Condition s a -> ActionHandler s a -> Dispatcher s
forall s a.
Serializable a =>
Condition s a -> CastHandler s a -> Dispatcher s
handleDispatchIf (Condition s a -> ActionHandler s a -> Dispatcher s)
-> Condition s a -> ActionHandler s a -> Dispatcher s
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> Condition s a
forall s m. Serializable m => (m -> Bool) -> Condition s m
input (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Constructs a handler for both /call/ and /cast/ messages. Messages are only
-- dispatched to the handler if the supplied condition evaluates to @True@.
-- Handlers defined in this way have no access to the call context (if one
-- exists) and cannot therefore reply to calls.
--
handleDispatchIf :: forall s a . (Serializable a)
                 => Condition s a
                 -> ActionHandler s a
                 -> Dispatcher s
handleDispatchIf :: forall s a.
Serializable a =>
Condition s a -> CastHandler s a -> Dispatcher s
handleDispatchIf Condition s a
cond ActionHandler s a
handler = DispatchIf {
      dispatch :: s -> Message a () -> Process (ProcessAction s)
dispatch = Serializable a =>
ActionHandler s a -> s -> Message a () -> Process (ProcessAction s)
ActionHandler s a -> s -> Message a () -> Process (ProcessAction s)
doHandle ActionHandler s a
handler
    , dispatchIf :: s -> Message a () -> Bool
dispatchIf = Condition s a -> s -> Message a () -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
check Condition s a
cond
    }
  where doHandle :: (Serializable a)
                 => ActionHandler s a
                 -> s
                 -> Message a ()
                 -> Process (ProcessAction s)
        doHandle :: Serializable a =>
ActionHandler s a -> s -> Message a () -> Process (ProcessAction s)
doHandle ActionHandler s a
h s
s Message a ()
msg =
            case Message a ()
msg of
                (CallMessage a
p CallRef ()
_) -> ActionHandler s a
h s
s a
p
                (CastMessage a
p)   -> ActionHandler s a
h s
s a
p
                (ChanMessage a
p SendPort ()
_) -> ActionHandler s a
h s
s a
p

-- | Creates a generic input handler (i.e., for received messages that are /not/
-- sent using the 'cast' or 'call' APIs) from an ordinary function in the
-- 'Process' monad.
handleInfo :: forall s a. (Serializable a)
           => ActionHandler s a
           -> DeferredDispatcher s
handleInfo :: forall s a.
Serializable a =>
ActionHandler s a -> DeferredDispatcher s
handleInfo ActionHandler s a
h = DeferredDispatcher { dispatchInfo :: s -> Message -> Process (Maybe (ProcessAction s))
dispatchInfo = ActionHandler s a
-> s -> Message -> Process (Maybe (ProcessAction s))
forall s2 a2.
Serializable a2 =>
ActionHandler s2 a2
-> s2 -> Message -> Process (Maybe (ProcessAction s2))
doHandleInfo ActionHandler s a
h }
  where
    doHandleInfo :: forall s2 a2. (Serializable a2)
                             => ActionHandler s2 a2
                             -> s2
                             -> P.Message
                             -> Process (Maybe (ProcessAction s2))
    doHandleInfo :: forall s2 a2.
Serializable a2 =>
ActionHandler s2 a2
-> s2 -> Message -> Process (Maybe (ProcessAction s2))
doHandleInfo ActionHandler s2 a2
h' s2
s Message
msg = Message
-> (a2 -> Process (ProcessAction s2))
-> Process (Maybe (ProcessAction s2))
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
msg (ActionHandler s2 a2
h' s2
s)

-- | Handle completely /raw/ input messages.
--
handleRaw :: forall s. ActionHandler s P.Message
          -> DeferredDispatcher s
handleRaw :: forall s. ActionHandler s Message -> DeferredDispatcher s
handleRaw ActionHandler s Message
h = DeferredDispatcher { dispatchInfo :: s -> Message -> Process (Maybe (ProcessAction s))
dispatchInfo = ActionHandler s Message
-> s -> Message -> Process (Maybe (ProcessAction s))
forall {f :: * -> *} {t} {t} {a}.
Functor f =>
(t -> t -> f a) -> t -> t -> f (Maybe a)
doHandle ActionHandler s Message
h }
  where
    doHandle :: (t -> t -> f a) -> t -> t -> f (Maybe a)
doHandle t -> t -> f a
h' t
s t
msg = (a -> Maybe a) -> f a -> f (Maybe a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (t -> t -> f a
h' t
s t
msg)

-- | Creates an /exit handler/ scoped to the execution of any and all the
-- registered call, cast and info handlers for the process.
handleExit :: forall s a. (Serializable a)
           => (ProcessId -> ActionHandler s a)
           -> ExitSignalDispatcher s
handleExit :: forall s a.
Serializable a =>
(ProcessId -> ActionHandler s a) -> ExitSignalDispatcher s
handleExit ProcessId -> ActionHandler s a
h = ExitSignalDispatcher { dispatchExit :: s -> ProcessId -> Message -> Process (Maybe (ProcessAction s))
dispatchExit = (ProcessId -> ActionHandler s a)
-> s -> ProcessId -> Message -> Process (Maybe (ProcessAction s))
doHandleExit ProcessId -> ActionHandler s a
h }
  where
    doHandleExit :: (ProcessId -> ActionHandler s a)
                 -> s
                 -> ProcessId
                 -> P.Message
                 -> Process (Maybe (ProcessAction s))
    doHandleExit :: (ProcessId -> ActionHandler s a)
-> s -> ProcessId -> Message -> Process (Maybe (ProcessAction s))
doHandleExit ProcessId -> ActionHandler s a
h' s
s ProcessId
p Message
msg = Message
-> (a -> Process (ProcessAction s))
-> Process (Maybe (ProcessAction s))
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
msg (ProcessId -> ActionHandler s a
h' ProcessId
p s
s)

-- | Conditional version of @handleExit@
handleExitIf :: forall s a . (Serializable a)
             => (s -> a -> Bool)
             -> (ProcessId -> ActionHandler s a)
             -> ExitSignalDispatcher s
handleExitIf :: forall s a.
Serializable a =>
(s -> a -> Bool)
-> (ProcessId -> ActionHandler s a) -> ExitSignalDispatcher s
handleExitIf s -> a -> Bool
c ProcessId -> ActionHandler s a
h = ExitSignalDispatcher { dispatchExit :: s -> ProcessId -> Message -> Process (Maybe (ProcessAction s))
dispatchExit = (s -> a -> Bool)
-> (ProcessId -> ActionHandler s a)
-> s
-> ProcessId
-> Message
-> Process (Maybe (ProcessAction s))
doHandleExit s -> a -> Bool
c ProcessId -> ActionHandler s a
h }
  where
    doHandleExit :: (s -> a -> Bool)
                 -> (ProcessId -> ActionHandler s a)
                 -> s
                 -> ProcessId
                 -> P.Message
                 -> Process (Maybe (ProcessAction s))
    doHandleExit :: (s -> a -> Bool)
-> (ProcessId -> ActionHandler s a)
-> s
-> ProcessId
-> Message
-> Process (Maybe (ProcessAction s))
doHandleExit s -> a -> Bool
c' ProcessId -> ActionHandler s a
h' s
s ProcessId
p Message
msg = Message
-> (a -> Bool)
-> (a -> Process (ProcessAction s))
-> Process (Maybe (ProcessAction s))
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> Bool) -> (a -> m b) -> m (Maybe b)
handleMessageIf Message
msg (s -> a -> Bool
c' s
s) (ProcessId -> ActionHandler s a
h' ProcessId
p s
s)

-- handling 'reply-to' in the main process loop is awkward at best,
-- so we handle it here instead and return the 'action' to the loop
mkReply :: (Serializable b)
        => CallRef b
        -> ProcessReply b s
        -> Process (ProcessAction s)
mkReply :: forall b s.
Serializable b =>
CallRef b -> ProcessReply b s -> Process (ProcessAction s)
mkReply CallRef b
cRef ProcessReply b s
act
  | (NoReply ProcessAction s
a)          <- ProcessReply b s
act  = ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessAction s
a
  | (CallRef (Recipient
_, CallId
tg'))   <- CallRef b
cRef
  , (ProcessReply  b
r' ProcessAction s
a) <- ProcessReply b s
act  = CallRef b -> CallResponse b -> Process ()
forall m.
(Serializable m, Resolvable (CallRef b)) =>
CallRef b -> m -> Process ()
forall a m.
(Routable a, Serializable m, Resolvable a) =>
a -> m -> Process ()
sendTo CallRef b
cRef (b -> CallId -> CallResponse b
forall a. a -> CallId -> CallResponse a
CallResponse b
r' CallId
tg') Process ()
-> Process (ProcessAction s) -> Process (ProcessAction s)
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessAction s
a
  | (CallRef (Recipient
_, CallId
ct'))   <- CallRef b
cRef
  , (ProcessReject String
r' ProcessAction s
a) <- ProcessReply b s
act  = CallRef b -> CallRejected -> Process ()
forall m.
(Serializable m, Resolvable (CallRef b)) =>
CallRef b -> m -> Process ()
forall a m.
(Routable a, Serializable m, Resolvable a) =>
a -> m -> Process ()
sendTo CallRef b
cRef (String -> CallId -> CallRejected
CallRejected String
r' CallId
ct') Process ()
-> Process (ProcessAction s) -> Process (ProcessAction s)
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessAction s -> Process (ProcessAction s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessAction s
a
  | Bool
otherwise                    = ExitReason -> Process (ProcessAction s)
forall a b. Serializable a => a -> Process b
die (ExitReason -> Process (ProcessAction s))
-> ExitReason -> Process (ProcessAction s)
forall a b. (a -> b) -> a -> b
$ String -> ExitReason
ExitOther String
"mkReply.InvalidState"

-- these functions are the inverse of 'condition', 'state' and 'input'

check :: forall s m a . (Serializable m)
            => Condition s m
            -> s
            -> Message m a
            -> Bool
check :: forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
check (Condition s -> m -> Bool
c) s
st Message m a
msg = s -> m -> Bool
c s
st (m -> Bool) -> m -> Bool
forall a b. (a -> b) -> a -> b
$ Message m a -> m
forall a b. Message a b -> a
decode Message m a
msg
check (State     s -> Bool
c) s
st Message m a
_   = s -> Bool
c s
st
check (Input     m -> Bool
c) s
_  Message m a
msg = m -> Bool
c (m -> Bool) -> m -> Bool
forall a b. (a -> b) -> a -> b
$ Message m a -> m
forall a b. Message a b -> a
decode Message m a
msg

checkRpc :: forall s m a . (Serializable m)
            => Condition s m
            -> s
            -> Message m a
            -> Bool
checkRpc :: forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
checkRpc Condition s m
cond s
st msg :: Message m a
msg@(ChanMessage m
_ SendPort a
_) = Condition s m -> s -> Message m a -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
check Condition s m
cond s
st Message m a
msg
checkRpc Condition s m
_    s
_  Message m a
_                     = Bool
False

checkCall :: forall s m a . (Serializable m)
             => Condition s m
             -> s
             -> Message m a
             -> Bool
checkCall :: forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
checkCall Condition s m
cond s
st msg :: Message m a
msg@(CallMessage m
_ CallRef a
_) = Condition s m -> s -> Message m a -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
check Condition s m
cond s
st Message m a
msg
checkCall Condition s m
_    s
_  Message m a
_                     = Bool
False

checkCast :: forall s m . (Serializable m)
             => Condition s m
             -> s
             -> Message m ()
             -> Bool
checkCast :: forall s m.
Serializable m =>
Condition s m -> s -> Message m () -> Bool
checkCast Condition s m
cond s
st msg :: Message m ()
msg@(CastMessage m
_) = Condition s m -> s -> Message m () -> Bool
forall s m a.
Serializable m =>
Condition s m -> s -> Message m a -> Bool
check Condition s m
cond s
st Message m ()
msg
checkCast Condition s m
_    s
_     Message m ()
_                = Bool
False

decode :: Message a b -> a
decode :: forall a b. Message a b -> a
decode (CallMessage a
a CallRef b
_) = a
a
decode (CastMessage a
a)   = a
a
decode (ChanMessage a
a SendPort b
_) = a
a