module Control.Eff.Concurrent.Api.Client
(
cast
, call
, callWithTimeout
, castRegistered
, callRegistered
, ServesApi
, ServerReader
, whereIsServer
, registerServer
)
where
import Control.Eff
import Control.Eff.Reader.Strict
import Control.Eff.Concurrent.Api
import Control.Eff.Concurrent.Api.Request
import Control.Eff.Concurrent.Process
import Control.Eff.Concurrent.Process.Timer
import Control.Eff.Log
import Data.Typeable ( Typeable )
import Data.Type.Pretty
import Control.DeepSeq
import GHC.Stack
cast
:: forall r q o
. ( HasCallStack
, SetMember Process (Process q) r
, PrettyTypeShow (ToPretty o)
, Member Interrupts r
, Typeable o
, Typeable (Api o 'Asynchronous)
, NFData (Api o 'Asynchronous)
)
=> Server o
-> Api o 'Asynchronous
-> Eff r ()
cast (Server pid) castMsg = sendMessage pid (Cast castMsg)
call
:: forall result api r q
. ( SetMember Process (Process q) r
, Member Interrupts r
, Typeable api
, PrettyTypeShow (ToPretty api)
, Typeable (Api api ( 'Synchronous result))
, NFData (Api api ( 'Synchronous result))
, Typeable result
, NFData result
, Show result
, HasCallStack
)
=> Server api
-> Api api ( 'Synchronous result)
-> Eff r result
call (Server pidInternal) req = do
callRef <- makeReference
fromPid <- self
let requestMessage = Call callRef fromPid $! req
sendMessage pidInternal requestMessage
let selectResult :: MessageSelector result
selectResult =
let extractResult
:: Reply (Api api ( 'Synchronous result)) -> Maybe result
extractResult (Reply _pxResult callRefMsg result) =
if callRefMsg == callRef then Just result else Nothing
in selectMessageWith extractResult
resultOrError <- receiveWithMonitor pidInternal selectResult
either (interrupt . becauseProcessIsDown) return resultOrError
callWithTimeout
:: forall result api r q
. ( SetMember Process (Process q) r
, Member Interrupts r
, Typeable api
, Typeable (Api api ( 'Synchronous result))
, NFData (Api api ( 'Synchronous result))
, Typeable result
, NFData result
, Show result
, Member Logs r
, Lifted IO q
, Lifted IO r
, HasCallStack
, PrettyTypeShow (ToPretty api)
)
=> Server api
-> Api api ( 'Synchronous result)
-> Timeout
-> Eff r result
callWithTimeout serverP@(Server pidInternal) req timeOut = do
fromPid <- self
callRef <- makeReference
let requestMessage = Call callRef fromPid $! req
sendMessage pidInternal requestMessage
let selectResult =
let extractResult
:: Reply (Api api ( 'Synchronous result)) -> Maybe result
extractResult (Reply _pxResult callRefMsg result) =
if callRefMsg == callRef then Just result else Nothing
in selectMessageWith extractResult
resultOrError <- receiveSelectedWithMonitorAfter pidInternal selectResult timeOut
let onTimeout timerRef = do
let msg = "call timed out after "
++ show timeOut ++ " to server: "
++ show serverP ++ " from "
++ show fromPid ++ " "
++ show timerRef
logWarning' msg
interrupt (TimeoutInterrupt msg)
onProcDown p = do
logWarning' ("call to dead server: "++ show serverP ++ " from " ++ show fromPid)
interrupt (becauseProcessIsDown p)
either (either onProcDown onTimeout) return resultOrError
type ServesApi o r q =
( Typeable o
, PrettyTypeShow (ToPretty o)
, SetMember Process (Process q) r
, Member (ServerReader o) r
)
type ServerReader o = Reader (Server o)
registerServer
:: HasCallStack => Server o -> Eff (ServerReader o ': r) a -> Eff r a
registerServer = runReader
whereIsServer :: Member (ServerReader o) e => Eff e (Server o)
whereIsServer = ask
callRegistered
:: ( Typeable reply
, ServesApi o r q
, HasCallStack
, NFData reply
, Show reply
, NFData (Api o ( 'Synchronous reply))
, Member Interrupts r
)
=> Api o ( 'Synchronous reply)
-> Eff r reply
callRegistered method = do
serverPid <- whereIsServer
call serverPid method
castRegistered
:: (Typeable o, ServesApi o r q, HasCallStack, Member Interrupts r, NFData (Api o 'Asynchronous))
=> Api o 'Asynchronous
-> Eff r ()
castRegistered method = do
serverPid <- whereIsServer
cast serverPid method