{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Capnp.Rpc.Server
( Server(..)
, ServerOps(..)
, CallInfo(..)
, runServer
, MethodHandler
, untypedHandler
, toUntypedHandler
, fromUntypedHandler
) where
import Control.Concurrent.STM
import Data.Word
import Data.Typeable (Typeable)
import Capnp.Message (Mutability(..))
import Capnp.Rpc.Promise (Fulfiller)
import Capnp.Untyped (Ptr)
import qualified Internal.TCloseQ as TCloseQ
newtype MethodHandler m p r = MethodHandler
{ MethodHandler m p r
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod
:: Maybe (Ptr 'Const)
-> Fulfiller (Maybe (Ptr 'Const))
-> m ()
}
toUntypedHandler
:: MethodHandler m p r
-> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
toUntypedHandler :: MethodHandler m p r
-> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
toUntypedHandler MethodHandler{Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod :: Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod :: forall (m :: * -> *) p r.
MethodHandler m p r
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
..} = MethodHandler :: forall (m :: * -> *) p r.
(Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ())
-> MethodHandler m p r
MethodHandler{Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod :: Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod :: Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
..}
fromUntypedHandler
:: MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
-> MethodHandler m p r
fromUntypedHandler :: MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
-> MethodHandler m p r
fromUntypedHandler MethodHandler{Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod :: Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod :: forall (m :: * -> *) p r.
MethodHandler m p r
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
..} = MethodHandler :: forall (m :: * -> *) p r.
(Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ())
-> MethodHandler m p r
MethodHandler{Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod :: Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod :: Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
..}
untypedHandler
:: (Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ())
-> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
untypedHandler :: (Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ())
-> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
untypedHandler = (Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ())
-> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
forall (m :: * -> *) p r.
(Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ())
-> MethodHandler m p r
MethodHandler
class Monad m => Server m a | a -> m where
shutdown :: a -> m ()
shutdown a
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
unwrap :: Typeable b => a -> Maybe b
unwrap a
_ = Maybe b
forall a. Maybe a
Nothing
data ServerOps m = ServerOps
{ ServerOps m
-> Word64
-> Word16
-> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
handleCall
:: Word64
-> Word16
-> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
, ServerOps m -> m ()
handleStop :: m ()
, ServerOps m -> forall a. Typeable a => Maybe a
handleCast :: forall a. Typeable a => Maybe a
}
data CallInfo = CallInfo
{ CallInfo -> Word64
interfaceId :: !Word64
, CallInfo -> Word16
methodId :: !Word16
, CallInfo -> Maybe (Ptr 'Const)
arguments :: Maybe (Ptr 'Const)
, CallInfo -> Fulfiller (Maybe (Ptr 'Const))
response :: Fulfiller (Maybe (Ptr 'Const))
}
runServer :: TCloseQ.Q CallInfo -> ServerOps IO -> IO ()
runServer :: Q CallInfo -> ServerOps IO -> IO ()
runServer Q CallInfo
q ServerOps IO
ops = IO ()
go
where
go :: IO ()
go = STM (Maybe CallInfo) -> IO (Maybe CallInfo)
forall a. STM a -> IO a
atomically (Q CallInfo -> STM (Maybe CallInfo)
forall a. Q a -> STM (Maybe a)
TCloseQ.read Q CallInfo
q) IO (Maybe CallInfo) -> (Maybe CallInfo -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe CallInfo
Nothing ->
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just CallInfo{Word64
interfaceId :: Word64
interfaceId :: CallInfo -> Word64
interfaceId, Word16
methodId :: Word16
methodId :: CallInfo -> Word16
methodId, Maybe (Ptr 'Const)
arguments :: Maybe (Ptr 'Const)
arguments :: CallInfo -> Maybe (Ptr 'Const)
arguments, Fulfiller (Maybe (Ptr 'Const))
response :: Fulfiller (Maybe (Ptr 'Const))
response :: CallInfo -> Fulfiller (Maybe (Ptr 'Const))
response} -> do
MethodHandler IO (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
forall (m :: * -> *) p r.
MethodHandler m p r
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()
handleMethod
(ServerOps IO
-> Word64
-> Word16
-> MethodHandler IO (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
forall (m :: * -> *).
ServerOps m
-> Word64
-> Word16
-> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
handleCall ServerOps IO
ops Word64
interfaceId Word16
methodId)
Maybe (Ptr 'Const)
arguments
Fulfiller (Maybe (Ptr 'Const))
response
IO ()
go