{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}
module Control.Eff.Concurrent.Api.Server
( ApiHandler (..)
, serve
, unhandledCallError
, unhandledCastError
, defaultTermination
, serveBoth
, serve3
, tryApiHandler
, UnhandledRequest()
, catchUnhandled
, ensureAllHandled
, castMessage
, exitUnhandled
)
where
import Control.Eff
import Control.Eff.InternalExtra
import qualified Control.Eff.Exception as Exc
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
$ \ mReq ->
case mReq of
Left Nothing ->
applyApiHandler px handlers (Terminate Nothing)
Left (Just reason) ->
applyApiHandler px handlers (Terminate (Just reason))
Right dyn ->
ensureAllHandled px
(do msg <- castMessage 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 Bool) -> 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 Bool
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 Bool)
-> 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 e =
maybe (exitNormally px) (exitWithError px) e
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
$ \ 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)
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 <- castMessage 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
castMessage :: forall r a .
( HasCallStack
, Typeable a
, Member (Exc.Exc UnhandledRequest) r)
=> Dynamic -> Eff r a
castMessage 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