-- | Functions to implement 'Api' __servers__.
module Control.Eff.Concurrent.Api.Server
(
-- * Api Server
serve
, ApiHandler(..)
-- * ApiHandler default callbacks
, unhandledCallError
, unhandledCastError
, defaultTermination
-- * Multi Api Server
, serveBoth
, serve3
, tryApiHandler
, UnhandledRequest()
, catchUnhandled
, ensureAllHandled
, requestFromDynamic
, exitUnhandled
)
where
import Control.Eff
import qualified Control.Eff.Exception as Exc
import Control.Eff.Extend
import Control.Eff.Concurrent.Api
import Control.Eff.Concurrent.Api.Internal
import Control.Eff.Concurrent.Process
import Data.Proxy
import Data.Typeable ( Typeable
, typeRep
)
import Data.Dynamic
import GHC.Stack
-- | Receive and process incoming requests until the process exits, using an 'ApiHandler'.
serve
:: forall r q p
. (Typeable p, SetMember Process (Process q) r, HasCallStack)
=> SchedulerProxy q
-> ApiHandler p r
-> Eff r ()
serve px handlers = receiveLoop px $ \case
Left Nothing -> applyApiHandler px handlers (Terminate Nothing)
Left (Just reason) -> applyApiHandler px handlers (Terminate (Just reason))
Right dyn -> ensureAllHandled
px
(do
msg <- requestFromDynamic dyn
raise (applyApiHandler px handlers msg)
)
-- | A record of callbacks, handling requests sent to a /server/ 'Process', all
-- belonging to a specific 'Api' family instance.
data ApiHandler p r where
ApiHandler ::
{ -- | A cast will not return a result directly. This is used for async
-- methods.
_handleCast
:: HasCallStack
=> Api p 'Asynchronous -> Eff r ()
-- | A call is a blocking operation, the caller is blocked until this
-- handler calls the reply continuation.
, _handleCall
:: forall x . HasCallStack
=> Api p ('Synchronous x) -> (x -> Eff r ()) -> Eff r ()
-- | This callback is called with @Nothing@ if the process exits
-- peacefully, or @Just "error message..."@ if the process exits with an
-- error. This function is responsible to exit the process if necessary.
-- The default behavior is defined in 'defaultTermination'.
, _handleTerminate
:: HasCallStack
=> Maybe String -> Eff r ()
} -> ApiHandler p r
-- | Apply either the '_handleCall', '_handleCast' or the '_handleTerminate'
-- callback to an incoming request. Note, it is unlikely that this function must be used.
applyApiHandler
:: forall r q p
. (Typeable p, SetMember Process (Process q) r, HasCallStack)
=> SchedulerProxy q
-> ApiHandler p r
-> Request p
-> Eff r ()
applyApiHandler _px handlers (Terminate e) = _handleTerminate handlers e
applyApiHandler _ handlers (Cast request) = _handleCast handlers request
applyApiHandler px handlers (Call fromPid request) = _handleCall handlers
request
sendReply
where
sendReply :: Typeable x => x -> Eff r ()
sendReply reply =
sendMessage px fromPid (toDyn $! (Response (Proxy @p) $! reply))
-- | A default handler to use in '_handleCall' in 'ApiHandler'. It will call
-- 'raiseError' with a nice error message.
unhandledCallError
:: forall p x r q
. ( Show (Api p ( 'Synchronous x))
, Typeable p
, HasCallStack
, SetMember Process (Process q) r
)
=> SchedulerProxy q
-> Api p ( 'Synchronous x)
-> (x -> Eff r ())
-> Eff r ()
unhandledCallError px api _ = withFrozenCallStack $ raiseError
px
("Unhandled call: (" ++ show api ++ " :: " ++ show (typeRep (Proxy @p)) ++ ")"
)
-- | A default handler to use in '_handleCast' in 'ApiHandler'. It will call
-- 'raiseError' with a nice error message.
unhandledCastError
:: forall p r q
. ( Show (Api p 'Asynchronous)
, Typeable p
, HasCallStack
, SetMember Process (Process q) r
)
=> SchedulerProxy q
-> Api p 'Asynchronous
-> Eff r ()
unhandledCastError px api = withFrozenCallStack $ raiseError
px
("Unhandled cast: (" ++ show api ++ " :: " ++ show (typeRep (Proxy @p)) ++ ")"
)
-- | Exit the process either normally of the error message is @Nothing@
-- or with 'exitWithError' otherwise.
defaultTermination
:: forall q r
. (HasCallStack, SetMember Process (Process q) r)
=> SchedulerProxy q
-> Maybe String
-> Eff r ()
defaultTermination px =
withFrozenCallStack $ maybe (exitNormally px) (exitWithError px)
-- | 'serve' two 'ApiHandler's at once. The first handler is used for
-- termination handling.
serveBoth
:: forall r q p1 p2
. ( Typeable p1
, Typeable p2
, SetMember Process (Process q) r
, HasCallStack
)
=> SchedulerProxy q
-> ApiHandler p1 r
-> ApiHandler p2 r
-> Eff r ()
serveBoth px h1 h2 = receiveLoop px $ \case
Left Nothing -> applyApiHandler px h1 (Terminate Nothing)
Left (Just reason) -> applyApiHandler px h1 (Terminate (Just reason))
Right dyn -> ensureAllHandled
px
(tryApiHandler px h1 dyn `catchUnhandled` tryApiHandler px h2)
-- | 'serve' three 'ApiHandler's at once. The first handler is used for
-- termination handling.
serve3
:: forall r q p1 p2 p3
. ( Typeable p1
, Typeable p2
, Typeable p3
, SetMember Process (Process q) r
, HasCallStack
)
=> SchedulerProxy q
-> ApiHandler p1 r
-> ApiHandler p2 r
-> ApiHandler p3 r
-> Eff r ()
serve3 px h1 h2 h3 = receiveLoop px $ \mReq -> case mReq of
Left Nothing -> applyApiHandler px h1 (Terminate Nothing)
Left (Just reason) -> applyApiHandler px h1 (Terminate (Just reason))
Right dyn -> ensureAllHandled
px
( tryApiHandler px h1 dyn
`catchUnhandled` tryApiHandler px h2
`catchUnhandled` tryApiHandler px h3
)
-- | The basic building block of the combination of 'ApiHandler's is this
-- function, which can not only be passed to 'receiveLoop', but also throws an
-- 'UnhandledRequest' exception if 'requestFromDynamic' failed, such that multiple
-- invokation of this function for different 'ApiHandler's can be tried, by using 'catchUnhandled'.
--
-- > tryApiHandler px handlers1 message
-- > `catchUnhandled`
-- > tryApiHandler px handlers2
-- > `catchUnhandled`
-- > tryApiHandler px handlers3
--
tryApiHandler
:: forall r q p
. (Typeable p, SetMember Process (Process q) r, HasCallStack)
=> SchedulerProxy q
-> ApiHandler p r
-> Dynamic
-> Eff (Exc.Exc UnhandledRequest ': r) ()
tryApiHandler px handlers message = do
request <- requestFromDynamic message
raise (applyApiHandler px handlers request)
-- | An exception that is used by the mechanism that chains together multiple
-- different 'ApiHandler' allowing a single process to implement multiple
-- 'Api's. This exception is thrown by 'requestFromDynamic'. This
-- exception can be caught with 'catchUnhandled', this way, several
-- distinct 'ApiHandler' can be tried until one /fits/ or until the
-- 'exitUnhandled' is invoked.
newtype UnhandledRequest = UnhandledRequest { fromUnhandledRequest :: Dynamic }
-- | If 'requestFromDynamic' failes to cast the message to a 'Request' for a
-- certain 'ApiHandler' it throws an 'UnhandledRequest' exception. That
-- exception is caught by this function and the raw message is given to the
-- handler function. This is the basis for chaining 'ApiHandler's.
catchUnhandled
:: forall r a
. (Member (Exc.Exc UnhandledRequest) r, HasCallStack)
=> Eff r a
-> (Dynamic -> Eff r a)
-> Eff r a
catchUnhandled effect handler =
withFrozenCallStack $ effect `Exc.catchError` (handler . fromUnhandledRequest)
-- | Catch 'UnhandledRequest's and terminate the process with an error, if necessary.
ensureAllHandled
:: forall r q
. (HasCallStack, SetMember Process (Process q) r)
=> SchedulerProxy q
-> Eff (Exc.Exc UnhandledRequest ': r) ()
-> Eff r ()
ensureAllHandled px effect = withFrozenCallStack $ do
result <- Exc.runError effect
either (exitUnhandled px . fromUnhandledRequest) return result
-- | Cast a 'Dynamic' value, and if that fails, throw an 'UnhandledRequest'
-- error.
requestFromDynamic
:: forall r a
. (HasCallStack, Typeable a, Member (Exc.Exc UnhandledRequest) r)
=> Dynamic
-> Eff r a
requestFromDynamic message = withFrozenCallStack $ maybe
(Exc.throwError (UnhandledRequest message))
return
(fromDynamic message)
-- | If an incoming message could not be casted to a 'Request' corresponding to
-- an 'ApiHandler' (e.g. with 'requestFromDynamic') one should use this function to
-- exit the process with a corresponding error.
exitUnhandled
:: forall r q
. (SetMember Process (Process q) r, HasCallStack)
=> SchedulerProxy q
-> Dynamic
-> Eff r ()
exitUnhandled px message = withFrozenCallStack $ do
let reason = "unhandled message: " ++ show message
exitWithError px reason