{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}
-- |
-- Module: Capnp.GenHelpers.Rpc
-- Description: Rpc-system helpers for genrated code.
--
-- This module defines various helpers used by generated code. Users
-- of the library are not expected to use this module directly.
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."
                        }

-- | A valid implementation of 'fromPtr' for any type that implements 'IsClient'.
--
-- GHC gets very confused if we try to just define a single instance
-- @IsClient a => FromPtr msg a@, so instead we define this helper function and
-- emit a trivial instance for each type from the code generator.
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"

-- | A valid implementation of 'toPtr' for any type that implements 'IsClient'.
--
-- See the notes for 'isClientFromPtr'.
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