{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Capnp.Rpc.Server
( CallHandler,
MethodHandler,
UntypedMethodHandler,
CallInfo (..),
ServerOps (..),
Export (..),
exportToServerOps,
findMethod,
SomeServer (..),
runServer,
castHandler,
handleParsed,
handleRaw,
methodUnimplemented,
toUntypedMethodHandler,
MethodHandlerTree (..),
)
where
import qualified Capnp.Basics as B
import qualified Capnp.Classes as C
import Capnp.Convert (parsedToRaw)
import Capnp.Message (Mutability (..))
import qualified Capnp.Repr as R
import Capnp.Rpc.Errors
( eFailed,
eMethodUnimplemented,
wrapException,
)
import Capnp.Rpc.Promise
( Fulfiller,
breakPromise,
fulfill,
)
import Capnp.TraversalLimit (defaultLimit, evalLimitT)
import qualified Capnp.Untyped as U
import Control.Concurrent.STM (atomically)
import Control.Exception.Safe (withException)
import Data.Function ((&))
import Data.Functor.Contravariant (contramap)
import Data.Kind (Constraint, Type)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable)
import qualified Data.Vector as V
import Data.Word
import GHC.Prim (coerce)
import Internal.BuildPure (createPure)
import qualified Internal.TCloseQ as TCloseQ
data CallInfo = CallInfo
{
CallInfo -> Word64
interfaceId :: !Word64,
CallInfo -> Word16
methodId :: !Word16,
CallInfo -> Maybe (Ptr 'Const)
arguments :: Maybe (U.Ptr 'Const),
CallInfo -> Fulfiller (Maybe (Ptr 'Const))
response :: Fulfiller (Maybe (U.Ptr 'Const))
}
data ServerOps = ServerOps
{
ServerOps -> Word64 -> Word16 -> UntypedMethodHandler
handleCall :: Word64 -> Word16 -> UntypedMethodHandler,
ServerOps -> IO ()
handleStop :: IO (),
ServerOps -> forall a. Typeable a => Maybe a
handleCast :: forall a. Typeable a => Maybe a
}
type CallHandler = M.Map Word64 (V.Vector UntypedMethodHandler)
type MethodHandler p r =
R.Raw p 'Const ->
Fulfiller (R.Raw r 'Const) ->
IO ()
castHandler ::
forall p q r s.
(R.ReprFor p ~ R.ReprFor q, R.ReprFor r ~ R.ReprFor s) =>
MethodHandler p r ->
MethodHandler q s
castHandler :: forall p q r s.
(ReprFor p ~ ReprFor q, ReprFor r ~ ReprFor s) =>
MethodHandler p r -> MethodHandler q s
castHandler = coerce :: forall a b. Coercible a b => a -> b
coerce
type UntypedMethodHandler = MethodHandler (Maybe B.AnyPointer) (Maybe B.AnyPointer)
class SomeServer a where
shutdown :: a -> IO ()
shutdown a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
unwrap :: Typeable b => a -> Maybe b
unwrap a
_ = forall a. Maybe a
Nothing
class (R.IsCap i, C.HasTypeId i) => Export i where
type Server i :: Type -> Constraint
methodHandlerTree :: Server i s => Proxy i -> s -> MethodHandlerTree
data MethodHandlerTree = MethodHandlerTree
{
MethodHandlerTree -> Word64
mhtId :: Word64,
MethodHandlerTree -> [UntypedMethodHandler]
mhtHandlers :: [UntypedMethodHandler],
MethodHandlerTree -> [MethodHandlerTree]
mhtParents :: [MethodHandlerTree]
}
mhtToCallHandler :: MethodHandlerTree -> CallHandler
mhtToCallHandler :: MethodHandlerTree -> CallHandler
mhtToCallHandler = CallHandler -> [MethodHandlerTree] -> CallHandler
go forall k a. Map k a
M.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
where
go :: CallHandler -> [MethodHandlerTree] -> CallHandler
go CallHandler
accum [] = CallHandler
accum
go CallHandler
accum (MethodHandlerTree
t : [MethodHandlerTree]
ts)
| MethodHandlerTree -> Word64
mhtId MethodHandlerTree
t forall k a. Ord k => k -> Map k a -> Bool
`M.member` CallHandler
accum = CallHandler -> [MethodHandlerTree] -> CallHandler
go CallHandler
accum [MethodHandlerTree]
ts
| Bool
otherwise =
CallHandler -> [MethodHandlerTree] -> CallHandler
go (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (MethodHandlerTree -> Word64
mhtId MethodHandlerTree
t) (forall a. [a] -> Vector a
V.fromList (MethodHandlerTree -> [UntypedMethodHandler]
mhtHandlers MethodHandlerTree
t)) CallHandler
accum) (MethodHandlerTree -> [MethodHandlerTree]
mhtParents MethodHandlerTree
t forall a. [a] -> [a] -> [a]
++ [MethodHandlerTree]
ts)
findMethod :: Word64 -> Word16 -> CallHandler -> Maybe UntypedMethodHandler
findMethod :: Word64 -> Word16 -> CallHandler -> Maybe UntypedMethodHandler
findMethod Word64
interfaceId Word16
methodId CallHandler
handler = do
Vector UntypedMethodHandler
iface <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Word64
interfaceId CallHandler
handler
Vector UntypedMethodHandler
iface forall a. Vector a -> Int -> Maybe a
V.!? forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
methodId
toUntypedMethodHandler ::
forall p r.
(R.IsStruct p, R.IsStruct r) =>
MethodHandler p r ->
UntypedMethodHandler
toUntypedMethodHandler :: forall p r.
(IsStruct p, IsStruct r) =>
MethodHandler p r -> UntypedMethodHandler
toUntypedMethodHandler MethodHandler p r
h =
\case
R.Raw (Just (U.PtrStruct Struct 'Const
param)) -> \Fulfiller (Raw (Maybe AnyPointer) 'Const)
ret ->
MethodHandler p r
h
(forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw Struct 'Const
param)
( forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap
(\(R.Raw Unwrapped (Untyped (ReprFor r) 'Const)
s) -> forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (mut :: Mutability). Struct mut -> Ptr mut
U.PtrStruct Unwrapped (Untyped (ReprFor r) 'Const)
s)
Fulfiller (Raw (Maybe AnyPointer) 'Const)
ret
)
Raw (Maybe AnyPointer) 'Const
_ ->
\Fulfiller (Raw (Maybe AnyPointer) 'Const)
ret -> forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller (Raw (Maybe AnyPointer) 'Const)
ret (Text -> Parsed Exception
eFailed Text
"Parameter was not a struct")
someServerToServerOps :: SomeServer a => a -> CallHandler -> ServerOps
someServerToServerOps :: forall a. SomeServer a => a -> CallHandler -> ServerOps
someServerToServerOps a
srv CallHandler
callHandler =
ServerOps
{ $sel:handleStop:ServerOps :: IO ()
handleStop = forall a. SomeServer a => a -> IO ()
shutdown a
srv,
$sel:handleCast:ServerOps :: forall a. Typeable a => Maybe a
handleCast = forall a b. (SomeServer a, Typeable b) => a -> Maybe b
unwrap a
srv,
$sel:handleCall:ServerOps :: Word64 -> Word16 -> UntypedMethodHandler
handleCall = \Word64
interfaceId Word16
methodId ->
Word64 -> Word16 -> CallHandler -> Maybe UntypedMethodHandler
findMethod Word64
interfaceId Word16
methodId CallHandler
callHandler
forall a b. a -> (a -> b) -> b
& forall a. a -> Maybe a -> a
fromMaybe forall p r. MethodHandler p r
methodUnimplemented
}
exportToServerOps :: forall i s. (Export i, Server i s, SomeServer s) => Proxy i -> s -> ServerOps
exportToServerOps :: forall i s.
(Export i, Server i s, SomeServer s) =>
Proxy i -> s -> ServerOps
exportToServerOps Proxy i
proxy s
srv =
MethodHandlerTree -> CallHandler
mhtToCallHandler (forall i s.
(Export i, Server i s) =>
Proxy i -> s -> MethodHandlerTree
methodHandlerTree Proxy i
proxy s
srv)
forall a b. a -> (a -> b) -> b
& forall a. SomeServer a => a -> CallHandler -> ServerOps
someServerToServerOps s
srv
handleParsed ::
( C.Parse p pp,
R.IsStruct p,
C.Parse r pr,
R.IsStruct r
) =>
(pp -> IO pr) ->
MethodHandler p r
handleParsed :: forall p pp r pr.
(Parse p pp, IsStruct p, Parse r pr, IsStruct r) =>
(pp -> IO pr) -> MethodHandler p r
handleParsed pp -> IO pr
handler Raw p 'Const
param = forall a b. (Fulfiller a -> IO b) -> Fulfiller a -> IO b
propagateExceptions forall a b. (a -> b) -> a -> b
$ \Fulfiller (Raw r 'Const)
f -> do
pp
p <- forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
defaultLimit forall a b. (a -> b) -> a -> b
$ forall t p (m :: * -> *).
(Parse t p, ReadCtx m 'Const) =>
Raw t 'Const -> m p
C.parse Raw p 'Const
param
pr
r <- pp -> IO pr
handler pp
p
Struct 'Const
struct <- forall (m :: * -> *) (f :: Mutability -> *).
(MonadThrow m, MaybeMutable f) =>
WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const)
createPure forall a. Bounded a => a
maxBound forall a b. (a -> b) -> a -> b
$ forall a (mut :: Mutability).
Raw a mut -> Unwrapped (Untyped (ReprFor a) mut)
R.fromRaw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *) pa s.
(RWCtx m s, IsStruct a, Parse a pa) =>
pa -> m (Raw a ('Mut s))
parsedToRaw pr
r
forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller (Raw r 'Const)
f (forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw Struct 'Const
struct)
handleRaw ::
(R.IsStruct p, R.IsStruct r) =>
(R.Raw p 'Const -> IO (R.Raw r 'Const)) ->
MethodHandler p r
handleRaw :: forall p r.
(IsStruct p, IsStruct r) =>
(Raw p 'Const -> IO (Raw r 'Const)) -> MethodHandler p r
handleRaw Raw p 'Const -> IO (Raw r 'Const)
handler Raw p 'Const
param = forall a b. (Fulfiller a -> IO b) -> Fulfiller a -> IO b
propagateExceptions forall a b. (a -> b) -> a -> b
$ \Fulfiller (Raw r 'Const)
f ->
Raw p 'Const -> IO (Raw r 'Const)
handler Raw p 'Const
param forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
fulfill Fulfiller (Raw r 'Const)
f
propagateExceptions :: (Fulfiller a -> IO b) -> Fulfiller a -> IO b
propagateExceptions :: forall a b. (Fulfiller a -> IO b) -> Fulfiller a -> IO b
propagateExceptions Fulfiller a -> IO b
h Fulfiller a
f =
Fulfiller a -> IO b
h Fulfiller a
f forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
`withException` (forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SomeException -> Parsed Exception
wrapException Bool
False)
methodUnimplemented :: MethodHandler p r
methodUnimplemented :: forall p r. MethodHandler p r
methodUnimplemented Raw p 'Const
_ Fulfiller (Raw r 'Const)
f = forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller (Raw r 'Const)
f Parsed Exception
eMethodUnimplemented
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
$sel:interfaceId:CallInfo :: CallInfo -> Word64
interfaceId, Word16
methodId :: Word16
$sel:methodId:CallInfo :: CallInfo -> Word16
methodId, Maybe (Ptr 'Const)
arguments :: Maybe (Ptr 'Const)
$sel:arguments:CallInfo :: CallInfo -> Maybe (Ptr 'Const)
arguments, Fulfiller (Maybe (Ptr 'Const))
response :: Fulfiller (Maybe (Ptr 'Const))
$sel:response:CallInfo :: CallInfo -> Fulfiller (Maybe (Ptr 'Const))
response} ->
do
ServerOps -> Word64 -> Word16 -> UntypedMethodHandler
handleCall ServerOps
ops Word64
interfaceId Word16
methodId (forall a (mut :: Mutability).
Unwrapped (Untyped (ReprFor a) mut) -> Raw a mut
R.Raw Maybe (Ptr 'Const)
arguments) (coerce :: forall a b. Coercible a b => a -> b
coerce Fulfiller (Maybe (Ptr 'Const))
response)
IO ()
go