module Control.Eff.Concurrent.Api.Server
(
serve
, ApiHandler(..)
, unhandledCallError
, unhandledCastError
, defaultTermination
, 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
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)
)
data ApiHandler p r where
ApiHandler ::
{
_handleCast
:: HasCallStack
=> Api p 'Asynchronous -> Eff r ()
, _handleCall
:: forall x . HasCallStack
=> Api p ('Synchronous x) -> (x -> Eff r ()) -> Eff r ()
, _handleTerminate
:: HasCallStack
=> Maybe String -> Eff r ()
} -> ApiHandler p r
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))
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 _ = raiseError
px
("Unhandled call: (" ++ show api ++ " :: " ++ show (typeRep (Proxy @p)) ++ ")"
)
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 = raiseError
px
("Unhandled cast: (" ++ show api ++ " :: " ++ show (typeRep (Proxy @p)) ++ ")"
)
defaultTermination
:: forall q r
. (HasCallStack, SetMember Process (Process q) r)
=> SchedulerProxy q
-> Maybe String
-> Eff r ()
defaultTermination px = maybe (exitNormally px) (exitWithError px)
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)
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
)
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)
newtype UnhandledRequest = UnhandledRequest { fromUnhandledRequest :: Dynamic }
catchUnhandled
:: forall r a
. (Member (Exc.Exc UnhandledRequest) r, HasCallStack)
=> Eff r a
-> (Dynamic -> Eff r a)
-> Eff r a
catchUnhandled effect handler =
effect `Exc.catchError` (handler . fromUnhandledRequest)
ensureAllHandled
:: forall r q
. (HasCallStack, SetMember Process (Process q) r)
=> SchedulerProxy q
-> Eff (Exc.Exc UnhandledRequest ': r) ()
-> Eff r ()
ensureAllHandled px effect = do
result <- Exc.runError effect
either (exitUnhandled px . fromUnhandledRequest) return result
requestFromDynamic
:: forall r a
. (HasCallStack, Typeable a, Member (Exc.Exc UnhandledRequest) r)
=> Dynamic
-> Eff r a
requestFromDynamic message =
maybe (Exc.throwError (UnhandledRequest message)) return (fromDynamic message)
exitUnhandled
:: forall r q
. (SetMember Process (Process q) r, HasCallStack)
=> SchedulerProxy q
-> Dynamic
-> Eff r ()
exitUnhandled px message = do
let reason = "unhandled message: " ++ show message
exitWithError px reason