{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Capnp.GenHelpers.Rpc where
import Control.Exception.Safe (fromException, tryAny)
import Control.Monad.Catch (MonadThrow (..))
import Data.Default (def)
import Capnp.Classes (Decerialize (..), FromPtr (..))
import Capnp.Message (Mutability (..))
import Capnp.TraversalLimit (evalLimitT)
import qualified Capnp.Errors as E
import qualified Capnp.GenHelpers.Pure as PH
import qualified Capnp.Message as M
import qualified Capnp.Rpc.Promise as Promise
import qualified Capnp.Rpc.Untyped as Rpc
import qualified Capnp.Untyped as U
handleMethod :: t -> (t -> t -> m a) -> Maybe (Ptr 'Const) -> Fulfiller a -> m ()
handleMethod t
server t -> t -> m a
method Maybe (Ptr 'Const)
paramContent Fulfiller a
fulfiller = do
Either SomeException a
ret <- m a -> m (Either SomeException a)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny (m a -> m (Either SomeException a))
-> m a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ do
t
content <- WordCount -> LimitT m t -> m t
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
forall a. Bounded a => a
maxBound (LimitT m t -> m t) -> LimitT m t -> m t
forall a b. (a -> b) -> a -> b
$
Message 'Const -> Maybe (Ptr 'Const) -> LimitT m (Cerial 'Const t)
forall (mut :: Mutability) a (m :: * -> *).
(FromPtr mut a, ReadCtx m mut) =>
Message mut -> Maybe (Ptr mut) -> m a
fromPtr Message 'Const
M.empty Maybe (Ptr 'Const)
paramContent LimitT m (Cerial 'Const t)
-> (Cerial 'Const t -> LimitT m t) -> LimitT m t
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cerial 'Const t -> LimitT m t
forall a (m :: * -> *).
(Decerialize a, ReadCtx m 'Const) =>
Cerial 'Const a -> m a
decerialize
a
results <- t -> t -> m a
method t
content t
server
WordCount -> LimitT m a -> m a
forall (m :: * -> *) a.
MonadThrow m =>
WordCount -> LimitT m a -> m a
evalLimitT WordCount
forall a. Bounded a => a
maxBound (LimitT m a -> m a) -> LimitT m a -> m a
forall a b. (a -> b) -> a -> b
$ a -> LimitT m a
forall (m :: * -> *) s a b.
(RWCtx m s, MonadReadMessage 'Const m, Cerialize s a,
ToStruct ('Mut s) (Cerial ('Mut s) a), Decerialize b,
FromStruct 'Const (Cerial 'Const b)) =>
a -> m b
PH.convertValue a
results
case Either SomeException a
ret of
Right a
resultStruct ->
Fulfiller a -> a -> m ()
forall (m :: * -> *) a. MonadSTM m => Fulfiller a -> a -> m ()
Promise.fulfill Fulfiller a
fulfiller a
resultStruct
Left SomeException
e ->
case SomeException -> Maybe Exception
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just Exception
exn ->
Fulfiller a -> Exception -> m ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
Promise.breakPromise Fulfiller a
fulfiller Exception
exn
Maybe Exception
Nothing ->
Fulfiller a -> Exception -> m ()
forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Exception -> m ()
Promise.breakPromise Fulfiller a
fulfiller Exception
forall a. Default a => a
def
{ $sel:type_:Exception :: Exception'Type
Rpc.type_ = Exception'Type
Rpc.Exception'Type'failed
, $sel:reason:Exception :: Text
Rpc.reason = Text
"Method threw an unhandled exception."
}
isClientFromPtr :: (Rpc.IsClient a, U.ReadCtx m mut) => M.Message mut -> Maybe (U.Ptr mut) -> m a
isClientFromPtr :: Message mut -> Maybe (Ptr mut) -> m a
isClientFromPtr Message mut
_ Maybe (Ptr mut)
Nothing = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ Client -> a
forall a. IsClient a => Client -> a
Rpc.fromClient Client
Rpc.nullClient
isClientFromPtr Message mut
_ (Just (U.PtrCap Cap mut
cap)) = Client -> a
forall a. IsClient a => Client -> a
Rpc.fromClient (Client -> a) -> m Client -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cap mut -> m Client
forall (m :: * -> *) (mut :: Mutability).
ReadCtx m mut =>
Cap mut -> m Client
U.getClient Cap mut
cap
isClientFromPtr Message mut
_ (Just Ptr mut
_) = Error -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Error -> m a) -> Error -> m a
forall a b. (a -> b) -> a -> b
$ String -> Error
E.SchemaViolationError String
"Expected capability pointer"
isClientToPtr :: (Rpc.IsClient a, M.WriteCtx m s) => M.Message ('Mut s) -> a -> m (Maybe (U.Ptr ('Mut s)))
isClientToPtr :: Message ('Mut s) -> a -> m (Maybe (Ptr ('Mut s)))
isClientToPtr Message ('Mut s)
msg a
client = do
Cap ('Mut s)
cap <- Message ('Mut s) -> Client -> m (Cap ('Mut s))
forall (m :: * -> *) s.
WriteCtx m s =>
Message ('Mut s) -> Client -> m (Cap ('Mut s))
U.appendCap Message ('Mut s)
msg (a -> Client
forall a. IsClient a => a -> Client
Rpc.toClient a
client)
Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s))))
-> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s)))
forall a b. (a -> b) -> a -> b
$ Ptr ('Mut s) -> Maybe (Ptr ('Mut s))
forall a. a -> Maybe a
Just (Ptr ('Mut s) -> Maybe (Ptr ('Mut s)))
-> Ptr ('Mut s) -> Maybe (Ptr ('Mut s))
forall a b. (a -> b) -> a -> b
$ Cap ('Mut s) -> Ptr ('Mut s)
forall (mut :: Mutability). Cap mut -> Ptr mut
U.PtrCap Cap ('Mut s)
cap