{-# LANGUAGE DataKinds #-}
{-# 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,
    UntypedMethodHandler,
    handleUntypedMethod,

    -- ** Working with untyped data
    untypedHandler,
    toUntypedHandler,
    fromUntypedHandler,
  )
where

import Capnp.Message (Mutability (..))
import Capnp.Rpc.Promise (Fulfiller)
import Capnp.Untyped (Ptr)
import Control.Concurrent.STM
import Data.Typeable (Typeable)
import Data.Word
import qualified Internal.TCloseQ as TCloseQ

-- | a @'MethodHandler' p r@ handles a method call with parameters @p@
-- and return type @r@.
--
-- 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 p r = MethodHandler
  { forall p r.
MethodHandler p r
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
handleMethod ::
      Maybe (Ptr 'Const) ->
      Fulfiller (Maybe (Ptr 'Const)) ->
      IO ()
  }

-- | Alias for a 'MethodHandler' whose parameter and return types are
-- untyped pointers.
type UntypedMethodHandler = MethodHandler (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))

handleUntypedMethod :: UntypedMethodHandler -> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
handleUntypedMethod :: UntypedMethodHandler
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
handleUntypedMethod = forall p r.
MethodHandler p r
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
handleMethod

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

-- | Inverse of 'toUntypedHandler'
fromUntypedHandler :: UntypedMethodHandler -> MethodHandler p r
fromUntypedHandler :: forall p r. UntypedMethodHandler -> MethodHandler p r
fromUntypedHandler MethodHandler {Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
handleMethod :: Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
handleMethod :: forall p r.
MethodHandler p r
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
..} = MethodHandler {Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
handleMethod :: Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
handleMethod :: Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
..}

-- | 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 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()) ->
  MethodHandler (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const))
untypedHandler :: (Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ())
-> UntypedMethodHandler
untypedHandler = forall p r.
(Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ())
-> MethodHandler p r
MethodHandler

-- | Base class for things that can act as capnproto servers.
class Server a where
  -- | Called when the last live reference to a server is dropped.
  shutdown :: a -> IO ()
  shutdown a
_ = 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
_ = 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 = ServerOps
  { -- | Handle a method call; takes the interface and method id and returns
    -- a handler for the specific method.
    ServerOps -> Word64 -> Word16 -> UntypedMethodHandler
handleCall ::
      Word64 ->
      Word16 ->
      MethodHandler (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)),
    -- | Handle shutting-down the receiver; this is called when the last
    -- reference to the capability is dropped.
    ServerOps -> IO ()
handleStop :: IO (),
    -- | used to unwrap the server when reflecting on a local client.
    ServerOps -> forall a. Typeable a => Maybe a
handleCast :: forall a. Typeable a => Maybe a
  }

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

-- | 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 ()
runServer :: Q CallInfo -> ServerOps -> IO ()
runServer Q CallInfo
q ServerOps
ops = IO ()
go
  where
    go :: IO ()
go =
      forall a. STM a -> IO a
atomically (forall a. Q a -> STM (Maybe a)
TCloseQ.read Q CallInfo
q) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe CallInfo
Nothing ->
          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
          forall p r.
MethodHandler p r
-> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()
handleMethod
            (ServerOps -> Word64 -> Word16 -> UntypedMethodHandler
handleCall ServerOps
ops Word64
interfaceId Word16
methodId)
            Maybe (Ptr 'Const)
arguments
            Fulfiller (Maybe (Ptr 'Const))
response
          IO ()
go