{-# LANGUAGE OverloadedStrings #-}

-- | Module: Capnp.Rpc.Revoke
-- Description: support for revocable capababilities
module Capnp.Rpc.Revoke
  ( makeRevocable,
  )
where

import Capnp.Rpc.Errors (eFailed)
import qualified Capnp.Rpc.Membrane as Membrane
import Capnp.Rpc.Promise (breakPromise)
import qualified Capnp.Rpc.Server as Server
import Capnp.Rpc.Untyped (IsClient)
import Control.Concurrent.STM
import Control.Monad.STM.Class (MonadSTM, liftSTM)
import Supervisors (Supervisor)

-- | @'makeRevocable' sup cap@ returns a pair @(wrappedCap, revoke)@, such that
-- @wrappedCap@ is @cap@ wrapped by a membrane which forwards all method invocations
-- along until @revoke@ is executed, after which all methods that cross the membrane
-- (in either direction) will return errors.
--
-- Note that, as per usual with membranes, the membrane will wrap any objects returned
-- by method calls. So revoke cuts off access to the entire object graph reached through
-- @cap@.
makeRevocable :: (MonadSTM m, IsClient c) => Supervisor -> c -> m (c, STM ())
makeRevocable :: forall (m :: * -> *) c.
(MonadSTM m, IsClient c) =>
Supervisor -> c -> m (c, STM ())
makeRevocable Supervisor
sup c
client = forall (m :: * -> *) a. MonadSTM m => STM a -> m a
liftSTM forall a b. (a -> b) -> a -> b
$ do
  TVar Bool
isRevoked <- forall a. a -> STM (TVar a)
newTVar Bool
False
  c
wrappedClient <- forall c (m :: * -> *).
(IsClient c, MonadSTM m) =>
Supervisor -> c -> Policy -> m c
Membrane.enclose Supervisor
sup c
client (TVar Bool -> Policy
revokerPolicy TVar Bool
isRevoked)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (c
wrappedClient, forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
isRevoked Bool
True)

revokerPolicy :: TVar Bool -> Membrane.Policy
revokerPolicy :: TVar Bool -> Policy
revokerPolicy TVar Bool
isRevoked Call
_call = do
  Bool
revoked <- forall a. TVar a -> STM a
readTVar TVar Bool
isRevoked
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    if Bool
revoked
      then UntypedMethodHandler -> Action
Membrane.Handle UntypedMethodHandler
revokedHandler
      else Action
Membrane.Forward

revokedHandler :: Server.UntypedMethodHandler
revokedHandler :: UntypedMethodHandler
revokedHandler = (Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ())
-> UntypedMethodHandler
Server.untypedHandler forall a b. (a -> b) -> a -> b
$ \Maybe (Ptr 'Const)
_ Fulfiller (Maybe (Ptr 'Const))
response -> forall (m :: * -> *) a.
MonadSTM m =>
Fulfiller a -> Parsed Exception -> m ()
breakPromise Fulfiller (Maybe (Ptr 'Const))
response (Text -> Parsed Exception
eFailed Text
"revoked")