{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE NamedFieldPuns         #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-|
Module: Capnp.Rpc.Server
Description: handlers for incoming method calls.

The term server in this context refers to a thread that handles method calls for
a particular capability (The capnproto rpc protocol itself has no concept of
clients and servers).
-}
module Capnp.Rpc.Server
    ( Server(..)
    , ServerOps(..)
    , CallInfo(..)
    , runServer

    -- * Handling methods
    , MethodHandler
    -- ** Using high-level representations
    , pureHandler
    -- ** Using low-level representations
    , rawHandler
    , rawAsyncHandler
    -- ** Always throwing exceptions
    , methodThrow
    , methodUnimplemented
    -- ** Working with untyped data
    , untypedHandler
    , toUntypedHandler
    , fromUntypedHandler

    -- * Invoking methods
    , invoke
    ) where

import Control.Concurrent.STM
import Control.Monad.STM.Class
import Data.Word

import Control.Exception.Safe  (MonadCatch, finally, try)
import Control.Monad.IO.Class  (MonadIO, liftIO)
import Control.Monad.Primitive (PrimMonad, PrimState)
import Data.Typeable           (Typeable)

import Capnp.Classes
    ( Cerialize
    , Decerialize(Cerial, decerialize)
    , FromPtr(fromPtr)
    , ToStruct(toStruct)
    )
import Capnp.Convert        (valueToMsg)
import Capnp.Message        (ConstMsg, MutMsg)
import Capnp.Rpc.Errors     (eMethodUnimplemented, wrapException)
import Capnp.Rpc.Promise    (Fulfiller, breakPromise, fulfill, newCallback)
import Capnp.TraversalLimit (defaultLimit, evalLimitT)
import Capnp.Untyped        (Ptr)
import Data.Mutable         (freeze)

import qualified Capnp.Gen.Capnp.Rpc.Pure as RpcGen
import qualified Capnp.Message            as Message
import qualified Capnp.Untyped            as Untyped
import qualified Internal.TCloseQ         as TCloseQ

-- | a @'MethodHandler' m p r@ handles a method call with parameters @p@
-- and return type @r@, in monad @m@.
--
-- The library represents method handlers via an abstract type
-- 'MethodHandler', parametrized over parameter (@p@) and return (@r@)
-- types, and the monadic context in which it runs (@m@). This allows us
-- to provide different strategies for actually handling methods; there
-- are various helper functions which construct these handlers.
--
-- At some point we will likely additionally provide handlers affording:
--
-- * Working directly with the low-level data types.
-- * Replying to the method call asynchronously, allowing later method
--   calls to be serviced before the current one is finished.
newtype MethodHandler m p r = MethodHandler
    { MethodHandler m p r
-> Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod
        :: Maybe (Ptr ConstMsg)
        -> Fulfiller (Maybe (Ptr ConstMsg))
        -> m ()
    }

invoke
    :: MonadSTM m
    => MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
    -> Maybe (Ptr ConstMsg)
    -> Fulfiller (Maybe (Ptr ConstMsg))
    -> m ()
invoke :: MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
-> Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
invoke = MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
-> Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
forall (m :: * -> *) p r.
MethodHandler m p r
-> Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod

-- | @'pureHandler' f cap@ is a 'MethodHandler' which calls a function @f@
-- that accepts the receiver and the parameter type as exposed by the
-- high-level API, and returns the high-level API representation of the
-- return type.
pureHandler ::
    ( MonadCatch m
    , MonadSTM m
    , PrimMonad m
    , s ~ PrimState m
    , Decerialize p
    , FromPtr ConstMsg (Cerial ConstMsg p)
    , Cerialize s r
    , ToStruct (MutMsg s) (Cerial (MutMsg s) r)
    ) =>
    (cap -> p -> m r)
    -> cap
    -> MethodHandler m p r
pureHandler :: (cap -> p -> m r) -> cap -> MethodHandler m p r
pureHandler cap -> p -> m r
f cap
cap = MethodHandler :: forall (m :: * -> *) p r.
(Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m p r
MethodHandler
    { handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod = \Maybe (Ptr ConstMsg)
ptr Fulfiller (Maybe (Ptr ConstMsg))
reply -> do
        p
param <- WordCount -> LimitT m p -> m p
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT m p -> m p) -> LimitT m p -> m p
forall a b. (a -> b) -> a -> b
$
            ConstMsg -> Maybe (Ptr ConstMsg) -> LimitT m (Cerial ConstMsg p)
forall msg a (m :: * -> *).
(FromPtr msg a, ReadCtx m msg) =>
msg -> Maybe (Ptr msg) -> m a
fromPtr ConstMsg
Message.empty Maybe (Ptr ConstMsg)
ptr LimitT m (Cerial ConstMsg p)
-> (Cerial ConstMsg p -> LimitT m p) -> LimitT m p
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cerial ConstMsg p -> LimitT m p
forall a (m :: * -> *).
(Decerialize a, ReadCtx m ConstMsg) =>
Cerial ConstMsg a -> m a
decerialize
        Either SomeException r
result <- m r -> m (Either SomeException r)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m r -> m (Either SomeException r))
-> m r -> m (Either SomeException r)
forall a b. (a -> b) -> a -> b
$ cap -> p -> m r
f cap
cap p
param
        case Either SomeException r
result of
            Right r
val -> do
                Struct ConstMsg
struct <- WordCount -> LimitT m (Struct ConstMsg) -> m (Struct ConstMsg)
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT m (Struct ConstMsg) -> m (Struct ConstMsg))
-> LimitT m (Struct ConstMsg) -> m (Struct ConstMsg)
forall a b. (a -> b) -> a -> b
$
                    r -> LimitT m (MutMsg s)
forall (m :: * -> *) s a.
(MonadLimit m, WriteCtx m s, Cerialize s a,
 ToStruct (MutMsg s) (Cerial (MutMsg s) a)) =>
a -> m (MutMsg s)
valueToMsg r
val LimitT m (MutMsg s)
-> (MutMsg s -> LimitT m ConstMsg) -> LimitT m ConstMsg
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutMsg s -> LimitT m ConstMsg
forall a (m :: * -> *) s.
(Thaw a, PrimMonad m, PrimState m ~ s) =>
Mutable s a -> m a
freeze LimitT m ConstMsg
-> (ConstMsg -> LimitT m (Struct ConstMsg))
-> LimitT m (Struct ConstMsg)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConstMsg -> LimitT m (Struct ConstMsg)
forall (m :: * -> *) msg. ReadCtx m msg => msg -> m (Struct msg)
Untyped.rootPtr
                STM () -> m ()
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ Fulfiller (Maybe (Ptr ConstMsg)) -> Maybe (Ptr ConstMsg) -> STM ()
forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller (Maybe (Ptr ConstMsg))
reply (Ptr ConstMsg -> Maybe (Ptr ConstMsg)
forall a. a -> Maybe a
Just (Struct ConstMsg -> Ptr ConstMsg
forall msg. Struct msg -> Ptr msg
Untyped.PtrStruct Struct ConstMsg
struct))
            Left SomeException
e ->
                -- TODO: find a way to get the connection config's debugMode
                -- option to be accessible from here, so we can use it.
                STM () -> m ()
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ Fulfiller (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
reply (Bool -> SomeException -> Exception
wrapException Bool
False SomeException
e)
    }

-- | Like 'pureHandler', except that the parameter and return value use the
-- low-level representation.
rawHandler ::
    ( MonadCatch m
    , MonadSTM m
    , PrimMonad m
    , s ~ PrimState m
    , Decerialize p
    , FromPtr ConstMsg (Cerial ConstMsg p)
    , Decerialize r
    , ToStruct ConstMsg (Cerial ConstMsg r)
    ) =>
    (cap -> Cerial ConstMsg p -> m (Cerial ConstMsg r))
    -> cap
    -> MethodHandler m p r
rawHandler :: (cap -> Cerial ConstMsg p -> m (Cerial ConstMsg r))
-> cap -> MethodHandler m p r
rawHandler cap -> Cerial ConstMsg p -> m (Cerial ConstMsg r)
f cap
cap = MethodHandler :: forall (m :: * -> *) p r.
(Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m p r
MethodHandler
    { handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod = \Maybe (Ptr ConstMsg)
ptr Fulfiller (Maybe (Ptr ConstMsg))
reply -> do
        Cerial ConstMsg p
cerial <- WordCount -> LimitT m (Cerial ConstMsg p) -> m (Cerial ConstMsg p)
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT m (Cerial ConstMsg p) -> m (Cerial ConstMsg p))
-> LimitT m (Cerial ConstMsg p) -> m (Cerial ConstMsg p)
forall a b. (a -> b) -> a -> b
$ ConstMsg -> Maybe (Ptr ConstMsg) -> LimitT m (Cerial ConstMsg p)
forall msg a (m :: * -> *).
(FromPtr msg a, ReadCtx m msg) =>
msg -> Maybe (Ptr msg) -> m a
fromPtr ConstMsg
Message.empty Maybe (Ptr ConstMsg)
ptr
        Either SomeException (Cerial ConstMsg r)
result <- m (Cerial ConstMsg r)
-> m (Either SomeException (Cerial ConstMsg r))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m (Cerial ConstMsg r)
 -> m (Either SomeException (Cerial ConstMsg r)))
-> m (Cerial ConstMsg r)
-> m (Either SomeException (Cerial ConstMsg r))
forall a b. (a -> b) -> a -> b
$ cap -> Cerial ConstMsg p -> m (Cerial ConstMsg r)
f cap
cap Cerial ConstMsg p
cerial
        case Either SomeException (Cerial ConstMsg r)
result of
            Right Cerial ConstMsg r
val -> STM () -> m ()
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ Fulfiller (Maybe (Ptr ConstMsg)) -> Maybe (Ptr ConstMsg) -> STM ()
forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller (Maybe (Ptr ConstMsg))
reply (Ptr ConstMsg -> Maybe (Ptr ConstMsg)
forall a. a -> Maybe a
Just (Struct ConstMsg -> Ptr ConstMsg
forall msg. Struct msg -> Ptr msg
Untyped.PtrStruct (Cerial ConstMsg r -> Struct ConstMsg
forall msg a. ToStruct msg a => a -> Struct msg
toStruct Cerial ConstMsg r
val)))
            Left SomeException
e -> STM () -> m ()
forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ Fulfiller (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
reply (Bool -> SomeException -> Exception
wrapException Bool
False SomeException
e)
    }

-- | Like 'rawHandler', except that it takes a fulfiller for the result,
-- instead of returning it. This allows the result to be supplied some time
-- after the method returns, making it possible to service other method
-- calls before the result is available.
rawAsyncHandler ::
    ( MonadCatch m
    , MonadSTM m
    , PrimMonad m
    , s ~ PrimState m
    , Decerialize p
    , FromPtr ConstMsg (Cerial ConstMsg p)
    , Decerialize r
    , ToStruct ConstMsg (Cerial ConstMsg r)
    ) =>
    (cap -> Cerial ConstMsg p -> Fulfiller (Cerial ConstMsg r) -> m ())
    -> cap
    -> MethodHandler m p r
rawAsyncHandler :: (cap -> Cerial ConstMsg p -> Fulfiller (Cerial ConstMsg r) -> m ())
-> cap -> MethodHandler m p r
rawAsyncHandler cap -> Cerial ConstMsg p -> Fulfiller (Cerial ConstMsg r) -> m ()
f cap
cap = MethodHandler :: forall (m :: * -> *) p r.
(Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m p r
MethodHandler
    { handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod = \Maybe (Ptr ConstMsg)
ptr Fulfiller (Maybe (Ptr ConstMsg))
reply -> do
        Fulfiller (Cerial ConstMsg r)
fulfiller <- (Either Exception (Cerial ConstMsg r) -> STM ())
-> m (Fulfiller (Cerial ConstMsg r))
forall (m :: * -> *) a.
MonadSTM m =>
(Either Exception a -> STM ()) -> m (Fulfiller a)
newCallback ((Either Exception (Cerial ConstMsg r) -> STM ())
 -> m (Fulfiller (Cerial ConstMsg r)))
-> (Either Exception (Cerial ConstMsg r) -> STM ())
-> m (Fulfiller (Cerial ConstMsg r))
forall a b. (a -> b) -> a -> b
$ \case
            Left Exception
e  -> Fulfiller (Maybe (Ptr ConstMsg)) -> Exception -> STM ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
reply Exception
e
            Right Cerial ConstMsg r
v -> Fulfiller (Maybe (Ptr ConstMsg)) -> Maybe (Ptr ConstMsg) -> STM ()
forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller (Maybe (Ptr ConstMsg))
reply (Maybe (Ptr ConstMsg) -> STM ()) -> Maybe (Ptr ConstMsg) -> STM ()
forall a b. (a -> b) -> a -> b
$ Ptr ConstMsg -> Maybe (Ptr ConstMsg)
forall a. a -> Maybe a
Just (Struct ConstMsg -> Ptr ConstMsg
forall msg. Struct msg -> Ptr msg
Untyped.PtrStruct (Cerial ConstMsg r -> Struct ConstMsg
forall msg a. ToStruct msg a => a -> Struct msg
toStruct Cerial ConstMsg r
v))
        Cerial ConstMsg p
cerial <- WordCount -> LimitT m (Cerial ConstMsg p) -> m (Cerial ConstMsg p)
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit (LimitT m (Cerial ConstMsg p) -> m (Cerial ConstMsg p))
-> LimitT m (Cerial ConstMsg p) -> m (Cerial ConstMsg p)
forall a b. (a -> b) -> a -> b
$ ConstMsg -> Maybe (Ptr ConstMsg) -> LimitT m (Cerial ConstMsg p)
forall msg a (m :: * -> *).
(FromPtr msg a, ReadCtx m msg) =>
msg -> Maybe (Ptr msg) -> m a
fromPtr ConstMsg
Message.empty Maybe (Ptr ConstMsg)
ptr
        cap -> Cerial ConstMsg p -> Fulfiller (Cerial ConstMsg r) -> m ()
f cap
cap Cerial ConstMsg p
cerial Fulfiller (Cerial ConstMsg r)
fulfiller
    }

-- | Convert a 'MethodHandler' for any parameter and return types into
-- one that deals with untyped pointers.
toUntypedHandler
    :: MethodHandler m p r
    -> MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
toUntypedHandler :: MethodHandler m p r
-> MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
toUntypedHandler MethodHandler{Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod :: forall (m :: * -> *) p r.
MethodHandler m p r
-> Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
..} = MethodHandler :: forall (m :: * -> *) p r.
(Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m p r
MethodHandler{Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
..}

-- | Inverse of 'toUntypedHandler'
fromUntypedHandler
    :: MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
    -> MethodHandler m p r
fromUntypedHandler :: MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
-> MethodHandler m p r
fromUntypedHandler MethodHandler{Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod :: forall (m :: * -> *) p r.
MethodHandler m p r
-> Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
..} = MethodHandler :: forall (m :: * -> *) p r.
(Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m p r
MethodHandler{Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
..}

-- | Construct a method handler from a function accepting an untyped
-- pointer for the method's parameter, and a 'Fulfiller' which accepts
-- an untyped pointer for the method's return value.
untypedHandler
    :: (Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
    -> MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
untypedHandler :: (Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
untypedHandler = (Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
forall (m :: * -> *) p r.
(Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m p r
MethodHandler

-- | @'methodThrow' exn@ is a 'MethodHandler' which always throws @exn@.
methodThrow :: MonadIO m => RpcGen.Exception -> MethodHandler m p r
methodThrow :: Exception -> MethodHandler m p r
methodThrow Exception
exn = MethodHandler :: forall (m :: * -> *) p r.
(Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ())
-> MethodHandler m p r
MethodHandler
    { handleMethod :: Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod = \Maybe (Ptr ConstMsg)
_ Fulfiller (Maybe (Ptr ConstMsg))
fulfiller -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Fulfiller (Maybe (Ptr ConstMsg)) -> Exception -> IO ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr ConstMsg))
fulfiller Exception
exn
    }

-- | A 'MethodHandler' which always throws an @unimplemented@ exception.
methodUnimplemented :: MonadIO m => MethodHandler m p r
methodUnimplemented :: MethodHandler m p r
methodUnimplemented = Exception -> MethodHandler m p r
forall (m :: * -> *) p r.
MonadIO m =>
Exception -> MethodHandler m p r
methodThrow Exception
eMethodUnimplemented

-- | Base class for things that can act as capnproto servers.
class Monad m => Server m a | a -> m where
    -- | Called when the last live reference to a server is dropped.
    shutdown :: a -> m ()
    shutdown a
_ = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- | Try to extract a value of a given type. The default implementation
    -- always fails (returns 'Nothing'). If an instance chooses to implement
    -- this, it will be possible to use "reflection" on clients that point
    -- at local servers to dynamically unwrap the server value. A typical
    -- implementation will just call Typeable's @cast@ method, but this
    -- needn't be the case -- a server may wish to allow local peers to
    -- unwrap some value that is not exactly the data the server has access
    -- to.
    unwrap :: Typeable b => a -> Maybe b
    unwrap a
_ = Maybe b
forall a. Maybe a
Nothing

-- | The operations necessary to receive and handle method calls, i.e.
-- to implement an object. It is parametrized over the monadic context
-- in which methods are serviced.
data ServerOps m = ServerOps
    { ServerOps m
-> Word64
-> Word16
-> MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
handleCall
        :: Word64
        -> Word16
        -> MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
    -- ^ Handle a method call; takes the interface and method id and returns
    -- a handler for the specific method.
    , ServerOps m -> m ()
handleStop :: m ()
    -- ^ Handle shutting-down the receiver; this is called when the last
    -- reference to the capability is dropped.
    , ServerOps m -> forall a. Typeable a => Maybe a
handleCast :: forall a. Typeable a => Maybe a
    -- ^ used to unwrap the server when reflecting on a local client.
    }

-- | A 'CallInfo' contains information about a method call.
data CallInfo = CallInfo
    { CallInfo -> Word64
interfaceId :: !Word64
    -- ^ The id of the interface whose method is being called.
    , CallInfo -> Word16
methodId    :: !Word16
    -- ^ The method id of the method being called.
    , CallInfo -> Maybe (Ptr ConstMsg)
arguments   :: Maybe (Ptr ConstMsg)
    -- ^ The arguments to the method call.
    , CallInfo -> Fulfiller (Maybe (Ptr ConstMsg))
response    :: Fulfiller (Maybe (Ptr ConstMsg))
    -- ^ A 'Fulfiller' which accepts the method's return value.
    }

-- | Handle incoming messages for a given object.
--
-- Accepts a queue of messages to handle, and 'ServerOps' used to handle them.
-- returns when it receives a 'Stop' message.
runServer :: TCloseQ.Q CallInfo -> ServerOps IO -> IO ()
runServer :: Q CallInfo -> ServerOps IO -> IO ()
runServer Q CallInfo
q ServerOps IO
ops = IO ()
go IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` ServerOps IO -> IO ()
forall (m :: * -> *). ServerOps m -> m ()
handleStop ServerOps IO
ops
  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 ConstMsg)
arguments :: Maybe (Ptr ConstMsg)
arguments :: CallInfo -> Maybe (Ptr ConstMsg)
arguments, Fulfiller (Maybe (Ptr ConstMsg))
response :: Fulfiller (Maybe (Ptr ConstMsg))
response :: CallInfo -> Fulfiller (Maybe (Ptr ConstMsg))
response} -> do
            MethodHandler IO (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
-> Maybe (Ptr ConstMsg)
-> Fulfiller (Maybe (Ptr ConstMsg))
-> IO ()
forall (m :: * -> *) p r.
MethodHandler m p r
-> Maybe (Ptr ConstMsg) -> Fulfiller (Maybe (Ptr ConstMsg)) -> m ()
handleMethod
                (ServerOps IO
-> Word64
-> Word16
-> MethodHandler IO (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
forall (m :: * -> *).
ServerOps m
-> Word64
-> Word16
-> MethodHandler m (Maybe (Ptr ConstMsg)) (Maybe (Ptr ConstMsg))
handleCall ServerOps IO
ops Word64
interfaceId Word16
methodId)
                Maybe (Ptr ConstMsg)
arguments
                Fulfiller (Maybe (Ptr ConstMsg))
response
            IO ()
go