{-# 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, serve_, unhandledCallError, unhandledCastError )
where
import Control.Eff
import Control.Eff.Concurrent.Api
import Control.Eff.Concurrent.Api.Internal
import Control.Eff.Concurrent.MessagePassing
import Control.Lens
import Control.Monad
import Data.Kind
import Data.Proxy
import Data.Typeable (Typeable, typeRep)
import GHC.Stack
data ApiHandler p r e where
ApiHandler ::
{ _handleCast
:: (Typeable p, Typeable (Api p 'Asynchronous), HasCallStack)
=> Api p 'Asynchronous -> Eff r e
, _handleCall
:: forall x . (Typeable p, Typeable (Api p ('Synchronous x)), Typeable x, HasCallStack)
=> Api p ('Synchronous x) -> (x -> Eff r Bool) -> Eff r e
, _handleTerminate
:: (Typeable p, HasCallStack)
=> String -> Eff r ()
} -> ApiHandler p r e
serve_
:: forall r p
. (Typeable p, Member MessagePassing r, Member Process r, HasCallStack)
=> ApiHandler p r ()
-> Eff r ()
serve_ = void . serve
serve
:: forall r p e
. (Typeable p, Member MessagePassing r, Member Process r, HasCallStack)
=> ApiHandler p r e
-> Eff r (Message e)
serve (ApiHandler handleCast handleCall handleTerminate) = do
mReq <- receiveMessage (Proxy @(Request p))
mapM receiveCallReq mReq >>= catchProcessControlMessage
where
catchProcessControlMessage :: Message e -> Eff r (Message e)
catchProcessControlMessage s@(ProcessControlMessage msg) =
handleTerminate msg >> return s
catchProcessControlMessage s = return s
receiveCallReq :: Request p -> Eff r e
receiveCallReq (Cast request ) = handleCast request
receiveCallReq (Call fromPid request) = handleCall request
(sendReply request)
where
sendReply :: Typeable x => Api p ( 'Synchronous x) -> x -> Eff r Bool
sendReply _ reply = sendMessage fromPid (Response (Proxy :: Proxy p) reply)
unhandledCallError
:: ( Show (Api p ( 'Synchronous x))
, Typeable p
, Typeable (Api p ( 'Synchronous x))
, Typeable x
, HasCallStack
, Member Process r
)
=> Api p ( 'Synchronous x)
-> (x -> Eff r Bool)
-> Eff r e
unhandledCallError api _ = raiseError
("Unhandled call: (" ++ show api ++ " :: " ++ show (typeRep api) ++ ")")
unhandledCastError
:: ( Show (Api p 'Asynchronous)
, Typeable p
, Typeable (Api p 'Asynchronous)
, HasCallStack
, Member Process r
)
=> Api p 'Asynchronous
-> Eff r e
unhandledCastError api = raiseError
("Unhandled cast: (" ++ show api ++ " :: " ++ show (typeRep api) ++ ")")