{-# 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.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 ConstMsg) -> Fulfiller a -> m ()
handleMethod t
server t -> t -> m a
method Maybe (Ptr ConstMsg)
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
$
            ConstMsg -> Maybe (Ptr ConstMsg) -> LimitT m (Cerial ConstMsg t)
forall msg a (m :: * -> *).
(FromPtr msg a, ReadCtx m msg) =>
msg -> Maybe (Ptr msg) -> m a
fromPtr ConstMsg
M.empty Maybe (Ptr ConstMsg)
paramContent LimitT m (Cerial ConstMsg t)
-> (Cerial ConstMsg t -> LimitT m t) -> LimitT m t
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cerial ConstMsg t -> LimitT m t
forall a (m :: * -> *).
(Decerialize a, ReadCtx m ConstMsg) =>
Cerial ConstMsg 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, Message m ConstMsg, Cerialize s a,
 ToStruct (MutMsg s) (Cerial (MutMsg s) a), Decerialize b,
 FromStruct ConstMsg (Cerial ConstMsg 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 msg) => msg -> Maybe (U.Ptr msg) -> m a
isClientFromPtr :: msg -> Maybe (Ptr msg) -> m a
isClientFromPtr msg
_ Maybe (Ptr msg)
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 msg
_ (Just (U.PtrCap Cap msg
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 msg -> m Client
forall (m :: * -> *) msg. ReadCtx m msg => Cap msg -> m Client
U.getClient Cap msg
cap
isClientFromPtr msg
_ (Just Ptr msg
_) = 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.MutMsg s -> a -> m (Maybe (U.Ptr (M.MutMsg s)))
isClientToPtr :: MutMsg s -> a -> m (Maybe (Ptr (MutMsg s)))
isClientToPtr MutMsg s
msg a
client = do
    Cap (MutMsg s)
cap <- MutMsg s -> Client -> m (Cap (MutMsg s))
forall (m :: * -> *) s.
WriteCtx m s =>
MutMsg s -> Client -> m (Cap (MutMsg s))
U.appendCap MutMsg s
msg (a -> Client
forall a. IsClient a => a -> Client
Rpc.toClient a
client)
    Maybe (Ptr (MutMsg s)) -> m (Maybe (Ptr (MutMsg s)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Ptr (MutMsg s)) -> m (Maybe (Ptr (MutMsg s))))
-> Maybe (Ptr (MutMsg s)) -> m (Maybe (Ptr (MutMsg s)))
forall a b. (a -> b) -> a -> b
$ Ptr (MutMsg s) -> Maybe (Ptr (MutMsg s))
forall a. a -> Maybe a
Just (Ptr (MutMsg s) -> Maybe (Ptr (MutMsg s)))
-> Ptr (MutMsg s) -> Maybe (Ptr (MutMsg s))
forall a b. (a -> b) -> a -> b
$ Cap (MutMsg s) -> Ptr (MutMsg s)
forall msg. Cap msg -> Ptr msg
U.PtrCap Cap (MutMsg s)
cap