{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE PatternGuards              #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE AllowAmbiguousTypes        #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Distributed.Process.ManagedProcess.Server.Priority
-- 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 Prioritised Server portion of the /Managed Process/ API.
-----------------------------------------------------------------------------
module Control.Distributed.Process.ManagedProcess.Server.Priority
  ( -- * Prioritising API Handlers
    prioritiseCall
  , prioritiseCall_
  , prioritiseCast
  , prioritiseCast_
  , prioritiseInfo
  , prioritiseInfo_
  , setPriority
    -- * Creating Filters
  , check
  , raw
  , raw_
  , api
  , api_
  , info
  , info_
  , refuse
  , reject
  , rejectApi
  , store
  , storeM
  , crash
  , ensure
  , ensureM
  , Filter()
  , DispatchFilter()
  , safe
  , apiSafe
  , safely
  , Message()
  , evalAfter
  , currentTimeout
  , processState
  , processDefinition
  , processFilters
  , processUnhandledMsgPolicy
  , setUserTimeout
  , setProcessState
  , GenProcess
  , peek
  , push
  , addUserTimer
  , act
  , runAfter
  ) where

import Control.Distributed.Process hiding (call, Message)
import qualified Control.Distributed.Process as P (Message)
import Control.Distributed.Process.Extras
  ( ExitReason(..)
  )
import Control.Distributed.Process.ManagedProcess.Internal.GenProcess
  ( addUserTimer
  , currentTimeout
  , processState
  , processDefinition
  , processFilters
  , processUnhandledMsgPolicy
  , setUserTimeout
  , setProcessState
  , GenProcess
  , peek
  , push
  , evalAfter
  , act
  , runAfter
  )
import Control.Distributed.Process.ManagedProcess.Internal.Types
import Control.Distributed.Process.Serializable
import Prelude hiding (init)

-- | Sent to a caller in cases where the server is rejecting an API input and
-- a @Recipient@ is available (i.e. a /call/ message handling filter).
data RejectedByServer = RejectedByServer deriving (Int -> RejectedByServer -> ShowS
[RejectedByServer] -> ShowS
RejectedByServer -> String
(Int -> RejectedByServer -> ShowS)
-> (RejectedByServer -> String)
-> ([RejectedByServer] -> ShowS)
-> Show RejectedByServer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RejectedByServer -> ShowS
showsPrec :: Int -> RejectedByServer -> ShowS
$cshow :: RejectedByServer -> String
show :: RejectedByServer -> String
$cshowList :: [RejectedByServer] -> ShowS
showList :: [RejectedByServer] -> ShowS
Show)

-- | Represents a pair of expressions that can be used to define a @DispatchFilter@.
data FilterHandler s =
    forall m . (Serializable m) =>
    HandlePure
    {
      ()
pureCheck :: s -> m -> Process Bool
    , ()
handler :: s -> m -> Process (Filter s)
    } -- ^ A pure handler, usable where the target handler is based on @handleInfo@
  | forall m b . (Serializable m, Serializable b) =>
    HandleApi
    {
      ()
apiCheck :: s -> m -> Process Bool
    , ()
apiHandler :: s -> Message m b -> Process (Filter s)
    } -- ^ An API handler, usable where the target handler is based on @handle{Call, Cast, RpcChan}@
  | HandleRaw
    {
      forall s. FilterHandler s -> s -> Message -> Process Bool
rawCheck :: s -> P.Message -> Process Bool
    , forall s.
FilterHandler s -> s -> Message -> Process (Maybe (Filter s))
rawHandler :: s -> P.Message -> Process (Maybe (Filter s))
    } -- ^ A raw handler, usable where the target handler is based on @handleRaw@
  | HandleState { forall s. FilterHandler s -> s -> Process (Maybe (Filter s))
stateHandler :: s -> Process (Maybe (Filter s)) }
  | HandleSafe
    {
      forall s. FilterHandler s -> s -> Message -> Process Bool
safeCheck :: s -> P.Message -> Process Bool
    } -- ^ A safe wrapper

{-
check :: forall c s m . (Check c s m)
      => c -> (s -> Process (Filter s)) -> s -> m -> Process (Filter s)
-}

-- | Create a filter from a @FilterHandler@.
check :: forall s . FilterHandler s -> DispatchFilter s
check :: forall s. FilterHandler s -> DispatchFilter s
check FilterHandler s
h
  | HandlePure{s -> m -> Process Bool
s -> m -> Process (Filter s)
pureCheck :: ()
handler :: ()
pureCheck :: s -> m -> Process Bool
handler :: s -> m -> Process (Filter s)
..}  <- FilterHandler s
h = (s -> m -> Process (Filter s)) -> DispatchFilter s
forall s a.
Serializable a =>
(s -> a -> Process (Filter s)) -> DispatchFilter s
FilterAny ((s -> m -> Process (Filter s)) -> DispatchFilter s)
-> (s -> m -> Process (Filter s)) -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ \s
s m
m -> s -> m -> Process Bool
pureCheck s
s m
m Process Bool -> (Bool -> Process (Filter s)) -> Process (Filter s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s
-> m
-> (s -> m -> Process (Filter s))
-> Bool
-> Process (Filter s)
forall {m :: * -> *} {t} {t}.
Monad m =>
t -> t -> (t -> t -> m (Filter t)) -> Bool -> m (Filter t)
procUnless s
s m
m s -> m -> Process (Filter s)
handler
  | HandleRaw{s -> Message -> Process Bool
s -> Message -> Process (Maybe (Filter s))
rawCheck :: forall s. FilterHandler s -> s -> Message -> Process Bool
rawHandler :: forall s.
FilterHandler s -> s -> Message -> Process (Maybe (Filter s))
rawCheck :: s -> Message -> Process Bool
rawHandler :: s -> Message -> Process (Maybe (Filter s))
..}   <- FilterHandler s
h = (s -> Message -> Process (Maybe (Filter s))) -> DispatchFilter s
forall s.
(s -> Message -> Process (Maybe (Filter s))) -> DispatchFilter s
FilterRaw ((s -> Message -> Process (Maybe (Filter s))) -> DispatchFilter s)
-> (s -> Message -> Process (Maybe (Filter s))) -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ \s
s Message
m -> do
      Bool
c <- s -> Message -> Process Bool
rawCheck s
s Message
m
      if Bool
c then Maybe (Filter s) -> Process (Maybe (Filter s))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Filter s) -> Process (Maybe (Filter s)))
-> Maybe (Filter s) -> Process (Maybe (Filter s))
forall a b. (a -> b) -> a -> b
$ Filter s -> Maybe (Filter s)
forall a. a -> Maybe a
Just (Filter s -> Maybe (Filter s)) -> Filter s -> Maybe (Filter s)
forall a b. (a -> b) -> a -> b
$ s -> Filter s
forall s. s -> Filter s
FilterOk s
s
           else s -> Message -> Process (Maybe (Filter s))
rawHandler s
s Message
m
  | HandleState{s -> Process (Maybe (Filter s))
stateHandler :: forall s. FilterHandler s -> s -> Process (Maybe (Filter s))
stateHandler :: s -> Process (Maybe (Filter s))
..} <- FilterHandler s
h = (s -> Process (Maybe (Filter s))) -> DispatchFilter s
forall s. (s -> Process (Maybe (Filter s))) -> DispatchFilter s
FilterState s -> Process (Maybe (Filter s))
stateHandler
  | HandleApi{s -> m -> Process Bool
s -> Message m b -> Process (Filter s)
apiCheck :: ()
apiHandler :: ()
apiCheck :: s -> m -> Process Bool
apiHandler :: s -> Message m b -> Process (Filter s)
..}   <- FilterHandler s
h = (s -> Message m b -> Process (Filter s)) -> DispatchFilter s
forall s a b.
(Serializable a, Serializable b) =>
(s -> Message a b -> Process (Filter s)) -> DispatchFilter s
FilterApi ((s -> Message m b -> Process (Filter s)) -> DispatchFilter s)
-> (s -> Message m b -> Process (Filter s)) -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ \s
s m :: Message m b
m@(CallMessage m
m' CallRef b
_) -> do
      Bool
c <- s -> m -> Process Bool
apiCheck s
s m
m'
      if Bool
c then Filter s -> Process (Filter s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Filter s -> Process (Filter s)) -> Filter s -> Process (Filter s)
forall a b. (a -> b) -> a -> b
$ s -> Filter s
forall s. s -> Filter s
FilterOk s
s
           else s -> Message m b -> Process (Filter s)
apiHandler s
s Message m b
m
  | HandleSafe{s -> Message -> Process Bool
safeCheck :: forall s. FilterHandler s -> s -> Message -> Process Bool
safeCheck :: s -> Message -> Process Bool
..}  <- FilterHandler s
h = (s -> Message -> Process (Maybe (Filter s))) -> DispatchFilter s
forall s.
(s -> Message -> Process (Maybe (Filter s))) -> DispatchFilter s
FilterRaw ((s -> Message -> Process (Maybe (Filter s))) -> DispatchFilter s)
-> (s -> Message -> Process (Maybe (Filter s))) -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ \s
s Message
m -> do
      Bool
c <- s -> Message -> Process Bool
safeCheck s
s Message
m
      let ctr :: s -> Filter s
ctr = if Bool
c then s -> Filter s
forall s. s -> Filter s
FilterSafe else s -> Filter s
forall s. s -> Filter s
FilterOk
      Maybe (Filter s) -> Process (Maybe (Filter s))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Filter s) -> Process (Maybe (Filter s)))
-> Maybe (Filter s) -> Process (Maybe (Filter s))
forall a b. (a -> b) -> a -> b
$ Filter s -> Maybe (Filter s)
forall a. a -> Maybe a
Just (Filter s -> Maybe (Filter s)) -> Filter s -> Maybe (Filter s)
forall a b. (a -> b) -> a -> b
$ s -> Filter s
forall s. s -> Filter s
ctr s
s

  where
    procUnless :: t -> t -> (t -> t -> m (Filter t)) -> Bool -> m (Filter t)
procUnless t
s t
_ t -> t -> m (Filter t)
_ Bool
True  = Filter t -> m (Filter t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Filter t -> m (Filter t)) -> Filter t -> m (Filter t)
forall a b. (a -> b) -> a -> b
$ t -> Filter t
forall s. s -> Filter s
FilterOk t
s
    procUnless t
s t
m t -> t -> m (Filter t)
h' Bool
False = t -> t -> m (Filter t)
h' t
s t
m

-- | A raw filter (targetting raw messages).
raw :: forall s .
       (s -> P.Message -> Process Bool)
    -> (s -> P.Message -> Process (Maybe (Filter s)))
    -> FilterHandler s
raw :: forall s.
(s -> Message -> Process Bool)
-> (s -> Message -> Process (Maybe (Filter s))) -> FilterHandler s
raw = (s -> Message -> Process Bool)
-> (s -> Message -> Process (Maybe (Filter s))) -> FilterHandler s
forall s.
(s -> Message -> Process Bool)
-> (s -> Message -> Process (Maybe (Filter s))) -> FilterHandler s
HandleRaw

-- | A raw filter that ignores the server state in its condition expression.
raw_ :: forall s .
        (P.Message -> Process Bool)
     -> (s -> P.Message -> Process (Maybe (Filter s)))
     -> FilterHandler s
raw_ :: forall s.
(Message -> Process Bool)
-> (s -> Message -> Process (Maybe (Filter s))) -> FilterHandler s
raw_ Message -> Process Bool
c s -> Message -> Process (Maybe (Filter s))
h = (s -> Message -> Process Bool)
-> (s -> Message -> Process (Maybe (Filter s))) -> FilterHandler s
forall s.
(s -> Message -> Process Bool)
-> (s -> Message -> Process (Maybe (Filter s))) -> FilterHandler s
raw ((Message -> Process Bool) -> s -> Message -> Process Bool
forall a b. a -> b -> a
const ((Message -> Process Bool) -> s -> Message -> Process Bool)
-> (Message -> Process Bool) -> s -> Message -> Process Bool
forall a b. (a -> b) -> a -> b
$ Message -> Process Bool
c) s -> Message -> Process (Maybe (Filter s))
h

-- | An API filter (targetting /call/, /cast/, and /chan/ messages).
api :: forall s m b . (Serializable m, Serializable b)
    => (s -> m -> Process Bool)
    -> (s -> Message m b -> Process (Filter s))
    -> FilterHandler s
api :: forall s m b.
(Serializable m, Serializable b) =>
(s -> m -> Process Bool)
-> (s -> Message m b -> Process (Filter s)) -> FilterHandler s
api = (s -> m -> Process Bool)
-> (s -> Message m b -> Process (Filter s)) -> FilterHandler s
forall s m b.
(Serializable m, Serializable b) =>
(s -> m -> Process Bool)
-> (s -> Message m b -> Process (Filter s)) -> FilterHandler s
HandleApi

-- | An API filter that ignores the server state in its condition expression.
api_ :: forall m b s . (Serializable m, Serializable b)
     => (m -> Process Bool)
     -> (s -> Message m b -> Process (Filter s))
     -> FilterHandler s
api_ :: forall m b s.
(Serializable m, Serializable b) =>
(m -> Process Bool)
-> (s -> Message m b -> Process (Filter s)) -> FilterHandler s
api_ m -> Process Bool
c s -> Message m b -> Process (Filter s)
h = (s -> m -> Process Bool)
-> (s -> Message m b -> Process (Filter s)) -> FilterHandler s
forall s m b.
(Serializable m, Serializable b) =>
(s -> m -> Process Bool)
-> (s -> Message m b -> Process (Filter s)) -> FilterHandler s
api ((m -> Process Bool) -> s -> m -> Process Bool
forall a b. a -> b -> a
const ((m -> Process Bool) -> s -> m -> Process Bool)
-> (m -> Process Bool) -> s -> m -> Process Bool
forall a b. (a -> b) -> a -> b
$ m -> Process Bool
c) s -> Message m b -> Process (Filter s)
h

-- | An info filter (targetting info messages of a specific type)
info :: forall s m . (Serializable m)
        => (s -> m -> Process Bool)
        -> (s -> m -> Process (Filter s))
        -> FilterHandler s
info :: forall s m.
Serializable m =>
(s -> m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
info = (s -> m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
forall s m.
Serializable m =>
(s -> m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
HandlePure

-- | An info filter that ignores the server state in its condition expression.
info_ :: forall s m . (Serializable m)
        => (m -> Process Bool)
        -> (s -> m -> Process (Filter s))
        -> FilterHandler s
info_ :: forall s m.
Serializable m =>
(m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
info_ m -> Process Bool
c s -> m -> Process (Filter s)
h = (s -> m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
forall s m.
Serializable m =>
(s -> m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
info ((m -> Process Bool) -> s -> m -> Process Bool
forall a b. a -> b -> a
const ((m -> Process Bool) -> s -> m -> Process Bool)
-> (m -> Process Bool) -> s -> m -> Process Bool
forall a b. (a -> b) -> a -> b
$ m -> Process Bool
c) s -> m -> Process (Filter s)
h

-- | As 'safe', but as applied to api messages (i.e. those originating from
-- call as cast client interactions).
apiSafe :: forall s m b . (Serializable m, Serializable b)
     => (s -> m -> Maybe b -> Bool)
     -> DispatchFilter s
apiSafe :: forall s m b.
(Serializable m, Serializable b) =>
(s -> m -> Maybe b -> Bool) -> DispatchFilter s
apiSafe s -> m -> Maybe b -> Bool
c = FilterHandler s -> DispatchFilter s
forall s. FilterHandler s -> DispatchFilter s
check (FilterHandler s -> DispatchFilter s)
-> FilterHandler s -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ (s -> Message -> Process Bool) -> FilterHandler s
forall s. (s -> Message -> Process Bool) -> FilterHandler s
HandleSafe ((s -> m -> Maybe b -> Bool) -> s -> Message -> Process Bool
forall {t} {a}.
(t -> m -> Maybe a -> Bool) -> t -> Message -> Process Bool
go s -> m -> Maybe b -> Bool
c)
  where
    go :: (t -> m -> Maybe a -> Bool) -> t -> Message -> Process Bool
go t -> m -> Maybe a -> Bool
c' t
s (Message
i :: P.Message) = do
      Maybe (Message m b)
m <- Message -> Process (Maybe (Message m b))
forall (m :: * -> *) a.
(Monad m, Serializable a) =>
Message -> m (Maybe a)
unwrapMessage Message
i :: Process (Maybe (Message m b))
      case Maybe (Message m b)
m of
        Just (CallMessage m
m' CallRef b
_) -> 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
$ t -> m -> Maybe a -> Bool
c' t
s m
m' Maybe a
forall a. Maybe a
Nothing
        Just (CastMessage m
m')   -> 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
$ t -> m -> Maybe a -> Bool
c' t
s m
m' Maybe a
forall a. Maybe a
Nothing
        Just (ChanMessage m
m' SendPort b
_) -> 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
$ t -> m -> Maybe a -> Bool
c' t
s m
m' Maybe a
forall a. Maybe a
Nothing
        Maybe (Message m b)
Nothing                 -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Given a check expression, if it evaluates to @True@ for some input,
-- then do not dequeue the message until after any matching handlers have
-- successfully run, or the the unhandled message policy is chosen if none match.
-- Thus, if an exit signal (async exception) terminates execution of a handler, and we
-- have an installed exit handler which allows the process to continue running,
-- we will retry the input in question since it has not been fully dequeued prior
-- to the exit signal arriving.
safe :: forall s m . (Serializable m)
     => (s -> m -> Bool)
     -> DispatchFilter s
safe :: forall s m. Serializable m => (s -> m -> Bool) -> DispatchFilter s
safe s -> m -> Bool
c = FilterHandler s -> DispatchFilter s
forall s. FilterHandler s -> DispatchFilter s
check (FilterHandler s -> DispatchFilter s)
-> FilterHandler s -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ (s -> Message -> Process Bool) -> FilterHandler s
forall s. (s -> Message -> Process Bool) -> FilterHandler s
HandleSafe ((s -> m -> Bool) -> s -> Message -> Process Bool
forall {t}. (t -> m -> Bool) -> t -> Message -> Process Bool
go s -> m -> Bool
c)
  where
    go :: (t -> m -> Bool) -> t -> Message -> Process Bool
go t -> m -> Bool
c' t
s (Message
i :: P.Message) = do
      Maybe m
m <- Message -> Process (Maybe m)
forall (m :: * -> *) a.
(Monad m, Serializable a) =>
Message -> m (Maybe a)
unwrapMessage Message
i :: Process (Maybe m)
      case Maybe m
m of
        Just m
m' -> 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
$ t -> m -> Bool
c' t
s m
m'
        Maybe m
Nothing -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | As 'safe', but matches on a raw message.
safely :: forall s . (s -> P.Message -> Bool) -> DispatchFilter s
safely :: forall s. (s -> Message -> Bool) -> DispatchFilter s
safely s -> Message -> Bool
c = FilterHandler s -> DispatchFilter s
forall s. FilterHandler s -> DispatchFilter s
check (FilterHandler s -> DispatchFilter s)
-> FilterHandler s -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ (s -> Message -> Process Bool) -> FilterHandler s
forall s. (s -> Message -> Process Bool) -> FilterHandler s
HandleSafe ((s -> Message -> Process Bool) -> FilterHandler s)
-> (s -> Message -> Process Bool) -> FilterHandler s
forall a b. (a -> b) -> a -> b
$ \s
s Message
m -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> Message -> Bool
c s
s Message
m)

-- | Create a filter expression that will reject all messages of a specific type.
reject :: forall s m r . (Show r)
       => r -> s -> m -> Process (Filter s)
reject :: forall s m r. Show r => r -> s -> m -> Process (Filter s)
reject r
r = \s
s m
_ -> do Filter s -> Process (Filter s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Filter s -> Process (Filter s)) -> Filter s -> Process (Filter s)
forall a b. (a -> b) -> a -> b
$ String -> s -> Filter s
forall s m. Show m => m -> s -> Filter s
FilterReject (r -> String
forall a. Show a => a -> String
show r
r) s
s

-- | Create a filter expression that will crash (i.e. stop) the server.
crash :: forall s . s -> ExitReason -> Process (Filter s)
crash :: forall s. s -> ExitReason -> Process (Filter s)
crash s
s ExitReason
r = Filter s -> Process (Filter s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Filter s -> Process (Filter s)) -> Filter s -> Process (Filter s)
forall a b. (a -> b) -> a -> b
$ s -> ExitReason -> Filter s
forall s. s -> ExitReason -> Filter s
FilterStop s
s ExitReason
r

-- | A version of @reject@ that deals with API messages (i.e. /call/, /cast/, etc)
-- and in the case of a /call/ interaction, will reject the messages and reply to
-- the sender accordingly (with @CallRejected@).
rejectApi :: forall s m b r . (Show r, Serializable m, Serializable b)
          => r -> s -> Message m b -> Process (Filter s)
rejectApi :: forall s m b r.
(Show r, Serializable m, Serializable b) =>
r -> s -> Message m b -> Process (Filter s)
rejectApi r
r = \s
s Message m b
m -> do let r' :: String
r' = r -> String
forall a. Show a => a -> String
show r
r
                         Message m b -> String -> Process ()
forall a b. Message a b -> String -> Process ()
rejectToCaller Message m b
m String
r'
                         Filter s -> Process (Filter s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Filter s -> Process (Filter s)) -> Filter s -> Process (Filter s)
forall a b. (a -> b) -> a -> b
$ s -> Filter s
forall s. s -> Filter s
FilterSkip s
s

-- | Modify the server state every time a message is recieved.
store :: (s -> s) -> DispatchFilter s
store :: forall s. (s -> s) -> DispatchFilter s
store s -> s
f = (s -> Process (Maybe (Filter s))) -> DispatchFilter s
forall s. (s -> Process (Maybe (Filter s))) -> DispatchFilter s
FilterState ((s -> Process (Maybe (Filter s))) -> DispatchFilter s)
-> (s -> Process (Maybe (Filter s))) -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ Maybe (Filter s) -> Process (Maybe (Filter s))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Filter s) -> Process (Maybe (Filter s)))
-> (s -> Maybe (Filter s)) -> s -> Process (Maybe (Filter s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Filter s -> Maybe (Filter s)
forall a. a -> Maybe a
Just (Filter s -> Maybe (Filter s))
-> (s -> Filter s) -> s -> Maybe (Filter s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Filter s
forall s. s -> Filter s
FilterOk (s -> Filter s) -> (s -> s) -> s -> Filter s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
f

-- | Motify the server state when messages of a certain type arrive...
storeM :: forall s m . (Serializable m)
       => (s -> m -> Process s)
       -> DispatchFilter s
storeM :: forall s m.
Serializable m =>
(s -> m -> Process s) -> DispatchFilter s
storeM s -> m -> Process s
proc = FilterHandler s -> DispatchFilter s
forall s. FilterHandler s -> DispatchFilter s
check (FilterHandler s -> DispatchFilter s)
-> FilterHandler s -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ (s -> m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
forall s m.
Serializable m =>
(s -> m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
HandlePure (\s
_ m
_ -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
                                 (\s
s m
m -> s -> m -> Process s
proc s
s m
m Process s -> (s -> Process (Filter s)) -> Process (Filter s)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Filter s -> Process (Filter s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Filter s -> Process (Filter s))
-> (s -> Filter s) -> s -> Process (Filter s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Filter s
forall s. s -> Filter s
FilterOk)

-- | Refuse messages for which the given expression evaluates to @True@.
refuse :: forall s m . (Serializable m)
       => (m -> Bool)
       -> DispatchFilter s
refuse :: forall s m. Serializable m => (m -> Bool) -> DispatchFilter s
refuse m -> Bool
c = FilterHandler s -> DispatchFilter s
forall s. FilterHandler s -> DispatchFilter s
check (FilterHandler s -> DispatchFilter s)
-> FilterHandler s -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ (s -> m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
forall s m.
Serializable m =>
(s -> m -> Process Bool)
-> (s -> m -> Process (Filter s)) -> FilterHandler s
info ((m -> Process Bool) -> s -> m -> Process Bool
forall a b. a -> b -> a
const ((m -> Process Bool) -> s -> m -> Process Bool)
-> (m -> Process Bool) -> s -> m -> Process Bool
forall a b. (a -> b) -> a -> b
$ \m
m -> 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
$ m -> Bool
c m
m) (RejectedByServer -> s -> m -> Process (Filter s)
forall s m r. Show r => r -> s -> m -> Process (Filter s)
reject RejectedByServer
RejectedByServer)

{-
apiCheck :: forall s m r . (Serializable m, Serializable r)
      => (s -> Message m r -> Bool)
      -> (s -> Message m r -> Process (Filter s))
      -> DispatchFilter s
apiCheck c h = checkM (\s m -> return $ c s m) h
-}

-- | Ensure that the server state is consistent with the given expression each
-- time a message arrives/is processed. If the expression evaluates to @True@
-- then the filter will evaluate to "FilterOk", otherwise "FilterStop" (which
-- will cause the server loop to stop with @ExitOther filterFail@).
ensure :: forall s . (s -> Bool) -> DispatchFilter s
ensure :: forall s. (s -> Bool) -> DispatchFilter s
ensure s -> Bool
c =
  FilterHandler s -> DispatchFilter s
forall s. FilterHandler s -> DispatchFilter s
check (FilterHandler s -> DispatchFilter s)
-> FilterHandler s -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ HandleState { stateHandler :: s -> Process (Maybe (Filter s))
stateHandler = (\s
s -> if s -> Bool
c s
s
                                                then Maybe (Filter s) -> Process (Maybe (Filter s))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Filter s) -> Process (Maybe (Filter s)))
-> Maybe (Filter s) -> Process (Maybe (Filter s))
forall a b. (a -> b) -> a -> b
$ Filter s -> Maybe (Filter s)
forall a. a -> Maybe a
Just (Filter s -> Maybe (Filter s)) -> Filter s -> Maybe (Filter s)
forall a b. (a -> b) -> a -> b
$ s -> Filter s
forall s. s -> Filter s
FilterOk s
s
                                                else Maybe (Filter s) -> Process (Maybe (Filter s))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Filter s) -> Process (Maybe (Filter s)))
-> Maybe (Filter s) -> Process (Maybe (Filter s))
forall a b. (a -> b) -> a -> b
$ Filter s -> Maybe (Filter s)
forall a. a -> Maybe a
Just (Filter s -> Maybe (Filter s)) -> Filter s -> Maybe (Filter s)
forall a b. (a -> b) -> a -> b
$ s -> ExitReason -> Filter s
forall s. s -> ExitReason -> Filter s
FilterStop s
s ExitReason
filterFail)
                      }
-- | As @ensure@ but runs in the @Process@ monad, and matches only inputs of type @m@.
ensureM :: forall s m . (Serializable m) => (s -> m -> Process Bool) -> DispatchFilter s
ensureM :: forall s m.
Serializable m =>
(s -> m -> Process Bool) -> DispatchFilter s
ensureM s -> m -> Process Bool
c =
  FilterHandler s -> DispatchFilter s
forall s. FilterHandler s -> DispatchFilter s
check (FilterHandler s -> DispatchFilter s)
-> FilterHandler s -> DispatchFilter s
forall a b. (a -> b) -> a -> b
$ HandlePure { pureCheck :: s -> m -> Process Bool
pureCheck = s -> m -> Process Bool
c
                     , handler :: s -> m -> Process (Filter s)
handler = (\s
s m
_ -> Filter s -> Process (Filter s)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Filter s -> Process (Filter s)) -> Filter s -> Process (Filter s)
forall a b. (a -> b) -> a -> b
$ s -> ExitReason -> Filter s
forall s. s -> ExitReason -> Filter s
FilterStop s
s ExitReason
filterFail) :: s -> m -> Process (Filter s)
                     }

-- TODO: add the type rep for a more descriptive failure message

filterFail :: ExitReason
filterFail :: ExitReason
filterFail = String -> ExitReason
ExitOther String
"Control.Distributed.Process.ManagedProcess.Priority:FilterFailed"

-- | Sets an explicit priority from 1..100. Values > 100 are rounded to 100,
-- and values < 1 are set to 0.
setPriority :: Int -> Priority m
setPriority :: forall m. Int -> Priority m
setPriority Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1     = Int -> Priority m
forall m. Int -> Priority m
Priority Int
0
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
100   = Int -> Priority m
forall m. Int -> Priority m
Priority Int
100
  | Bool
otherwise = Int -> Priority m
forall m. Int -> Priority m
Priority Int
n

-- | Prioritise a call handler, ignoring the server's state
prioritiseCall_ :: forall s a b . (Serializable a, Serializable b)
                => (a -> Priority b)
                -> DispatchPriority s
prioritiseCall_ :: forall s a b.
(Serializable a, Serializable b) =>
(a -> Priority b) -> DispatchPriority s
prioritiseCall_ a -> Priority b
h = (s -> a -> Priority b) -> DispatchPriority s
forall s a b.
(Serializable a, Serializable b) =>
(s -> a -> Priority b) -> DispatchPriority s
prioritiseCall ((a -> Priority b) -> s -> a -> Priority b
forall a b. a -> b -> a
const a -> Priority b
h)

-- | Prioritise a call handler
prioritiseCall :: forall s a b . (Serializable a, Serializable b)
               => (s -> a -> Priority b)
               -> DispatchPriority s
prioritiseCall :: forall s a b.
(Serializable a, Serializable b) =>
(s -> a -> Priority b) -> DispatchPriority s
prioritiseCall s -> a -> Priority b
h = (s -> Message -> Process (Maybe (Int, Message)))
-> DispatchPriority s
forall s.
(s -> Message -> Process (Maybe (Int, Message)))
-> DispatchPriority s
PrioritiseCall ((a -> Priority b) -> Message -> Process (Maybe (Int, Message))
unCall ((a -> Priority b) -> Message -> Process (Maybe (Int, Message)))
-> (s -> a -> Priority b)
-> s
-> Message
-> Process (Maybe (Int, Message))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> a -> Priority b
h)
  where
    unCall :: (a -> Priority b) -> P.Message -> Process (Maybe (Int, P.Message))
    unCall :: (a -> Priority b) -> Message -> Process (Maybe (Int, Message))
unCall a -> Priority b
h' Message
m = (Maybe (Message a b) -> Maybe (Int, Message))
-> Process (Maybe (Message a b)) -> Process (Maybe (Int, Message))
forall a b. (a -> b) -> Process a -> Process b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Message
-> (a -> Priority b) -> Maybe (Message a b) -> Maybe (Int, Message)
matchPrioritise Message
m a -> Priority b
h') (Message -> Process (Maybe (Message a b))
forall (m :: * -> *) a.
(Monad m, Serializable a) =>
Message -> m (Maybe a)
unwrapMessage Message
m)

    matchPrioritise :: P.Message
                    -> (a -> Priority b)
                    -> Maybe (Message a b)
                    -> Maybe (Int, P.Message)
    matchPrioritise :: Message
-> (a -> Priority b) -> Maybe (Message a b) -> Maybe (Int, Message)
matchPrioritise Message
msg a -> Priority b
p Maybe (Message a b)
msgIn
      | (Just a :: Message a b
a@(CallMessage a
m CallRef b
_)) <- Maybe (Message a b)
msgIn
      , Bool
True  <- Message -> Bool
isEncoded Message
msg = (Int, Message) -> Maybe (Int, Message)
forall a. a -> Maybe a
Just (Priority b -> Int
forall a. Priority a -> Int
getPrio (Priority b -> Int) -> Priority b -> Int
forall a b. (a -> b) -> a -> b
$ a -> Priority b
p a
m, Message a b -> Message
forall a. Serializable a => a -> Message
wrapMessage Message a b
a)
      | (Just   (CallMessage a
m CallRef b
_)) <- Maybe (Message a b)
msgIn
      , Bool
False <- Message -> Bool
isEncoded Message
msg = (Int, Message) -> Maybe (Int, Message)
forall a. a -> Maybe a
Just (Priority b -> Int
forall a. Priority a -> Int
getPrio (Priority b -> Int) -> Priority b -> Int
forall a b. (a -> b) -> a -> b
$ a -> Priority b
p a
m, Message
msg)
      | Bool
otherwise              = Maybe (Int, Message)
forall a. Maybe a
Nothing

-- | Prioritise a cast handler, ignoring the server's state
prioritiseCast_ :: forall s a . (Serializable a)
                => (a -> Priority ())
                -> DispatchPriority s
prioritiseCast_ :: forall s a.
Serializable a =>
(a -> Priority ()) -> DispatchPriority s
prioritiseCast_ a -> Priority ()
h = (s -> a -> Priority ()) -> DispatchPriority s
forall s a.
Serializable a =>
(s -> a -> Priority ()) -> DispatchPriority s
prioritiseCast ((a -> Priority ()) -> s -> a -> Priority ()
forall a b. a -> b -> a
const a -> Priority ()
h)

-- | Prioritise a cast handler
prioritiseCast :: forall s a . (Serializable a)
               => (s -> a -> Priority ())
               -> DispatchPriority s
prioritiseCast :: forall s a.
Serializable a =>
(s -> a -> Priority ()) -> DispatchPriority s
prioritiseCast s -> a -> Priority ()
h = (s -> Message -> Process (Maybe (Int, Message)))
-> DispatchPriority s
forall s.
(s -> Message -> Process (Maybe (Int, Message)))
-> DispatchPriority s
PrioritiseCast ((a -> Priority ()) -> Message -> Process (Maybe (Int, Message))
unCast ((a -> Priority ()) -> Message -> Process (Maybe (Int, Message)))
-> (s -> a -> Priority ())
-> s
-> Message
-> Process (Maybe (Int, Message))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> a -> Priority ()
h)
  where
    unCast :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message))
    unCast :: (a -> Priority ()) -> Message -> Process (Maybe (Int, Message))
unCast a -> Priority ()
h' Message
m = (Maybe (Message a ()) -> Maybe (Int, Message))
-> Process (Maybe (Message a ())) -> Process (Maybe (Int, Message))
forall a b. (a -> b) -> Process a -> Process b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Message
-> (a -> Priority ())
-> Maybe (Message a ())
-> Maybe (Int, Message)
matchPrioritise Message
m a -> Priority ()
h') (Message -> Process (Maybe (Message a ()))
forall (m :: * -> *) a.
(Monad m, Serializable a) =>
Message -> m (Maybe a)
unwrapMessage Message
m)

    matchPrioritise :: P.Message
                    -> (a -> Priority ())
                    -> Maybe (Message a ())
                    -> Maybe (Int, P.Message)
    matchPrioritise :: Message
-> (a -> Priority ())
-> Maybe (Message a ())
-> Maybe (Int, Message)
matchPrioritise Message
msg a -> Priority ()
p Maybe (Message a ())
msgIn
      | (Just a :: Message a ()
a@(CastMessage a
m)) <- Maybe (Message a ())
msgIn
      , Bool
True  <- Message -> Bool
isEncoded Message
msg = (Int, Message) -> Maybe (Int, Message)
forall a. a -> Maybe a
Just (Priority () -> Int
forall a. Priority a -> Int
getPrio (Priority () -> Int) -> Priority () -> Int
forall a b. (a -> b) -> a -> b
$ a -> Priority ()
p a
m, Message a () -> Message
forall a. Serializable a => a -> Message
wrapMessage Message a ()
a)
      | (Just   (CastMessage a
m)) <- Maybe (Message a ())
msgIn
      , Bool
False <- Message -> Bool
isEncoded Message
msg = (Int, Message) -> Maybe (Int, Message)
forall a. a -> Maybe a
Just (Priority () -> Int
forall a. Priority a -> Int
getPrio (Priority () -> Int) -> Priority () -> Int
forall a b. (a -> b) -> a -> b
$ a -> Priority ()
p a
m, Message
msg)
      | Bool
otherwise              = Maybe (Int, Message)
forall a. Maybe a
Nothing

-- | Prioritise an info handler, ignoring the server's state
prioritiseInfo_ :: forall s a . (Serializable a)
                => (a -> Priority ())
                -> DispatchPriority s
prioritiseInfo_ :: forall s a.
Serializable a =>
(a -> Priority ()) -> DispatchPriority s
prioritiseInfo_ a -> Priority ()
h = (s -> a -> Priority ()) -> DispatchPriority s
forall s a.
Serializable a =>
(s -> a -> Priority ()) -> DispatchPriority s
prioritiseInfo ((a -> Priority ()) -> s -> a -> Priority ()
forall a b. a -> b -> a
const a -> Priority ()
h)

-- | Prioritise an info handler
prioritiseInfo :: forall s a . (Serializable a)
               => (s -> a -> Priority ())
               -> DispatchPriority s
prioritiseInfo :: forall s a.
Serializable a =>
(s -> a -> Priority ()) -> DispatchPriority s
prioritiseInfo s -> a -> Priority ()
h = (s -> Message -> Process (Maybe (Int, Message)))
-> DispatchPriority s
forall s.
(s -> Message -> Process (Maybe (Int, Message)))
-> DispatchPriority s
PrioritiseInfo ((a -> Priority ()) -> Message -> Process (Maybe (Int, Message))
unMsg ((a -> Priority ()) -> Message -> Process (Maybe (Int, Message)))
-> (s -> a -> Priority ())
-> s
-> Message
-> Process (Maybe (Int, Message))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> a -> Priority ()
h)
  where
    unMsg :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message))
    unMsg :: (a -> Priority ()) -> Message -> Process (Maybe (Int, Message))
unMsg a -> Priority ()
h' Message
m = (Maybe a -> Maybe (Int, Message))
-> Process (Maybe a) -> Process (Maybe (Int, Message))
forall a b. (a -> b) -> Process a -> Process b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Message -> (a -> Priority ()) -> Maybe a -> Maybe (Int, Message)
matchPrioritise Message
m a -> Priority ()
h') (Message -> Process (Maybe a)
forall (m :: * -> *) a.
(Monad m, Serializable a) =>
Message -> m (Maybe a)
unwrapMessage Message
m)

    matchPrioritise :: P.Message
                    -> (a -> Priority ())
                    -> Maybe a
                    -> Maybe (Int, P.Message)
    matchPrioritise :: Message -> (a -> Priority ()) -> Maybe a -> Maybe (Int, Message)
matchPrioritise Message
msg a -> Priority ()
p Maybe a
msgIn
      | (Just a
m') <- Maybe a
msgIn
      , Bool
True <- Message -> Bool
isEncoded Message
msg  = (Int, Message) -> Maybe (Int, Message)
forall a. a -> Maybe a
Just (Priority () -> Int
forall a. Priority a -> Int
getPrio (Priority () -> Int) -> Priority () -> Int
forall a b. (a -> b) -> a -> b
$ a -> Priority ()
p a
m', a -> Message
forall a. Serializable a => a -> Message
wrapMessage a
m')
      | (Just a
m') <- Maybe a
msgIn
      , Bool
False <- Message -> Bool
isEncoded Message
msg = (Int, Message) -> Maybe (Int, Message)
forall a. a -> Maybe a
Just (Priority () -> Int
forall a. Priority a -> Int
getPrio (Priority () -> Int) -> Priority () -> Int
forall a b. (a -> b) -> a -> b
$ a -> Priority ()
p a
m', Message
msg)
      | Bool
otherwise              = Maybe (Int, Message)
forall a. Maybe a
Nothing